{-# LANGUAGE CPP             #-}
{-# LANGUAGE MultiWayIf      #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
module Data.Matchable.TH (
  deriveInstances,

  deriveMatchable, makeZipMatchWith,
  deriveBimatchable, makeBizipMatchWith,

  makeLiftEq, makeLiftEq2
) where

import           Data.Bifunctor (Bifunctor (..))
import           Data.Traversable (forM)
import           Data.Bimatchable             (Bimatchable (..))
import           Data.Matchable               (Matchable (..))
import Data.Functor.Classes ( Eq2(..), Eq1(..) )

import           Language.Haskell.TH hiding (TyVarBndr(..))
import           Language.Haskell.TH.Datatype (ConstructorInfo (..),
                                               DatatypeInfo (..), reifyDatatype)
import           Language.Haskell.TH.Datatype.TyVarBndr

import Data.Bifunctor.TH ( makeBimap )
import Data.Monoid (Any (..))

import Data.Matchable.TH.Matcher

warnStrat :: Maybe DerivStrategy -> Q ()
warnStrat :: Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
warnStrat (Just DerivStrategy
strat) = String -> Q ()
reportWarning forall a b. (a -> b) -> a -> b
$ String
"Specifying deriving strategy have no effect: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DerivStrategy
strat

data Deriver = Deriver { Deriver -> Name
_className :: Name, Deriver -> [(Name, Name -> Q Exp)]
_methodDerivers :: [(Name, Name -> Q Exp)] }

deriveInstanceWith :: Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith :: Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith Deriver
deriver Cxt
context Type
ty =
  case Type -> (Type, Cxt)
spine Type
ty of
    (ConT Name
dataCon, Cxt
_) -> do
      [Dec]
methods <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Deriver -> [(Name, Name -> Q Exp)]
_methodDerivers Deriver
deriver) forall a b. (a -> b) -> a -> b
$ \(Name
methodName, Name -> Q Exp
makeImpl) -> do
        Exp
impl <- Name -> Q Exp
makeImpl Name
dataCon
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD Name
methodName [ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
impl) [] ]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing Cxt
context (Name -> Type
ConT (Deriver -> Name
_className Deriver
deriver) Type -> Type -> Type
`AppT` Type
ty) [Dec]
methods]
    (Type, Cxt)
_ -> do String -> Q ()
reportError (String
"Instance declaration must be of shape Cls (TyCon ty1 ty2 ...), but it's" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
ty)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | This function transforms multiple instance declarations written in @StandaloneDeriving@
--   format to instances derived by TemplateHaskell.
--
--   ==== Example
--   
--   @
--   {-# LANGUAGE DeriveFunctor #-}
--   {-# LANGUAGE StandaloneDeriving #-}
--   [-# LANGUAGE TemplateHaskell #-}
--   data Foo a b = Foo a b (Either a b)
--      deriving (Show, Eq, Functor)
--   @
--   
--   To use 'deriveInstances' for @Foo@, write as below:
--
--   @
--   deriveInstances [d|
--     deriving instance Eq a => Eq1 (Foo a)
--     deriving instance Eq a => Matchable (Foo a)
--     deriving instance Eq2 Foo
--     deriving instance Bifunctor Foo
--     deriving instance Bimatchable Foo
--     |]
--   @

deriveInstances :: Q [Dec] -> Q [Dec]
deriveInstances :: Q [Dec] -> Q [Dec]
deriveInstances Q [Dec]
decsQ = do
  [Dec]
decs <- Q [Dec]
decsQ
  [[Dec]]
derivedDecss <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec -> Q [Dec]
deriveInstance [Dec]
decs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
derivedDecss

deriveInstance :: Dec -> Q [Dec]
deriveInstance :: Dec -> Q [Dec]
deriveInstance Dec
dec = case Dec
dec of
  StandaloneDerivD Maybe DerivStrategy
strat Cxt
context Type
typ -> case Type
typ of
    AppT (ConT Name
cls) Type
typ'
      | Name
cls forall a. Eq a => a -> a -> Bool
== ''Eq      -> String -> Q ()
reportWarning String
"Use stock deriving for Eq" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dec]
      | Name
cls forall a. Eq a => a -> a -> Bool
== ''Functor -> String -> Q ()
reportWarning String
"Use stock deriving for Functor" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dec]
      | Name
cls forall a. Eq a => a -> a -> Bool
== ''Bifunctor -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith Deriver
bifunctorDeriver Cxt
context Type
typ'
      | Name
cls forall a. Eq a => a -> a -> Bool
== ''Eq1     -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith Deriver
eq1Deriver Cxt
context Type
typ'
      | Name
cls forall a. Eq a => a -> a -> Bool
== ''Matchable -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith Deriver
matchableDeriver Cxt
context Type
typ'
      | Name
cls forall a. Eq a => a -> a -> Bool
== ''Eq2     -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith Deriver
eq2Deriver Cxt
context Type
typ'
      | Name
cls forall a. Eq a => a -> a -> Bool
== ''Bimatchable -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith Deriver
bimatchableDeriver Cxt
context Type
typ'
    Type
_ -> String -> Q ()
reportError (String
"Unsupported Instance: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
typ) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  Dec
_ -> String -> Q ()
reportError String
"Use standalone deriving declarations only" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure []

bifunctorDeriver, eq1Deriver, matchableDeriver, eq2Deriver, bimatchableDeriver :: Deriver
bifunctorDeriver :: Deriver
bifunctorDeriver = Name -> [(Name, Name -> Q Exp)] -> Deriver
Deriver ''Bifunctor [ ('bimap, Name -> Q Exp
makeBimap) ]
eq1Deriver :: Deriver
eq1Deriver = Name -> [(Name, Name -> Q Exp)] -> Deriver
Deriver ''Eq1 [ ('liftEq, Name -> Q Exp
makeLiftEq) ]

eq2Deriver :: Deriver
eq2Deriver = Name -> [(Name, Name -> Q Exp)] -> Deriver
Deriver ''Eq2 [ ('liftEq2, Name -> Q Exp
makeLiftEq2 ) ]
matchableDeriver :: Deriver
matchableDeriver = Name -> [(Name, Name -> Q Exp)] -> Deriver
Deriver ''Matchable [ ('zipMatchWith, Name -> Q Exp
makeZipMatchWith) ]
bimatchableDeriver :: Deriver
bimatchableDeriver = Name -> [(Name, Name -> Q Exp)] -> Deriver
Deriver ''Bimatchable [ ('bizipMatchWith, Name -> Q Exp
makeBizipMatchWith) ]

makeLiftEq :: Name -> Q Exp
makeLiftEq :: Name -> Q Exp
makeLiftEq Name
name = do
  DatatypeInfo { datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeVars = [TyVarBndrUnit]
dtVarsNames , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons }
     <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  Type
tyA <- case forall a. [a] -> Maybe ([a], a)
viewLast [TyVarBndrUnit]
dtVarsNames of
    Maybe ([TyVarBndrUnit], TyVarBndrUnit)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not a type constructor:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
name
    Just ([TyVarBndrUnit]
_, TyVarBndrUnit
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
VarT (forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
a))
  
  Name
eq <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"eq"

  [Q Clause]
matchClauses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ConstructorInfo]
cons forall a b. (a -> b) -> a -> b
$
    \(ConstructorInfo Name
ctrName [TyVarBndrUnit]
_ Cxt
_ Cxt
fields [FieldStrictness]
_ ConstructorVariant
_) -> do
        Matcher Any
matcher <- forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName) [Q Exp] -> Q Exp
andBoolExprs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Name -> Type -> Q (Matcher Any)
dEq1Field Type
tyA Name
eq) Cxt
fields
        let Any Bool
bodyUsesF = forall u. Matcher u -> u
additionalInfo Matcher Any
matcher
            fPat :: PatQ
fPat = if Bool
bodyUsesF then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
eq else forall (m :: * -> *). Quote m => m Pat
wildP
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ
fPat, forall u. Matcher u -> PatQ
leftPat Matcher Any
matcher, forall u. Matcher u -> PatQ
rightPat Matcher Any
matcher] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall u. Matcher u -> Q Exp
bodyExp Matcher Any
matcher)) []
  let mismatchClause :: Q Clause
mismatchClause = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP ] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| False |]) []
      finalClauses :: [Q Clause]
finalClauses = case [ConstructorInfo]
cons of
        []  -> []
        [ConstructorInfo
_] -> [Q Clause]
matchClauses
        [ConstructorInfo]
_   -> [Q Clause]
matchClauses forall a. [a] -> [a] -> [a]
++ [Q Clause
mismatchClause]
  
  Name
lifteq <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"lifteq"
  forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
lifteq [Q Clause]
finalClauses ] (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
lifteq)

dEq1Field :: Type -> Name -> Type -> Q (Matcher Any)
dEq1Field :: Type -> Name -> Type -> Q (Matcher Any)
dEq1Field Type
tyA Name
fName = Type -> Q (Matcher Any)
go
  where
    isConst :: Type -> Bool
isConst Type
t = Bool -> Bool
not (Type -> Type -> Bool
occurs Type
tyA Type
t)

    go :: Type -> Q (Matcher Any)
go Type
ty = case Type
ty of
      Type
_ | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyA -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName) (Bool -> Any
Any Bool
True)
        | Type -> Bool
isConst Type
ty -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher ([| (==) |]) (Bool -> Any
Any Bool
False)
      AppT Type
g Type
ty' | Type -> Bool
isConst Type
g -> do
        Matcher Any
matcher <- Type -> Q (Matcher Any)
go Type
ty'
        forall a. Q Exp -> Matcher a -> Q (Matcher a)
liftMatcher [| liftEq |] Matcher Any
matcher
      AppT (AppT Type
g Type
ty1') Type
ty2' | Type -> Bool
isConst Type
g -> do
        Matcher Any
matcher1 <- Type -> Q (Matcher Any)
go Type
ty1'
        Matcher Any
matcher2 <- Type -> Q (Matcher Any)
go Type
ty2'
        forall a.
Semigroup a =>
Q Exp -> Matcher a -> Matcher a -> Q (Matcher a)
liftMatcher2 [| liftEq2 |] Matcher Any
matcher1 Matcher Any
matcher2
      (Type -> (Type, Cxt)
spine -> (TupleT Int
_, Cxt
subtys)) -> do
        [Matcher Any]
matchers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q (Matcher Any)
go (forall a. [a] -> [a]
reverse Cxt
subtys)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Q Exp] -> Q Exp
andBoolExprs [Matcher Any]
matchers
      Type
_ -> forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Eq1"

makeLiftEq2 :: Name -> Q Exp
makeLiftEq2 :: Name -> Q Exp
makeLiftEq2 Name
name = do
  DatatypeInfo { datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeVars = [TyVarBndrUnit]
dtVarsNames , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons }
     <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  (Type
tyA, Type
tyB) <- case forall a. [a] -> Maybe ([a], a, a)
viewLastTwo [TyVarBndrUnit]
dtVarsNames of
    Maybe ([TyVarBndrUnit], TyVarBndrUnit, TyVarBndrUnit)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not a type constructor:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
name
    Just ([TyVarBndrUnit]
_, TyVarBndrUnit
a, TyVarBndrUnit
b) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
VarT (forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
a), Name -> Type
VarT (forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
b))
  
  Name
eqA <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"eqA"
  Name
eqB <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"eqB"

  [Q Clause]
matchClauses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ConstructorInfo]
cons forall a b. (a -> b) -> a -> b
$
    \(ConstructorInfo Name
ctrName [TyVarBndrUnit]
_ Cxt
_ Cxt
fields [FieldStrictness]
_ ConstructorVariant
_) -> do
        Matcher (Any, Any)
matcher <- forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName) [Q Exp] -> Q Exp
andBoolExprs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Name -> Type -> Name -> Type -> Q (Matcher (Any, Any))
dEq2Field Type
tyA Name
eqA Type
tyB Name
eqB) Cxt
fields
        let (Any Bool
bodyUsesF, Any Bool
bodyUsesG) = forall u. Matcher u -> u
additionalInfo Matcher (Any, Any)
matcher
            fPat :: PatQ
fPat = if Bool
bodyUsesF then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
eqA else forall (m :: * -> *). Quote m => m Pat
wildP
            gPat :: PatQ
gPat = if Bool
bodyUsesG then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
eqB else forall (m :: * -> *). Quote m => m Pat
wildP
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ
fPat, PatQ
gPat, forall u. Matcher u -> PatQ
leftPat Matcher (Any, Any)
matcher, forall u. Matcher u -> PatQ
rightPat Matcher (Any, Any)
matcher] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall u. Matcher u -> Q Exp
bodyExp Matcher (Any, Any)
matcher)) []
  let mismatchClause :: Q Clause
mismatchClause = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP ] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| False |]) []
      finalClauses :: [Q Clause]
finalClauses = case [ConstructorInfo]
cons of
        []  -> []
        [ConstructorInfo
_] -> [Q Clause]
matchClauses
        [ConstructorInfo]
_   -> [Q Clause]
matchClauses forall a. [a] -> [a] -> [a]
++ [Q Clause
mismatchClause]
  
  Name
lifteq <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"lifteq"
  forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
lifteq [Q Clause]
finalClauses ] (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
lifteq)

dEq2Field :: Type -> Name -> Type -> Name -> Type -> Q (Matcher (Any, Any))
dEq2Field :: Type -> Name -> Type -> Name -> Type -> Q (Matcher (Any, Any))
dEq2Field Type
tyA Name
fName Type
tyB Name
gName = Type -> Q (Matcher (Any, Any))
go
  where
    isConst :: Type -> Bool
isConst Type
t = Bool -> Bool
not (Type -> Type -> Bool
occurs Type
tyA Type
t Bool -> Bool -> Bool
|| Type -> Type -> Bool
occurs Type
tyB Type
t)

    go :: Type -> Q (Matcher (Any, Any))
go Type
ty = case Type
ty of
      Type
_ | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyA -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName) (Bool -> Any
Any Bool
True, Bool -> Any
Any Bool
False)
        | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyB -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
gName) (Bool -> Any
Any Bool
False, Bool -> Any
Any Bool
True)
        | Type -> Bool
isConst Type
ty -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher ([| (==) |]) forall a. Monoid a => a
mempty
      AppT Type
g Type
ty' | Type -> Bool
isConst Type
g -> do
        Matcher (Any, Any)
matcher <- Type -> Q (Matcher (Any, Any))
go Type
ty'
        forall a. Q Exp -> Matcher a -> Q (Matcher a)
liftMatcher [| liftEq |] Matcher (Any, Any)
matcher
      AppT (AppT Type
g Type
ty1') Type
ty2' | Type -> Bool
isConst Type
g -> do
        Matcher (Any, Any)
matcher1 <- Type -> Q (Matcher (Any, Any))
go Type
ty1'
        Matcher (Any, Any)
matcher2 <- Type -> Q (Matcher (Any, Any))
go Type
ty2'
        forall a.
Semigroup a =>
Q Exp -> Matcher a -> Matcher a -> Q (Matcher a)
liftMatcher2 [| liftEq2 |] Matcher (Any, Any)
matcher1 Matcher (Any, Any)
matcher2
      (Type -> (Type, Cxt)
spine -> (TupleT Int
_, Cxt
subtys)) -> do
        [Matcher (Any, Any)]
matchers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q (Matcher (Any, Any))
go (forall a. [a] -> [a]
reverse Cxt
subtys)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Q Exp] -> Q Exp
andBoolExprs [Matcher (Any, Any)]
matchers
      Type
_ -> forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Eq1"

-- | Build an instance of 'Matchable' for a data type.
--
-- /e.g./
--
-- @
-- data Exp a = Plus a a | Times a a
-- 'deriveMatchable' ''Exp
-- @
--
-- will create
--
-- @
-- instance Matchable Exp where
--   zipMatchWith f (Plus  l1 l2) (Plus  r1 r2) = pure Plus  <*> f l1 r1 <*> f l2 r2
--   zipMatchWith f (Times l1 l2) (Times r1 r2) = pure Times <*> f l1 r1 <*> f l2 r2
--   zipMatchWith _ _ _ = Nothing
-- @
deriveMatchable :: Name -> Q [Dec]
deriveMatchable :: Name -> Q [Dec]
deriveMatchable Name
name = do
  ((Cxt
ctx, Type
f), [Q Clause]
zipMatchWithClauses) <- Name -> Q ((Cxt, Type), [Q Clause])
makeZipMatchWith' Name
name

  Dec
dec <- forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
ctx) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Matchable) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
f))
           [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'zipMatchWith [Q Clause]
zipMatchWithClauses ]

  forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dec]

makeZipMatchWith :: Name -> ExpQ
makeZipMatchWith :: Name -> Q Exp
makeZipMatchWith Name
name = do
  ((Cxt, Type)
_, [Q Clause]
clauses) <- Name -> Q ((Cxt, Type), [Q Clause])
makeZipMatchWith' Name
name
  Name
z <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
  forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
z [Q Clause]
clauses ] (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z)

makeZipMatchWith' :: Name -> Q ((Cxt, Type), [Q Clause])
makeZipMatchWith' :: Name -> Q ((Cxt, Type), [Q Clause])
makeZipMatchWith' Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  let DatatypeInfo { datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeVars = [TyVarBndrUnit]
dtVarsNames , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons } = DatatypeInfo
info
  (Type
dtFunctor, Type
tyA) <- case forall a. [a] -> Maybe ([a], a)
viewLast (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall flag. TyVarBndr_ flag -> Name
tvName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndrUnit]
dtVarsNames) of
    Maybe (Cxt, Type)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not a type constructor:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
name
    Just (Cxt
rest, Type
tyA) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
rest, Type
tyA)
  
  Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"

  [(Cxt, Q Clause)]
matchClausesAndCtxs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ConstructorInfo]
cons forall a b. (a -> b) -> a -> b
$
    \(ConstructorInfo Name
ctrName [TyVarBndrUnit]
_ Cxt
_ Cxt
fields [FieldStrictness]
_ ConstructorVariant
_) -> do
        let body :: [Q Exp] -> Q Exp
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x Q Exp
y -> [| $x <*> $y |]) [| pure $(conE ctrName) |]
        Matcher (Cxt, Any)
matcher <- forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName) [Q Exp] -> Q Exp
body forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Name -> Type -> Q (Matcher (Cxt, Any))
dMatchField Type
tyA Name
f) Cxt
fields
        let (Cxt
ctx, Any Bool
bodyUsesF) = forall u. Matcher u -> u
additionalInfo Matcher (Cxt, Any)
matcher
            fPat :: PatQ
fPat = if Bool
bodyUsesF then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f else forall (m :: * -> *). Quote m => m Pat
wildP
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Cxt
ctx, forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ
fPat, forall u. Matcher u -> PatQ
leftPat Matcher (Cxt, Any)
matcher, forall u. Matcher u -> PatQ
rightPat Matcher (Cxt, Any)
matcher] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall u. Matcher u -> Q Exp
bodyExp Matcher (Cxt, Any)
matcher)) [])

  let matchClauses :: [Q Clause]
matchClauses = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Cxt, Q Clause)]
matchClausesAndCtxs
      ctx :: Cxt
ctx = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> a
fst [(Cxt, Q Clause)]
matchClausesAndCtxs
      mismatchClause :: Q Clause
mismatchClause = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP ] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| Nothing |]) []
      finalClauses :: [Q Clause]
finalClauses = case [ConstructorInfo]
cons of
        []  -> []
        [ConstructorInfo
_] -> [Q Clause]
matchClauses
        [ConstructorInfo]
_   -> [Q Clause]
matchClauses forall a. [a] -> [a] -> [a]
++ [Q Clause
mismatchClause]

  forall (m :: * -> *) a. Monad m => a -> m a
return ((Cxt
ctx, Type
dtFunctor), [Q Clause]
finalClauses)

dMatchField :: Type -> Name -> Type -> Q (Matcher (Cxt, Any))
dMatchField :: Type -> Name -> Type -> Q (Matcher (Cxt, Any))
dMatchField Type
tyA Name
fName = Type -> Q (Matcher (Cxt, Any))
go
  where
    isConst :: Type -> Bool
isConst = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Bool
occurs Type
tyA

    go :: Type -> Q (Matcher (Cxt, Any))
go Type
ty = case Type
ty of
      Type
_ | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyA -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName) ([], Bool -> Any
Any Bool
True)
        | Type -> Bool
isConst Type
ty -> 
            let ctx :: Cxt
ctx = [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) Type
ty | Type -> Bool
hasTyVar Type
ty ]
            in forall a. (Q Exp -> Q Exp -> Q Exp) -> a -> Q (Matcher a)
matcherExpr
                  (\Q Exp
l Q Exp
r -> [| if $l == $r then Just $l else Nothing |])
                  (Cxt
ctx, Bool -> Any
Any Bool
False)
      (AppT Type
g Type
ty') | Type -> Bool
isConst Type
g -> do
        let ctxG :: Cxt
ctxG = [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Matchable) Type
g | Type -> Bool
hasTyVar Type
g ]
        Matcher (Cxt, Any)
matcher <- Type -> Q (Matcher (Cxt, Any))
go Type
ty'
        Matcher (Cxt, Any)
matcher' <- forall a. Q Exp -> Matcher a -> Q (Matcher a)
liftMatcher [| zipMatchWith |] Matcher (Cxt, Any)
matcher
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Cxt
ctxG, forall a. Monoid a => a
mempty) forall a. Semigroup a => a -> Matcher a -> Matcher a
`addInfo` Matcher (Cxt, Any)
matcher'
      (AppT (AppT Type
g Type
ty1') Type
ty2') | Type -> Bool
isConst Type
g -> do
        let ctxG :: Cxt
ctxG = [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Bimatchable) Type
g | Type -> Bool
hasTyVar Type
g ]
        Matcher (Cxt, Any)
matcher1 <- Type -> Q (Matcher (Cxt, Any))
go Type
ty1'
        Matcher (Cxt, Any)
matcher2 <- Type -> Q (Matcher (Cxt, Any))
go Type
ty2'
        Matcher (Cxt, Any)
matcher' <- forall a.
Semigroup a =>
Q Exp -> Matcher a -> Matcher a -> Q (Matcher a)
liftMatcher2 [| bizipMatchWith |] Matcher (Cxt, Any)
matcher1 Matcher (Cxt, Any)
matcher2
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Cxt
ctxG, forall a. Monoid a => a
mempty) forall a. Semigroup a => a -> Matcher a -> Matcher a
`addInfo` Matcher (Cxt, Any)
matcher'
      (Type -> (Type, Cxt)
spine -> (TupleT Int
n, Cxt
subtys)) -> do
        let body :: [Q Exp] -> Q Exp
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x Q Exp
y -> [| $x <*> $y |]) [| pure $(conE (tupleDataName n)) |]
        [Matcher (Cxt, Any)]
matchers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q (Matcher (Cxt, Any))
go (forall a. [a] -> [a]
reverse Cxt
subtys)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Q Exp] -> Q Exp
body [Matcher (Cxt, Any)]
matchers
      Type
_ -> forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Matchable"

-- | Build an instance of 'Bimatchable' for a data type.
--
-- /e.g./
--
-- @
-- data Sum a b = InL a | InR b
-- 'deriveMatchable' ''Sum
-- @
--
-- will create
--
-- @
-- instance Matchable Sum where
--   bizipMatchWith f _ (InL l1) (InL r1) = pure InL <$> f l1 r1
--   bizipMatchWith _ g (InR l1) (InR r1) = pure InR <$> g l1 r1
-- @
deriveBimatchable :: Name -> Q [Dec]
deriveBimatchable :: Name -> Q [Dec]
deriveBimatchable Name
name = do
  ((Cxt
ctx, Type
f), [Q Clause]
clauses) <- Name -> Q ((Cxt, Type), [Q Clause])
makeBizipMatchWith' Name
name

  Dec
dec <- forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
ctx) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Bimatchable) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
f))
           [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'bizipMatchWith [Q Clause]
clauses ]

  forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dec]

makeBizipMatchWith :: Name -> ExpQ
makeBizipMatchWith :: Name -> Q Exp
makeBizipMatchWith Name
name = do
  ((Cxt, Type)
_, [Q Clause]
clauses) <- Name -> Q ((Cxt, Type), [Q Clause])
makeBizipMatchWith' Name
name
  Name
z <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
  forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
z [Q Clause]
clauses ] (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z)

makeBizipMatchWith' :: Name -> Q ((Cxt, Type), [Q Clause])
makeBizipMatchWith' :: Name -> Q ((Cxt, Type), [Q Clause])
makeBizipMatchWith' Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  let DatatypeInfo { datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeVars = [TyVarBndrUnit]
dtVars , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons } = DatatypeInfo
info
  (Type
dtFunctor, Type
tyA, Type
tyB) <- case forall a. [a] -> Maybe ([a], a, a)
viewLastTwo (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall flag. TyVarBndr_ flag -> Name
tvName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndrUnit]
dtVars) of
      Maybe (Cxt, Type, Type)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not a datatype with at least 2 parameters: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
name
      Just (Cxt
rest, Type
tyA, Type
tyB) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
rest, Type
tyA, Type
tyB)

  Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  Name
g <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"g"

  [(Cxt, Q Clause)]
matchClausesAndCtxs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ConstructorInfo]
cons forall a b. (a -> b) -> a -> b
$
    \(ConstructorInfo Name
ctrName [TyVarBndrUnit]
_ Cxt
_ Cxt
fields [FieldStrictness]
_ ConstructorVariant
_) -> do
        let body :: [Q Exp] -> Q Exp
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x Q Exp
y -> [| $x <*> $y |]) [| pure $(conE ctrName) |]
        Matcher (Cxt, Any, Any)
matcher <- forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName) [Q Exp] -> Q Exp
body forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Name -> Type -> Name -> Type -> Q (Matcher (Cxt, Any, Any))
dBimatchField Type
tyA Name
f Type
tyB Name
g) Cxt
fields
        let (Cxt
ctx, Any Bool
bodyUsesF, Any Bool
bodyUsesG) = forall u. Matcher u -> u
additionalInfo Matcher (Cxt, Any, Any)
matcher
            fPat :: PatQ
fPat = if Bool
bodyUsesF then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f else forall (m :: * -> *). Quote m => m Pat
wildP
            gPat :: PatQ
gPat = if Bool
bodyUsesG then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
g else forall (m :: * -> *). Quote m => m Pat
wildP
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Cxt
ctx, forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ
fPat, PatQ
gPat, forall u. Matcher u -> PatQ
leftPat Matcher (Cxt, Any, Any)
matcher, forall u. Matcher u -> PatQ
rightPat Matcher (Cxt, Any, Any)
matcher] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall u. Matcher u -> Q Exp
bodyExp Matcher (Cxt, Any, Any)
matcher)) [])

  let matchClauses :: [Q Clause]
matchClauses = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Cxt, Q Clause)]
matchClausesAndCtxs
      ctx :: Cxt
ctx = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> a
fst [(Cxt, Q Clause)]
matchClausesAndCtxs
      mismatchClause :: Q Clause
mismatchClause = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP ] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| Nothing |]) []
      finalClauses :: [Q Clause]
finalClauses = case [ConstructorInfo]
cons of
        []  -> []
        [ConstructorInfo
_] -> [Q Clause]
matchClauses
        [ConstructorInfo]
_   -> [Q Clause]
matchClauses forall a. [a] -> [a] -> [a]
++ [Q Clause
mismatchClause]

  forall (m :: * -> *) a. Monad m => a -> m a
return ((Cxt
ctx, Type
dtFunctor), [Q Clause]
finalClauses)

dBimatchField :: Type -> Name -> Type -> Name -> Type -> Q (Matcher (Cxt, Any, Any))
dBimatchField :: Type -> Name -> Type -> Name -> Type -> Q (Matcher (Cxt, Any, Any))
dBimatchField Type
tyA Name
fName Type
tyB Name
gName = Type -> Q (Matcher (Cxt, Any, Any))
go
  where
    isConst :: Type -> Bool
isConst Type
t = Bool -> Bool
not (Type -> Type -> Bool
occurs Type
tyA Type
t Bool -> Bool -> Bool
|| Type -> Type -> Bool
occurs Type
tyB Type
t)
    
    go :: Type -> Q (Matcher (Cxt, Any, Any))
go Type
ty = case Type
ty of
      Type
_ | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyA -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName) ([], Bool -> Any
Any Bool
True, Bool -> Any
Any Bool
False)
        | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyB -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
gName) ([], Bool -> Any
Any Bool
False, Bool -> Any
Any Bool
True)
        | Type -> Bool
isConst Type
ty -> 
            let ctx :: Cxt
ctx = [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) Type
ty | Type -> Bool
hasTyVar Type
ty ]
            in forall a. (Q Exp -> Q Exp -> Q Exp) -> a -> Q (Matcher a)
matcherExpr
                  (\Q Exp
l Q Exp
r -> [| if $l == $r then Just $l else Nothing |])
                  (Cxt
ctx, Bool -> Any
Any Bool
False, Bool -> Any
Any Bool
False)
      (AppT Type
g Type
ty') | Type -> Bool
isConst Type
g -> do
        let ctxG :: Cxt
ctxG = [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Matchable) Type
g | Type -> Bool
hasTyVar Type
g ]
        Matcher (Cxt, Any, Any)
matcher <- Type -> Q (Matcher (Cxt, Any, Any))
go Type
ty'
        Matcher (Cxt, Any, Any)
matcher' <- forall a. Q Exp -> Matcher a -> Q (Matcher a)
liftMatcher [| zipMatchWith |] Matcher (Cxt, Any, Any)
matcher
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Cxt
ctxG, forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty) forall a. Semigroup a => a -> Matcher a -> Matcher a
`addInfo` Matcher (Cxt, Any, Any)
matcher'
      (AppT (AppT Type
g Type
ty1') Type
ty2') | Type -> Bool
isConst Type
g -> do
        let ctxG :: Cxt
ctxG = [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Bimatchable) Type
g | Type -> Bool
hasTyVar Type
g ]
        Matcher (Cxt, Any, Any)
matcher1 <- Type -> Q (Matcher (Cxt, Any, Any))
go Type
ty1'
        Matcher (Cxt, Any, Any)
matcher2 <- Type -> Q (Matcher (Cxt, Any, Any))
go Type
ty2'
        Matcher (Cxt, Any, Any)
matcher' <- forall a.
Semigroup a =>
Q Exp -> Matcher a -> Matcher a -> Q (Matcher a)
liftMatcher2 [| bizipMatchWith |] Matcher (Cxt, Any, Any)
matcher1 Matcher (Cxt, Any, Any)
matcher2
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Cxt
ctxG, forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty) forall a. Semigroup a => a -> Matcher a -> Matcher a
`addInfo` Matcher (Cxt, Any, Any)
matcher'
      (Type -> (Type, Cxt)
spine -> (TupleT Int
n, Cxt
subtys)) -> do
        [Matcher (Cxt, Any, Any)]
matchers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q (Matcher (Cxt, Any, Any))
go (forall a. [a] -> [a]
reverse Cxt
subtys)
        let body :: [Q Exp] -> Q Exp
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x Q Exp
y -> [| $x <*> $y |]) [| pure $(conE (tupleDataName n)) |]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Q Exp] -> Q Exp
body [Matcher (Cxt, Any, Any)]
matchers
      Type
_ -> forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Bimatchable"
    

-----------------------------

unexpectedType :: Type -> String -> Q a
unexpectedType :: forall a. Type -> String -> Q a
unexpectedType Type
ty String
cls = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
  String
"unexpected type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
ty forall a. [a] -> [a] -> [a]
++ String
" in derivation of " forall a. [a] -> [a] -> [a]
++ String
cls forall a. [a] -> [a] -> [a]
++
  String
" (it's only possible to implement " forall a. [a] -> [a] -> [a]
++ String
cls forall a. [a] -> [a] -> [a]
++
  String
" genericaly when all subterms are traversable)"

andBoolExprs :: [Q Exp] -> Q Exp
andBoolExprs :: [Q Exp] -> Q Exp
andBoolExprs [] = [| True |]
andBoolExprs [Q Exp]
xs = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
x Q Exp
y -> [| $x && $y |]) [Q Exp]
xs

spine :: Type -> (Type, [Type])
spine :: Type -> (Type, Cxt)
spine (ParensT Type
t)  = Type -> (Type, Cxt)
spine Type
t
spine (AppT Type
t1 Type
t2) = let (Type
h, Cxt
r) = Type -> (Type, Cxt)
spine Type
t1 in (Type
h, Type
t2forall a. a -> [a] -> [a]
:Cxt
r)
spine (SigT Type
t Type
_)   = Type -> (Type, Cxt)
spine Type
t
spine Type
t            = (Type
t, [])

occurs :: Type -> Type -> Bool
occurs :: Type -> Type -> Bool
occurs Type
t Type
u | Type
t forall a. Eq a => a -> a -> Bool
== Type
u = Bool
True
occurs Type
t Type
u = case Type
u of
  AppT Type
u1 Type
u2 -> Type -> Type -> Bool
occurs Type
t Type
u1 Bool -> Bool -> Bool
|| Type -> Type -> Bool
occurs Type
t Type
u2
  ParensT Type
u' -> Type -> Type -> Bool
occurs Type
t Type
u'
  SigT Type
u' Type
_  -> Type -> Type -> Bool
occurs Type
t Type
u'
  Type
_          -> Bool
False

hasTyVar :: Type -> Bool
hasTyVar :: Type -> Bool
hasTyVar (VarT Name
_)     = Bool
True
hasTyVar (ParensT Type
t)  = Type -> Bool
hasTyVar Type
t
hasTyVar (AppT Type
t1 Type
t2) = Type -> Bool
hasTyVar Type
t1 Bool -> Bool -> Bool
|| Type -> Bool
hasTyVar Type
t2
hasTyVar (SigT Type
t Type
_)   = Type -> Bool
hasTyVar Type
t
hasTyVar Type
_            = Bool
False

viewLast :: [a] -> Maybe ([a], a)
viewLast :: forall a. [a] -> Maybe ([a], a)
viewLast [a]
as = case forall a. [a] -> [a]
reverse [a]
as of
  [] -> forall a. Maybe a
Nothing
  a
a:[a]
rest -> forall a. a -> Maybe a
Just (forall a. [a] -> [a]
reverse [a]
rest, a
a)

viewLastTwo :: [a] -> Maybe ([a],a,a)
viewLastTwo :: forall a. [a] -> Maybe ([a], a, a)
viewLastTwo [a]
as = case forall a. [a] -> [a]
reverse [a]
as of
  a
b:a
a:[a]
rest -> forall a. a -> Maybe a
Just (forall a. [a] -> [a]
reverse [a]
rest, a
a, a
b)
  [a]
_ -> forall a. Maybe a
Nothing