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