{-# LANGUAGE CPP             #-}
{-# LANGUAGE MultiWayIf      #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
module Data.Matchable.TH (
  -- * @derive@ functions
  deriveInstances,
  deriveMatchable, deriveBimatchable,

  -- * @make-@ functions
  makeZipMatchWith,
  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 = () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
warnStrat (Just DerivStrategy
strat) = String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Specifying deriving strategy have no effect: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DerivStrategy -> String
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 <- [(Name, Name -> Q Exp)]
-> ((Name, Name -> Q Exp) -> Q Dec) -> Q [Dec]
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) (((Name, Name -> Q Exp) -> Q Dec) -> Q [Dec])
-> ((Name, Name -> Q Exp) -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \(Name
methodName, Name -> Q Exp
makeImpl) -> do
        Exp
impl <- Name -> Q Exp
makeImpl Name
dataCon
        Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD Name
methodName [ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
impl) [] ]
      [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
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" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
ty)
            [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Derive multiple instances of 'Matchable', 'Bimatchable', or their superclasses,
--   each written in @StandaloneDeriving@ syntax.
--
--   Passing declarations other than standalone deriving instances is an error.
--   Also, passing any instances other than 'Matchable', 'Bimatchable' or their superclasses is an error.
--   Explicitly, it accepts standalone deriving declarations of the following types:
--
--   - 'Eq1'
--   - 'Eq2'
--   - 'Bifunctor'
--   - 'Matchable'
--   - 'Bimatchable'
--   
--   Passing an 'Eq' or 'Functor' instance declarations does not cause a compilation error
--   and generates the same standalone deriving declaration passed in, but also causes
--   a /warning/ telling you that you can use stock deriving for them.
--   
--   ==== 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 <- (Dec -> Q [Dec]) -> [Dec] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Dec -> Q [Dec]
deriveInstance [Dec]
decs
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Eq      -> String -> Q ()
reportWarning String
"Use stock deriving for Eq" Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dec]
      | Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Functor -> String -> Q ()
reportWarning String
"Use stock deriving for Functor" Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dec]
      | Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Bifunctor -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Eq1     -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Matchable -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Eq2     -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Bimatchable -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
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: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
typ) Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  Dec
_ -> String -> Q ()
reportError String
"Use standalone deriving declarations only" Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Dec] -> Q [Dec]
forall a. a -> Q a
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) ]

-- | Generates an expression which behaves like 'liftEq' for the given data type.
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 [TyVarBndrUnit] -> Maybe ([TyVarBndrUnit], TyVarBndrUnit)
forall a. [a] -> Maybe ([a], a)
viewLast [TyVarBndrUnit]
dtVarsNames of
    Maybe ([TyVarBndrUnit], TyVarBndrUnit)
Nothing -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Not a type constructor:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name
    Just ([TyVarBndrUnit]
_, TyVarBndrUnit
a) -> Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
VarT (TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
a))
  
  Name
eq <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"eq"

  [Q Clause]
matchClauses <- [ConstructorInfo]
-> (ConstructorInfo -> Q (Q Clause)) -> Q [Q Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ConstructorInfo]
cons ((ConstructorInfo -> Q (Q Clause)) -> Q [Q Clause])
-> (ConstructorInfo -> Q (Q Clause)) -> Q [Q Clause]
forall a b. (a -> b) -> a -> b
$
    \(ConstructorInfo Name
ctrName [TyVarBndrUnit]
_ Cxt
_ Cxt
fields [FieldStrictness]
_ ConstructorVariant
_) -> do
        Matcher Any
matcher <- ([PatQ] -> PatQ)
-> ([Q Exp] -> Q Exp) -> [Matcher Any] -> Matcher Any
forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers (Name -> [PatQ] -> PatQ
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName) [Q Exp] -> Q Exp
andBoolExprs ([Matcher Any] -> Matcher Any)
-> Q [Matcher Any] -> Q (Matcher Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q (Matcher Any)) -> Cxt -> Q [Matcher Any]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type -> Name -> Type -> Q (Matcher Any)
dEq1Field Type
tyA Name
eq) Cxt
fields
        let Any Bool
bodyUsesF = Matcher Any -> Any
forall u. Matcher u -> u
additionalInfo Matcher Any
matcher
            fPat :: PatQ
fPat = if Bool
bodyUsesF then Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
eq else PatQ
forall (m :: * -> *). Quote m => m Pat
wildP
        Q Clause -> Q (Q Clause)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Q Clause -> Q (Q Clause)) -> Q Clause -> Q (Q Clause)
forall a b. (a -> b) -> a -> b
$ [PatQ] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ
fPat, Matcher Any -> PatQ
forall u. Matcher u -> PatQ
leftPat Matcher Any
matcher, Matcher Any -> PatQ
forall u. Matcher u -> PatQ
rightPat Matcher Any
matcher] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Matcher Any -> Q Exp
forall u. Matcher u -> Q Exp
bodyExp Matcher Any
matcher)) []
  let mismatchClause :: Q Clause
mismatchClause = [PatQ] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ PatQ
forall (m :: * -> *). Quote m => m Pat
wildP, PatQ
forall (m :: * -> *). Quote m => m Pat
wildP, PatQ
forall (m :: * -> *). Quote m => m Pat
wildP ] (Q Exp -> Q Body
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 [Q Clause] -> [Q Clause] -> [Q Clause]
forall a. [a] -> [a] -> [a]
++ [Q Clause
mismatchClause]
  
  Name
lifteq <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"lifteq"
  [Q Dec] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
lifteq [Q Clause]
finalClauses ] (Name -> Q Exp
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 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tyA -> Q Exp -> Any -> Q (Matcher Any)
forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName) (Bool -> Any
Any Bool
True)
        | Type -> Bool
isConst Type
ty -> Q Exp -> Any -> Q (Matcher Any)
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'
        Q Exp -> Matcher Any -> Q (Matcher Any)
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'
        Q Exp -> Matcher Any -> Matcher Any -> Q (Matcher Any)
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 <- (Type -> Q (Matcher Any)) -> Cxt -> Q [Matcher Any]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q (Matcher Any)
go (Cxt -> Cxt
forall a. [a] -> [a]
reverse Cxt
subtys)
        Matcher Any -> Q (Matcher Any)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Matcher Any -> Q (Matcher Any)) -> Matcher Any -> Q (Matcher Any)
forall a b. (a -> b) -> a -> b
$ ([PatQ] -> PatQ)
-> ([Q Exp] -> Q Exp) -> [Matcher Any] -> Matcher Any
forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers [PatQ] -> PatQ
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Q Exp] -> Q Exp
andBoolExprs [Matcher Any]
matchers
      Type
_ -> Type -> String -> Q (Matcher Any)
forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Eq1"

-- | Generates an expression which behaves like 'liftEq2' for the given data type.
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 [TyVarBndrUnit]
-> Maybe ([TyVarBndrUnit], TyVarBndrUnit, TyVarBndrUnit)
forall a. [a] -> Maybe ([a], a, a)
viewLastTwo [TyVarBndrUnit]
dtVarsNames of
    Maybe ([TyVarBndrUnit], TyVarBndrUnit, TyVarBndrUnit)
Nothing -> String -> Q (Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Type)) -> String -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$ String
"Not a type constructor:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name
    Just ([TyVarBndrUnit]
_, TyVarBndrUnit
a, TyVarBndrUnit
b) -> (Type, Type) -> Q (Type, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
VarT (TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
a), Name -> Type
VarT (TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
b))
  
  Name
eqA <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"eqA"
  Name
eqB <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"eqB"

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

-- | Build an instance of 'Matchable' for a data type.
--
-- Note that 'deriveMatchable' generates the 'Matchable' instance only. Because 'Matchable'
-- requires 'Functor' and 'Eq1' (and 'Eq' transitively) as its superclasses, to actually use the generated instance,
-- it's necessary to provide them too.
--
-- Use 'deriveInstances' to generate both @Matchable@ and @Eq1@ instances at once.
--
-- ==== Example
--
-- @
-- data Exp a = Plus a a | Times a a
-- 'deriveMatchable' ''Exp
-- @
--
-- will generate the following instance.
--
-- @
-- 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 <- Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
ctx) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Matchable) (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
f))
           [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'zipMatchWith [Q Clause]
zipMatchWithClauses ]

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

-- | Generates an expression which behaves like 'zipMatchWith' for the given data type.
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 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
  [Q Dec] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
z [Q Clause]
clauses ] (Name -> Q Exp
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 Cxt -> Maybe (Cxt, Type)
forall a. [a] -> Maybe ([a], a)
viewLast (Name -> Type
VarT (Name -> Type) -> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName (TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndrUnit]
dtVarsNames) of
    Maybe (Cxt, Type)
Nothing -> String -> Q (Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Type)) -> String -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$ String
"Not a type constructor:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name
    Just (Cxt
rest, Type
tyA) -> (Type, Type) -> Q (Type, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
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 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"

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

  let matchClauses :: [Q Clause]
matchClauses = ((Cxt, Q Clause) -> Q Clause) -> [(Cxt, Q Clause)] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Cxt, Q Clause) -> Q Clause
forall a b. (a, b) -> b
snd [(Cxt, Q Clause)]
matchClausesAndCtxs
      ctx :: Cxt
ctx = ((Cxt, Q Clause) -> Cxt) -> [(Cxt, Q Clause)] -> Cxt
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cxt, Q Clause) -> Cxt
forall a b. (a, b) -> a
fst [(Cxt, Q Clause)]
matchClausesAndCtxs
      mismatchClause :: Q Clause
mismatchClause = [PatQ] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ PatQ
forall (m :: * -> *). Quote m => m Pat
wildP, PatQ
forall (m :: * -> *). Quote m => m Pat
wildP, PatQ
forall (m :: * -> *). Quote m => m Pat
wildP ] (Q Exp -> Q Body
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 [Q Clause] -> [Q Clause] -> [Q Clause]
forall a. [a] -> [a] -> [a]
++ [Q Clause
mismatchClause]

  ((Cxt, Type), [Q Clause]) -> Q ((Cxt, Type), [Q Clause])
forall a. a -> Q a
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 (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
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 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tyA -> Q Exp -> (Cxt, Any) -> Q (Matcher (Cxt, Any))
forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (Name -> Q Exp
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 (Q Exp -> Q Exp -> Q Exp) -> (Cxt, Any) -> Q (Matcher (Cxt, Any))
forall a. (Q Exp -> Q Exp -> Q Exp) -> a -> Q (Matcher a)
matcherExpr
                  (\Q Exp
l Q Exp
r -> [| if $Q Exp
l == $Q Exp
r then Just $Q Exp
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' <- Q Exp -> Matcher (Cxt, Any) -> Q (Matcher (Cxt, Any))
forall a. Q Exp -> Matcher a -> Q (Matcher a)
liftMatcher [| zipMatchWith |] Matcher (Cxt, Any)
matcher
        Matcher (Cxt, Any) -> Q (Matcher (Cxt, Any))
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher (Cxt, Any) -> Q (Matcher (Cxt, Any)))
-> Matcher (Cxt, Any) -> Q (Matcher (Cxt, Any))
forall a b. (a -> b) -> a -> b
$ (Cxt
ctxG, Any
forall a. Monoid a => a
mempty) (Cxt, Any) -> Matcher (Cxt, Any) -> Matcher (Cxt, Any)
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' <- Q Exp
-> Matcher (Cxt, Any)
-> Matcher (Cxt, Any)
-> Q (Matcher (Cxt, Any))
forall a.
Semigroup a =>
Q Exp -> Matcher a -> Matcher a -> Q (Matcher a)
liftMatcher2 [| bizipMatchWith |] Matcher (Cxt, Any)
matcher1 Matcher (Cxt, Any)
matcher2
        Matcher (Cxt, Any) -> Q (Matcher (Cxt, Any))
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher (Cxt, Any) -> Q (Matcher (Cxt, Any)))
-> Matcher (Cxt, Any) -> Q (Matcher (Cxt, Any))
forall a b. (a -> b) -> a -> b
$ (Cxt
ctxG, Any
forall a. Monoid a => a
mempty) (Cxt, Any) -> Matcher (Cxt, Any) -> Matcher (Cxt, Any)
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 = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x Q Exp
y -> [| $Q Exp
x <*> $Q Exp
y |]) [| pure $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Int -> Name
tupleDataName Int
n)) |]
        [Matcher (Cxt, Any)]
matchers <- (Type -> Q (Matcher (Cxt, Any))) -> Cxt -> Q [Matcher (Cxt, Any)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q (Matcher (Cxt, Any))
go (Cxt -> Cxt
forall a. [a] -> [a]
reverse Cxt
subtys)
        Matcher (Cxt, Any) -> Q (Matcher (Cxt, Any))
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Matcher (Cxt, Any) -> Q (Matcher (Cxt, Any)))
-> Matcher (Cxt, Any) -> Q (Matcher (Cxt, Any))
forall a b. (a -> b) -> a -> b
$ ([PatQ] -> PatQ)
-> ([Q Exp] -> Q Exp) -> [Matcher (Cxt, Any)] -> Matcher (Cxt, Any)
forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers [PatQ] -> PatQ
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Q Exp] -> Q Exp
body [Matcher (Cxt, Any)]
matchers
      Type
_ -> Type -> String -> Q (Matcher (Cxt, Any))
forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Matchable"

-- | Build an instance of 'Bimatchable' for a data type.
--
-- Note that 'deriveBimatchable' generates the 'Bimatchable' instance only. Because 'Bimatchable'
-- requires 'Bifunctor' and 'Eq2' (and 'Functor', 'Eq', 'Eq1' transitively) as its superclasses,
-- to actually use the generated instance, it's necessary to provide them too.
--
-- Use 'deriveInstances' to generate all of these instances at once.
--
-- ==== Example
-- 
-- @
-- data Sum a b = InL a | InR b
-- 'deriveBimatchable' ''Sum
-- @
--
-- will create
--
-- @
-- instance Bimatchable 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 <- Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
ctx) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Bimatchable) (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
f))
           [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'bizipMatchWith [Q Clause]
clauses ]

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

-- | Generates an expression which behaves like 'bizipMatchWith' for the given data type.
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 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
  [Q Dec] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
z [Q Clause]
clauses ] (Name -> Q Exp
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 Cxt -> Maybe (Cxt, Type, Type)
forall a. [a] -> Maybe ([a], a, a)
viewLastTwo (Name -> Type
VarT (Name -> Type) -> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName (TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndrUnit]
dtVars) of
      Maybe (Cxt, Type, Type)
Nothing -> String -> Q (Type, Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Type, Type)) -> String -> Q (Type, Type, Type)
forall a b. (a -> b) -> a -> b
$ String
"Not a datatype with at least 2 parameters: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name
      Just (Cxt
rest, Type
tyA, Type
tyB) -> (Type, Type, Type) -> Q (Type, Type, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
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 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  Name
g <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"g"

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

  let matchClauses :: [Q Clause]
matchClauses = ((Cxt, Q Clause) -> Q Clause) -> [(Cxt, Q Clause)] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Cxt, Q Clause) -> Q Clause
forall a b. (a, b) -> b
snd [(Cxt, Q Clause)]
matchClausesAndCtxs
      ctx :: Cxt
ctx = ((Cxt, Q Clause) -> Cxt) -> [(Cxt, Q Clause)] -> Cxt
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cxt, Q Clause) -> Cxt
forall a b. (a, b) -> a
fst [(Cxt, Q Clause)]
matchClausesAndCtxs
      mismatchClause :: Q Clause
mismatchClause = [PatQ] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ PatQ
forall (m :: * -> *). Quote m => m Pat
wildP, PatQ
forall (m :: * -> *). Quote m => m Pat
wildP, PatQ
forall (m :: * -> *). Quote m => m Pat
wildP, PatQ
forall (m :: * -> *). Quote m => m Pat
wildP ] (Q Exp -> Q Body
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 [Q Clause] -> [Q Clause] -> [Q Clause]
forall a. [a] -> [a] -> [a]
++ [Q Clause
mismatchClause]

  ((Cxt, Type), [Q Clause]) -> Q ((Cxt, Type), [Q Clause])
forall a. a -> Q a
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 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tyA -> Q Exp -> (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any))
forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName) ([], Bool -> Any
Any Bool
True, Bool -> Any
Any Bool
False)
        | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tyB -> Q Exp -> (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any))
forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (Name -> Q Exp
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 (Q Exp -> Q Exp -> Q Exp)
-> (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any))
forall a. (Q Exp -> Q Exp -> Q Exp) -> a -> Q (Matcher a)
matcherExpr
                  (\Q Exp
l Q Exp
r -> [| if $Q Exp
l == $Q Exp
r then Just $Q Exp
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' <- Q Exp -> Matcher (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any))
forall a. Q Exp -> Matcher a -> Q (Matcher a)
liftMatcher [| zipMatchWith |] Matcher (Cxt, Any, Any)
matcher
        Matcher (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any))
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any)))
-> Matcher (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any))
forall a b. (a -> b) -> a -> b
$ (Cxt
ctxG, Any
forall a. Monoid a => a
mempty, Any
forall a. Monoid a => a
mempty) (Cxt, Any, Any)
-> Matcher (Cxt, Any, Any) -> Matcher (Cxt, Any, Any)
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' <- Q Exp
-> Matcher (Cxt, Any, Any)
-> Matcher (Cxt, Any, Any)
-> Q (Matcher (Cxt, Any, Any))
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
        Matcher (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any))
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any)))
-> Matcher (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any))
forall a b. (a -> b) -> a -> b
$ (Cxt
ctxG, Any
forall a. Monoid a => a
mempty, Any
forall a. Monoid a => a
mempty) (Cxt, Any, Any)
-> Matcher (Cxt, Any, Any) -> Matcher (Cxt, Any, Any)
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 <- (Type -> Q (Matcher (Cxt, Any, Any)))
-> Cxt -> Q [Matcher (Cxt, Any, Any)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q (Matcher (Cxt, Any, Any))
go (Cxt -> Cxt
forall a. [a] -> [a]
reverse Cxt
subtys)
        let body :: [Q Exp] -> Q Exp
body = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x Q Exp
y -> [| $Q Exp
x <*> $Q Exp
y |]) [| pure $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Int -> Name
tupleDataName Int
n)) |]
        Matcher (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any))
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Matcher (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any)))
-> Matcher (Cxt, Any, Any) -> Q (Matcher (Cxt, Any, Any))
forall a b. (a -> b) -> a -> b
$ ([PatQ] -> PatQ)
-> ([Q Exp] -> Q Exp)
-> [Matcher (Cxt, Any, Any)]
-> Matcher (Cxt, Any, Any)
forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers [PatQ] -> PatQ
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Q Exp] -> Q Exp
body [Matcher (Cxt, Any, Any)]
matchers
      Type
_ -> Type -> String -> Q (Matcher (Cxt, Any, Any))
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 = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$
  String
"unexpected type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in derivation of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cls String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
" (it's only possible to implement " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cls String -> String -> String
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 = (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
x Q Exp
y -> [| $Q Exp
x && $Q Exp
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
t2Type -> Cxt -> Cxt
forall 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 Type -> Type -> Bool
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 [a] -> [a]
forall a. [a] -> [a]
reverse [a]
as of
  [] -> Maybe ([a], a)
forall a. Maybe a
Nothing
  a
a:[a]
rest -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([a] -> [a]
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 [a] -> [a]
forall a. [a] -> [a]
reverse [a]
as of
  a
b:a
a:[a]
rest -> ([a], a, a) -> Maybe ([a], a, a)
forall a. a -> Maybe a
Just ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
rest, a
a, a
b)
  [a]
_ -> Maybe ([a], a, a)
forall a. Maybe a
Nothing