{-# 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
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 ]
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 }
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 ]
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