{-# LANGUAGE CPP             #-}
{-# LANGUAGE MultiWayIf      #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Matchable.TH (
  deriveMatchable, makeZipMatchWith,
  deriveBimatchable, makeBizipMatchWith
) where

import           Data.Bimatchable             (Bimatchable (..))
import           Data.Matchable               (Matchable (..))

import           Data.Monoid                  (Monoid (..))
import           Data.Semigroup               (Semigroup (..))

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

-- | 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
  ((Q Cxt
ctx, Type
f), ExpQ
zipMatchWithE) <- Name -> Q ((Q Cxt, Type), ExpQ)
makeZipMatchWith' Name
name

  Dec
dec <- forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD Q 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 [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
zipMatchWithE) []] ]

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

makeZipMatchWith :: Name -> ExpQ
makeZipMatchWith :: Name -> ExpQ
makeZipMatchWith Name
name = Name -> Q ((Q Cxt, Type), ExpQ)
makeZipMatchWith' Name
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b. (a, b) -> b
snd

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)

makeZipMatchWith' :: Name -> Q ((Q Cxt, Type), ExpQ)
makeZipMatchWith' :: Name -> Q ((Q Cxt, Type), ExpQ)
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"

  let mkMatchClause :: ConstructorInfo -> Q (Q Clause, [TypeQ])
mkMatchClause (ConstructorInfo Name
ctrName [TyVarBndrUnit]
_ Cxt
_ Cxt
fields [FieldStrictness]
_ ConstructorVariant
_) =
        do [Matcher Bool]
matchers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Name -> Type -> Q (Matcher Bool)
dMatchField Type
tyA Name
f) Cxt
fields
           let lFieldsP :: [PatQ]
lFieldsP = forall u. Matcher u -> PatQ
leftPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher Bool]
matchers
               rFieldsP :: [PatQ]
rFieldsP = forall u. Matcher u -> PatQ
rightPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher Bool]
matchers
               bodyUsesF :: Bool
bodyUsesF = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall u. Matcher u -> u
additionalInfo [Matcher Bool]
matchers
               body :: ExpQ
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
x ExpQ
y -> [| $x <*> $y |])
                            [| pure $(conE ctrName) |]
                            (forall u. Matcher u -> ExpQ
bodyExp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher Bool]
matchers)
               ctx :: [TypeQ]
ctx = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall u. Matcher u -> [TypeQ]
requiredCtx [Matcher Bool]
matchers
               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
               lPat :: PatQ
lPat = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName [PatQ]
lFieldsP
               rPat :: PatQ
rPat = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName [PatQ]
rFieldsP
           forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ
fPat, PatQ
lPat, PatQ
rPat] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
body) [], [TypeQ]
ctx)

  [(Q Clause, [TypeQ])]
matchClausesAndCtxs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ConstructorInfo -> Q (Q Clause, [TypeQ])
mkMatchClause [ConstructorInfo]
cons

  let matchClauses :: [Q Clause]
matchClauses = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Q Clause, [TypeQ])]
matchClausesAndCtxs
      ctx :: [TypeQ]
ctx = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Q Clause, [TypeQ])]
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]

  Name
zmw <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"zmw"
  forall (m :: * -> *) a. Monad m => a -> m a
return ((forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [TypeQ]
ctx, Type
dtFunctor), forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
zmw [Q Clause]
finalClauses ] (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
zmw))

data Matcher u = Matcher
  { forall u. Matcher u -> PatQ
leftPat        :: PatQ
  , forall u. Matcher u -> PatQ
rightPat       :: PatQ
  , forall u. Matcher u -> ExpQ
bodyExp        :: ExpQ
  , forall u. Matcher u -> [TypeQ]
requiredCtx    :: [TypeQ]
  , forall u. Matcher u -> u
additionalInfo :: u }

dMatchField :: Type -> Name -> Type -> Q (Matcher Bool)
dMatchField :: Type -> Name -> Type -> Q (Matcher Bool)
dMatchField Type
tyA Name
fName Type
ty = case Type -> (Type, Cxt)
spine Type
ty of
  (Type, Cxt)
_ | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyA -> do
        Name
l <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"l"
        Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher
          { leftPat :: PatQ
leftPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
l
          , rightPat :: PatQ
rightPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r
          , additionalInfo :: Bool
additionalInfo = Bool
True
          , bodyExp :: ExpQ
bodyExp = [| $(varE fName) $(varE l) $(varE r) |]
          , requiredCtx :: [TypeQ]
requiredCtx = [] }
    | Bool -> Bool
not (Type -> Type -> Bool
occurs Type
tyA Type
ty) -> do
        Name
l <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"l"
        Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
        let ctx :: [TypeQ]
ctx = [ forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) Type
ty) | Type -> Bool
hasTyVar Type
ty ]
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher
          { leftPat :: PatQ
leftPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
l
          , rightPat :: PatQ
rightPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r
          , additionalInfo :: Bool
additionalInfo = Bool
False
          , bodyExp :: ExpQ
bodyExp = [| if $(varE l) == $(varE r)
                           then Just $(varE l)
                           else Nothing |]
          , requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctx }
  (Type
ListT, Type
ty':Cxt
_) -> Type -> Q (Matcher Bool)
dWrapped Type
ty'
  (TupleT Int
n, Cxt
subtys) -> do
     [Matcher Bool]
matchers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Name -> Type -> Q (Matcher Bool)
dMatchField Type
tyA Name
fName) (forall a. [a] -> [a]
reverse Cxt
subtys)
     let lP :: PatQ
lP = forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP (forall u. Matcher u -> PatQ
leftPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher Bool]
matchers)
         rP :: PatQ
rP = forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP (forall u. Matcher u -> PatQ
rightPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher Bool]
matchers)
         tupcon :: ExpQ
tupcon = [| pure $(conE (tupleDataName n)) |]
         anyUsesF :: Bool
anyUsesF = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall u. Matcher u -> u
additionalInfo [Matcher Bool]
matchers
         body :: ExpQ
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
x ExpQ
y -> [| $x <*> $y |]) ExpQ
tupcon (forall u. Matcher u -> ExpQ
bodyExp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher Bool]
matchers)
         ctx :: [TypeQ]
ctx = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall u. Matcher u -> [TypeQ]
requiredCtx [Matcher Bool]
matchers
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher
       { leftPat :: PatQ
leftPat = PatQ
lP
       , rightPat :: PatQ
rightPat = PatQ
rP
       , additionalInfo :: Bool
additionalInfo = Bool
anyUsesF
       , bodyExp :: ExpQ
bodyExp = ExpQ
body
       , requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctx }
  (ConT Name
tcon, Type
ty' : Cxt
rest) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Bool
occurs Type
tyA) Cxt
rest -> do
     let g :: Type
g = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
AppT) (Name -> Type
ConT Name
tcon) Cxt
rest
         ctxG :: [TypeQ]
ctxG = [ forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type -> Type
AppT (Name -> Type
ConT ''Matchable) Type
g) | Type -> Bool
hasTyVar Type
g ]
     Matcher Bool
matcher <- Type -> Q (Matcher Bool)
dWrapped Type
ty'
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher Bool
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG forall a. [a] -> [a] -> [a]
++ forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher }
  (ConT Name
tcon, Type
ty1' : Type
ty2' : Cxt
rest) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Bool
occurs Type
tyA) Cxt
rest -> do
     let g :: Type
g = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
AppT) (Name -> Type
ConT Name
tcon) Cxt
rest
         ctxG :: [TypeQ]
ctxG = [ forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type -> Type
AppT (Name -> Type
ConT ''Bimatchable) Type
g) | Type -> Bool
hasTyVar Type
g ]
     -- Note that since @spine@ reverses argument order,
     -- it must be dWrappedBi ty2 ty1.
     Matcher Bool
matcher <- Type -> Type -> Q (Matcher Bool)
dWrappedBi Type
ty2' Type
ty1'
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher Bool
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG forall a. [a] -> [a] -> [a]
++ forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher }
  (VarT Name
t, Type
ty' : Cxt
rest) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Bool
occurs Type
tyA) Cxt
rest -> do
     let g :: Type
g = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
AppT) (Name -> Type
VarT Name
t) Cxt
rest
         ctxG :: [TypeQ]
ctxG = [ forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type -> Type
AppT (Name -> Type
ConT ''Matchable) Type
g) ]
     Matcher Bool
matcher <- Type -> Q (Matcher Bool)
dWrapped Type
ty'
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher Bool
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG forall a. [a] -> [a] -> [a]
++ forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher }
  (VarT Name
t, Type
ty1' : Type
ty2' : Cxt
rest) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Bool
occurs Type
tyA) Cxt
rest -> do
     let g :: Type
g = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
AppT) (Name -> Type
VarT Name
t) Cxt
rest
         ctxG :: [TypeQ]
ctxG = [ forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type -> Type
AppT (Name -> Type
ConT ''Bimatchable) Type
g) | Type -> Bool
hasTyVar Type
g ]
     Matcher Bool
matcher <- Type -> Type -> Q (Matcher Bool)
dWrappedBi Type
ty2' Type
ty1'
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher Bool
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG forall a. [a] -> [a] -> [a]
++ forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher }
  (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
_, Cxt
_) -> forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Matchable"
  (ParensT Type
_, Cxt
_) -> forall a. HasCallStack => String -> a
error String
"Never reach here"
  (AppT Type
_ Type
_, Cxt
_) -> forall a. HasCallStack => String -> a
error String
"Never reach here"
  (SigT Type
_ Type
_, Cxt
_) -> forall a. HasCallStack => String -> a
error String
"Never reach here"
  (Type, Cxt)
_ -> forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Matchable"

  where
    dWrapped :: Type -> Q (Matcher Bool)
    dWrapped :: Type -> Q (Matcher Bool)
dWrapped Type
ty' =do
      Name
l <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"l"
      Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
      (Bool
usesF', [TypeQ]
ctx, ExpQ
fun) <- do
         Matcher Bool
matcher <- Type -> Name -> Type -> Q (Matcher Bool)
dMatchField Type
tyA Name
fName Type
ty'
         let fun :: ExpQ
fun = forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall u. Matcher u -> PatQ
leftPat Matcher Bool
matcher, forall u. Matcher u -> PatQ
rightPat Matcher Bool
matcher] (forall u. Matcher u -> ExpQ
bodyExp Matcher Bool
matcher)
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall u. Matcher u -> u
additionalInfo Matcher Bool
matcher, forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher, ExpQ
fun)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher
        { leftPat :: PatQ
leftPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
l
        , rightPat :: PatQ
rightPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r
        , additionalInfo :: Bool
additionalInfo = Bool
usesF'
        , bodyExp :: ExpQ
bodyExp = [| zipMatchWith $fun $(varE l) $(varE r) |]
        , requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctx }

    dWrappedBi :: Type -> Type -> Q (Matcher Bool)
    dWrappedBi :: Type -> Type -> Q (Matcher Bool)
dWrappedBi Type
ty1 Type
ty2 = do
      Name
l <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"l"
      Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
      (Bool
usesF', [TypeQ]
ctx, ExpQ
fun1, ExpQ
fun2) <- do
         Matcher Bool
matcher1 <- Type -> Name -> Type -> Q (Matcher Bool)
dMatchField Type
tyA Name
fName Type
ty1
         Matcher Bool
matcher2 <- Type -> Name -> Type -> Q (Matcher Bool)
dMatchField Type
tyA Name
fName Type
ty2
         let fun1 :: ExpQ
fun1 = forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall u. Matcher u -> PatQ
leftPat Matcher Bool
matcher1, forall u. Matcher u -> PatQ
rightPat Matcher Bool
matcher1] (forall u. Matcher u -> ExpQ
bodyExp Matcher Bool
matcher1)
             fun2 :: ExpQ
fun2 = forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall u. Matcher u -> PatQ
leftPat Matcher Bool
matcher2, forall u. Matcher u -> PatQ
rightPat Matcher Bool
matcher2] (forall u. Matcher u -> ExpQ
bodyExp Matcher Bool
matcher2)
             usesF' :: Bool
usesF' = forall u. Matcher u -> u
additionalInfo Matcher Bool
matcher1 Bool -> Bool -> Bool
|| forall u. Matcher u -> u
additionalInfo Matcher Bool
matcher2
             ctx :: [TypeQ]
ctx = forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher1 forall a. [a] -> [a] -> [a]
++ forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher2
         forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
usesF', [TypeQ]
ctx, ExpQ
fun1, ExpQ
fun2)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher
        { leftPat :: PatQ
leftPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
l
        , rightPat :: PatQ
rightPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r
        , additionalInfo :: Bool
additionalInfo = Bool
usesF'
        , bodyExp :: ExpQ
bodyExp = [| bizipMatchWith $fun1 $fun2 $(varE l) $(varE r) |]
        , requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctx }

-- | 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
  ((Q Cxt
ctx, Type
f), ExpQ
zipMatchWithE) <- Name -> Q ((Q Cxt, Type), ExpQ)
makeBizipMatchWith' Name
name

  Dec
dec <- forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD Q 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 [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
zipMatchWithE) []] ]

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

makeBizipMatchWith :: Name -> ExpQ
makeBizipMatchWith :: Name -> ExpQ
makeBizipMatchWith Name
name = Name -> Q ((Q Cxt, Type), ExpQ)
makeBizipMatchWith' Name
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b. (a, b) -> b
snd

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

makeBizipMatchWith' :: Name -> Q ((Q Cxt, Type), ExpQ)
makeBizipMatchWith' :: Name -> Q ((Q Cxt, Type), ExpQ)
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"

  let mkMatchClause :: ConstructorInfo -> Q (Q Clause, [TypeQ])
mkMatchClause (ConstructorInfo Name
ctrName [TyVarBndrUnit]
_ Cxt
_ Cxt
fields [FieldStrictness]
_ ConstructorVariant
_) =
        do [Matcher FunUsage2]
matchers <- 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 FunUsage2)
dBimatchField Type
tyA Name
f Type
tyB Name
g) Cxt
fields
           let lFieldsP :: [PatQ]
lFieldsP = forall u. Matcher u -> PatQ
leftPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher FunUsage2]
matchers
               rFieldsP :: [PatQ]
rFieldsP = forall u. Matcher u -> PatQ
rightPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher FunUsage2]
matchers
               Usage2 Bool
usesF Bool
usesG = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall u. Matcher u -> u
additionalInfo [Matcher FunUsage2]
matchers
               body :: ExpQ
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
x ExpQ
y -> [| $x <*> $y |])
                            [| pure $(conE ctrName) |]
                            (forall u. Matcher u -> ExpQ
bodyExp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher FunUsage2]
matchers)
               ctx :: [TypeQ]
ctx = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall u. Matcher u -> [TypeQ]
requiredCtx [Matcher FunUsage2]
matchers
               fPat :: PatQ
fPat = if Bool
usesF then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f else forall (m :: * -> *). Quote m => m Pat
wildP
               gPat :: PatQ
gPat = if Bool
usesG then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
g else forall (m :: * -> *). Quote m => m Pat
wildP
               lPat :: PatQ
lPat = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName [PatQ]
lFieldsP
               rPat :: PatQ
rPat = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName [PatQ]
rFieldsP
           forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ
fPat, PatQ
gPat, PatQ
lPat, PatQ
rPat] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
body) [], [TypeQ]
ctx)

  [(Q Clause, [TypeQ])]
matchClausesAndCtxs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ConstructorInfo -> Q (Q Clause, [TypeQ])
mkMatchClause [ConstructorInfo]
cons

  let matchClauses :: [Q Clause]
matchClauses = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Q Clause, [TypeQ])]
matchClausesAndCtxs
      ctx :: [TypeQ]
ctx = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Q Clause, [TypeQ])]
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]

  Name
bzmw <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"bzmw"
  forall (m :: * -> *) a. Monad m => a -> m a
return ((forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [TypeQ]
ctx, Type
dtFunctor), forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
bzmw [Q Clause]
finalClauses ] (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
bzmw))

data FunUsage2 = Usage2 Bool Bool

instance Semigroup FunUsage2 where
  Usage2 Bool
f1 Bool
g1 <> :: FunUsage2 -> FunUsage2 -> FunUsage2
<> Usage2 Bool
f2 Bool
g2 = Bool -> Bool -> FunUsage2
Usage2 (Bool
f1 Bool -> Bool -> Bool
|| Bool
f2) (Bool
g1 Bool -> Bool -> Bool
|| Bool
g2)

instance Monoid FunUsage2 where
  mempty :: FunUsage2
mempty = Bool -> Bool -> FunUsage2
Usage2 Bool
False Bool
False
  mappend :: FunUsage2 -> FunUsage2 -> FunUsage2
mappend = forall a. Semigroup a => a -> a -> a
(<>)

dBimatchField :: Type -> Name -> Type -> Name -> Type -> Q (Matcher FunUsage2)
dBimatchField :: Type -> Name -> Type -> Name -> Type -> Q (Matcher FunUsage2)
dBimatchField Type
tyA Name
fName Type
tyB Name
gName Type
ty = case Type -> (Type, Cxt)
spine Type
ty of
  (Type, Cxt)
_ | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyA -> do
        Name
l <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"l"
        Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher
          { leftPat :: PatQ
leftPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
l
          , rightPat :: PatQ
rightPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r
          , additionalInfo :: FunUsage2
additionalInfo = Bool -> Bool -> FunUsage2
Usage2 Bool
True Bool
False
          , bodyExp :: ExpQ
bodyExp = [| $(varE fName) $(varE l) $(varE r) |]
          , requiredCtx :: [TypeQ]
requiredCtx = [] }
    | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyB -> do
        Name
l <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"l"
        Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher
          { leftPat :: PatQ
leftPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
l
          , rightPat :: PatQ
rightPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r
          , additionalInfo :: FunUsage2
additionalInfo = Bool -> Bool -> FunUsage2
Usage2 Bool
False Bool
True
          , bodyExp :: ExpQ
bodyExp = [| $(varE gName) $(varE l) $(varE r) |]
          , requiredCtx :: [TypeQ]
requiredCtx = [] }
    | Type -> Bool
isConst Type
ty -> do
        Name
l <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"l"
        Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
        let ctx :: [TypeQ]
ctx = [ forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) Type
ty) | Type -> Bool
hasTyVar Type
ty ]
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher
          { leftPat :: PatQ
leftPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
l
          , rightPat :: PatQ
rightPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r
          , additionalInfo :: FunUsage2
additionalInfo = Bool -> Bool -> FunUsage2
Usage2 Bool
False Bool
False
          , bodyExp :: ExpQ
bodyExp = [| if $(varE l) == $(varE r)
                           then Just $(varE l)
                           else Nothing |]
          , requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctx }
  (Type
ListT, Type
ty':Cxt
_) -> Type -> Q (Matcher FunUsage2)
dWrapped Type
ty'
  (TupleT Int
n, Cxt
subtys) -> do
     [Matcher FunUsage2]
matchers <- 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 FunUsage2)
dBimatchField Type
tyA Name
fName Type
tyB Name
gName) (forall a. [a] -> [a]
reverse Cxt
subtys)
     let lP :: PatQ
lP = forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP (forall u. Matcher u -> PatQ
leftPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher FunUsage2]
matchers)
         rP :: PatQ
rP = forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP (forall u. Matcher u -> PatQ
rightPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher FunUsage2]
matchers)
         tupcon :: ExpQ
tupcon = [| pure $(conE (tupleDataName n)) |]
         anyUsesF :: FunUsage2
anyUsesF = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall u. Matcher u -> u
additionalInfo [Matcher FunUsage2]
matchers
         body :: ExpQ
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
x ExpQ
y -> [| $x <*> $y |]) ExpQ
tupcon (forall u. Matcher u -> ExpQ
bodyExp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher FunUsage2]
matchers)
         ctx :: [TypeQ]
ctx = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall u. Matcher u -> [TypeQ]
requiredCtx [Matcher FunUsage2]
matchers
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher
       { leftPat :: PatQ
leftPat = PatQ
lP
       , rightPat :: PatQ
rightPat = PatQ
rP
       , additionalInfo :: FunUsage2
additionalInfo = FunUsage2
anyUsesF
       , bodyExp :: ExpQ
bodyExp = ExpQ
body
       , requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctx }
  (ConT Name
tcon, Type
ty' : Cxt
rest) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isConst Cxt
rest -> do
     let g :: Type
g = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
AppT) (Name -> Type
ConT Name
tcon) Cxt
rest
         ctxG :: [TypeQ]
ctxG = [ forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type -> Type
AppT (Name -> Type
ConT ''Matchable) Type
g) | Type -> Bool
hasTyVar Type
g ]
     Matcher FunUsage2
matcher <- Type -> Q (Matcher FunUsage2)
dWrapped Type
ty'
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher FunUsage2
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG forall a. [a] -> [a] -> [a]
++ forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher }
  (ConT Name
tcon, Type
ty1' : Type
ty2' : Cxt
rest) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isConst Cxt
rest -> do
     let g :: Type
g = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
AppT) (Name -> Type
ConT Name
tcon) Cxt
rest
         ctxG :: [TypeQ]
ctxG = [ forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type -> Type
AppT (Name -> Type
ConT ''Bimatchable) Type
g) | Type -> Bool
hasTyVar Type
g ]
     -- Note that since @spine@ reverses argument order,
     -- it must be dWrappedBi ty2 ty1.
     Matcher FunUsage2
matcher <- Type -> Type -> Q (Matcher FunUsage2)
dWrappedBi Type
ty2' Type
ty1'
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher FunUsage2
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG forall a. [a] -> [a] -> [a]
++ forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher }
  (VarT Name
t, Type
ty' : Cxt
rest) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isConst Cxt
rest -> do
     let g :: Type
g = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
AppT) (Name -> Type
VarT Name
t) Cxt
rest
         ctxG :: [TypeQ]
ctxG = [ forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type -> Type
AppT (Name -> Type
ConT ''Matchable) Type
g) ]
     Matcher FunUsage2
matcher <- Type -> Q (Matcher FunUsage2)
dWrapped Type
ty'
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher FunUsage2
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG forall a. [a] -> [a] -> [a]
++ forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher }
  (VarT Name
t, Type
ty1' : Type
ty2' : Cxt
rest) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isConst Cxt
rest -> do
     let g :: Type
g = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
AppT) (Name -> Type
VarT Name
t) Cxt
rest
         ctxG :: [TypeQ]
ctxG = [ forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type -> Type
AppT (Name -> Type
ConT ''Bimatchable) Type
g) | Type -> Bool
hasTyVar Type
g ]
     Matcher FunUsage2
matcher <- Type -> Type -> Q (Matcher FunUsage2)
dWrappedBi Type
ty2' Type
ty1'
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher FunUsage2
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG forall a. [a] -> [a] -> [a]
++ forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher }
  (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
_, Cxt
_) -> forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Bimatchable"
  (ParensT Type
_, Cxt
_) -> forall a. HasCallStack => String -> a
error String
"Never reach here"
  (AppT Type
_ Type
_, Cxt
_) -> forall a. HasCallStack => String -> a
error String
"Never reach here"
  (SigT Type
_ Type
_, Cxt
_) -> forall a. HasCallStack => String -> a
error String
"Never reach here"
  (Type, Cxt)
_ -> forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Bimatchable"

  where
    isConst :: Type -> Bool
    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)

    dWrapped :: Type -> Q (Matcher FunUsage2)
    dWrapped :: Type -> Q (Matcher FunUsage2)
dWrapped Type
ty' = do
      Name
l <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"l"
      Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
      (FunUsage2
usesF', [TypeQ]
ctx, ExpQ
fun) <- do
         Matcher FunUsage2
matcher <- Type -> Name -> Type -> Name -> Type -> Q (Matcher FunUsage2)
dBimatchField Type
tyA Name
fName Type
tyB Name
gName Type
ty'
         let fun :: ExpQ
fun = forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall u. Matcher u -> PatQ
leftPat Matcher FunUsage2
matcher, forall u. Matcher u -> PatQ
rightPat Matcher FunUsage2
matcher] (forall u. Matcher u -> ExpQ
bodyExp Matcher FunUsage2
matcher)
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall u. Matcher u -> u
additionalInfo Matcher FunUsage2
matcher, forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher, ExpQ
fun)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher
        { leftPat :: PatQ
leftPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
l
        , rightPat :: PatQ
rightPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r
        , additionalInfo :: FunUsage2
additionalInfo = FunUsage2
usesF'
        , bodyExp :: ExpQ
bodyExp = [| zipMatchWith $fun $(varE l) $(varE r) |]
        , requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctx }

    dWrappedBi :: Type -> Type -> Q (Matcher FunUsage2)
    dWrappedBi :: Type -> Type -> Q (Matcher FunUsage2)
dWrappedBi Type
ty1 Type
ty2 = do
      Name
l <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"l"
      Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
      (FunUsage2
usesF', [TypeQ]
ctx, ExpQ
fun1, ExpQ
fun2) <- do
         Matcher FunUsage2
matcher1 <- Type -> Name -> Type -> Name -> Type -> Q (Matcher FunUsage2)
dBimatchField Type
tyA Name
fName Type
tyB Name
gName Type
ty1
         Matcher FunUsage2
matcher2 <- Type -> Name -> Type -> Name -> Type -> Q (Matcher FunUsage2)
dBimatchField Type
tyA Name
fName Type
tyB Name
gName Type
ty2
         let fun1 :: ExpQ
fun1 = forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall u. Matcher u -> PatQ
leftPat Matcher FunUsage2
matcher1, forall u. Matcher u -> PatQ
rightPat Matcher FunUsage2
matcher1] (forall u. Matcher u -> ExpQ
bodyExp Matcher FunUsage2
matcher1)
             fun2 :: ExpQ
fun2 = forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall u. Matcher u -> PatQ
leftPat Matcher FunUsage2
matcher2, forall u. Matcher u -> PatQ
rightPat Matcher FunUsage2
matcher2] (forall u. Matcher u -> ExpQ
bodyExp Matcher FunUsage2
matcher2)
             usesF' :: FunUsage2
usesF' = forall u. Matcher u -> u
additionalInfo Matcher FunUsage2
matcher1 forall a. Semigroup a => a -> a -> a
<> forall u. Matcher u -> u
additionalInfo Matcher FunUsage2
matcher2
             ctx :: [TypeQ]
ctx = forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher1 forall a. [a] -> [a] -> [a]
++ forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher2
         forall (m :: * -> *) a. Monad m => a -> m a
return (FunUsage2
usesF', [TypeQ]
ctx, ExpQ
fun1, ExpQ
fun2)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher
        { leftPat :: PatQ
leftPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
l
        , rightPat :: PatQ
rightPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r
        , additionalInfo :: FunUsage2
additionalInfo = FunUsage2
usesF'
        , bodyExp :: ExpQ
bodyExp = [| bizipMatchWith $fun1 $fun2 $(varE l) $(varE r) |]
        , requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctx }

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

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)"

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