{-# 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 <- Q Cxt -> TypeQ -> [DecQ] -> DecQ
instanceD Q Cxt
ctx (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''Matchable) (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
f))
           [ Name -> [ClauseQ] -> DecQ
funD 'zipMatchWith [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
zipMatchWithE) []] ]

  [Dec] -> Q [Dec]
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 Q ((Q Cxt, Type), ExpQ) -> (((Q Cxt, Type), ExpQ) -> ExpQ) -> ExpQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Q Cxt, Type), ExpQ) -> ExpQ
forall a b. (a, b) -> b
snd

viewLast :: [a] -> Maybe ([a], a)
viewLast :: [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)

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 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. TyVarBndrUnit -> 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 (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 (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type -> Type) -> Type -> Cxt -> Type
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
newName String
"f"

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

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

  let matchClauses :: [ClauseQ]
matchClauses = ((ClauseQ, [TypeQ]) -> ClauseQ)
-> [(ClauseQ, [TypeQ])] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (ClauseQ, [TypeQ]) -> ClauseQ
forall a b. (a, b) -> a
fst [(ClauseQ, [TypeQ])]
matchClausesAndCtxs
      ctx :: [TypeQ]
ctx = ((ClauseQ, [TypeQ]) -> [TypeQ]) -> [(ClauseQ, [TypeQ])] -> [TypeQ]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ClauseQ, [TypeQ]) -> [TypeQ]
forall a b. (a, b) -> b
snd [(ClauseQ, [TypeQ])]
matchClausesAndCtxs
      mismatchClause :: ClauseQ
mismatchClause = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [ PatQ
wildP, PatQ
wildP, PatQ
wildP ] (ExpQ -> BodyQ
normalB [| Nothing |]) []
      finalClauses :: [ClauseQ]
finalClauses = case [ConstructorInfo]
cons of
        []  -> []
        [ConstructorInfo
_] -> [ClauseQ]
matchClauses
        [ConstructorInfo]
_   -> [ClauseQ]
matchClauses [ClauseQ] -> [ClauseQ] -> [ClauseQ]
forall a. [a] -> [a] -> [a]
++ [ClauseQ
mismatchClause]

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

data Matcher u = Matcher
  { Matcher u -> PatQ
leftPat        :: PatQ
  , Matcher u -> PatQ
rightPat       :: PatQ
  , Matcher u -> ExpQ
bodyExp        :: ExpQ
  , Matcher u -> [TypeQ]
requiredCtx    :: [TypeQ]
  , 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 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tyA -> do
        Name
l <- String -> Q Name
newName String
"l"
        Name
r <- String -> Q Name
newName String
"r"
        Matcher Bool -> Q (Matcher Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher Bool -> Q (Matcher Bool))
-> Matcher Bool -> Q (Matcher Bool)
forall a b. (a -> b) -> a -> b
$ Matcher :: forall u. PatQ -> PatQ -> ExpQ -> [TypeQ] -> u -> Matcher u
Matcher
          { leftPat :: PatQ
leftPat = Name -> PatQ
varP Name
l
          , rightPat :: PatQ
rightPat = Name -> PatQ
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 <- String -> Q Name
newName String
"l"
        Name
r <- String -> Q Name
newName String
"r"
        let ctx :: [TypeQ]
ctx = [ Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) Type
ty) | Type -> Bool
hasTyVar Type
ty ]
        Matcher Bool -> Q (Matcher Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher Bool -> Q (Matcher Bool))
-> Matcher Bool -> Q (Matcher Bool)
forall a b. (a -> b) -> a -> b
$ Matcher :: forall u. PatQ -> PatQ -> ExpQ -> [TypeQ] -> u -> Matcher u
Matcher
          { leftPat :: PatQ
leftPat = Name -> PatQ
varP Name
l
          , rightPat :: PatQ
rightPat = Name -> PatQ
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 <- (Type -> Q (Matcher Bool)) -> Cxt -> Q [Matcher Bool]
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) (Cxt -> Cxt
forall a. [a] -> [a]
reverse Cxt
subtys)
     let lP :: PatQ
lP = [PatQ] -> PatQ
tupP (Matcher Bool -> PatQ
forall u. Matcher u -> PatQ
leftPat (Matcher Bool -> PatQ) -> [Matcher Bool] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher Bool]
matchers)
         rP :: PatQ
rP = [PatQ] -> PatQ
tupP (Matcher Bool -> PatQ
forall u. Matcher u -> PatQ
rightPat (Matcher Bool -> PatQ) -> [Matcher Bool] -> [PatQ]
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 = (Matcher Bool -> Bool) -> [Matcher Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Matcher Bool -> Bool
forall u. Matcher u -> u
additionalInfo [Matcher Bool]
matchers
         body :: ExpQ
body = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
x ExpQ
y -> [| $x <*> $y |]) ExpQ
tupcon (Matcher Bool -> ExpQ
forall u. Matcher u -> ExpQ
bodyExp (Matcher Bool -> ExpQ) -> [Matcher Bool] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher Bool]
matchers)
         ctx :: [TypeQ]
ctx = (Matcher Bool -> [TypeQ]) -> [Matcher Bool] -> [TypeQ]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Matcher Bool -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx [Matcher Bool]
matchers
     Matcher Bool -> Q (Matcher Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher Bool -> Q (Matcher Bool))
-> Matcher Bool -> Q (Matcher Bool)
forall a b. (a -> b) -> a -> b
$ Matcher :: forall u. PatQ -> PatQ -> ExpQ -> [TypeQ] -> u -> Matcher u
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) | (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (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) Cxt
rest -> do
     let g :: Type
g = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type -> Type) -> Type -> Type -> Type
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 = [ Type -> TypeQ
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'
     Matcher Bool -> Q (Matcher Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher Bool -> Q (Matcher Bool))
-> Matcher Bool -> Q (Matcher Bool)
forall a b. (a -> b) -> a -> b
$ Matcher Bool
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ Matcher Bool -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher }
  (ConT Name
tcon, Type
ty1' : Type
ty2' : Cxt
rest) | (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (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) Cxt
rest -> do
     let g :: Type
g = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type -> Type) -> Type -> Type -> Type
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 = [ Type -> TypeQ
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'
     Matcher Bool -> Q (Matcher Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher Bool -> Q (Matcher Bool))
-> Matcher Bool -> Q (Matcher Bool)
forall a b. (a -> b) -> a -> b
$ Matcher Bool
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ Matcher Bool -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher }
  (VarT Name
t, Type
ty' : Cxt
rest) | (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (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) Cxt
rest -> do
     let g :: Type
g = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type -> Type) -> Type -> Type -> Type
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 = [ Type -> TypeQ
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'
     Matcher Bool -> Q (Matcher Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher Bool -> Q (Matcher Bool))
-> Matcher Bool -> Q (Matcher Bool)
forall a b. (a -> b) -> a -> b
$ Matcher Bool
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ Matcher Bool -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher }
  (VarT Name
t, Type
ty1' : Type
ty2' : Cxt
rest) | (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (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) Cxt
rest -> do
     let g :: Type
g = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type -> Type) -> Type -> Type -> Type
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 = [ Type -> TypeQ
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'
     Matcher Bool -> Q (Matcher Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher Bool -> Q (Matcher Bool))
-> Matcher Bool -> Q (Matcher Bool)
forall a b. (a -> b) -> a -> b
$ Matcher Bool
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ Matcher Bool -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher }
  (ForallT [TyVarBndrUnit]
_ Cxt
_ Type
_, Cxt
_) -> Type -> String -> Q (Matcher Bool)
forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Matchable"
  (ParensT Type
_, Cxt
_) -> String -> Q (Matcher Bool)
forall a. HasCallStack => String -> a
error String
"Never reach here"
  (AppT Type
_ Type
_, Cxt
_) -> String -> Q (Matcher Bool)
forall a. HasCallStack => String -> a
error String
"Never reach here"
  (SigT Type
_ Type
_, Cxt
_) -> String -> Q (Matcher Bool)
forall a. HasCallStack => String -> a
error String
"Never reach here"
  (Type, Cxt)
_ -> Type -> String -> Q (Matcher Bool)
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 <- String -> Q Name
newName String
"l"
      Name
r <- String -> Q 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 = [PatQ] -> ExpQ -> ExpQ
lamE [Matcher Bool -> PatQ
forall u. Matcher u -> PatQ
leftPat Matcher Bool
matcher, Matcher Bool -> PatQ
forall u. Matcher u -> PatQ
rightPat Matcher Bool
matcher] (Matcher Bool -> ExpQ
forall u. Matcher u -> ExpQ
bodyExp Matcher Bool
matcher)
         (Bool, [TypeQ], ExpQ) -> Q (Bool, [TypeQ], ExpQ)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher Bool -> Bool
forall u. Matcher u -> u
additionalInfo Matcher Bool
matcher, Matcher Bool -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher, ExpQ
fun)
      Matcher Bool -> Q (Matcher Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher Bool -> Q (Matcher Bool))
-> Matcher Bool -> Q (Matcher Bool)
forall a b. (a -> b) -> a -> b
$ Matcher :: forall u. PatQ -> PatQ -> ExpQ -> [TypeQ] -> u -> Matcher u
Matcher
        { leftPat :: PatQ
leftPat = Name -> PatQ
varP Name
l
        , rightPat :: PatQ
rightPat = Name -> PatQ
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 <- String -> Q Name
newName String
"l"
      Name
r <- String -> Q 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 = [PatQ] -> ExpQ -> ExpQ
lamE [Matcher Bool -> PatQ
forall u. Matcher u -> PatQ
leftPat Matcher Bool
matcher1, Matcher Bool -> PatQ
forall u. Matcher u -> PatQ
rightPat Matcher Bool
matcher1] (Matcher Bool -> ExpQ
forall u. Matcher u -> ExpQ
bodyExp Matcher Bool
matcher1)
             fun2 :: ExpQ
fun2 = [PatQ] -> ExpQ -> ExpQ
lamE [Matcher Bool -> PatQ
forall u. Matcher u -> PatQ
leftPat Matcher Bool
matcher2, Matcher Bool -> PatQ
forall u. Matcher u -> PatQ
rightPat Matcher Bool
matcher2] (Matcher Bool -> ExpQ
forall u. Matcher u -> ExpQ
bodyExp Matcher Bool
matcher2)
             usesF' :: Bool
usesF' = Matcher Bool -> Bool
forall u. Matcher u -> u
additionalInfo Matcher Bool
matcher1 Bool -> Bool -> Bool
|| Matcher Bool -> Bool
forall u. Matcher u -> u
additionalInfo Matcher Bool
matcher2
             ctx :: [TypeQ]
ctx = Matcher Bool -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher1 [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ Matcher Bool -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher Bool
matcher2
         (Bool, [TypeQ], ExpQ, ExpQ) -> Q (Bool, [TypeQ], ExpQ, ExpQ)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
usesF', [TypeQ]
ctx, ExpQ
fun1, ExpQ
fun2)
      Matcher Bool -> Q (Matcher Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher Bool -> Q (Matcher Bool))
-> Matcher Bool -> Q (Matcher Bool)
forall a b. (a -> b) -> a -> b
$ Matcher :: forall u. PatQ -> PatQ -> ExpQ -> [TypeQ] -> u -> Matcher u
Matcher
        { leftPat :: PatQ
leftPat = Name -> PatQ
varP Name
l
        , rightPat :: PatQ
rightPat = Name -> PatQ
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 <- Q Cxt -> TypeQ -> [DecQ] -> DecQ
instanceD Q Cxt
ctx (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''Bimatchable) (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
f))
           [ Name -> [ClauseQ] -> DecQ
funD 'bizipMatchWith [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
zipMatchWithE) []] ]

  [Dec] -> Q [Dec]
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 Q ((Q Cxt, Type), ExpQ) -> (((Q Cxt, Type), ExpQ) -> ExpQ) -> ExpQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Q Cxt, Type), ExpQ) -> ExpQ
forall a b. (a, b) -> b
snd

viewLastTwo :: [a] -> Maybe ([a],a,a)
viewLastTwo :: [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

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 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. TyVarBndrUnit -> 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 (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 (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type -> Type) -> Type -> Cxt -> Type
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
newName String
"f"
  Name
g <- String -> Q Name
newName String
"g"

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

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

  let matchClauses :: [ClauseQ]
matchClauses = ((ClauseQ, [TypeQ]) -> ClauseQ)
-> [(ClauseQ, [TypeQ])] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (ClauseQ, [TypeQ]) -> ClauseQ
forall a b. (a, b) -> a
fst [(ClauseQ, [TypeQ])]
matchClausesAndCtxs
      ctx :: [TypeQ]
ctx = ((ClauseQ, [TypeQ]) -> [TypeQ]) -> [(ClauseQ, [TypeQ])] -> [TypeQ]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ClauseQ, [TypeQ]) -> [TypeQ]
forall a b. (a, b) -> b
snd [(ClauseQ, [TypeQ])]
matchClausesAndCtxs
      mismatchClause :: ClauseQ
mismatchClause = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [ PatQ
wildP, PatQ
wildP, PatQ
wildP, PatQ
wildP ] (ExpQ -> BodyQ
normalB [| Nothing |]) []
      finalClauses :: [ClauseQ]
finalClauses = case [ConstructorInfo]
cons of
        []  -> []
        [ConstructorInfo
_] -> [ClauseQ]
matchClauses
        [ConstructorInfo]
_   -> [ClauseQ]
matchClauses [ClauseQ] -> [ClauseQ] -> [ClauseQ]
forall a. [a] -> [a] -> [a]
++ [ClauseQ
mismatchClause]

  Name
bzmw <- String -> Q Name
newName String
"bzmw"
  ((Q Cxt, Type), ExpQ) -> Q ((Q Cxt, Type), ExpQ)
forall (m :: * -> *) a. Monad m => a -> m a
return (([TypeQ] -> Q Cxt
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [TypeQ]
ctx, Type
dtFunctor), [DecQ] -> ExpQ -> ExpQ
letE [ Name -> [ClauseQ] -> DecQ
funD Name
bzmw [ClauseQ]
finalClauses ] (Name -> ExpQ
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 = FunUsage2 -> FunUsage2 -> FunUsage2
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 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tyA -> do
        Name
l <- String -> Q Name
newName String
"l"
        Name
r <- String -> Q Name
newName String
"r"
        Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher FunUsage2 -> Q (Matcher FunUsage2))
-> Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall a b. (a -> b) -> a -> b
$ Matcher :: forall u. PatQ -> PatQ -> ExpQ -> [TypeQ] -> u -> Matcher u
Matcher
          { leftPat :: PatQ
leftPat = Name -> PatQ
varP Name
l
          , rightPat :: PatQ
rightPat = Name -> PatQ
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 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tyB -> do
        Name
l <- String -> Q Name
newName String
"l"
        Name
r <- String -> Q Name
newName String
"r"
        Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher FunUsage2 -> Q (Matcher FunUsage2))
-> Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall a b. (a -> b) -> a -> b
$ Matcher :: forall u. PatQ -> PatQ -> ExpQ -> [TypeQ] -> u -> Matcher u
Matcher
          { leftPat :: PatQ
leftPat = Name -> PatQ
varP Name
l
          , rightPat :: PatQ
rightPat = Name -> PatQ
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 <- String -> Q Name
newName String
"l"
        Name
r <- String -> Q Name
newName String
"r"
        let ctx :: [TypeQ]
ctx = [ Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) Type
ty) | Type -> Bool
hasTyVar Type
ty ]
        Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher FunUsage2 -> Q (Matcher FunUsage2))
-> Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall a b. (a -> b) -> a -> b
$ Matcher :: forall u. PatQ -> PatQ -> ExpQ -> [TypeQ] -> u -> Matcher u
Matcher
          { leftPat :: PatQ
leftPat = Name -> PatQ
varP Name
l
          , rightPat :: PatQ
rightPat = Name -> PatQ
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 <- (Type -> Q (Matcher FunUsage2)) -> Cxt -> Q [Matcher FunUsage2]
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) (Cxt -> Cxt
forall a. [a] -> [a]
reverse Cxt
subtys)
     let lP :: PatQ
lP = [PatQ] -> PatQ
tupP (Matcher FunUsage2 -> PatQ
forall u. Matcher u -> PatQ
leftPat (Matcher FunUsage2 -> PatQ) -> [Matcher FunUsage2] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher FunUsage2]
matchers)
         rP :: PatQ
rP = [PatQ] -> PatQ
tupP (Matcher FunUsage2 -> PatQ
forall u. Matcher u -> PatQ
rightPat (Matcher FunUsage2 -> PatQ) -> [Matcher FunUsage2] -> [PatQ]
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 = (Matcher FunUsage2 -> FunUsage2)
-> [Matcher FunUsage2] -> FunUsage2
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Matcher FunUsage2 -> FunUsage2
forall u. Matcher u -> u
additionalInfo [Matcher FunUsage2]
matchers
         body :: ExpQ
body = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
x ExpQ
y -> [| $x <*> $y |]) ExpQ
tupcon (Matcher FunUsage2 -> ExpQ
forall u. Matcher u -> ExpQ
bodyExp (Matcher FunUsage2 -> ExpQ) -> [Matcher FunUsage2] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher FunUsage2]
matchers)
         ctx :: [TypeQ]
ctx = (Matcher FunUsage2 -> [TypeQ]) -> [Matcher FunUsage2] -> [TypeQ]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Matcher FunUsage2 -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx [Matcher FunUsage2]
matchers
     Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher FunUsage2 -> Q (Matcher FunUsage2))
-> Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall a b. (a -> b) -> a -> b
$ Matcher :: forall u. PatQ -> PatQ -> ExpQ -> [TypeQ] -> u -> Matcher u
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) | (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isConst Cxt
rest -> do
     let g :: Type
g = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type -> Type) -> Type -> Type -> Type
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 = [ Type -> TypeQ
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'
     Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher FunUsage2 -> Q (Matcher FunUsage2))
-> Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall a b. (a -> b) -> a -> b
$ Matcher FunUsage2
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ Matcher FunUsage2 -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher }
  (ConT Name
tcon, Type
ty1' : Type
ty2' : Cxt
rest) | (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isConst Cxt
rest -> do
     let g :: Type
g = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type -> Type) -> Type -> Type -> Type
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 = [ Type -> TypeQ
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'
     Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher FunUsage2 -> Q (Matcher FunUsage2))
-> Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall a b. (a -> b) -> a -> b
$ Matcher FunUsage2
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ Matcher FunUsage2 -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher }
  (VarT Name
t, Type
ty' : Cxt
rest) | (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isConst Cxt
rest -> do
     let g :: Type
g = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type -> Type) -> Type -> Type -> Type
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 = [ Type -> TypeQ
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'
     Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher FunUsage2 -> Q (Matcher FunUsage2))
-> Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall a b. (a -> b) -> a -> b
$ Matcher FunUsage2
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ Matcher FunUsage2 -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher }
  (VarT Name
t, Type
ty1' : Type
ty2' : Cxt
rest) | (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isConst Cxt
rest -> do
     let g :: Type
g = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type -> Type) -> Type -> Type -> Type
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 = [ Type -> TypeQ
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'
     Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher FunUsage2 -> Q (Matcher FunUsage2))
-> Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall a b. (a -> b) -> a -> b
$ Matcher FunUsage2
matcher{ requiredCtx :: [TypeQ]
requiredCtx = [TypeQ]
ctxG [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ Matcher FunUsage2 -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher }
  (ForallT [TyVarBndrUnit]
_ Cxt
_ Type
_, Cxt
_) -> Type -> String -> Q (Matcher FunUsage2)
forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Bimatchable"
  (ParensT Type
_, Cxt
_) -> String -> Q (Matcher FunUsage2)
forall a. HasCallStack => String -> a
error String
"Never reach here"
  (AppT Type
_ Type
_, Cxt
_) -> String -> Q (Matcher FunUsage2)
forall a. HasCallStack => String -> a
error String
"Never reach here"
  (SigT Type
_ Type
_, Cxt
_) -> String -> Q (Matcher FunUsage2)
forall a. HasCallStack => String -> a
error String
"Never reach here"
  (Type, Cxt)
_ -> Type -> String -> Q (Matcher FunUsage2)
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 <- String -> Q Name
newName String
"l"
      Name
r <- String -> Q 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 = [PatQ] -> ExpQ -> ExpQ
lamE [Matcher FunUsage2 -> PatQ
forall u. Matcher u -> PatQ
leftPat Matcher FunUsage2
matcher, Matcher FunUsage2 -> PatQ
forall u. Matcher u -> PatQ
rightPat Matcher FunUsage2
matcher] (Matcher FunUsage2 -> ExpQ
forall u. Matcher u -> ExpQ
bodyExp Matcher FunUsage2
matcher)
         (FunUsage2, [TypeQ], ExpQ) -> Q (FunUsage2, [TypeQ], ExpQ)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher FunUsage2 -> FunUsage2
forall u. Matcher u -> u
additionalInfo Matcher FunUsage2
matcher, Matcher FunUsage2 -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher, ExpQ
fun)
      Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher FunUsage2 -> Q (Matcher FunUsage2))
-> Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall a b. (a -> b) -> a -> b
$ Matcher :: forall u. PatQ -> PatQ -> ExpQ -> [TypeQ] -> u -> Matcher u
Matcher
        { leftPat :: PatQ
leftPat = Name -> PatQ
varP Name
l
        , rightPat :: PatQ
rightPat = Name -> PatQ
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 <- String -> Q Name
newName String
"l"
      Name
r <- String -> Q 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 = [PatQ] -> ExpQ -> ExpQ
lamE [Matcher FunUsage2 -> PatQ
forall u. Matcher u -> PatQ
leftPat Matcher FunUsage2
matcher1, Matcher FunUsage2 -> PatQ
forall u. Matcher u -> PatQ
rightPat Matcher FunUsage2
matcher1] (Matcher FunUsage2 -> ExpQ
forall u. Matcher u -> ExpQ
bodyExp Matcher FunUsage2
matcher1)
             fun2 :: ExpQ
fun2 = [PatQ] -> ExpQ -> ExpQ
lamE [Matcher FunUsage2 -> PatQ
forall u. Matcher u -> PatQ
leftPat Matcher FunUsage2
matcher2, Matcher FunUsage2 -> PatQ
forall u. Matcher u -> PatQ
rightPat Matcher FunUsage2
matcher2] (Matcher FunUsage2 -> ExpQ
forall u. Matcher u -> ExpQ
bodyExp Matcher FunUsage2
matcher2)
             usesF' :: FunUsage2
usesF' = Matcher FunUsage2 -> FunUsage2
forall u. Matcher u -> u
additionalInfo Matcher FunUsage2
matcher1 FunUsage2 -> FunUsage2 -> FunUsage2
forall a. Semigroup a => a -> a -> a
<> Matcher FunUsage2 -> FunUsage2
forall u. Matcher u -> u
additionalInfo Matcher FunUsage2
matcher2
             ctx :: [TypeQ]
ctx = Matcher FunUsage2 -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher1 [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ Matcher FunUsage2 -> [TypeQ]
forall u. Matcher u -> [TypeQ]
requiredCtx Matcher FunUsage2
matcher2
         (FunUsage2, [TypeQ], ExpQ, ExpQ)
-> Q (FunUsage2, [TypeQ], ExpQ, ExpQ)
forall (m :: * -> *) a. Monad m => a -> m a
return (FunUsage2
usesF', [TypeQ]
ctx, ExpQ
fun1, ExpQ
fun2)
      Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matcher FunUsage2 -> Q (Matcher FunUsage2))
-> Matcher FunUsage2 -> Q (Matcher FunUsage2)
forall a b. (a -> b) -> a -> b
$ Matcher :: forall u. PatQ -> PatQ -> ExpQ -> [TypeQ] -> u -> Matcher u
Matcher
        { leftPat :: PatQ
leftPat = Name -> PatQ
varP Name
l
        , rightPat :: PatQ
rightPat = Name -> PatQ
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 :: Type -> String -> Q a
unexpectedType Type
ty String
cls = 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)"

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