{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
module Data.Matchable.TH (
deriveInstances,
deriveMatchable, makeZipMatchWith,
deriveBimatchable, makeBizipMatchWith,
makeLiftEq, makeLiftEq2
) where
import Data.Bifunctor (Bifunctor (..))
import Data.Traversable (forM)
import Data.Bimatchable (Bimatchable (..))
import Data.Matchable (Matchable (..))
import Data.Functor.Classes ( Eq2(..), Eq1(..) )
import Language.Haskell.TH hiding (TyVarBndr(..))
import Language.Haskell.TH.Datatype (ConstructorInfo (..),
DatatypeInfo (..), reifyDatatype)
import Language.Haskell.TH.Datatype.TyVarBndr
import Data.Bifunctor.TH ( makeBimap )
import Data.Monoid (Any (..))
import Data.Matchable.TH.Matcher
warnStrat :: Maybe DerivStrategy -> Q ()
warnStrat :: Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
warnStrat (Just DerivStrategy
strat) = String -> Q ()
reportWarning forall a b. (a -> b) -> a -> b
$ String
"Specifying deriving strategy have no effect: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DerivStrategy
strat
data Deriver = Deriver { Deriver -> Name
_className :: Name, Deriver -> [(Name, Name -> Q Exp)]
_methodDerivers :: [(Name, Name -> Q Exp)] }
deriveInstanceWith :: Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith :: Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith Deriver
deriver Cxt
context Type
ty =
case Type -> (Type, Cxt)
spine Type
ty of
(ConT Name
dataCon, Cxt
_) -> do
[Dec]
methods <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Deriver -> [(Name, Name -> Q Exp)]
_methodDerivers Deriver
deriver) forall a b. (a -> b) -> a -> b
$ \(Name
methodName, Name -> Q Exp
makeImpl) -> do
Exp
impl <- Name -> Q Exp
makeImpl Name
dataCon
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD Name
methodName [ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
impl) [] ]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing Cxt
context (Name -> Type
ConT (Deriver -> Name
_className Deriver
deriver) Type -> Type -> Type
`AppT` Type
ty) [Dec]
methods]
(Type, Cxt)
_ -> do String -> Q ()
reportError (String
"Instance declaration must be of shape Cls (TyCon ty1 ty2 ...), but it's" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
ty)
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
deriveInstances :: Q [Dec] -> Q [Dec]
deriveInstances :: Q [Dec] -> Q [Dec]
deriveInstances Q [Dec]
decsQ = do
[Dec]
decs <- Q [Dec]
decsQ
[[Dec]]
derivedDecss <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec -> Q [Dec]
deriveInstance [Dec]
decs
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
derivedDecss
deriveInstance :: Dec -> Q [Dec]
deriveInstance :: Dec -> Q [Dec]
deriveInstance Dec
dec = case Dec
dec of
StandaloneDerivD Maybe DerivStrategy
strat Cxt
context Type
typ -> case Type
typ of
AppT (ConT Name
cls) Type
typ'
| Name
cls forall a. Eq a => a -> a -> Bool
== ''Eq -> String -> Q ()
reportWarning String
"Use stock deriving for Eq" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dec]
| Name
cls forall a. Eq a => a -> a -> Bool
== ''Functor -> String -> Q ()
reportWarning String
"Use stock deriving for Functor" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dec]
| Name
cls forall a. Eq a => a -> a -> Bool
== ''Bifunctor -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith Deriver
bifunctorDeriver Cxt
context Type
typ'
| Name
cls forall a. Eq a => a -> a -> Bool
== ''Eq1 -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith Deriver
eq1Deriver Cxt
context Type
typ'
| Name
cls forall a. Eq a => a -> a -> Bool
== ''Matchable -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith Deriver
matchableDeriver Cxt
context Type
typ'
| Name
cls forall a. Eq a => a -> a -> Bool
== ''Eq2 -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith Deriver
eq2Deriver Cxt
context Type
typ'
| Name
cls forall a. Eq a => a -> a -> Bool
== ''Bimatchable -> Maybe DerivStrategy -> Q ()
warnStrat Maybe DerivStrategy
strat forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Deriver -> Cxt -> Type -> Q [Dec]
deriveInstanceWith Deriver
bimatchableDeriver Cxt
context Type
typ'
Type
_ -> String -> Q ()
reportError (String
"Unsupported Instance: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
typ) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Dec
_ -> String -> Q ()
reportError String
"Use standalone deriving declarations only" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
bifunctorDeriver, eq1Deriver, matchableDeriver, eq2Deriver, bimatchableDeriver :: Deriver
bifunctorDeriver :: Deriver
bifunctorDeriver = Name -> [(Name, Name -> Q Exp)] -> Deriver
Deriver ''Bifunctor [ ('bimap, Name -> Q Exp
makeBimap) ]
eq1Deriver :: Deriver
eq1Deriver = Name -> [(Name, Name -> Q Exp)] -> Deriver
Deriver ''Eq1 [ ('liftEq, Name -> Q Exp
makeLiftEq) ]
eq2Deriver :: Deriver
eq2Deriver = Name -> [(Name, Name -> Q Exp)] -> Deriver
Deriver ''Eq2 [ ('liftEq2, Name -> Q Exp
makeLiftEq2 ) ]
matchableDeriver :: Deriver
matchableDeriver = Name -> [(Name, Name -> Q Exp)] -> Deriver
Deriver ''Matchable [ ('zipMatchWith, Name -> Q Exp
makeZipMatchWith) ]
bimatchableDeriver :: Deriver
bimatchableDeriver = Name -> [(Name, Name -> Q Exp)] -> Deriver
Deriver ''Bimatchable [ ('bizipMatchWith, Name -> Q Exp
makeBizipMatchWith) ]
makeLiftEq :: Name -> Q Exp
makeLiftEq :: Name -> Q Exp
makeLiftEq Name
name = do
DatatypeInfo { datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeVars = [TyVarBndrUnit]
dtVarsNames , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons }
<- Name -> Q DatatypeInfo
reifyDatatype Name
name
Type
tyA <- case forall a. [a] -> Maybe ([a], a)
viewLast [TyVarBndrUnit]
dtVarsNames of
Maybe ([TyVarBndrUnit], TyVarBndrUnit)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not a type constructor:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
name
Just ([TyVarBndrUnit]
_, TyVarBndrUnit
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
VarT (forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
a))
Name
eq <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"eq"
[Q Clause]
matchClauses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ConstructorInfo]
cons forall a b. (a -> b) -> a -> b
$
\(ConstructorInfo Name
ctrName [TyVarBndrUnit]
_ Cxt
_ Cxt
fields [FieldStrictness]
_ ConstructorVariant
_) -> do
Matcher Any
matcher <- forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName) [Q Exp] -> Q Exp
andBoolExprs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Name -> Type -> Q (Matcher Any)
dEq1Field Type
tyA Name
eq) Cxt
fields
let Any Bool
bodyUsesF = forall u. Matcher u -> u
additionalInfo Matcher Any
matcher
fPat :: PatQ
fPat = if Bool
bodyUsesF then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
eq else forall (m :: * -> *). Quote m => m Pat
wildP
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ
fPat, forall u. Matcher u -> PatQ
leftPat Matcher Any
matcher, forall u. Matcher u -> PatQ
rightPat Matcher Any
matcher] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall u. Matcher u -> Q Exp
bodyExp Matcher Any
matcher)) []
let mismatchClause :: Q Clause
mismatchClause = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP ] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| False |]) []
finalClauses :: [Q Clause]
finalClauses = case [ConstructorInfo]
cons of
[] -> []
[ConstructorInfo
_] -> [Q Clause]
matchClauses
[ConstructorInfo]
_ -> [Q Clause]
matchClauses forall a. [a] -> [a] -> [a]
++ [Q Clause
mismatchClause]
Name
lifteq <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"lifteq"
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
lifteq [Q Clause]
finalClauses ] (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
lifteq)
dEq1Field :: Type -> Name -> Type -> Q (Matcher Any)
dEq1Field :: Type -> Name -> Type -> Q (Matcher Any)
dEq1Field Type
tyA Name
fName = Type -> Q (Matcher Any)
go
where
isConst :: Type -> Bool
isConst Type
t = Bool -> Bool
not (Type -> Type -> Bool
occurs Type
tyA Type
t)
go :: Type -> Q (Matcher Any)
go Type
ty = case Type
ty of
Type
_ | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyA -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName) (Bool -> Any
Any Bool
True)
| Type -> Bool
isConst Type
ty -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher ([| (==) |]) (Bool -> Any
Any Bool
False)
AppT Type
g Type
ty' | Type -> Bool
isConst Type
g -> do
Matcher Any
matcher <- Type -> Q (Matcher Any)
go Type
ty'
forall a. Q Exp -> Matcher a -> Q (Matcher a)
liftMatcher [| liftEq |] Matcher Any
matcher
AppT (AppT Type
g Type
ty1') Type
ty2' | Type -> Bool
isConst Type
g -> do
Matcher Any
matcher1 <- Type -> Q (Matcher Any)
go Type
ty1'
Matcher Any
matcher2 <- Type -> Q (Matcher Any)
go Type
ty2'
forall a.
Semigroup a =>
Q Exp -> Matcher a -> Matcher a -> Q (Matcher a)
liftMatcher2 [| liftEq2 |] Matcher Any
matcher1 Matcher Any
matcher2
(Type -> (Type, Cxt)
spine -> (TupleT Int
_, Cxt
subtys)) -> do
[Matcher Any]
matchers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q (Matcher Any)
go (forall a. [a] -> [a]
reverse Cxt
subtys)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Q Exp] -> Q Exp
andBoolExprs [Matcher Any]
matchers
Type
_ -> forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Eq1"
makeLiftEq2 :: Name -> Q Exp
makeLiftEq2 :: Name -> Q Exp
makeLiftEq2 Name
name = do
DatatypeInfo { datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeVars = [TyVarBndrUnit]
dtVarsNames , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons }
<- Name -> Q DatatypeInfo
reifyDatatype Name
name
(Type
tyA, Type
tyB) <- case forall a. [a] -> Maybe ([a], a, a)
viewLastTwo [TyVarBndrUnit]
dtVarsNames of
Maybe ([TyVarBndrUnit], TyVarBndrUnit, TyVarBndrUnit)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not a type constructor:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
name
Just ([TyVarBndrUnit]
_, TyVarBndrUnit
a, TyVarBndrUnit
b) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
VarT (forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
a), Name -> Type
VarT (forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
b))
Name
eqA <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"eqA"
Name
eqB <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"eqB"
[Q Clause]
matchClauses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ConstructorInfo]
cons forall a b. (a -> b) -> a -> b
$
\(ConstructorInfo Name
ctrName [TyVarBndrUnit]
_ Cxt
_ Cxt
fields [FieldStrictness]
_ ConstructorVariant
_) -> do
Matcher (Any, Any)
matcher <- forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName) [Q Exp] -> Q Exp
andBoolExprs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Name -> Type -> Name -> Type -> Q (Matcher (Any, Any))
dEq2Field Type
tyA Name
eqA Type
tyB Name
eqB) Cxt
fields
let (Any Bool
bodyUsesF, Any Bool
bodyUsesG) = forall u. Matcher u -> u
additionalInfo Matcher (Any, Any)
matcher
fPat :: PatQ
fPat = if Bool
bodyUsesF then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
eqA else forall (m :: * -> *). Quote m => m Pat
wildP
gPat :: PatQ
gPat = if Bool
bodyUsesG then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
eqB else forall (m :: * -> *). Quote m => m Pat
wildP
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ
fPat, PatQ
gPat, forall u. Matcher u -> PatQ
leftPat Matcher (Any, Any)
matcher, forall u. Matcher u -> PatQ
rightPat Matcher (Any, Any)
matcher] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall u. Matcher u -> Q Exp
bodyExp Matcher (Any, Any)
matcher)) []
let mismatchClause :: Q Clause
mismatchClause = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP ] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| False |]) []
finalClauses :: [Q Clause]
finalClauses = case [ConstructorInfo]
cons of
[] -> []
[ConstructorInfo
_] -> [Q Clause]
matchClauses
[ConstructorInfo]
_ -> [Q Clause]
matchClauses forall a. [a] -> [a] -> [a]
++ [Q Clause
mismatchClause]
Name
lifteq <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"lifteq"
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
lifteq [Q Clause]
finalClauses ] (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
lifteq)
dEq2Field :: Type -> Name -> Type -> Name -> Type -> Q (Matcher (Any, Any))
dEq2Field :: Type -> Name -> Type -> Name -> Type -> Q (Matcher (Any, Any))
dEq2Field Type
tyA Name
fName Type
tyB Name
gName = Type -> Q (Matcher (Any, Any))
go
where
isConst :: Type -> Bool
isConst Type
t = Bool -> Bool
not (Type -> Type -> Bool
occurs Type
tyA Type
t Bool -> Bool -> Bool
|| Type -> Type -> Bool
occurs Type
tyB Type
t)
go :: Type -> Q (Matcher (Any, Any))
go Type
ty = case Type
ty of
Type
_ | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyA -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName) (Bool -> Any
Any Bool
True, Bool -> Any
Any Bool
False)
| Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyB -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
gName) (Bool -> Any
Any Bool
False, Bool -> Any
Any Bool
True)
| Type -> Bool
isConst Type
ty -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher ([| (==) |]) forall a. Monoid a => a
mempty
AppT Type
g Type
ty' | Type -> Bool
isConst Type
g -> do
Matcher (Any, Any)
matcher <- Type -> Q (Matcher (Any, Any))
go Type
ty'
forall a. Q Exp -> Matcher a -> Q (Matcher a)
liftMatcher [| liftEq |] Matcher (Any, Any)
matcher
AppT (AppT Type
g Type
ty1') Type
ty2' | Type -> Bool
isConst Type
g -> do
Matcher (Any, Any)
matcher1 <- Type -> Q (Matcher (Any, Any))
go Type
ty1'
Matcher (Any, Any)
matcher2 <- Type -> Q (Matcher (Any, Any))
go Type
ty2'
forall a.
Semigroup a =>
Q Exp -> Matcher a -> Matcher a -> Q (Matcher a)
liftMatcher2 [| liftEq2 |] Matcher (Any, Any)
matcher1 Matcher (Any, Any)
matcher2
(Type -> (Type, Cxt)
spine -> (TupleT Int
_, Cxt
subtys)) -> do
[Matcher (Any, Any)]
matchers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q (Matcher (Any, Any))
go (forall a. [a] -> [a]
reverse Cxt
subtys)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Q Exp] -> Q Exp
andBoolExprs [Matcher (Any, Any)]
matchers
Type
_ -> forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Eq1"
deriveMatchable :: Name -> Q [Dec]
deriveMatchable :: Name -> Q [Dec]
deriveMatchable Name
name = do
((Cxt
ctx, Type
f), [Q Clause]
zipMatchWithClauses) <- Name -> Q ((Cxt, Type), [Q Clause])
makeZipMatchWith' Name
name
Dec
dec <- forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
ctx) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Matchable) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
f))
[ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'zipMatchWith [Q Clause]
zipMatchWithClauses ]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dec]
makeZipMatchWith :: Name -> ExpQ
makeZipMatchWith :: Name -> Q Exp
makeZipMatchWith Name
name = do
((Cxt, Type)
_, [Q Clause]
clauses) <- Name -> Q ((Cxt, Type), [Q Clause])
makeZipMatchWith' Name
name
Name
z <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
z [Q Clause]
clauses ] (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z)
makeZipMatchWith' :: Name -> Q ((Cxt, Type), [Q Clause])
makeZipMatchWith' :: Name -> Q ((Cxt, Type), [Q Clause])
makeZipMatchWith' Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
let DatatypeInfo { datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeVars = [TyVarBndrUnit]
dtVarsNames , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons } = DatatypeInfo
info
(Type
dtFunctor, Type
tyA) <- case forall a. [a] -> Maybe ([a], a)
viewLast (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall flag. TyVarBndr_ flag -> Name
tvName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndrUnit]
dtVarsNames) of
Maybe (Cxt, Type)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not a type constructor:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
name
Just (Cxt
rest, Type
tyA) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
rest, Type
tyA)
Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
[(Cxt, Q Clause)]
matchClausesAndCtxs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ConstructorInfo]
cons forall a b. (a -> b) -> a -> b
$
\(ConstructorInfo Name
ctrName [TyVarBndrUnit]
_ Cxt
_ Cxt
fields [FieldStrictness]
_ ConstructorVariant
_) -> do
let body :: [Q Exp] -> Q Exp
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x Q Exp
y -> [| $x <*> $y |]) [| pure $(conE ctrName) |]
Matcher (Cxt, Any)
matcher <- forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName) [Q Exp] -> Q Exp
body forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Name -> Type -> Q (Matcher (Cxt, Any))
dMatchField Type
tyA Name
f) Cxt
fields
let (Cxt
ctx, Any Bool
bodyUsesF) = forall u. Matcher u -> u
additionalInfo Matcher (Cxt, Any)
matcher
fPat :: PatQ
fPat = if Bool
bodyUsesF then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f else forall (m :: * -> *). Quote m => m Pat
wildP
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Cxt
ctx, forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ
fPat, forall u. Matcher u -> PatQ
leftPat Matcher (Cxt, Any)
matcher, forall u. Matcher u -> PatQ
rightPat Matcher (Cxt, Any)
matcher] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall u. Matcher u -> Q Exp
bodyExp Matcher (Cxt, Any)
matcher)) [])
let matchClauses :: [Q Clause]
matchClauses = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Cxt, Q Clause)]
matchClausesAndCtxs
ctx :: Cxt
ctx = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> a
fst [(Cxt, Q Clause)]
matchClausesAndCtxs
mismatchClause :: Q Clause
mismatchClause = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP ] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| Nothing |]) []
finalClauses :: [Q Clause]
finalClauses = case [ConstructorInfo]
cons of
[] -> []
[ConstructorInfo
_] -> [Q Clause]
matchClauses
[ConstructorInfo]
_ -> [Q Clause]
matchClauses forall a. [a] -> [a] -> [a]
++ [Q Clause
mismatchClause]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Cxt
ctx, Type
dtFunctor), [Q Clause]
finalClauses)
dMatchField :: Type -> Name -> Type -> Q (Matcher (Cxt, Any))
dMatchField :: Type -> Name -> Type -> Q (Matcher (Cxt, Any))
dMatchField Type
tyA Name
fName = Type -> Q (Matcher (Cxt, Any))
go
where
isConst :: Type -> Bool
isConst = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Bool
occurs Type
tyA
go :: Type -> Q (Matcher (Cxt, Any))
go Type
ty = case Type
ty of
Type
_ | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyA -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName) ([], Bool -> Any
Any Bool
True)
| Type -> Bool
isConst Type
ty ->
let ctx :: Cxt
ctx = [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) Type
ty | Type -> Bool
hasTyVar Type
ty ]
in forall a. (Q Exp -> Q Exp -> Q Exp) -> a -> Q (Matcher a)
matcherExpr
(\Q Exp
l Q Exp
r -> [| if $l == $r then Just $l else Nothing |])
(Cxt
ctx, Bool -> Any
Any Bool
False)
(AppT Type
g Type
ty') | Type -> Bool
isConst Type
g -> do
let ctxG :: Cxt
ctxG = [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Matchable) Type
g | Type -> Bool
hasTyVar Type
g ]
Matcher (Cxt, Any)
matcher <- Type -> Q (Matcher (Cxt, Any))
go Type
ty'
Matcher (Cxt, Any)
matcher' <- forall a. Q Exp -> Matcher a -> Q (Matcher a)
liftMatcher [| zipMatchWith |] Matcher (Cxt, Any)
matcher
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Cxt
ctxG, forall a. Monoid a => a
mempty) forall a. Semigroup a => a -> Matcher a -> Matcher a
`addInfo` Matcher (Cxt, Any)
matcher'
(AppT (AppT Type
g Type
ty1') Type
ty2') | Type -> Bool
isConst Type
g -> do
let ctxG :: Cxt
ctxG = [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Bimatchable) Type
g | Type -> Bool
hasTyVar Type
g ]
Matcher (Cxt, Any)
matcher1 <- Type -> Q (Matcher (Cxt, Any))
go Type
ty1'
Matcher (Cxt, Any)
matcher2 <- Type -> Q (Matcher (Cxt, Any))
go Type
ty2'
Matcher (Cxt, Any)
matcher' <- forall a.
Semigroup a =>
Q Exp -> Matcher a -> Matcher a -> Q (Matcher a)
liftMatcher2 [| bizipMatchWith |] Matcher (Cxt, Any)
matcher1 Matcher (Cxt, Any)
matcher2
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Cxt
ctxG, forall a. Monoid a => a
mempty) forall a. Semigroup a => a -> Matcher a -> Matcher a
`addInfo` Matcher (Cxt, Any)
matcher'
(Type -> (Type, Cxt)
spine -> (TupleT Int
n, Cxt
subtys)) -> do
let body :: [Q Exp] -> Q Exp
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x Q Exp
y -> [| $x <*> $y |]) [| pure $(conE (tupleDataName n)) |]
[Matcher (Cxt, Any)]
matchers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q (Matcher (Cxt, Any))
go (forall a. [a] -> [a]
reverse Cxt
subtys)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Q Exp] -> Q Exp
body [Matcher (Cxt, Any)]
matchers
Type
_ -> forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Matchable"
deriveBimatchable :: Name -> Q [Dec]
deriveBimatchable :: Name -> Q [Dec]
deriveBimatchable Name
name = do
((Cxt
ctx, Type
f), [Q Clause]
clauses) <- Name -> Q ((Cxt, Type), [Q Clause])
makeBizipMatchWith' Name
name
Dec
dec <- forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
ctx) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Bimatchable) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
f))
[ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'bizipMatchWith [Q Clause]
clauses ]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dec]
makeBizipMatchWith :: Name -> ExpQ
makeBizipMatchWith :: Name -> Q Exp
makeBizipMatchWith Name
name = do
((Cxt, Type)
_, [Q Clause]
clauses) <- Name -> Q ((Cxt, Type), [Q Clause])
makeBizipMatchWith' Name
name
Name
z <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
z [Q Clause]
clauses ] (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z)
makeBizipMatchWith' :: Name -> Q ((Cxt, Type), [Q Clause])
makeBizipMatchWith' :: Name -> Q ((Cxt, Type), [Q Clause])
makeBizipMatchWith' Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
let DatatypeInfo { datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeVars = [TyVarBndrUnit]
dtVars , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons } = DatatypeInfo
info
(Type
dtFunctor, Type
tyA, Type
tyB) <- case forall a. [a] -> Maybe ([a], a, a)
viewLastTwo (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall flag. TyVarBndr_ flag -> Name
tvName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndrUnit]
dtVars) of
Maybe (Cxt, Type, Type)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not a datatype with at least 2 parameters: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
name
Just (Cxt
rest, Type
tyA, Type
tyB) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
rest, Type
tyA, Type
tyB)
Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
Name
g <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"g"
[(Cxt, Q Clause)]
matchClausesAndCtxs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ConstructorInfo]
cons forall a b. (a -> b) -> a -> b
$
\(ConstructorInfo Name
ctrName [TyVarBndrUnit]
_ Cxt
_ Cxt
fields [FieldStrictness]
_ ConstructorVariant
_) -> do
let body :: [Q Exp] -> Q Exp
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x Q Exp
y -> [| $x <*> $y |]) [| pure $(conE ctrName) |]
Matcher (Cxt, Any, Any)
matcher <- forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
ctrName) [Q Exp] -> Q Exp
body forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Name -> Type -> Name -> Type -> Q (Matcher (Cxt, Any, Any))
dBimatchField Type
tyA Name
f Type
tyB Name
g) Cxt
fields
let (Cxt
ctx, Any Bool
bodyUsesF, Any Bool
bodyUsesG) = forall u. Matcher u -> u
additionalInfo Matcher (Cxt, Any, Any)
matcher
fPat :: PatQ
fPat = if Bool
bodyUsesF then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f else forall (m :: * -> *). Quote m => m Pat
wildP
gPat :: PatQ
gPat = if Bool
bodyUsesG then forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
g else forall (m :: * -> *). Quote m => m Pat
wildP
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Cxt
ctx, forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ
fPat, PatQ
gPat, forall u. Matcher u -> PatQ
leftPat Matcher (Cxt, Any, Any)
matcher, forall u. Matcher u -> PatQ
rightPat Matcher (Cxt, Any, Any)
matcher] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall u. Matcher u -> Q Exp
bodyExp Matcher (Cxt, Any, Any)
matcher)) [])
let matchClauses :: [Q Clause]
matchClauses = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Cxt, Q Clause)]
matchClausesAndCtxs
ctx :: Cxt
ctx = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> a
fst [(Cxt, Q Clause)]
matchClausesAndCtxs
mismatchClause :: Q Clause
mismatchClause = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => m Pat
wildP ] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| Nothing |]) []
finalClauses :: [Q Clause]
finalClauses = case [ConstructorInfo]
cons of
[] -> []
[ConstructorInfo
_] -> [Q Clause]
matchClauses
[ConstructorInfo]
_ -> [Q Clause]
matchClauses forall a. [a] -> [a] -> [a]
++ [Q Clause
mismatchClause]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Cxt
ctx, Type
dtFunctor), [Q Clause]
finalClauses)
dBimatchField :: Type -> Name -> Type -> Name -> Type -> Q (Matcher (Cxt, Any, Any))
dBimatchField :: Type -> Name -> Type -> Name -> Type -> Q (Matcher (Cxt, Any, Any))
dBimatchField Type
tyA Name
fName Type
tyB Name
gName = Type -> Q (Matcher (Cxt, Any, Any))
go
where
isConst :: Type -> Bool
isConst Type
t = Bool -> Bool
not (Type -> Type -> Bool
occurs Type
tyA Type
t Bool -> Bool -> Bool
|| Type -> Type -> Bool
occurs Type
tyB Type
t)
go :: Type -> Q (Matcher (Cxt, Any, Any))
go Type
ty = case Type
ty of
Type
_ | Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyA -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName) ([], Bool -> Any
Any Bool
True, Bool -> Any
Any Bool
False)
| Type
ty forall a. Eq a => a -> a -> Bool
== Type
tyB -> forall a. Q Exp -> a -> Q (Matcher a)
funMatcher (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
gName) ([], Bool -> Any
Any Bool
False, Bool -> Any
Any Bool
True)
| Type -> Bool
isConst Type
ty ->
let ctx :: Cxt
ctx = [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) Type
ty | Type -> Bool
hasTyVar Type
ty ]
in forall a. (Q Exp -> Q Exp -> Q Exp) -> a -> Q (Matcher a)
matcherExpr
(\Q Exp
l Q Exp
r -> [| if $l == $r then Just $l else Nothing |])
(Cxt
ctx, Bool -> Any
Any Bool
False, Bool -> Any
Any Bool
False)
(AppT Type
g Type
ty') | Type -> Bool
isConst Type
g -> do
let ctxG :: Cxt
ctxG = [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Matchable) Type
g | Type -> Bool
hasTyVar Type
g ]
Matcher (Cxt, Any, Any)
matcher <- Type -> Q (Matcher (Cxt, Any, Any))
go Type
ty'
Matcher (Cxt, Any, Any)
matcher' <- forall a. Q Exp -> Matcher a -> Q (Matcher a)
liftMatcher [| zipMatchWith |] Matcher (Cxt, Any, Any)
matcher
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Cxt
ctxG, forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty) forall a. Semigroup a => a -> Matcher a -> Matcher a
`addInfo` Matcher (Cxt, Any, Any)
matcher'
(AppT (AppT Type
g Type
ty1') Type
ty2') | Type -> Bool
isConst Type
g -> do
let ctxG :: Cxt
ctxG = [ Type -> Type -> Type
AppT (Name -> Type
ConT ''Bimatchable) Type
g | Type -> Bool
hasTyVar Type
g ]
Matcher (Cxt, Any, Any)
matcher1 <- Type -> Q (Matcher (Cxt, Any, Any))
go Type
ty1'
Matcher (Cxt, Any, Any)
matcher2 <- Type -> Q (Matcher (Cxt, Any, Any))
go Type
ty2'
Matcher (Cxt, Any, Any)
matcher' <- forall a.
Semigroup a =>
Q Exp -> Matcher a -> Matcher a -> Q (Matcher a)
liftMatcher2 [| bizipMatchWith |] Matcher (Cxt, Any, Any)
matcher1 Matcher (Cxt, Any, Any)
matcher2
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Cxt
ctxG, forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty) forall a. Semigroup a => a -> Matcher a -> Matcher a
`addInfo` Matcher (Cxt, Any, Any)
matcher'
(Type -> (Type, Cxt)
spine -> (TupleT Int
n, Cxt
subtys)) -> do
[Matcher (Cxt, Any, Any)]
matchers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q (Matcher (Cxt, Any, Any))
go (forall a. [a] -> [a]
reverse Cxt
subtys)
let body :: [Q Exp] -> Q Exp
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x Q Exp
y -> [| $x <*> $y |]) [| pure $(conE (tupleDataName n)) |]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([Q Exp] -> Q Exp) -> [Matcher a] -> Matcher a
combineMatchers forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Q Exp] -> Q Exp
body [Matcher (Cxt, Any, Any)]
matchers
Type
_ -> forall a. Type -> String -> Q a
unexpectedType Type
ty String
"Bimatchable"
unexpectedType :: Type -> String -> Q a
unexpectedType :: forall a. Type -> String -> Q a
unexpectedType Type
ty String
cls = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"unexpected type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
ty forall a. [a] -> [a] -> [a]
++ String
" in derivation of " forall a. [a] -> [a] -> [a]
++ String
cls forall a. [a] -> [a] -> [a]
++
String
" (it's only possible to implement " forall a. [a] -> [a] -> [a]
++ String
cls forall a. [a] -> [a] -> [a]
++
String
" genericaly when all subterms are traversable)"
andBoolExprs :: [Q Exp] -> Q Exp
andBoolExprs :: [Q Exp] -> Q Exp
andBoolExprs [] = [| True |]
andBoolExprs [Q Exp]
xs = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
x Q Exp
y -> [| $x && $y |]) [Q Exp]
xs
spine :: Type -> (Type, [Type])
spine :: Type -> (Type, Cxt)
spine (ParensT Type
t) = Type -> (Type, Cxt)
spine Type
t
spine (AppT Type
t1 Type
t2) = let (Type
h, Cxt
r) = Type -> (Type, Cxt)
spine Type
t1 in (Type
h, Type
t2forall a. a -> [a] -> [a]
:Cxt
r)
spine (SigT Type
t Type
_) = Type -> (Type, Cxt)
spine Type
t
spine Type
t = (Type
t, [])
occurs :: Type -> Type -> Bool
occurs :: Type -> Type -> Bool
occurs Type
t Type
u | Type
t forall a. Eq a => a -> a -> Bool
== Type
u = Bool
True
occurs Type
t Type
u = case Type
u of
AppT Type
u1 Type
u2 -> Type -> Type -> Bool
occurs Type
t Type
u1 Bool -> Bool -> Bool
|| Type -> Type -> Bool
occurs Type
t Type
u2
ParensT Type
u' -> Type -> Type -> Bool
occurs Type
t Type
u'
SigT Type
u' Type
_ -> Type -> Type -> Bool
occurs Type
t Type
u'
Type
_ -> Bool
False
hasTyVar :: Type -> Bool
hasTyVar :: Type -> Bool
hasTyVar (VarT Name
_) = Bool
True
hasTyVar (ParensT Type
t) = Type -> Bool
hasTyVar Type
t
hasTyVar (AppT Type
t1 Type
t2) = Type -> Bool
hasTyVar Type
t1 Bool -> Bool -> Bool
|| Type -> Bool
hasTyVar Type
t2
hasTyVar (SigT Type
t Type
_) = Type -> Bool
hasTyVar Type
t
hasTyVar Type
_ = Bool
False
viewLast :: [a] -> Maybe ([a], a)
viewLast :: forall a. [a] -> Maybe ([a], a)
viewLast [a]
as = case forall a. [a] -> [a]
reverse [a]
as of
[] -> forall a. Maybe a
Nothing
a
a:[a]
rest -> forall a. a -> Maybe a
Just (forall a. [a] -> [a]
reverse [a]
rest, a
a)
viewLastTwo :: [a] -> Maybe ([a],a,a)
viewLastTwo :: forall a. [a] -> Maybe ([a], a, a)
viewLastTwo [a]
as = case forall a. [a] -> [a]
reverse [a]
as of
a
b:a
a:[a]
rest -> forall a. a -> Maybe a
Just (forall a. [a] -> [a]
reverse [a]
rest, a
a, a
b)
[a]
_ -> forall a. Maybe a
Nothing