{-# 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
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
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
Ord, ReadPrec [FFTOptions]
ReadPrec FFTOptions
Int -> ReadS FFTOptions
ReadS [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
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 { 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 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
Name
z <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
Name
t <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
appEndoValName
, forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
getDualValName
, forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ FFTOptions -> Name -> Q Exp
makeFoldMapOptions FFTOptions
opts Name
name, Name -> Q Exp
foldFun Name
f, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t]
]
, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z
]
where
foldFun :: Name -> Q Exp
foldFun :: Name -> Q Exp
foldFun Name
n = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
dualDataName)
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
(forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
endoDataName)
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
flipValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unwrapMonadValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName) forall a b. (a -> b) -> a -> b
$
FFTOptions -> Name -> Q Exp
makeTraverseOptions FFTOptions
opts Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
wrapMonadExp Name
f
where
wrapMonadExp :: Name -> Q Exp
wrapMonadExp :: Name -> Q Exp
wrapMonadExp Name
n = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
wrapMonadDataName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName) (forall (m :: * -> *). Quote m => Name -> m 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 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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)
<- forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance FunctorClass
fc Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
(forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(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 =
forall a b. (a -> b) -> [a] -> [b]
map FunctorFun -> Q Dec
makeFunD forall a b. (a -> b) -> a -> b
$ FunctorClass -> [FunctorFun]
functorClassToFuns FunctorClass
fc
where
makeFunD :: FunctorFun -> Q Dec
makeFunD :: FunctorFun -> Q Dec
makeFunD FunctorFun
ff =
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (FunctorFun -> Name
functorFunName FunctorFun
ff)
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB 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
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
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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
Name
z <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
Name
value <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"value"
let argNames :: [Name]
argNames = forall a. [Maybe a] -> [a]
catMaybes [ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FunctorFun
ff forall a. Eq a => a -> a -> Bool
/= FunctorFun
Null) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. a -> Maybe a
Just Name
mapFun
, forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FunctorFun
ff forall a. Eq a => a -> a -> Bool
== FunctorFun
Foldr) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. a -> Maybe a
Just Name
z
, forall a. a -> Maybe a
Just Name
value
]
lastTyVar :: Name
lastTyVar = Type -> Name
varTToName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last Cxt
instTypes
tvMap :: Map Name (OneOrTwoNames One)
tvMap = forall k a. k -> a -> Map k a
Map.singleton Name
lastTyVar forall a b. (a -> b) -> a -> b
$ Name -> OneOrTwoNames One
OneName Name
mapFun
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
argNames)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
forall a b. (a -> b) -> a -> b
$ [ forall (m :: * -> *). Quote m => Name -> m Exp
varE 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
] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m 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) <- forall a. [a] -> Maybe ([a], a)
unsnoc [Role]
roles
-> Name -> Name -> Q Exp
functorFunPhantom Name
z Name
value
#endif
| 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
| 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
-> forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value)
(forall a b. (a -> b) -> [a] -> [b]
map (FunctorFun
-> Name
-> Map Name (OneOrTwoNames One)
-> ConstructorInfo
-> Q Match
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
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
coerce)
FunctorFun
ff Name
z
where
coerce :: Q Exp
coerce :: Q Exp
coerce = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
coerceValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value
#endif
makeFunctorFunForCon :: FunctorFun -> Name -> TyVarMap1 -> ConstructorInfo -> Q Match
makeFunctorFunForCon :: FunctorFun
-> Name
-> Map Name (OneOrTwoNames One)
-> ConstructorInfo
-> Q Match
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
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 forall a b. (a -> b) -> a -> b
$
case FunctorFun
ff of
FunctorFun
Fmap -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeFmapMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
FunctorFun
Replace -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeReplaceMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
FunctorFun
Foldr -> Name -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeFoldrMatch Name
z Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
FunctorFun
FoldMap -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeFoldMapMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
FunctorFun
Null -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeNullMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
FunctorFun
Traverse -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeTraverseMatch Map Name (OneOrTwoNames One)
tvMap ConstructorInfo
con
makeFmapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeFmapMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeFmapMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Exp -> Q Exp]
parts <- 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] -> Q Match
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 { ft_triv :: Exp -> Q Exp
ft_triv = 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 forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
OneName Name
f -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ \Exp
b -> do
Exp
gg <- Exp -> Q Exp
g Exp
b
Exp -> Q Exp
h 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 = forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [Exp -> Q Exp] -> Q Match
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) <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
argVar Map Name (OneOrTwoNames One)
tvMap
-> forall (m :: * -> *) a. Monad m => a -> m a
return 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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
_ -> 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
_ -> forall a. Name -> Q a
contravarianceError Name
conName
}
makeReplaceMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
makeReplaceMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeReplaceMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Exp -> Q Exp]
parts <- 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] -> Q Match
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 { ft_triv :: Exp -> Q Exp
ft_triv = 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 forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
OneName Name
z -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ \Exp
b -> do
Exp
gg <- Exp -> Q Exp
g Exp
b
Exp -> Q Exp
h 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 = forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [Exp -> Q Exp] -> Q Match
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) <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
argVar Map Name (OneOrTwoNames One)
tvMap
-> forall (m :: * -> *) a. Monad m => a -> m a
return 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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
_ -> 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
_ -> 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] -> Q Match
match_for_con_functor = forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> Q Match
mkSimpleConMatch forall a b. (a -> b) -> a -> b
$ \Name
conName' [Q Exp]
xs ->
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName'forall a. a -> [a] -> [a]
:[Q Exp]
xs)
makeFoldrMatch :: Name -> TyVarMap1 -> ConstructorInfo -> Q Match
makeFoldrMatch :: Name -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> Q Match
makeFoldrMatch Name
z Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (Bool, Exp)]
parts <- 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' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
Exp -> Name -> [(Bool, Exp)] -> Q Match
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 { ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Exp -> Q Exp) -> Q Exp
mkSimpleLam2 forall a b. (a -> b) -> a -> b
$ \Exp
_ Exp
z' -> forall (m :: * -> *) a. Monad m => a -> m a
return Exp
z'
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 forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
OneName Name
f -> 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 <- 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 forall a b. (a -> b) -> a -> b
$ \Exp
x Exp
z' ->
forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase (Exp -> Name -> [(Bool, Exp)] -> Q Match
match_for_con Exp
z') TupleSort
t [(Bool, Exp)]
gg Exp
x
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 forall a b. (a -> b) -> a -> b
$ \Exp
x Exp
z' -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
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
_ -> 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)
_ -> forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (Bool, Exp)
ft_bad_app = 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)] -> Q Match
match_for_con Exp
zExp = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
mkSimpleConMatch2 forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkFoldr [Exp]
xs
where
mkFoldr :: [Exp] -> Exp
mkFoldr :: [Exp] -> Exp
mkFoldr = 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 -> Q Match
makeFoldMapMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (Bool, Exp)]
parts <- 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' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
Name -> [(Bool, Exp)] -> Q Match
match_for_con Name
conName [(Bool, Exp)]
parts'
where
ft_foldMap :: FFoldType (Q (Bool, Exp))
ft_foldMap :: FFoldType (Q (Bool, Exp))
ft_foldMap = FT { ft_triv :: Q (Bool, Exp)
ft_triv = do Exp
lam <- (Exp -> Q Exp) -> Q Exp
mkSimpleLam forall a b. (a -> b) -> a -> b
$ \Exp
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
memptyValName
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 forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
OneName Name
f -> 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 <- 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 forall a b. (a -> b) -> a -> b
$ forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> Q Match
match_for_con TupleSort
t [(Bool, Exp)]
gg
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
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
_ -> 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)
_ -> forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (Bool, Exp)
ft_bad_app = 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)] -> Q Match
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
mkSimpleConMatch2 forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (Exp -> Exp -> Exp
AppE 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 -> Q Match
makeNullMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (NullM Exp)]
parts <- 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' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (NullM Exp)]
parts
case forall a. [NullM a] -> Maybe [(Bool, a)]
convert [NullM Exp]
parts' of
Maybe [(Bool, Exp)]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match (ConstructorInfo -> Pat
conWildPat ConstructorInfo
con) (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
falseDataName) []
Just [(Bool, Exp)]
cp -> Name -> [(Bool, Exp)] -> Q Match
match_for_con Name
conName [(Bool, Exp)]
cp
where
ft_null :: FFoldType (Q (NullM Exp))
ft_null :: FFoldType (Q (NullM Exp))
ft_null = FT { ft_triv :: Q (NullM Exp)
ft_triv = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> NullM a
IsNull forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
trueDataName
, ft_var :: Name -> Q (NullM Exp)
ft_var = \Name
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (NullM Exp)]
g
case forall a. [NullM a] -> Maybe [(Bool, a)]
convert [NullM Exp]
gg of
Maybe [(Bool, Exp)]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. NullM a
NotNull
Just [(Bool, Exp)]
ggg ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> NullM a
NullM forall a b. (a -> b) -> a -> b
$ (Exp -> Q Exp) -> Q Exp
mkSimpleLam
forall a b. (a -> b) -> a -> b
$ forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> Q Match
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 -> forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Q (NullM Exp)
g forall a b. (a -> b) -> a -> b
$ \NullM Exp
nestedResult ->
case NullM Exp
nestedResult of
NullM Exp
NotNull -> forall a. a -> NullM a
NullM forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
nullValName
r :: NullM Exp
r@IsNull{} -> NullM Exp
r
NullM Exp
nestedTest -> forall a. a -> NullM a
NullM 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
_ -> 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)
_ -> forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (NullM Exp)
ft_bad_app = 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)] -> Q Match
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
mkSimpleConMatch2 forall a b. (a -> b) -> a -> b
$ \Exp
_ [Exp]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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 :: forall a. [NullM a] -> Maybe [(Bool, a)]
convert = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {b}. NullM b -> Maybe (Bool, b)
go where
go :: NullM b -> Maybe (Bool, b)
go (IsNull b
a) = forall a. a -> Maybe a
Just (Bool
False, b
a)
go NullM b
NotNull = forall a. Maybe a
Nothing
go (NullM b
a) = 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 -> Q Match
makeTraverseMatch Map Name (OneOrTwoNames One)
tvMap con :: ConstructorInfo
con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
constructorName = Name
conName}) = do
[Q (Bool, Exp)]
parts <- 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' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q (Bool, Exp)]
parts
Name -> [(Bool, Exp)] -> Q Match
match_for_con Name
conName [(Bool, Exp)]
parts'
where
ft_trav :: FFoldType (Q (Bool, Exp))
ft_trav :: FFoldType (Q (Bool, Exp))
ft_trav = FT {
ft_triv :: Q (Bool, Exp)
ft_triv = 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 forall k a. Ord k => Map k a -> k -> a
Map.! Name
v of
OneName Name
f -> 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 <- 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 forall a b. (a -> b) -> a -> b
$ forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [(Bool, Exp)] -> Q Match
match_for_con TupleSort
t [(Bool, Exp)]
gg
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 ->
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
_ -> 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)
_ -> forall a. Name -> Q a
noFunctionsError Name
conName
, ft_bad_app :: Q (Bool, Exp)
ft_bad_app = 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)] -> Q Match
match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
mkSimpleConMatch2 forall a b. (a -> b) -> a -> b
$ \Exp
conExp [Exp]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return 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) = 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 (forall a. a -> Maybe a
Just Exp
se1) (Name -> Exp
VarE Name
apValName) (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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. ClassRep a => a -> Name
fullClassName FunctorClass
fClass
classConstraint FunctorClass
_ Int
_ = forall a. Maybe a
Nothing
data FunctorFun
= Fmap
| Replace
| Foldr
| FoldMap
| Null
| Traverse
deriving FunctorFun -> FunctorFun -> Bool
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
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
emptyCase)
FunctorFun
ff Name
z
where
emptyCase :: Q Exp
emptyCase :: Q Exp
emptyCase = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m 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
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
seqAndError)
FunctorFun
ff Name
z
where
seqAndError :: Q Exp
seqAndError :: Q Exp
seqAndError = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
seqValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
errorValName)
(forall (m :: * -> *). Quote m => String -> m Exp
stringE forall a b. (a -> b) -> a -> b
$ String
"Void " 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 = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z
go FunctorFun
FoldMap = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
memptyValName
go FunctorFun
Null = forall (m :: * -> *). Quote m => Name -> m 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 forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts) Pat
WildP
data FFoldType a
= FT { forall a. FFoldType a -> a
ft_triv :: a
, forall a. FFoldType a -> Name -> a
ft_var :: Name -> a
, forall a. FFoldType a -> Name -> a
ft_co_var :: Name -> a
, forall a. FFoldType a -> a -> a -> a
ft_fun :: a -> a -> a
, forall a. FFoldType a -> TupleSort -> [a] -> a
ft_tup :: TupleSort -> [a] -> a
, forall a. FFoldType a -> Type -> a -> a
ft_ty_app :: Type -> a -> a
, forall a. FFoldType a -> a
ft_bad_app :: a
, forall a. FFoldType a -> [TyVarBndrSpec] -> a -> a
ft_forall :: [TyVarBndrSpec] -> a -> a
}
functorLikeTraverse :: forall a.
TyVarMap1
-> FFoldType a
-> Type
-> Q a
functorLikeTraverse :: forall a.
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 -> Q Type
resolveTypeSynonyms Type
ty
(a
res, Bool
_) <- Bool -> Type -> Q (a, Bool)
go Bool
False Type
ty'
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 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) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ 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 = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseWrongArg, Bool
True)
case () of
()
_ | Bool -> Bool
not (forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
xcs)
-> Q (a, Bool)
trivial
| TupleT Int
len <- Type
f
-> TupleSort -> Q (a, Bool)
tuple 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 forall a b. (a -> b) -> a -> b
$ Int -> TupleSort
Unboxed Int
len
#endif
| Bool
fc Bool -> Bool -> Bool
|| forall (t :: * -> *). Foldable t => t Bool -> Bool
or (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 forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> a -> a
caseTyApp (forall a. [a] -> a
last Cxt
args) (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 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)
| forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
v Map Name (OneOrTwoNames One)
tvMap
= 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 = forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndrSpec]
tvbs
if Bool -> Bool
not Bool
tc Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
tvbNames) [Name]
tyVarNames
then Q (a, Bool)
trivial
else 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (a
caseTrivial, Bool
False)
tyVarNames :: [Name]
tyVarNames :: [Name]
tyVarNames = forall k a. Map k a -> [k]
Map.keys Map Name (OneOrTwoNames One)
tvMap
foldDataConArgs :: forall a. TyVarMap1 -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs :: forall a.
Map Name (OneOrTwoNames One)
-> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs Map Name (OneOrTwoNames One)
tvMap FFoldType a
ft ConstructorInfo
con = do
Cxt
fieldTys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Cxt
constructorFields ConstructorInfo
con
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 = 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"n"
Exp
body <- Exp -> Q Exp
lam (Name -> Exp
VarE Name
n)
forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"n1"
Name
n2 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"n2"
Exp
body <- Exp -> Exp -> Q Exp
lam (Name -> Exp
VarE Name
n1) (Name -> Exp
VarE Name
n2)
forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> Q Match
mkSimpleConMatch Name -> [a] -> Q Exp
fold Name
conName [Exp -> a]
insides = do
[Name]
varsNeeded <- String -> Int -> Q [Name]
newNameList String
"_arg" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp -> a]
insides
let pat :: Pat
pat = Name -> [Pat] -> Pat
conPCompat Name
conName (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
Exp
rhs <- Name -> [a] -> Q Exp
fold Name
conName (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Exp -> a
i Name
v -> Exp -> a
i forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
v) [Exp -> a]
insides [Name]
varsNeeded)
forall (m :: * -> *) a. Monad m => a -> m a
return 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)] -> Q Match
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 (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varsNeeded)
exps :: [Exp]
exps = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Bool
m, Exp
i) Name
v -> if Bool
m then forall a. a -> Maybe a
Just (Exp
i Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
v)
else forall a. Maybe a
Nothing)
[(Bool, Exp)]
insides [Name]
varsNeeded
argTysTyVarInfo :: [Bool]
argTysTyVarInfo = forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
m, Exp
_) -> Bool
m) [(Bool, Exp)]
insides
([Name]
asWithTyVar, [Name]
asWithoutTyVar) = forall a. [Bool] -> [a] -> ([a], [a])
partitionByList [Bool]
argTysTyVarInfo [Name]
varsNeeded
conExpQ :: Q Exp
conExpQ
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
asWithTyVar = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conNameforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
asWithoutTyVar)
| Bool
otherwise = do
[Name]
bs <- String -> Int -> Q [Name]
newNameList String
"b" Int
lengthInsides
let bs' :: [Name]
bs' = forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
argTysTyVarInfo [Name]
bs
vars :: [Q Exp]
vars = forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
argTysTyVarInfo
(forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
bs) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varsNeeded)
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
bs') (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conNameforall a. a -> [a] -> [a]
:[Q Exp]
vars))
Exp
conExp <- Q Exp
conExpQ
Exp
rhs <- Exp -> [Exp] -> Q Exp
fold Exp
conExp [Exp]
exps
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
rhs) []
where
lengthInsides :: Int
lengthInsides = 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 :: forall a.
(Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase Name -> [a] -> Q Match
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] -> Q Match
matchForCon Name
tupDataName [a]
insides
forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> Cxt -> [Pat] -> Pat
ConP Name
n
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
[Pat]
pats