{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
module Data.Functor.Deriving.Internal (
deriveFoldable
, deriveFoldableOptions
, makeFoldMap
, makeFoldMapOptions
, makeFoldr
, makeFoldrOptions
, makeFold
, makeFoldOptions
, makeFoldl
, makeFoldlOptions
, deriveFunctor
, deriveFunctorOptions
, makeFmap
, makeFmapOptions
, deriveTraversable
, deriveTraversableOptions
, makeTraverse
, makeTraverseOptions
, makeSequenceA
, makeSequenceAOptions
, makeMapM
, makeMapMOptions
, makeSequence
, makeSequenceOptions
, FFTOptions(..)
, defaultFFTOptions
) where
import Control.Monad (guard, zipWithM)
import Data.Deriving.Internal
import Data.Either (rights)
import Data.List
import qualified Data.Map as Map (keys, lookup, 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
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
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]
argNames <- (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Q Name
newName ([String] -> Q [Name]) -> [String] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [ String -> Maybe String
forall a. a -> Maybe a
Just "f"
, 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 String -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Maybe String
forall a. a -> Maybe a
Just "z"
, String -> Maybe String
forall a. a -> Maybe a
Just "value"
]
let mapFun :: Name
mapFun:others :: [Name]
others = [Name]
argNames
z :: Name
z = [Name] -> Name
forall a. [a] -> a
head [Name]
others
value :: Name
value = [Name] -> Name
forall a. [a] -> a
last [Name]
others
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
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
ts }) = do
Cxt
ts' <- (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
ts
[Name]
argNames <- String -> Int -> Q [Name]
newNameList "_arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
ts'
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
$
FunctorFun
-> Name
-> Map Name (OneOrTwoNames One)
-> Name
-> Cxt
-> [Name]
-> MatchQ
makeFunctorFunForArgs FunctorFun
ff Name
z Map Name (OneOrTwoNames One)
tvMap Name
conName Cxt
ts' [Name]
argNames
makeFunctorFunForArgs :: FunctorFun
-> Name
-> TyVarMap1
-> Name
-> [Type]
-> [Name]
-> Q Match
makeFunctorFunForArgs :: FunctorFun
-> Name
-> Map Name (OneOrTwoNames One)
-> Name
-> Cxt
-> [Name]
-> MatchQ
makeFunctorFunForArgs ff :: FunctorFun
ff z :: Name
z tvMap :: Map Name (OneOrTwoNames One)
tvMap conName :: Name
conName tys :: Cxt
tys args :: [Name]
args =
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ FunctorFun -> Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
functorFunCombine FunctorFun
ff Name
conName Name
z [Name]
args Q [Either Exp Exp]
mappedArgs)
[]
where
mappedArgs :: Q [Either Exp Exp]
mappedArgs :: Q [Either Exp Exp]
mappedArgs = (Type -> Name -> Q (Either Exp Exp))
-> Cxt -> [Name] -> Q [Either Exp Exp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Type
-> Name
-> Q (Either Exp Exp)
makeFunctorFunForArg FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName) Cxt
tys [Name]
args
makeFunctorFunForArg :: FunctorFun
-> TyVarMap1
-> Name
-> Type
-> Name
-> Q (Either Exp Exp)
makeFunctorFunForArg :: FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Type
-> Name
-> Q (Either Exp Exp)
makeFunctorFunForArg ff :: FunctorFun
ff tvMap :: Map Name (OneOrTwoNames One)
tvMap conName :: Name
conName ty :: Type
ty tyExpName :: Name
tyExpName =
FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName Bool
True Type
ty Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
`appEitherE` Name -> Q Exp
varE Name
tyExpName
makeFunctorFunForType :: FunctorFun
-> TyVarMap1
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType :: FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType ff :: FunctorFun
ff tvMap :: Map Name (OneOrTwoNames One)
tvMap conName :: Name
conName covariant :: Bool
covariant (VarT tyName :: Name
tyName) =
case Name -> Map Name (OneOrTwoNames One) -> Maybe (OneOrTwoNames One)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name (OneOrTwoNames One)
tvMap of
Just (OneName mapName :: Name
mapName) ->
(Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. b -> Either a b
Right (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$ if Bool
covariant
then Name -> Q Exp
varE Name
mapName
else Name -> Q Exp
forall a. Name -> Q a
contravarianceError Name
conName
Nothing -> (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. a -> Either a b
Left (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$ FunctorFun -> Q Exp
functorFunTriv FunctorFun
ff
makeFunctorFunForType ff :: FunctorFun
ff tvMap :: Map Name (OneOrTwoNames One)
tvMap conName :: Name
conName covariant :: Bool
covariant (SigT ty :: Type
ty _) =
FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName Bool
covariant Type
ty
makeFunctorFunForType ff :: FunctorFun
ff tvMap :: Map Name (OneOrTwoNames One)
tvMap conName :: Name
conName covariant :: Bool
covariant (ForallT _ _ ty :: Type
ty) =
FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName Bool
covariant Type
ty
makeFunctorFunForType ff :: FunctorFun
ff tvMap :: Map Name (OneOrTwoNames One)
tvMap conName :: Name
conName covariant :: Bool
covariant ty :: Type
ty =
let tyCon :: Type
tyArgs :: [Type]
tyCon :: Type
tyCon:tyArgs :: Cxt
tyArgs = Type -> Cxt
unapplyTy Type
ty
numLastArgs :: Int
numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min 1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs
lhsArgs, rhsArgs :: [Type]
(lhsArgs :: Cxt
lhsArgs, rhsArgs :: Cxt
rhsArgs) = Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
tyArgs
tyVarNames :: [Name]
tyVarNames :: [Name]
tyVarNames = Map Name (OneOrTwoNames One) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (OneOrTwoNames One)
tvMap
mentionsTyArgs :: Bool
mentionsTyArgs :: Bool
mentionsTyArgs = (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs
makeFunctorFunTuple :: ([Q Pat] -> Q Pat) -> (Int -> Name) -> Int
-> Q (Either Exp Exp)
makeFunctorFunTuple :: ([PatQ] -> PatQ) -> (Int -> Name) -> Int -> Q (Either Exp Exp)
makeFunctorFunTuple mkTupP :: [PatQ] -> PatQ
mkTupP mkTupleDataName :: Int -> Name
mkTupleDataName n :: Int
n = do
[Name]
args <- (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Q Name
newName ([String] -> Q [Name]) -> [String] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [ String -> Maybe String
forall a. a -> Maybe a
Just "x"
, 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 String -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Maybe String
forall a. a -> Maybe a
Just "z"
]
[Name]
xs <- String -> Int -> Q [Name]
newNameList "_tup" Int
n
let x :: Name
x = [Name] -> Name
forall a. [a] -> a
head [Name]
args
z :: Name
z = [Name] -> Name
forall a. [a] -> a
last [Name]
args
(Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. b -> Either a b
Right (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$ [PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
x)
[ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match ([PatQ] -> PatQ
mkTupP ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs)
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ FunctorFun -> Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
functorFunCombine FunctorFun
ff
(Int -> Name
mkTupleDataName Int
n)
Name
z
[Name]
xs
((Type -> Name -> Q (Either Exp Exp))
-> Cxt -> [Name] -> Q [Either Exp Exp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Type -> Name -> Q (Either Exp Exp)
makeFunctorFunTupleField Cxt
tyArgs [Name]
xs)
)
[]
]
makeFunctorFunTupleField :: Type -> Name -> Q (Either Exp Exp)
makeFunctorFunTupleField :: Type -> Name -> Q (Either Exp Exp)
makeFunctorFunTupleField fieldTy :: Type
fieldTy fieldName :: Name
fieldName =
FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName Bool
covariant Type
fieldTy
Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
`appEitherE` Name -> Q Exp
varE Name
fieldName
fc :: FunctorClass
fc :: FunctorClass
fc = FunctorFun -> FunctorClass
functorFunToClass FunctorFun
ff
in case Type
tyCon of
ArrowT
| Bool -> Bool
not (FunctorClass -> Bool
allowFunTys FunctorClass
fc) -> Name -> Q (Either Exp Exp)
forall a. Name -> Q a
noFunctionsError Name
conName
| Bool
mentionsTyArgs, [argTy :: Type
argTy, resTy :: Type
resTy] <- Cxt
tyArgs ->
do Name
x <- String -> Q Name
newName "x"
Name
b <- String -> Q Name
newName "b"
(Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. b -> Either a b
Right (Q Exp -> Q (Either Exp Exp))
-> (Q Exp -> Q Exp) -> Q Exp -> Q (Either Exp Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x, Name -> PatQ
varP Name
b] (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$
Bool -> Type -> Q Exp
covFunctorFun Bool
covariant Type
resTy Q Exp -> Q Exp -> Q Exp
`appE` (Name -> Q Exp
varE Name
x Q Exp -> Q Exp -> Q Exp
`appE`
(Bool -> Type -> Q Exp
covFunctorFun (Bool -> Bool
not Bool
covariant) Type
argTy Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
b))
where
covFunctorFun :: Bool -> Type -> Q Exp
covFunctorFun :: Bool -> Type -> Q Exp
covFunctorFun cov :: Bool
cov = (Either Exp Exp -> Exp) -> Q (Either Exp Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Exp Exp -> Exp
forall a. Either a a -> a
fromEither (Q (Either Exp Exp) -> Q Exp)
-> (Type -> Q (Either Exp Exp)) -> Type -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName Bool
cov
#if MIN_VERSION_template_haskell(2,6,0)
UnboxedTupleT n :: Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Bool
mentionsTyArgs -> ([PatQ] -> PatQ) -> (Int -> Name) -> Int -> Q (Either Exp Exp)
makeFunctorFunTuple [PatQ] -> PatQ
unboxedTupP Int -> Name
unboxedTupleDataName Int
n
#endif
TupleT n :: Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Bool
mentionsTyArgs -> ([PatQ] -> PatQ) -> (Int -> Name) -> Int -> Q (Either Exp Exp)
makeFunctorFunTuple [PatQ] -> PatQ
tupP Int -> Name
tupleDataName Int
n
_ -> do
Bool
itf <- Type -> Q Bool
isTyFamily Type
tyCon
if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
lhsArgs Bool -> Bool -> Bool
|| (Bool
itf Bool -> Bool -> Bool
&& Bool
mentionsTyArgs)
then FunctorClass -> Name -> Q (Either Exp Exp)
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError FunctorClass
fc Name
conName
else if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
then (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. b -> Either a b
Right (Q Exp -> Q (Either Exp Exp))
-> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q (Either Exp Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunctorFun -> Q Exp -> Q Exp
functorFunApp FunctorFun
ff (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 (Either Exp Exp)) -> [Q Exp] -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$
( Name -> Q Exp
varE (FunctorFun -> Name
functorFunName FunctorFun
ff)
Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Type -> Q Exp) -> Cxt -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ((Either Exp Exp -> Exp) -> Q (Either Exp Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Exp Exp -> Exp
forall a. Either a a -> a
fromEither (Q (Either Exp Exp) -> Q Exp)
-> (Type -> Q (Either Exp Exp)) -> Type -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunctorFun
-> Map Name (OneOrTwoNames One)
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType FunctorFun
ff Map Name (OneOrTwoNames One)
tvMap Name
conName Bool
covariant)
Cxt
rhsArgs
)
else (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Either Exp Exp
forall a b. a -> Either a b
Left (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
forall a b. (a -> b) -> a -> b
$ FunctorFun -> Q Exp
functorFunTriv FunctorFun
ff
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 | Foldr | FoldMap | 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 _ Foldr = String -> ShowS
showString "foldr"
showsPrec _ FoldMap = String -> ShowS
showString "foldMap"
showsPrec _ Traverse = String -> ShowS
showString "traverse"
functorFunConstName :: FunctorFun -> Name
functorFunConstName :: FunctorFun -> Name
functorFunConstName Fmap = Name
fmapConstValName
functorFunConstName Foldr = Name
foldrConstValName
functorFunConstName FoldMap = Name
foldMapConstValName
functorFunConstName Traverse = Name
traverseConstValName
functorFunName :: FunctorFun -> Name
functorFunName :: FunctorFun -> Name
functorFunName Fmap = Name
fmapValName
functorFunName Foldr = Name
foldrValName
functorFunName FoldMap = Name
foldMapValName
functorFunName Traverse = Name
traverseValName
functorClassToFuns :: FunctorClass -> [FunctorFun]
functorClassToFuns :: FunctorClass -> [FunctorFun]
functorClassToFuns Functor = [FunctorFun
Fmap]
functorClassToFuns Foldable = [FunctorFun
Foldr, FunctorFun
FoldMap]
functorClassToFuns Traversable = [FunctorFun
Traverse]
functorFunToClass :: FunctorFun -> FunctorClass
functorFunToClass :: FunctorFun -> FunctorClass
functorFunToClass Fmap = FunctorClass
Functor
functorFunToClass Foldr = FunctorClass
Foldable
functorFunToClass FoldMap = FunctorClass
Foldable
functorFunToClass Traverse = FunctorClass
Traversable
allowFunTys :: FunctorClass -> Bool
allowFunTys :: FunctorClass -> Bool
allowFunTys Functor = Bool
True
allowFunTys _ = Bool
False
functorFunTriv :: FunctorFun -> Q Exp
functorFunTriv :: FunctorFun -> Q Exp
functorFunTriv Fmap = do
Name
x <- String -> Q Name
newName "x"
PatQ -> Q Exp -> Q Exp
lam1E (Name -> PatQ
varP Name
x) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
x
functorFunTriv ff :: FunctorFun
ff = Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> (String -> Exp) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "functorFunTriv: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FunctorFun -> String
forall a. Show a => a -> String
show FunctorFun
ff
functorFunApp :: FunctorFun -> Q Exp -> Q Exp
functorFunApp :: FunctorFun -> Q Exp -> Q Exp
functorFunApp Foldr e :: Q Exp
e = do
Name
x <- String -> Q Name
newName "x"
Name
z <- String -> Q Name
newName "z"
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x, Name -> PatQ
varP Name
z] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
appsE [Q Exp
e, Name -> Q Exp
varE Name
z, Name -> Q Exp
varE Name
x]
functorFunApp _ e :: Q Exp
e = Q Exp
e
functorFunCombine :: FunctorFun
-> Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
functorFunCombine :: FunctorFun -> Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
functorFunCombine Fmap = Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
fmapCombine
functorFunCombine Foldr = Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
foldrCombine
functorFunCombine FoldMap = Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
foldMapCombine
functorFunCombine Traverse = Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
traverseCombine
fmapCombine :: Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
fmapCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
fmapCombine conName :: Name
conName _ _ = ([Either Exp Exp] -> Exp) -> Q [Either Exp Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
conName) ([Exp] -> Exp)
-> ([Either Exp Exp] -> [Exp]) -> [Either Exp Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Exp Exp -> Exp) -> [Either Exp Exp] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Exp Exp -> Exp
forall a. Either a a -> a
fromEither)
foldrCombine :: Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
foldrCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
foldrCombine _ zName :: Name
zName _ = ([Either Exp Exp] -> Exp) -> Q [Either Exp Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
zName) ([Exp] -> Exp)
-> ([Either Exp Exp] -> [Exp]) -> [Either Exp Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Exp Exp] -> [Exp]
forall a b. [Either a b] -> [b]
rights)
foldMapCombine :: Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
foldMapCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
foldMapCombine _ _ _ = ([Either Exp Exp] -> Exp) -> Q [Either Exp Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Exp] -> Exp
go ([Exp] -> Exp)
-> ([Either Exp Exp] -> [Exp]) -> [Either Exp Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Exp Exp] -> [Exp]
forall a b. [Either a b] -> [b]
rights)
where
go :: [Exp] -> Exp
go :: [Exp] -> Exp
go [] = Name -> Exp
VarE Name
memptyValName
go 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
traverseCombine :: Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
traverseCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
traverseCombine conName :: Name
conName _ args :: [Name]
args essQ :: Q [Either Exp Exp]
essQ = do
[Either Exp Exp]
ess <- Q [Either Exp Exp]
essQ
let argTysTyVarInfo :: [Bool]
argTysTyVarInfo :: [Bool]
argTysTyVarInfo = (Either Exp Exp -> Bool) -> [Either Exp Exp] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Either Exp Exp -> Bool
forall l r. Either l r -> Bool
isRight [Either Exp Exp]
ess
argsWithTyVar, argsWithoutTyVar :: [Name]
(argsWithTyVar :: [Name]
argsWithTyVar, argsWithoutTyVar :: [Name]
argsWithoutTyVar) = [Bool] -> [Name] -> ([Name], [Name])
forall a. [Bool] -> [a] -> ([a], [a])
partitionByList [Bool]
argTysTyVarInfo [Name]
args
conExpQ :: Q Exp
conExpQ :: Q Exp
conExpQ
| [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
argsWithTyVar
= [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]
argsWithoutTyVar)
| Bool
otherwise = do
[Name]
bs <- String -> Int -> Q [Name]
newNameList "b" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
args
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]
args)
[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
let go :: [Exp] -> Exp
go :: [Exp] -> Exp
go [] = Name -> Exp
VarE Name
pureValName Exp -> Exp -> Exp
`AppE` Exp
conExp
go [e :: Exp
e] = Name -> Exp
VarE Name
fmapValName Exp -> Exp -> Exp
`AppE` Exp
conExp Exp -> Exp -> Exp
`AppE` Exp
e
go (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' (\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))
(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
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp)
-> ([Either Exp Exp] -> Exp) -> [Either Exp Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
go ([Exp] -> Exp)
-> ([Either Exp Exp] -> [Exp]) -> [Either Exp Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Exp Exp] -> [Exp]
forall a b. [Either a b] -> [b]
rights ([Either Exp Exp] -> Q Exp) -> [Either Exp Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Either Exp Exp]
ess
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 Foldr = Name -> Q Exp
varE Name
z
go FoldMap = Name -> Q Exp
varE Name
memptyValName
go Traverse = Q Exp
traverseE