{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Functor.Deriving.Internal (
deriveFoldable
, deriveFoldableOptions
, makeFoldMap
, makeFoldMapOptions
, makeFoldr
, makeFoldrOptions
, makeFold
, makeFoldOptions
, makeFoldl
, makeFoldlOptions
, makeNull
, makeNullOptions
, deriveFunctor
, deriveFunctorOptions
, makeFmap
, makeFmapOptions
, makeReplace
, makeReplaceOptions
, deriveTraversable
, deriveTraversableOptions
, makeTraverse
, makeTraverseOptions
, makeSequenceA
, makeSequenceAOptions
, makeMapM
, makeMapMOptions
, makeSequence
, makeSequenceOptions
, FFTOptions(..)
, defaultFFTOptions
) where
import Control.Monad (guard)
import Data.Deriving.Internal
import qualified Data.List as List
import qualified Data.Map as Map ((!), keys, lookup, member, singleton)
import Data.Maybe
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
newtype FFTOptions = FFTOptions
{ FFTOptions -> Bool
fftEmptyCaseBehavior :: Bool
} deriving (FFTOptions -> FFTOptions -> Bool
(FFTOptions -> FFTOptions -> Bool)
-> (FFTOptions -> FFTOptions -> Bool) -> Eq FFTOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FFTOptions -> FFTOptions -> Bool
$c/= :: FFTOptions -> FFTOptions -> Bool
== :: FFTOptions -> FFTOptions -> Bool
$c== :: FFTOptions -> FFTOptions -> Bool
Eq, Eq FFTOptions
Eq FFTOptions
-> (FFTOptions -> FFTOptions -> Ordering)
-> (FFTOptions -> FFTOptions -> Bool)
-> (FFTOptions -> FFTOptions -> Bool)
-> (FFTOptions -> FFTOptions -> Bool)
-> (FFTOptions -> FFTOptions -> Bool)
-> (FFTOptions -> FFTOptions -> FFTOptions)
-> (FFTOptions -> FFTOptions -> FFTOptions)
-> Ord FFTOptions
FFTOptions -> FFTOptions -> Bool
FFTOptions -> FFTOptions -> Ordering
FFTOptions -> FFTOptions -> FFTOptions
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FFTOptions -> FFTOptions -> FFTOptions
$cmin :: FFTOptions -> FFTOptions -> FFTOptions
max :: FFTOptions -> FFTOptions -> FFTOptions
$cmax :: FFTOptions -> FFTOptions -> FFTOptions
>= :: FFTOptions -> FFTOptions -> Bool
$c>= :: FFTOptions -> FFTOptions -> Bool
> :: FFTOptions -> FFTOptions -> Bool
$c> :: FFTOptions -> FFTOptions -> Bool
<= :: FFTOptions -> FFTOptions -> Bool
$c<= :: FFTOptions -> FFTOptions -> Bool
< :: FFTOptions -> FFTOptions -> Bool
$c< :: FFTOptions -> FFTOptions -> Bool
compare :: FFTOptions -> FFTOptions -> Ordering
$ccompare :: FFTOptions -> FFTOptions -> Ordering
$cp1Ord :: Eq FFTOptions
Ord, ReadPrec [FFTOptions]
ReadPrec FFTOptions
Int -> ReadS FFTOptions
ReadS [FFTOptions]
(Int -> ReadS FFTOptions)
-> ReadS [FFTOptions]
-> ReadPrec FFTOptions
-> ReadPrec [FFTOptions]
-> Read FFTOptions
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FFTOptions]
$creadListPrec :: ReadPrec [FFTOptions]
readPrec :: ReadPrec FFTOptions
$creadPrec :: ReadPrec FFTOptions
readList :: ReadS [FFTOptions]
$creadList :: ReadS [FFTOptions]
readsPrec :: Int -> ReadS FFTOptions
$creadsPrec :: Int -> ReadS FFTOptions
Read, Int -> FFTOptions -> ShowS
[FFTOptions] -> ShowS
FFTOptions -> String
(Int -> FFTOptions -> ShowS)
-> (FFTOptions -> String)
-> ([FFTOptions] -> ShowS)
-> Show FFTOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FFTOptions] -> ShowS
$cshowList :: [FFTOptions] -> ShowS
show :: FFTOptions -> String
$cshow :: FFTOptions -> String
showsPrec :: Int -> FFTOptions -> ShowS
$cshowsPrec :: Int -> FFTOptions -> ShowS
Show)
defaultFFTOptions :: FFTOptions
defaultFFTOptions :: FFTOptions
defaultFFTOptions = FFTOptions :: Bool -> FFTOptions
FFTOptions { fftEmptyCaseBehavior :: Bool
fftEmptyCaseBehavior = Bool
False }
deriveFoldable :: Name -> Q [Dec]
deriveFoldable :: Name -> Q [Dec]
deriveFoldable = FFTOptions -> Name -> Q [Dec]
deriveFoldableOptions FFTOptions
defaultFFTOptions
deriveFoldableOptions :: FFTOptions -> Name -> Q [Dec]
deriveFoldableOptions :: FFTOptions -> Name -> Q [Dec]
deriveFoldableOptions = FunctorClass -> FFTOptions -> Name -> Q [Dec]
deriveFunctorClass FunctorClass
Foldable
makeFoldMap :: Name -> Q Exp
makeFoldMap :: Name -> Q Exp
makeFoldMap = FFTOptions -> Name -> Q Exp
makeFoldMapOptions FFTOptions
defaultFFTOptions
makeFoldMapOptions :: FFTOptions -> Name -> Q Exp
makeFoldMapOptions :: FFTOptions -> Name -> Q Exp
makeFoldMapOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
makeFunctorFun FunctorFun
FoldMap
makeNull :: Name -> Q Exp
makeNull :: Name -> Q Exp
makeNull = FFTOptions -> Name -> Q Exp
makeNullOptions FFTOptions
defaultFFTOptions
makeNullOptions :: FFTOptions -> Name -> Q Exp
makeNullOptions :: FFTOptions -> Name -> Q Exp
makeNullOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
makeFunctorFun FunctorFun
Null
makeFoldr :: Name -> Q Exp
makeFoldr :: Name -> Q Exp
makeFoldr = FFTOptions -> Name -> Q Exp
makeFoldrOptions FFTOptions
defaultFFTOptions
makeFoldrOptions :: FFTOptions -> Name -> Q Exp
makeFoldrOptions :: FFTOptions -> Name -> Q Exp
makeFoldrOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
makeFunctorFun FunctorFun
Foldr
makeFold :: Name -> Q Exp
makeFold :: Name -> Q Exp
makeFold = FFTOptions -> Name -> Q Exp
makeFoldOptions FFTOptions
defaultFFTOptions
makeFoldOptions :: FFTOptions -> Name -> Q Exp
makeFoldOptions :: FFTOptions -> Name -> Q Exp
makeFoldOptions FFTOptions
opts Name
name = FFTOptions -> Name -> Q Exp
makeFoldMapOptions FFTOptions
opts Name
name Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
idValName
makeFoldl :: Name -> Q Exp
makeFoldl :: Name -> Q Exp
makeFoldl = FFTOptions -> Name -> Q Exp
makeFoldlOptions FFTOptions
defaultFFTOptions
makeFoldlOptions :: FFTOptions -> Name -> Q Exp
makeFoldlOptions :: FFTOptions -> Name -> Q Exp
makeFoldlOptions FFTOptions
opts Name
name = do
Name
f <- String -> Q Name
newName String
"f"
Name
z <- String -> Q Name
newName String
"z"
Name
t <- String -> Q Name
newName String
"t"
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
z, Name -> PatQ
varP Name
t] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[Q Exp] -> Q Exp
appsE [ Name -> Q Exp
varE Name
appEndoValName
, [Q Exp] -> Q Exp
appsE [ Name -> Q Exp
varE Name
getDualValName
, [Q Exp] -> Q Exp
appsE [ FFTOptions -> Name -> Q Exp
makeFoldMapOptions FFTOptions
opts Name
name, Name -> Q Exp
foldFun Name
f, Name -> Q Exp
varE Name
t]
]
, Name -> Q Exp
varE Name
z
]
where
foldFun :: Name -> Q Exp
foldFun :: Name -> Q Exp
foldFun Name
n = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
conE Name
dualDataName)
(Name -> Q Exp
varE Name
composeValName)
(Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
conE Name
endoDataName)
(Name -> Q Exp
varE Name
composeValName)
(Name -> Q Exp
varE Name
flipValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
n)
)
deriveFunctor :: Name -> Q [Dec]
deriveFunctor :: Name -> Q [Dec]
deriveFunctor = FFTOptions -> Name -> Q [Dec]
deriveFunctorOptions FFTOptions
defaultFFTOptions
deriveFunctorOptions :: FFTOptions -> Name -> Q [Dec]
deriveFunctorOptions :: FFTOptions -> Name -> Q [Dec]
deriveFunctorOptions = FunctorClass -> FFTOptions -> Name -> Q [Dec]
deriveFunctorClass FunctorClass
Functor
makeFmap :: Name -> Q Exp
makeFmap :: Name -> Q Exp
makeFmap = FFTOptions -> Name -> Q Exp
makeFmapOptions FFTOptions
defaultFFTOptions
makeFmapOptions :: FFTOptions -> Name -> Q Exp
makeFmapOptions :: FFTOptions -> Name -> Q Exp
makeFmapOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
makeFunctorFun FunctorFun
Fmap
makeReplace :: Name -> Q Exp
makeReplace :: Name -> Q Exp
makeReplace = FFTOptions -> Name -> Q Exp
makeReplaceOptions FFTOptions
defaultFFTOptions
makeReplaceOptions :: FFTOptions -> Name -> Q Exp
makeReplaceOptions :: FFTOptions -> Name -> Q Exp
makeReplaceOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
makeFunctorFun FunctorFun
Replace
deriveTraversable :: Name -> Q [Dec]
deriveTraversable :: Name -> Q [Dec]
deriveTraversable = FFTOptions -> Name -> Q [Dec]
deriveTraversableOptions FFTOptions
defaultFFTOptions
deriveTraversableOptions :: FFTOptions -> Name -> Q [Dec]
deriveTraversableOptions :: FFTOptions -> Name -> Q [Dec]
deriveTraversableOptions = FunctorClass -> FFTOptions -> Name -> Q [Dec]
deriveFunctorClass FunctorClass
Traversable
makeTraverse :: Name -> Q Exp
makeTraverse :: Name -> Q Exp
makeTraverse = FFTOptions -> Name -> Q Exp
makeTraverseOptions FFTOptions
defaultFFTOptions
makeTraverseOptions :: FFTOptions -> Name -> Q Exp
makeTraverseOptions :: FFTOptions -> Name -> Q Exp
makeTraverseOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
makeFunctorFun FunctorFun
Traverse
makeSequenceA :: Name -> Q Exp
makeSequenceA :: Name -> Q Exp
makeSequenceA = FFTOptions -> Name -> Q Exp
makeSequenceAOptions FFTOptions
defaultFFTOptions
makeSequenceAOptions :: FFTOptions -> Name -> Q Exp
makeSequenceAOptions :: FFTOptions -> Name -> Q Exp
makeSequenceAOptions FFTOptions
opts Name
name = FFTOptions -> Name -> Q Exp
makeTraverseOptions FFTOptions
opts Name
name Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
idValName
makeMapM :: Name -> Q Exp
makeMapM :: Name -> Q Exp
makeMapM = FFTOptions -> Name -> Q Exp
makeMapMOptions FFTOptions
defaultFFTOptions
makeMapMOptions :: FFTOptions -> Name -> Q Exp
makeMapMOptions :: FFTOptions -> Name -> Q Exp
makeMapMOptions FFTOptions
opts Name
name = do
Name
f <- String -> Q Name
newName String
"f"
PatQ -> Q Exp -> Q Exp
lam1E (Name -> PatQ
varP Name
f) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
unwrapMonadValName) (Name -> Q Exp
varE Name
composeValName) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
FFTOptions -> Name -> Q Exp
makeTraverseOptions FFTOptions
opts Name
name Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
wrapMonadExp Name
f
where
wrapMonadExp :: Name -> Q Exp
wrapMonadExp :: Name -> Q Exp
wrapMonadExp Name
n = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
conE Name
wrapMonadDataName) (Name -> Q Exp
varE Name
composeValName) (Name -> Q Exp
varE Name
n)
makeSequence :: Name -> Q Exp
makeSequence :: Name -> Q Exp
makeSequence = FFTOptions -> Name -> Q Exp
makeSequenceOptions FFTOptions
defaultFFTOptions
makeSequenceOptions :: FFTOptions -> Name -> Q Exp
makeSequenceOptions :: FFTOptions -> Name -> Q Exp
makeSequenceOptions FFTOptions
opts Name
name = FFTOptions -> Name -> Q Exp
makeMapMOptions FFTOptions
opts Name
name Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
idValName
deriveFunctorClass :: FunctorClass -> FFTOptions -> Name -> Q [Dec]
deriveFunctorClass :: FunctorClass -> FFTOptions -> Name -> Q [Dec]
deriveFunctorClass FunctorClass
fc FFTOptions
opts Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
(Cxt
instanceCxt, Type
instanceType)
<- FunctorClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance FunctorClass
fc Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
(Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
(FunctorClass
-> FFTOptions -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
functorFunDecs FunctorClass
fc FFTOptions
opts Name
parentName Cxt
instTypes [ConstructorInfo]
cons)
functorFunDecs
:: FunctorClass -> FFTOptions -> Name -> [Type] -> [ConstructorInfo]
-> [Q Dec]
functorFunDecs :: FunctorClass
-> FFTOptions -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
functorFunDecs FunctorClass
fc FFTOptions
opts Name
parentName Cxt
instTypes [ConstructorInfo]
cons =
(FunctorFun -> Q Dec) -> [FunctorFun] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map FunctorFun -> Q Dec
makeFunD ([FunctorFun] -> [Q Dec]) -> [FunctorFun] -> [Q Dec]
forall a b. (a -> b) -> a -> b
$ FunctorClass -> [FunctorFun]
functorClassToFuns FunctorClass
fc
where
makeFunD :: FunctorFun -> Q Dec
makeFunD :: FunctorFun -> Q Dec
makeFunD FunctorFun
ff =
Name -> [ClauseQ] -> Q Dec
funD (FunctorFun -> Name
functorFunName FunctorFun
ff)
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ FunctorFun
-> FFTOptions -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeFunctorFunForCons FunctorFun
ff FFTOptions
opts Name
parentName Cxt
instTypes [ConstructorInfo]
cons)
[]
]
makeFunctorFun :: FunctorFun -> FFTOptions -> Name -> Q Exp
makeFunctorFun :: FunctorFun -> FFTOptions -> Name -> Q Exp
makeFunctorFun FunctorFun
ff FFTOptions
opts Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
FunctorClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance (FunctorFun -> FunctorClass
functorFunToClass FunctorFun
ff) Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
Q (Cxt, Type) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FunctorFun
-> FFTOptions -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeFunctorFunForCons FunctorFun
ff FFTOptions
opts Name
parentName Cxt
instTypes [ConstructorInfo]
cons
makeFunctorFunForCons
:: FunctorFun -> FFTOptions -> Name -> [Type] -> [ConstructorInfo]
-> Q Exp
makeFunctorFunForCons :: FunctorFun
-> FFTOptions -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
makeFunctorFunForCons FunctorFun
ff FFTOptions
opts Name
_parentName Cxt
instTypes [ConstructorInfo]
cons = do
Name
mapFun <- String -> Q Name
newName String
"f"
Name
z <- String -> Q Name
newName String
"z"
Name
value <- String -> Q Name
newName String
"value"
let argNames :: [Name]
argNames = [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes [ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FunctorFun
ff FunctorFun -> FunctorFun -> Bool
forall a. Eq a => a -> a -> Bool
/= FunctorFun
Null) Maybe () -> Maybe Name -> Maybe Name
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
mapFun
, Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FunctorFun
ff FunctorFun -> FunctorFun -> Bool
forall a. Eq a => a -> a -> Bool
== FunctorFun
Foldr) Maybe () -> Maybe Name -> Maybe Name
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
z
, Name -> Maybe Name
forall a. a -> Maybe a
Just Name
value
]
lastTyVar :: Name
lastTyVar = Type -> Name
varTToName (Type -> Name) -> Type -> Name
forall a b. (a -> b) -> a -> b
$ Cxt -> Type
forall a. [a] -> a
last Cxt
instTypes
tvMap :: Map Name (OneOrTwoNames One)
tvMap = Name -> OneOrTwoNames One -> Map Name (OneOrTwoNames One)
forall k a. k -> a -> Map k a
Map.singleton Name
lastTyVar (OneOrTwoNames One -> Map Name (OneOrTwoNames One))
-> OneOrTwoNames One -> Map Name (OneOrTwoNames One)
forall a b. (a -> b) -> a -> b
$ Name -> OneOrTwoNames One
OneName Name
mapFun
[PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
argNames)
(Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE
([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ FunctorFun -> Name
functorFunConstName FunctorFun
ff
, Name -> Name -> Map Name (OneOrTwoNames One) -> Q Exp
makeFun Name
z Name
value Map Name (OneOrTwoNames One)
tvMap
] [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
argNames
where
makeFun :: Name -> Name -> TyVarMap1 -> Q Exp
makeFun :: Name -> Name -> Map Name (OneOrTwoNames One) -> Q Exp
makeFun Name
z Name
value Map Name (OneOrTwoNames One)
tvMap = do
#if MIN_VERSION_template_haskell(2,9,0)
[Role]
roles <- Name -> Q [Role]
reifyRoles Name
_parentName
#endif
case () of
()
_
#if MIN_VERSION_template_haskell(2,9,0)
| Just ([Role]
_, Role
PhantomR) <- [Role] -> Maybe ([Role], Role)
forall a. [a] -> Maybe ([a], a)
unsnoc [Role]
roles
-> Name -> Name -> Q Exp
functorFunPhantom Name
z Name
value
#endif
| [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons Bool -> Bool -> Bool
&& FFTOptions -> Bool
fftEmptyCaseBehavior FFTOptions
opts Bool -> Bool -> Bool
&& Bool
ghc7'8OrLater
-> FunctorFun -> Name -> Name -> Q Exp
functorFunEmptyCase FunctorFun
ff Name
z Name
value
| [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
-> FunctorFun -> Name -> Name -> Q Exp
functorFunNoCons FunctorFun
ff Name
z Name
value
| Bool
otherwise
-> Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value)
((ConstructorInfo -> MatchQ) -> [ConstructorInfo] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (FunctorFun
-> Name
-> Map Name (OneOrTwoNames One)
-> ConstructorInfo
-> MatchQ
makeFunctorFunForCon FunctorFun
ff Name
z Map Name (OneOrTwoNames One)
tvMap) [ConstructorInfo]
cons)
#if MIN_VERSION_template_haskell(2,9,0)
functorFunPhantom :: Name -> Name -> Q Exp
functorFunPhantom :: Name -> Name -> Q Exp
functorFunPhantom Name
z Name
value =
Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
functorFunTrivial Q Exp
coerce
(Name -> Q Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
coerce)
FunctorFun
ff Name
z
where
coerce :: Q Exp
coerce :: Q Exp
coerce = Name -> Q Exp
varE Name
coerceValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
value
#endif
makeFunctorFunForCon :: FunctorFun -> Name -> TyVarMap1 -> ConstructorInfo -> Q Match
makeFunctorFunForCon :: FunctorFun
-> Name
-> Map Name (OneOrTwoNames One)
-> ConstructorInfo
-> MatchQ
makeFunctorFunForCon FunctorFun
ff Name
z Map Name (OneOrTwoNames One)
tvMap
con :: ConstructorInfo
con@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt }) = do
FunctorClass
-> Map Name (OneOrTwoNames One) -> Cxt -> Name -> MatchQ -> MatchQ
forall a b c.
ClassRep a =>
a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c
checkExistentialContext (FunctorFun -> FunctorClass
functorFunToClass FunctorFun
ff) Map Name (OneOrTwoNames One)
tvMap Cxt
ctxt Name
conName (MatchQ -> MatchQ) -> MatchQ -> MatchQ
forall a b. (a -> b) -> a -> b
$
case FunctorFun
ff of
FunctorFun
Fmap -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFmapMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
FunctorFun
Replace -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeReplaceMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
FunctorFun
Foldr -> Name -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFoldrMatch Name
z Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
FunctorFun
FoldMap -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFoldMapMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
FunctorFun
Null -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeNullMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
FunctorFun
Traverse -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeTraverseMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
makeFmapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeFmapMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFmapMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Exp -> Q Exp]
parts <- Map Name (OneOrTwoNames One)
-> FFoldType (Exp -> Q Exp) -> ConstructorInfo -> Q [Exp -> Q Exp]
forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType (Exp -> Q Exp)
ft_fmap ConstructorInfo
con
Name -> [Exp -> Q Exp] -> MatchQ
match_for_con_functor Name
conName [Exp -> Q Exp]
parts
where
ft_fmap :: FFoldType (Exp -> Q Exp)
ft_fmap :: FFoldType (Exp -> Q Exp)
ft_fmap = FT :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Type -> a -> a)
-> a
-> ([TyVarBndrSpec] -> a -> a)
-> FFoldType a
FT { ft_triv :: Exp -> Q Exp
ft_triv = Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return
, ft_var :: Name -> Exp -> Q Exp
ft_var = \Name
v Exp
x -> case Map Name (OneOrTwoNames One)
tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
OneName Name
f -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
f Exp -> Exp -> Exp
`AppE` Exp
x
, ft_fun :: (Exp -> Q Exp) -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_fun = \Exp -> Q Exp
g Exp -> Q Exp
h Exp
x -> (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
b -> do
Exp
gg <- Exp -> Q Exp
g Exp
b
Exp -> Q Exp
h (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
x Exp -> Exp -> Exp
`AppE` Exp
gg
, ft_tup :: TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
ft_tup = (Name -> [Exp -> Q Exp] -> MatchQ)
-> TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [Exp -> Q Exp] -> MatchQ
match_for_con_functor
, ft_ty_app :: Type -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_ty_app = \Type
argTy Exp -> Q Exp
g Exp
x -> do
case Type -> Maybe Name
varTToName_maybe Type
argTy of
Just Name
argVar
| Just (OneName Name
f) <- Name -> Map Name (OneOrTwoNames One) -> Maybe (OneOrTwoNames One)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
argVar Map Name (OneOrTwoNames One)
tvMap
-> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
f Exp -> Exp -> Exp
`AppE` Exp
x
Maybe Name
_ -> do Exp
gg <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
g
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
gg Exp -> Exp -> Exp
`AppE` Exp
x
, ft_forall :: [TyVarBndrSpec] -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_forall = \[TyVarBndrSpec]
_ Exp -> Q Exp
g Exp
x -> Exp -> Q Exp
g Exp
x
, ft_bad_app :: Exp -> Q Exp
ft_bad_app = \Exp
_ -> FunctorClass -> Name -> Q Exp
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
Functor Name
conName
, ft_co_var :: Name -> Exp -> Q Exp
ft_co_var = \Name
_ Exp
_ -> Name -> Q Exp
forall a. Name -> Q a
contravarianceError Name
conName
}
makeReplaceMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeReplaceMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeReplaceMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Exp -> Q Exp]
parts <- Map Name (OneOrTwoNames One)
-> FFoldType (Exp -> Q Exp) -> ConstructorInfo -> Q [Exp -> Q Exp]
forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType (Exp -> Q Exp)
ft_replace ConstructorInfo
con
Name -> [Exp -> Q Exp] -> MatchQ
match_for_con_functor Name
conName [Exp -> Q Exp]
parts
where
ft_replace :: FFoldType (Exp -> Q Exp)
ft_replace :: FFoldType (Exp -> Q Exp)
ft_replace = FT :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Type -> a -> a)
-> a
-> ([TyVarBndrSpec] -> a -> a)
-> FFoldType a
FT { ft_triv :: Exp -> Q Exp
ft_triv = Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return
, ft_var :: Name -> Exp -> Q Exp
ft_var = \Name
v Exp
_ -> case Map Name (OneOrTwoNames One)
tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
OneName Name
z -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
z
, ft_fun :: (Exp -> Q Exp) -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_fun = \Exp -> Q Exp
g Exp -> Q Exp
h Exp
x -> (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
b -> do
Exp
gg <- Exp -> Q Exp
g Exp
b
Exp -> Q Exp
h (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
x Exp -> Exp -> Exp
`AppE` Exp
gg
, ft_tup :: TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
ft_tup = (Name -> [Exp -> Q Exp] -> MatchQ)
-> TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [Exp -> Q Exp] -> MatchQ
match_for_con_functor
, ft_ty_app :: Type -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_ty_app = \Type
argTy Exp -> Q Exp
g Exp
x -> do
case Type -> Maybe Name
varTToName_maybe Type
argTy of
Just Name
argVar
| Just (OneName Name
z) <- Name -> Map Name (OneOrTwoNames One) -> Maybe (OneOrTwoNames One)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
argVar Map Name (OneOrTwoNames One)
tvMap
-> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
replaceValName Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
z Exp -> Exp -> Exp
`AppE` Exp
x
Maybe Name
_ -> do Exp
gg <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
g
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
gg Exp -> Exp -> Exp
`AppE` Exp
x
, ft_forall :: [TyVarBndrSpec] -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_forall = \[TyVarBndrSpec]
_ Exp -> Q Exp
g Exp
x -> Exp -> Q Exp
g Exp
x
, ft_bad_app :: Exp -> Q Exp
ft_bad_app = \Exp
_ -> FunctorClass -> Name -> Q Exp
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
Functor Name
conName
, ft_co_var :: Name -> Exp -> Q Exp
ft_co_var = \Name
_ Exp
_ -> Name -> Q Exp
forall a. Name -> Q a
contravarianceError Name
conName
}
match_for_con_functor :: Name -> [Exp -> Q Exp] -> Q Match
match_for_con_functor :: Name -> [Exp -> Q Exp] -> MatchQ
match_for_con_functor = (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> MatchQ
forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> MatchQ
mkSimpleConMatch ((Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> MatchQ)
-> (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \Name
conName' [Q Exp]
xs ->
[Q Exp] -> Q Exp
appsE (Name -> Q Exp
conE Name
conName'Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:[Q Exp]
xs)
makeFoldrMatch :: Name -> TyVarMap1 -> ConstructorInfo -> Q Match
makeFoldrMatch :: Name -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFoldrMatch Name
z Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (Bool, Exp)]
parts <- Map Name (OneOrTwoNames One)
-> FFoldType (Q (Bool, Exp))
-> ConstructorInfo
-> Q [Q (Bool, Exp)]
forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType (Q (Bool, Exp))
ft_foldr ConstructorInfo
con
[(Bool, Exp)]
parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
Exp -> Name -> [(Bool, Exp)] -> MatchQ
match_for_con (Name -> Exp
VarE Name
z) Name
conName [(Bool, Exp)]
parts'
where
ft_foldr :: FFoldType (Q (Bool, Exp))
ft_foldr :: FFoldType (Q (Bool, Exp))
ft_foldr = FT :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Type -> a -> a)
-> a
-> ([TyVarBndrSpec] -> a -> a)
-> FFoldType a
FT { ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
_ Exp
z' -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
z'
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Exp
lam)
, ft_var :: Name -> Q (Bool, Exp)
ft_var = \Name
v -> case Map Name (OneOrTwoNames One)
tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
OneName Name
f -> (Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE Name
f)
, ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
ft_tup = \TupleSort
t [Q (Bool, Exp)]
gs -> do
[(Bool, Exp)]
gg <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
gs
Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
x Exp
z' ->
(Name -> [(Bool, Exp)] -> MatchQ)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase (Exp -> Name -> [(Bool, Exp)] -> MatchQ
match_for_con Exp
z') TupleSort
t [(Bool, Exp)]
gg Exp
x
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
lam)
, ft_ty_app :: Type -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_ty_app = \Type
_ Q (Bool, Exp)
g -> do
(Bool
b, Exp
gg) <- Q (Bool, Exp)
g
Exp
e <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
x Exp
z' -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Name -> Exp
VarE Name
foldrValName Exp -> Exp -> Exp
`AppE` Exp
gg Exp -> Exp -> Exp
`AppE` Exp
z' Exp -> Exp -> Exp
`AppE` Exp
x
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
b, Exp
e)
, ft_forall :: [TyVarBndrSpec] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall = \[TyVarBndrSpec]
_ Q (Bool, Exp)
g -> Q (Bool, Exp)
g
, ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var = \Name
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
contravarianceError Name
conName
, ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_fun = \Q (Bool, Exp)
_ Q (Bool, Exp)
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (Bool, Exp)
ft_bad_app = FunctorClass -> Name -> Q (Bool, Exp)
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
Foldable Name
conName
}
match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match
match_for_con :: Exp -> Name -> [(Bool, Exp)] -> MatchQ
match_for_con Exp
zExp = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkFoldr [Exp]
xs
where
mkFoldr :: [Exp] -> Exp
mkFoldr :: [Exp] -> Exp
mkFoldr = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
AppE Exp
zExp
makeFoldMapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeFoldMapMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFoldMapMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (Bool, Exp)]
parts <- Map Name (OneOrTwoNames One)
-> FFoldType (Q (Bool, Exp))
-> ConstructorInfo
-> Q [Q (Bool, Exp)]
forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType (Q (Bool, Exp))
ft_foldMap ConstructorInfo
con
[(Bool, Exp)]
parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
Name -> [(Bool, Exp)] -> MatchQ
match_for_con Name
conName [(Bool, Exp)]
parts'
where
ft_foldMap :: FFoldType (Q (Bool, Exp))
ft_foldMap :: FFoldType (Q (Bool, Exp))
ft_foldMap = FT :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Type -> a -> a)
-> a
-> ([TyVarBndrSpec] -> a -> a)
-> FFoldType a
FT { ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
_ -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
memptyValName
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Exp
lam)
, ft_var :: Name -> Q (Bool, Exp)
ft_var = \Name
v -> case Map Name (OneOrTwoNames One)
tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
OneName Name
f -> (Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE Name
f)
, ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
ft_tup = \TupleSort
t [Q (Bool, Exp)]
gs -> do
[(Bool, Exp)]
gg <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
gs
Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> [(Bool, Exp)] -> MatchQ)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> MatchQ
match_for_con TupleSort
t [(Bool, Exp)]
gg
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
lam)
, ft_ty_app :: Type -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_ty_app = \Type
_ Q (Bool, Exp)
g -> do
((Bool, Exp) -> (Bool, Exp)) -> Q (Bool, Exp) -> Q (Bool, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Bool
b, Exp
e) -> (Bool
b, Name -> Exp
VarE Name
foldMapValName Exp -> Exp -> Exp
`AppE` Exp
e)) Q (Bool, Exp)
g
, ft_forall :: [TyVarBndrSpec] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall = \[TyVarBndrSpec]
_ Q (Bool, Exp)
g -> Q (Bool, Exp)
g
, ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var = \Name
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
contravarianceError Name
conName
, ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_fun = \Q (Bool, Exp)
_ Q (Bool, Exp)
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (Bool, Exp)
ft_bad_app = FunctorClass -> Name -> Q (Bool, Exp)
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
Foldable Name
conName
}
match_for_con :: Name -> [(Bool, Exp)] -> Q Match
match_for_con :: Name -> [(Bool, Exp)] -> MatchQ
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkFoldMap [Exp]
xs
where
mkFoldMap :: [Exp] -> Exp
mkFoldMap :: [Exp] -> Exp
mkFoldMap [] = Name -> Exp
VarE Name
memptyValName
mkFoldMap [Exp]
es = (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
mappendValName)) [Exp]
es
makeNullMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeNullMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeNullMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (NullM Exp)]
parts <- Map Name (OneOrTwoNames One)
-> FFoldType (Q (NullM Exp))
-> ConstructorInfo
-> Q [Q (NullM Exp)]
forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType (Q (NullM Exp))
ft_null ConstructorInfo
con
[NullM Exp]
parts' <- [Q (NullM Exp)] -> Q [NullM Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (NullM Exp)]
parts
case [NullM Exp] -> Maybe [(Bool, Exp)]
forall a. [NullM a] -> Maybe [(Bool, a)]
convert [NullM Exp]
parts' of
Maybe [(Bool, Exp)]
Nothing -> Match -> MatchQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> MatchQ) -> Match -> MatchQ
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match (ConstructorInfo -> Pat
conWildPat ConstructorInfo
con) (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
falseDataName) []
Just [(Bool, Exp)]
cp -> Name -> [(Bool, Exp)] -> MatchQ
match_for_con Name
conName [(Bool, Exp)]
cp
where
ft_null :: FFoldType (Q (NullM Exp))
ft_null :: FFoldType (Q (NullM Exp))
ft_null = FT :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Type -> a -> a)
-> a
-> ([TyVarBndrSpec] -> a -> a)
-> FFoldType a
FT { ft_triv :: Q (NullM Exp)
ft_triv = NullM Exp -> Q (NullM Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (NullM Exp -> Q (NullM Exp)) -> NullM Exp -> Q (NullM Exp)
forall a b. (a -> b) -> a -> b
$ Exp -> NullM Exp
forall a. a -> NullM a
IsNull (Exp -> NullM Exp) -> Exp -> NullM Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
trueDataName
, ft_var :: Name -> Q (NullM Exp)
ft_var = \Name
_ -> NullM Exp -> Q (NullM Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return NullM Exp
forall a. NullM a
NotNull
, ft_tup :: TupleSort -> [Q (NullM Exp)] -> Q (NullM Exp)
ft_tup = \TupleSort
t [Q (NullM Exp)]
g -> do
[NullM Exp]
gg <- [Q (NullM Exp)] -> Q [NullM Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (NullM Exp)]
g
case [NullM Exp] -> Maybe [(Bool, Exp)]
forall a. [NullM a] -> Maybe [(Bool, a)]
convert [NullM Exp]
gg of
Maybe [(Bool, Exp)]
Nothing -> NullM Exp -> Q (NullM Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return NullM Exp
forall a. NullM a
NotNull
Just [(Bool, Exp)]
ggg ->
(Exp -> NullM Exp) -> Q Exp -> Q (NullM Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> NullM Exp
forall a. a -> NullM a
NullM (Q Exp -> Q (NullM Exp)) -> Q Exp -> Q (NullM Exp)
forall a b. (a -> b) -> a -> b
$ (Exp -> Q Exp) -> Q Exp
mkSimpleLam
((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> [(Bool, Exp)] -> MatchQ)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> MatchQ
match_for_con TupleSort
t [(Bool, Exp)]
ggg
, ft_ty_app :: Type -> Q (NullM Exp) -> Q (NullM Exp)
ft_ty_app = \Type
_ Q (NullM Exp)
g -> ((NullM Exp -> NullM Exp) -> Q (NullM Exp) -> Q (NullM Exp))
-> Q (NullM Exp) -> (NullM Exp -> NullM Exp) -> Q (NullM Exp)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (NullM Exp -> NullM Exp) -> Q (NullM Exp) -> Q (NullM Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Q (NullM Exp)
g ((NullM Exp -> NullM Exp) -> Q (NullM Exp))
-> (NullM Exp -> NullM Exp) -> Q (NullM Exp)
forall a b. (a -> b) -> a -> b
$ \NullM Exp
nestedResult ->
case NullM Exp
nestedResult of
NullM Exp
NotNull -> Exp -> NullM Exp
forall a. a -> NullM a
NullM (Exp -> NullM Exp) -> Exp -> NullM Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
nullValName
r :: NullM Exp
r@IsNull{} -> NullM Exp
r
NullM Exp
nestedTest -> Exp -> NullM Exp
forall a. a -> NullM a
NullM (Exp -> NullM Exp) -> Exp -> NullM Exp
forall a b. (a -> b) -> a -> b
$
Name -> Exp
VarE Name
allValName Exp -> Exp -> Exp
`AppE` Exp
nestedTest
, ft_forall :: [TyVarBndrSpec] -> Q (NullM Exp) -> Q (NullM Exp)
ft_forall = \[TyVarBndrSpec]
_ Q (NullM Exp)
g -> Q (NullM Exp)
g
, ft_co_var :: Name -> Q (NullM Exp)
ft_co_var = \Name
_ -> Name -> Q (NullM Exp)
forall a. Name -> Q a
contravarianceError Name
conName
, ft_fun :: Q (NullM Exp) -> Q (NullM Exp) -> Q (NullM Exp)
ft_fun = \Q (NullM Exp)
_ Q (NullM Exp)
_ -> Name -> Q (NullM Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (NullM Exp)
ft_bad_app = FunctorClass -> Name -> Q (NullM Exp)
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
Foldable Name
conName
}
match_for_con :: Name -> [(Bool, Exp)] -> Q Match
match_for_con :: Name -> [(Bool, Exp)] -> MatchQ
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkNull [Exp]
xs
where
mkNull :: [Exp] -> Exp
mkNull :: [Exp] -> Exp
mkNull [] = Name -> Exp
ConE Name
trueDataName
mkNull [Exp]
xs = (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Exp
x Exp
y -> Name -> Exp
VarE Name
andValName Exp -> Exp -> Exp
`AppE` Exp
x Exp -> Exp -> Exp
`AppE` Exp
y) [Exp]
xs
convert :: [NullM a] -> Maybe [(Bool, a)]
convert :: [NullM a] -> Maybe [(Bool, a)]
convert = (NullM a -> Maybe (Bool, a)) -> [NullM a] -> Maybe [(Bool, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NullM a -> Maybe (Bool, a)
forall b. NullM b -> Maybe (Bool, b)
go where
go :: NullM b -> Maybe (Bool, b)
go (IsNull b
a) = (Bool, b) -> Maybe (Bool, b)
forall a. a -> Maybe a
Just (Bool
False, b
a)
go NullM b
NotNull = Maybe (Bool, b)
forall a. Maybe a
Nothing
go (NullM b
a) = (Bool, b) -> Maybe (Bool, b)
forall a. a -> Maybe a
Just (Bool
True, b
a)
data NullM a =
IsNull a
| NotNull
| NullM a
makeTraverseMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeTraverseMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeTraverseMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (Bool, Exp)]
parts <- Map Name (OneOrTwoNames One)
-> FFoldType (Q (Bool, Exp))
-> ConstructorInfo
-> Q [Q (Bool, Exp)]
forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType (Q (Bool, Exp))
ft_trav ConstructorInfo
con
[(Bool, Exp)]
parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
Name -> [(Bool, Exp)] -> MatchQ
match_for_con Name
conName [(Bool, Exp)]
parts'
where
ft_trav :: FFoldType (Q (Bool, Exp))
ft_trav :: FFoldType (Q (Bool, Exp))
ft_trav = FT :: forall a.
a
-> (Name -> a)
-> (Name -> a)
-> (a -> a -> a)
-> (TupleSort -> [a] -> a)
-> (Type -> a -> a)
-> a
-> ([TyVarBndrSpec] -> a -> a)
-> FFoldType a
FT {
ft_triv :: Q (Bool, Exp)
ft_triv = (Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Name -> Exp
VarE Name
pureValName)
, ft_var :: Name -> Q (Bool, Exp)
ft_var = \Name
v -> case Map Name (OneOrTwoNames One)
tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
OneName Name
f -> (Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Name -> Exp
VarE Name
f)
, ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
ft_tup = \TupleSort
t [Q (Bool, Exp)]
gs -> do
[(Bool, Exp)]
gg <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
gs
Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> [(Bool, Exp)] -> MatchQ)
-> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
forall a.
(Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> MatchQ
match_for_con TupleSort
t [(Bool, Exp)]
gg
(Bool, Exp) -> Q (Bool, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Exp
lam)
, ft_ty_app :: Type -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_ty_app = \Type
_ Q (Bool, Exp)
g ->
((Bool, Exp) -> (Bool, Exp)) -> Q (Bool, Exp) -> Q (Bool, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Bool
b, Exp
e) -> (Bool
b, Name -> Exp
VarE Name
traverseValName Exp -> Exp -> Exp
`AppE` Exp
e)) Q (Bool, Exp)
g
, ft_forall :: [TyVarBndrSpec] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall = \[TyVarBndrSpec]
_ Q (Bool, Exp)
g -> Q (Bool, Exp)
g
, ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var = \Name
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
contravarianceError Name
conName
, ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_fun = \Q (Bool, Exp)
_ Q (Bool, Exp)
_ -> Name -> Q (Bool, Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (Bool, Exp)
ft_bad_app = FunctorClass -> Name -> Q (Bool, Exp)
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
Traversable Name
conName
}
match_for_con :: Name -> [(Bool, Exp)] -> Q Match
match_for_con :: Name -> [(Bool, Exp)] -> MatchQ
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
-> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
forall a b. (a -> b) -> a -> b
$ \Exp
conExp [Exp]
xs -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Exp] -> Exp
mkApCon Exp
conExp [Exp]
xs
where
mkApCon :: Exp -> [Exp] -> Exp
mkApCon :: Exp -> [Exp] -> Exp
mkApCon Exp
conExp [] = Name -> Exp
VarE Name
pureValName Exp -> Exp -> Exp
`AppE` Exp
conExp
mkApCon Exp
conExp [Exp
e] = Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
conExp Exp -> Exp -> Exp
`AppE` Exp
e
mkApCon Exp
conExp (Exp
e1:Exp
e2:[Exp]
es) = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Exp -> Exp -> Exp
appAp
(Name -> Exp
VarE Name
liftA2ValName Exp -> Exp -> Exp
`AppE` Exp
conExp Exp -> Exp -> Exp
`AppE` Exp
e1 Exp -> Exp -> Exp
`AppE` Exp
e2) [Exp]
es
where appAp :: Exp -> Exp -> Exp
appAp Exp
se1 Exp
se2 = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
se1) (Name -> Exp
VarE Name
apValName) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
se2)
data FunctorClass = Functor | Foldable | Traversable
instance ClassRep FunctorClass where
arity :: FunctorClass -> Int
arity FunctorClass
_ = Int
1
allowExQuant :: FunctorClass -> Bool
allowExQuant FunctorClass
Foldable = Bool
True
allowExQuant FunctorClass
_ = Bool
False
fullClassName :: FunctorClass -> Name
fullClassName FunctorClass
Functor = Name
functorTypeName
fullClassName FunctorClass
Foldable = Name
foldableTypeName
fullClassName FunctorClass
Traversable = Name
traversableTypeName
classConstraint :: FunctorClass -> Int -> Maybe Name
classConstraint FunctorClass
fClass Int
1 = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ FunctorClass -> Name
forall a. ClassRep a => a -> Name
fullClassName FunctorClass
fClass
classConstraint FunctorClass
_ Int
_ = Maybe Name
forall a. Maybe a
Nothing
data FunctorFun
= Fmap
| Replace
| Foldr
| FoldMap
| Null
| Traverse
deriving FunctorFun -> FunctorFun -> Bool
(FunctorFun -> FunctorFun -> Bool)
-> (FunctorFun -> FunctorFun -> Bool) -> Eq FunctorFun
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FunctorFun -> FunctorFun -> Bool
$c/= :: FunctorFun -> FunctorFun -> Bool
== :: FunctorFun -> FunctorFun -> Bool
$c== :: FunctorFun -> FunctorFun -> Bool
Eq
instance Show FunctorFun where
showsPrec :: Int -> FunctorFun -> ShowS
showsPrec Int
_ FunctorFun
Fmap = String -> ShowS
showString String
"fmap"
showsPrec Int
_ FunctorFun
Replace = String -> ShowS
showString String
"(<$)"
showsPrec Int
_ FunctorFun
Foldr = String -> ShowS
showString String
"foldr"
showsPrec Int
_ FunctorFun
FoldMap = String -> ShowS
showString String
"foldMap"
showsPrec Int
_ FunctorFun
Null = String -> ShowS
showString String
"null"
showsPrec Int
_ FunctorFun
Traverse = String -> ShowS
showString String
"traverse"
functorFunConstName :: FunctorFun -> Name
functorFunConstName :: FunctorFun -> Name
functorFunConstName FunctorFun
Fmap = Name
fmapConstValName
functorFunConstName FunctorFun
Replace = Name
replaceConstValName
functorFunConstName FunctorFun
Foldr = Name
foldrConstValName
functorFunConstName FunctorFun
FoldMap = Name
foldMapConstValName
functorFunConstName FunctorFun
Null = Name
nullConstValName
functorFunConstName FunctorFun
Traverse = Name
traverseConstValName
functorFunName :: FunctorFun -> Name
functorFunName :: FunctorFun -> Name
functorFunName FunctorFun
Fmap = Name
fmapValName
functorFunName FunctorFun
Replace = Name
replaceValName
functorFunName FunctorFun
Foldr = Name
foldrValName
functorFunName FunctorFun
FoldMap = Name
foldMapValName
functorFunName FunctorFun
Null = Name
nullValName
functorFunName FunctorFun
Traverse = Name
traverseValName
functorClassToFuns :: FunctorClass -> [FunctorFun]
functorClassToFuns :: FunctorClass -> [FunctorFun]
functorClassToFuns FunctorClass
Functor = [ FunctorFun
Fmap, FunctorFun
Replace ]
functorClassToFuns FunctorClass
Foldable = [ FunctorFun
Foldr, FunctorFun
FoldMap
#if MIN_VERSION_base(4,8,0)
, FunctorFun
Null
#endif
]
functorClassToFuns FunctorClass
Traversable = [ FunctorFun
Traverse ]
functorFunToClass :: FunctorFun -> FunctorClass
functorFunToClass :: FunctorFun -> FunctorClass
functorFunToClass FunctorFun
Fmap = FunctorClass
Functor
functorFunToClass FunctorFun
Replace = FunctorClass
Functor
functorFunToClass FunctorFun
Foldr = FunctorClass
Foldable
functorFunToClass FunctorFun
FoldMap = FunctorClass
Foldable
functorFunToClass FunctorFun
Null = FunctorClass
Foldable
functorFunToClass FunctorFun
Traverse = FunctorClass
Traversable
functorFunEmptyCase :: FunctorFun -> Name -> Name -> Q Exp
functorFunEmptyCase :: FunctorFun -> Name -> Name -> Q Exp
functorFunEmptyCase FunctorFun
ff Name
z Name
value =
Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
functorFunTrivial Q Exp
emptyCase
(Name -> Q Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
emptyCase)
FunctorFun
ff Name
z
where
emptyCase :: Q Exp
emptyCase :: Q Exp
emptyCase = Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value) []
functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp
functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp
functorFunNoCons FunctorFun
ff Name
z Name
value =
Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
functorFunTrivial Q Exp
seqAndError
(Name -> Q Exp
varE Name
pureValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
seqAndError)
FunctorFun
ff Name
z
where
seqAndError :: Q Exp
seqAndError :: Q Exp
seqAndError = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
seqValName) (Name -> Q Exp
varE Name
value) Q Exp -> Q Exp -> Q Exp
`appE`
Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
errorValName)
(String -> Q Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Void " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (FunctorFun -> Name
functorFunName FunctorFun
ff))
functorFunTrivial :: Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
functorFunTrivial :: Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
functorFunTrivial Q Exp
fmapE Q Exp
traverseE FunctorFun
ff Name
z = FunctorFun -> Q Exp
go FunctorFun
ff
where
go :: FunctorFun -> Q Exp
go :: FunctorFun -> Q Exp
go FunctorFun
Fmap = Q Exp
fmapE
go FunctorFun
Replace = Q Exp
fmapE
go FunctorFun
Foldr = Name -> Q Exp
varE Name
z
go FunctorFun
FoldMap = Name -> Q Exp
varE Name
memptyValName
go FunctorFun
Null = Name -> Q Exp
conE Name
trueDataName
go FunctorFun
Traverse = Q Exp
traverseE
conWildPat :: ConstructorInfo -> Pat
conWildPat :: ConstructorInfo -> Pat
conWildPat (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
ts }) =
Name -> [Pat] -> Pat
conPCompat Name
conName ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts) Pat
WildP
data FFoldType a
= FT { FFoldType a -> a
ft_triv :: a
, FFoldType a -> Name -> a
ft_var :: Name -> a
, FFoldType a -> Name -> a
ft_co_var :: Name -> a
, FFoldType a -> a -> a -> a
ft_fun :: a -> a -> a
, FFoldType a -> TupleSort -> [a] -> a
ft_tup :: TupleSort -> [a] -> a
, FFoldType a -> Type -> a -> a
ft_ty_app :: Type -> a -> a
, FFoldType a -> a
ft_bad_app :: a
, FFoldType a -> [TyVarBndrSpec] -> a -> a
ft_forall :: [TyVarBndrSpec] -> a -> a
}
functorLikeTraverse :: forall a.
TyVarMap1
-> FFoldType a
-> Type
-> Q a
functorLikeTraverse :: Map Name (OneOrTwoNames One) -> FFoldType a -> Type -> Q a
functorLikeTraverse Map Name (OneOrTwoNames One)
tvMap (FT { ft_triv :: forall a. FFoldType a -> a
ft_triv = a
caseTrivial, ft_var :: forall a. FFoldType a -> Name -> a
ft_var = Name -> a
caseVar
, ft_co_var :: forall a. FFoldType a -> Name -> a
ft_co_var = Name -> a
caseCoVar, ft_fun :: forall a. FFoldType a -> a -> a -> a
ft_fun = a -> a -> a
caseFun
, ft_tup :: forall a. FFoldType a -> TupleSort -> [a] -> a
ft_tup = TupleSort -> [a] -> a
caseTuple, ft_ty_app :: forall a. FFoldType a -> Type -> a -> a
ft_ty_app = Type -> a -> a
caseTyApp
, ft_bad_app :: forall a. FFoldType a -> a
ft_bad_app = a
caseWrongArg, ft_forall :: forall a. FFoldType a -> [TyVarBndrSpec] -> a -> a
ft_forall = [TyVarBndrSpec] -> a -> a
caseForAll })
Type
ty
= do Type
ty' <- Type -> TypeQ
resolveTypeSynonyms Type
ty
(a
res, Bool
_) <- Bool -> Type -> Q (a, Bool)
go Bool
False Type
ty'
a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
where
go :: Bool
-> Type
-> Q (a, Bool)
go :: Bool -> Type -> Q (a, Bool)
go Bool
co t :: Type
t@AppT{}
| (Type
ArrowT, [Type
funArg, Type
funRes]) <- Type -> (Type, Cxt)
unapplyTy Type
t
= do (a
funArgR, Bool
funArgC) <- Bool -> Type -> Q (a, Bool)
go (Bool -> Bool
not Bool
co) Type
funArg
(a
funResR, Bool
funResC) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
funRes
if Bool
funArgC Bool -> Bool -> Bool
|| Bool
funResC
then (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a -> a
caseFun a
funArgR a
funResR, Bool
True)
else Q (a, Bool)
trivial
go Bool
co t :: Type
t@AppT{} = do
let (Type
f, Cxt
args) = Type -> (Type, Cxt)
unapplyTy Type
t
(a
_, Bool
fc) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
f
([a]
xrs, [Bool]
xcs) <- ([(a, Bool)] -> ([a], [Bool])) -> Q [(a, Bool)] -> Q ([a], [Bool])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(a, Bool)] -> ([a], [Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(a, Bool)] -> Q ([a], [Bool]))
-> Q [(a, Bool)] -> Q ([a], [Bool])
forall a b. (a -> b) -> a -> b
$ (Type -> Q (a, Bool)) -> Cxt -> Q [(a, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Type -> Q (a, Bool)
go Bool
co) Cxt
args
let tuple :: TupleSort -> Q (a, Bool)
tuple :: TupleSort -> Q (a, Bool)
tuple TupleSort
tupSort = (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (TupleSort -> [a] -> a
caseTuple TupleSort
tupSort [a]
xrs, Bool
True)
wrongArg :: Q (a, Bool)
wrongArg :: Q (a, Bool)
wrongArg = (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseWrongArg, Bool
True)
case () of
()
_ | Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
xcs)
-> Q (a, Bool)
trivial
| TupleT Int
len <- Type
f
-> TupleSort -> Q (a, Bool)
tuple (TupleSort -> Q (a, Bool)) -> TupleSort -> Q (a, Bool)
forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Boxed Int
len
#if MIN_VERSION_template_haskell(2,6,0)
| UnboxedTupleT Int
len <- Type
f
-> TupleSort -> Q (a, Bool)
tuple (TupleSort -> Q (a, Bool)) -> TupleSort -> Q (a, Bool)
forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Unboxed Int
len
#endif
| Bool
fc Bool -> Bool -> Bool
|| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> [Bool]
forall a. [a] -> [a]
init [Bool]
xcs)
-> Q (a, Bool)
wrongArg
| Bool
otherwise
-> do Bool
itf <- [Name] -> Type -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
f Cxt
args
if Bool
itf
then Q (a, Bool)
wrongArg
else (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> a -> a
caseTyApp (Cxt -> Type
forall a. [a] -> a
last Cxt
args) ([a] -> a
forall a. [a] -> a
last [a]
xrs), Bool
True)
go Bool
co (SigT Type
t Type
k) = do
(a
_, Bool
kc) <- Bool -> Type -> Q (a, Bool)
go_kind Bool
co Type
k
if Bool
kc
then (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseWrongArg, Bool
True)
else Bool -> Type -> Q (a, Bool)
go Bool
co Type
t
go Bool
co (VarT Name
v)
| Name -> Map Name (OneOrTwoNames One) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
v Map Name (OneOrTwoNames One)
tvMap
= (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
co then Name -> a
caseCoVar Name
v else Name -> a
caseVar Name
v, Bool
True)
| Bool
otherwise
= Q (a, Bool)
trivial
go Bool
co (ForallT [TyVarBndrSpec]
tvbs Cxt
_ Type
t) = do
(a
tr, Bool
tc) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
t
let tvbNames :: [Name]
tvbNames = (TyVarBndrSpec -> Name) -> [TyVarBndrSpec] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrSpec -> Name
forall flag. TyVarBndrSpec -> Name
tvName [TyVarBndrSpec]
tvbs
if Bool -> Bool
not Bool
tc Bool -> Bool -> Bool
|| (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
tvbNames) [Name]
tyVarNames
then Q (a, Bool)
trivial
else (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndrSpec] -> a -> a
caseForAll [TyVarBndrSpec]
tvbs a
tr, Bool
True)
go Bool
_ Type
_ = Q (a, Bool)
trivial
go_kind :: Bool
-> Kind
-> Q (a, Bool)
#if MIN_VERSION_template_haskell(2,9,0)
go_kind :: Bool -> Type -> Q (a, Bool)
go_kind = Bool -> Type -> Q (a, Bool)
go
#else
go_kind _ _ = trivial
#endif
trivial :: Q (a, Bool)
trivial :: Q (a, Bool)
trivial = (a, Bool) -> Q (a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseTrivial, Bool
False)
tyVarNames :: [Name]
tyVarNames :: [Name]
tyVarNames = Map Name (OneOrTwoNames One) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (OneOrTwoNames One)
tvMap
foldDataConArgs :: forall a. TyVarMap1 -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs :: Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType a
ft ConstructorInfo
con = do
Cxt
fieldTys <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms (Cxt -> CxtQ) -> Cxt -> CxtQ
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Cxt
constructorFields ConstructorInfo
con
(Type -> Q a) -> Cxt -> Q [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q a
foldArg Cxt
fieldTys
where
foldArg :: Type -> Q a
foldArg :: Type -> Q a
foldArg = Map Name (OneOrTwoNames One) -> FFoldType a -> Type -> Q a
forall a.
Map Name (OneOrTwoNames One) -> FFoldType a -> Type -> Q a
functorLikeTraverse Map Name (OneOrTwoNames One)
tvMap FFoldType a
ft
mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
mkSimpleLam Exp -> Q Exp
lam = do
Name
n <- String -> Q Name
newName String
"n"
Exp
body <- Exp -> Q Exp
lam (Name -> Exp
VarE Name
n)
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
n] Exp
body
mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 Exp -> Exp -> Q Exp
lam = do
Name
n1 <- String -> Q Name
newName String
"n1"
Name
n2 <- String -> Q Name
newName String
"n2"
Exp
body <- Exp -> Exp -> Q Exp
lam (Name -> Exp
VarE Name
n1) (Name -> Exp
VarE Name
n2)
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
n1, Name -> Pat
VarP Name
n2] Exp
body
mkSimpleConMatch :: (Name -> [a] -> Q Exp)
-> Name
-> [Exp -> a]
-> Q Match
mkSimpleConMatch :: (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> MatchQ
mkSimpleConMatch Name -> [a] -> Q Exp
fold Name
conName [Exp -> a]
insides = do
[Name]
varsNeeded <- String -> Int -> Q [Name]
newNameList String
"_arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Exp -> a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp -> a]
insides
let pat :: Pat
pat = Name -> [Pat] -> Pat
conPCompat Name
conName ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
Exp
rhs <- Name -> [a] -> Q Exp
fold Name
conName (((Exp -> a) -> Name -> a) -> [Exp -> a] -> [Name] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Exp -> a
i Name
v -> Exp -> a
i (Exp -> a) -> Exp -> a
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
v) [Exp -> a]
insides [Name]
varsNeeded)
Match -> MatchQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> MatchQ) -> Match -> MatchQ
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
rhs) []
mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp)
-> Name
-> [(Bool, Exp)]
-> Q Match
mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
mkSimpleConMatch2 Exp -> [Exp] -> Q Exp
fold Name
conName [(Bool, Exp)]
insides = do
[Name]
varsNeeded <- String -> Int -> Q [Name]
newNameList String
"_arg" Int
lengthInsides
let pat :: Pat
pat = Name -> [Pat] -> Pat
conPCompat Name
conName ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
exps :: [Exp]
exps = [Maybe Exp] -> [Exp]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Exp] -> [Exp]) -> [Maybe Exp] -> [Exp]
forall a b. (a -> b) -> a -> b
$ ((Bool, Exp) -> Name -> Maybe Exp)
-> [(Bool, Exp)] -> [Name] -> [Maybe Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Bool
m, Exp
i) Name
v -> if Bool
m then Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp
i Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
v)
else Maybe Exp
forall a. Maybe a
Nothing)
[(Bool, Exp)]
insides [Name]
varsNeeded
argTysTyVarInfo :: [Bool]
argTysTyVarInfo = ((Bool, Exp) -> Bool) -> [(Bool, Exp)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
m, Exp
_) -> Bool
m) [(Bool, Exp)]
insides
([Name]
asWithTyVar, [Name]
asWithoutTyVar) = [Bool] -> [Name] -> ([Name], [Name])
forall a. [Bool] -> [a] -> ([a], [a])
partitionByList [Bool]
argTysTyVarInfo [Name]
varsNeeded
conExpQ :: Q Exp
conExpQ
| [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
asWithTyVar = [Q Exp] -> Q Exp
appsE (Name -> Q Exp
conE Name
conNameQ Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:(Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
asWithoutTyVar)
| Bool
otherwise = do
[Name]
bs <- String -> Int -> Q [Name]
newNameList String
"b" Int
lengthInsides
let bs' :: [Name]
bs' = [Bool] -> [Name] -> [Name]
forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
argTysTyVarInfo [Name]
bs
vars :: [Q Exp]
vars = [Bool] -> [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
argTysTyVarInfo
((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
bs) ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
varsNeeded)
[PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
bs') ([Q Exp] -> Q Exp
appsE (Name -> Q Exp
conE Name
conNameQ Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:[Q Exp]
vars))
Exp
conExp <- Q Exp
conExpQ
Exp
rhs <- Exp -> [Exp] -> Q Exp
fold Exp
conExp [Exp]
exps
Match -> MatchQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> MatchQ) -> Match -> MatchQ
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
rhs) []
where
lengthInsides :: Int
lengthInsides = [(Bool, Exp)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Exp)]
insides
data TupleSort
= Boxed Int
#if MIN_VERSION_template_haskell(2,6,0)
| Unboxed Int
#endif
mkSimpleTupleCase :: (Name -> [a] -> Q Match)
-> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase :: (Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [a] -> MatchQ
matchForCon TupleSort
tupSort [a]
insides Exp
x = do
let tupDataName :: Name
tupDataName = case TupleSort
tupSort of
Boxed Int
len -> Int -> Name
tupleDataName Int
len
#if MIN_VERSION_template_haskell(2,6,0)
Unboxed Int
len -> Int -> Name
unboxedTupleDataName Int
len
#endif
Match
m <- Name -> [a] -> MatchQ
matchForCon Name
tupDataName [a]
insides
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
x [Match
m]
conPCompat :: Name -> [Pat] -> Pat
conPCompat :: Name -> [Pat] -> Pat
conPCompat Name
n [Pat]
pats = Name -> [Pat] -> Pat
ConP Name
n
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
[Pat]
pats