{-# 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 Data.List
import qualified Data.Map as Map ((!), keys, lookup, member, singleton)
import Data.Maybe
import Language.Haskell.TH.Datatype
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 opts :: FFTOptions
opts name :: 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 opts :: FFTOptions
opts name :: Name
name = do
Name
f <- String -> Q Name
newName "f"
Name
z <- String -> Q Name
newName "z"
Name
t <- String -> Q Name
newName "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 n :: 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 opts :: FFTOptions
opts name :: 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 opts :: FFTOptions
opts name :: Name
name = do
Name
f <- String -> Q Name
newName "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 n :: 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 opts :: FFTOptions
opts name :: 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 fc :: FunctorClass
fc opts :: FFTOptions
opts name :: 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
(instanceCxt :: Cxt
instanceCxt, instanceType :: 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 fc :: FunctorClass
fc opts :: FFTOptions
opts parentName :: Name
parentName instTypes :: Cxt
instTypes cons :: [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 ff :: 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 ff :: FunctorFun
ff opts :: FFTOptions
opts name :: 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 ff :: FunctorFun
ff opts :: FFTOptions
opts _parentName :: Name
_parentName instTypes :: Cxt
instTypes cons :: [ConstructorInfo]
cons = do
Name
mapFun <- String -> Q Name
newName "f"
Name
z <- String -> Q Name
newName "z"
Name
value <- String -> Q Name
newName "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 z :: Name
z value :: Name
value tvMap :: 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 (_, 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 z :: Name
z value :: 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 ff :: FunctorFun
ff z :: Name
z tvMap :: 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
Fmap -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFmapMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
Replace -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeReplaceMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
Foldr -> Name -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFoldrMatch Name
z Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
FoldMap -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeFoldMapMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
Null -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeNullMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
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 tvMap :: 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
-> ([TyVarBndr] -> 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 = \v :: Name
v x :: 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 f :: 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 = \g :: Exp -> Q Exp
g h :: Exp -> Q Exp
h x :: 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
$ \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 = \argTy :: Type
argTy g :: Exp -> Q Exp
g x :: Exp
x -> do
case Type -> Maybe Name
varTToName_maybe Type
argTy of
Just argVar :: Name
argVar
| Just (OneName f :: 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
_ -> 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 :: [TyVarBndr] -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_forall = \_ g :: Exp -> Q Exp
g x :: Exp
x -> Exp -> Q Exp
g Exp
x
, ft_bad_app :: Exp -> Q Exp
ft_bad_app = \_ -> 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 -> Q Exp
forall a. Name -> Q a
contravarianceError Name
conName
}
makeReplaceMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeReplaceMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
makeReplaceMatch tvMap :: 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
-> ([TyVarBndr] -> 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 = \v :: 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 z :: 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 = \g :: Exp -> Q Exp
g h :: Exp -> Q Exp
h x :: 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
$ \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 = \argTy :: Type
argTy g :: Exp -> Q Exp
g x :: Exp
x -> do
case Type -> Maybe Name
varTToName_maybe Type
argTy of
Just argVar :: Name
argVar
| Just (OneName z :: 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
_ -> 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 :: [TyVarBndr] -> (Exp -> Q Exp) -> Exp -> Q Exp
ft_forall = \_ g :: Exp -> Q Exp
g x :: Exp
x -> Exp -> Q Exp
g Exp
x
, ft_bad_app :: Exp -> Q Exp
ft_bad_app = \_ -> 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 -> 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
$ \conName' :: Name
conName' xs :: [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 z :: Name
z tvMap :: 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
-> ([TyVarBndr] -> 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
$ \_ z' :: 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 = \v :: 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 f :: 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 = \t :: TupleSort
t gs :: [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
$ \x :: Exp
x z' :: 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 = \_ g :: Q (Bool, Exp)
g -> do
(b :: Bool
b, gg :: 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
$ \x :: Exp
x z' :: 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 :: [TyVarBndr] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall = \_ g :: Q (Bool, Exp)
g -> Q (Bool, Exp)
g
, ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var = \_ -> 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 = \_ _ -> 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 zExp :: 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
$ \_ xs :: [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 tvMap :: 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
-> ([TyVarBndr] -> 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 -> 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 = \v :: 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 f :: 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 = \t :: TupleSort
t gs :: [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 = \_ g :: 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 (\(b :: Bool
b, e :: Exp
e) -> (Bool
b, Name -> Exp
VarE Name
foldMapValName Exp -> Exp -> Exp
`AppE` Exp
e)) Q (Bool, Exp)
g
, ft_forall :: [TyVarBndr] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall = \_ g :: Q (Bool, Exp)
g -> Q (Bool, Exp)
g
, ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var = \_ -> 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 = \_ _ -> 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
$ \_ xs :: [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 es :: [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 tvMap :: 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
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 cp :: [(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
-> ([TyVarBndr] -> 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 = \_ -> 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 = \t :: TupleSort
t g :: [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
Nothing -> NullM Exp -> Q (NullM Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return NullM Exp
forall a. NullM a
NotNull
Just ggg :: [(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 = \_ g :: 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
$ \nestedResult :: NullM Exp
nestedResult ->
case NullM Exp
nestedResult of
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 nestedTest :: 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 :: [TyVarBndr] -> Q (NullM Exp) -> Q (NullM Exp)
ft_forall = \_ g :: Q (NullM Exp)
g -> Q (NullM Exp)
g
, ft_co_var :: Name -> Q (NullM Exp)
ft_co_var = \_ -> 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 = \_ _ -> 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
$ \_ xs :: [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 xs :: [Exp]
xs = (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\x :: Exp
x y :: 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 a :: b
a) = (Bool, b) -> Maybe (Bool, b)
forall a. a -> Maybe a
Just (Bool
False, b
a)
go NotNull = Maybe (Bool, b)
forall a. Maybe a
Nothing
go (NullM a :: 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 tvMap :: 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
-> ([TyVarBndr] -> 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 = \v :: 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 f :: 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 = \t :: TupleSort
t gs :: [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 = \_ g :: 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 (\(b :: Bool
b, e :: Exp
e) -> (Bool
b, Name -> Exp
VarE Name
traverseValName Exp -> Exp -> Exp
`AppE` Exp
e)) Q (Bool, Exp)
g
, ft_forall :: [TyVarBndr] -> Q (Bool, Exp) -> Q (Bool, Exp)
ft_forall = \_ g :: Q (Bool, Exp)
g -> Q (Bool, Exp)
g
, ft_co_var :: Name -> Q (Bool, Exp)
ft_co_var = \_ -> 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 = \_ _ -> 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
$ \conExp :: Exp
conExp xs :: [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 conExp :: Exp
conExp [] = Name -> Exp
VarE Name
pureValName Exp -> Exp -> Exp
`AppE` Exp
conExp
mkApCon conExp :: Exp
conExp [e :: Exp
e] = Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
conExp Exp -> Exp -> Exp
`AppE` Exp
e
mkApCon conExp :: Exp
conExp (e1 :: Exp
e1:e2 :: Exp
e2:es :: [Exp]
es) = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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 se1 :: Exp
se1 se2 :: 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 _ = 1
allowExQuant :: FunctorClass -> Bool
allowExQuant Foldable = Bool
True
allowExQuant _ = Bool
False
fullClassName :: FunctorClass -> Name
fullClassName Functor = Name
functorTypeName
fullClassName Foldable = Name
foldableTypeName
fullClassName Traversable = Name
traversableTypeName
classConstraint :: FunctorClass -> Int -> Maybe Name
classConstraint fClass :: FunctorClass
fClass 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 _ _ = 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 _ Fmap = String -> ShowS
showString "fmap"
showsPrec _ Replace = String -> ShowS
showString "(<$)"
showsPrec _ Foldr = String -> ShowS
showString "foldr"
showsPrec _ FoldMap = String -> ShowS
showString "foldMap"
showsPrec _ Null = String -> ShowS
showString "null"
showsPrec _ Traverse = String -> ShowS
showString "traverse"
functorFunConstName :: FunctorFun -> Name
functorFunConstName :: FunctorFun -> Name
functorFunConstName Fmap = Name
fmapConstValName
functorFunConstName Replace = Name
replaceConstValName
functorFunConstName Foldr = Name
foldrConstValName
functorFunConstName FoldMap = Name
foldMapConstValName
functorFunConstName Null = Name
nullConstValName
functorFunConstName Traverse = Name
traverseConstValName
functorFunName :: FunctorFun -> Name
functorFunName :: FunctorFun -> Name
functorFunName Fmap = Name
fmapValName
functorFunName Replace = Name
replaceValName
functorFunName Foldr = Name
foldrValName
functorFunName FoldMap = Name
foldMapValName
functorFunName Null = Name
nullValName
functorFunName Traverse = Name
traverseValName
functorClassToFuns :: FunctorClass -> [FunctorFun]
functorClassToFuns :: FunctorClass -> [FunctorFun]
functorClassToFuns Functor = [ FunctorFun
Fmap, FunctorFun
Replace ]
functorClassToFuns Foldable = [ FunctorFun
Foldr, FunctorFun
FoldMap
#if MIN_VERSION_base(4,8,0)
, FunctorFun
Null
#endif
]
functorClassToFuns Traversable = [ FunctorFun
Traverse ]
functorFunToClass :: FunctorFun -> FunctorClass
functorFunToClass :: FunctorFun -> FunctorClass
functorFunToClass Fmap = FunctorClass
Functor
functorFunToClass Replace = FunctorClass
Functor
functorFunToClass Foldr = FunctorClass
Foldable
functorFunToClass FoldMap = FunctorClass
Foldable
functorFunToClass Null = FunctorClass
Foldable
functorFunToClass Traverse = FunctorClass
Traversable
functorFunEmptyCase :: FunctorFun -> Name -> Name -> Q Exp
functorFunEmptyCase :: FunctorFun -> Name -> Name -> Q Exp
functorFunEmptyCase ff :: FunctorFun
ff z :: Name
z value :: 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 ff :: FunctorFun
ff z :: Name
z value :: 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
$ "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 fmapE :: Q Exp
fmapE traverseE :: Q Exp
traverseE ff :: FunctorFun
ff z :: Name
z = FunctorFun -> Q Exp
go FunctorFun
ff
where
go :: FunctorFun -> Q Exp
go :: FunctorFun -> Q Exp
go Fmap = Q Exp
fmapE
go Replace = Q Exp
fmapE
go Foldr = Name -> Q Exp
varE Name
z
go FoldMap = Name -> Q Exp
varE Name
memptyValName
go Null = Name -> Q Exp
conE Name
trueDataName
go 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
ConP 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 -> [TyVarBndr] -> a -> a
ft_forall :: [TyVarBndr] -> a -> a
}
functorLikeTraverse :: forall a.
TyVarMap1
-> FFoldType a
-> Type
-> Q a
functorLikeTraverse :: Map Name (OneOrTwoNames One) -> FFoldType a -> Type -> Q a
functorLikeTraverse tvMap :: 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 -> [TyVarBndr] -> a -> a
ft_forall = [TyVarBndr] -> a -> a
caseForAll })
ty :: Type
ty
= do Type
ty' <- Type -> TypeQ
resolveTypeSynonyms Type
ty
(res :: a
res, _) <- 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 co :: Bool
co t :: Type
t@AppT{}
| (ArrowT, [funArg :: Type
funArg, funRes :: Type
funRes]) <- Type -> (Type, Cxt)
unapplyTy Type
t
= do (funArgR :: a
funArgR, funArgC :: Bool
funArgC) <- Bool -> Type -> Q (a, Bool)
go (Bool -> Bool
not Bool
co) Type
funArg
(funResR :: a
funResR, funResC :: 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 co :: Bool
co t :: Type
t@AppT{} = do
let (f :: Type
f, args :: Cxt
args) = Type -> (Type, Cxt)
unapplyTy Type
t
(_, fc :: Bool
fc) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
f
(xrs :: [a]
xrs, xcs :: [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 tupSort :: 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 len :: 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 len :: 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 co :: Bool
co (SigT t :: Type
t k :: Type
k) = do
(_, kc :: 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 co :: Bool
co (VarT v :: 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 co :: Bool
co (ForallT tvbs :: [TyVarBndr]
tvbs _ t :: Type
t) = do
(tr :: a
tr, tc :: Bool
tc) <- Bool -> Type -> Q (a, Bool)
go Bool
co Type
t
let tvbNames :: [Name]
tvbNames = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tvName [TyVarBndr]
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 ([TyVarBndr] -> a -> a
caseForAll [TyVarBndr]
tvbs a
tr, Bool
True)
go _ _ = 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 tvMap :: Map Name (OneOrTwoNames One)
tvMap ft :: FFoldType a
ft con :: 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 lam :: Exp -> Q Exp
lam = do
Name
n <- String -> Q Name
newName "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 lam :: Exp -> Exp -> Q Exp
lam = do
Name
n1 <- String -> Q Name
newName "n1"
Name
n2 <- String -> Q Name
newName "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 fold :: Name -> [a] -> Q Exp
fold conName :: Name
conName insides :: [Exp -> a]
insides = do
[Name]
varsNeeded <- String -> Int -> Q [Name]
newNameList "_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
ConP 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 (\i :: Exp -> a
i v :: 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 fold :: Exp -> [Exp] -> Q Exp
fold conName :: Name
conName insides :: [(Bool, Exp)]
insides = do
[Name]
varsNeeded <- String -> Int -> Q [Name]
newNameList "_arg" Int
lengthInsides
let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP 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 (\(m :: Bool
m, i :: Exp
i) v :: 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 (\(m :: Bool
m, _) -> Bool
m) [(Bool, Exp)]
insides
(asWithTyVar :: [Name]
asWithTyVar, asWithoutTyVar :: [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 "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 matchForCon :: Name -> [a] -> MatchQ
matchForCon tupSort :: TupleSort
tupSort insides :: [a]
insides x :: Exp
x = do
let tupDataName :: Name
tupDataName = case TupleSort
tupSort of
Boxed len :: Int
len -> Int -> Name
tupleDataName Int
len
#if MIN_VERSION_template_haskell(2,6,0)
Unboxed len :: 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]