module Data.Functor.Deriving.Internal (
deriveFoldable
, makeFoldMap
, makeFoldr
, makeFold
, makeFoldl
, deriveFunctor
, makeFmap
, deriveTraversable
, makeTraverse
, makeSequenceA
, makeMapM
, makeSequence
) 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)
import Data.Maybe
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
deriveFoldable :: Name -> Q [Dec]
deriveFoldable = deriveFunctorClass Foldable
makeFoldMap :: Name -> Q Exp
makeFoldMap = makeFunctorFun FoldMap
makeFoldr :: Name -> Q Exp
makeFoldr = makeFunctorFun Foldr
makeFold :: Name -> Q Exp
makeFold name = makeFoldMap name `appE` varE idValName
makeFoldl :: Name -> Q Exp
makeFoldl 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 [ makeFoldMap 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 = deriveFunctorClass Functor
makeFmap :: Name -> Q Exp
makeFmap = makeFunctorFun Fmap
deriveTraversable :: Name -> Q [Dec]
deriveTraversable = deriveFunctorClass Traversable
makeTraverse :: Name -> Q Exp
makeTraverse = makeFunctorFun Traverse
makeSequenceA :: Name -> Q Exp
makeSequenceA name = makeTraverse name `appE` varE idValName
makeMapM :: Name -> Q Exp
makeMapM name = do
f <- newName "f"
lam1E (varP f) . infixApp (varE unwrapMonadValName) (varE composeValName) $
makeTraverse name `appE` wrapMonadExp f
where
wrapMonadExp :: Name -> Q Exp
wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n)
makeSequence :: Name -> Q Exp
makeSequence name = makeMapM name `appE` varE idValName
deriveFunctorClass :: FunctorClass -> Name -> Q [Dec]
deriveFunctorClass fc name = withType name fromCons where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]
fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do
(instanceCxt, instanceType)
<- buildTypeInstance fc name' ctxt tvbs mbTys
instanceD (return instanceCxt)
(return instanceType)
(functorFunDecs fc cons)
functorFunDecs :: FunctorClass -> [Con] -> [Q Dec]
functorFunDecs fc cons = map makeFunD $ functorClassToFuns fc where
makeFunD :: FunctorFun -> Q Dec
makeFunD ff =
funD (functorFunName ff)
[ clause []
(normalB $ makeFunctorFunForCons ff cons)
[]
]
makeFunctorFun :: FunctorFun -> Name -> Q Exp
makeFunctorFun ff name = withType name fromCons where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
fromCons name' ctxt tvbs cons mbTys =
buildTypeInstance (functorFunToClass ff) name' ctxt tvbs mbTys
`seq` makeFunctorFunForCons ff cons
makeFunctorFunForCons :: FunctorFun -> [Con] -> Q Exp
makeFunctorFunForCons ff cons = do
argNames <- mapM newName $ catMaybes [ Just "f"
, guard (ff == Foldr) >> Just "z"
, Just "value"
]
let mapFun:others = argNames
z = head others
value = last others
lamE (map varP argNames)
. appsE
$ [ varE $ functorFunConstName ff
, if null cons
then appE (varE errorValName)
(stringE $ "Void " ++ nameBase (functorFunName ff))
else caseE (varE value)
(map (makeFunctorFunForCon ff z mapFun) cons)
] ++ map varE argNames
makeFunctorFunForCon :: FunctorFun -> Name -> Name -> Con -> Q Match
makeFunctorFunForCon ff z mapFun con = do
let conName = constructorName con
(ts, tvMap) <- reifyConTys1 (functorFunToClass ff) [mapFun] conName
argNames <- newNameList "_arg" $ length ts
makeFunctorFunForArgs ff z tvMap conName ts argNames
makeFunctorFunForArgs :: FunctorFun
-> Name
-> TyVarMap1
-> Name
-> [Type]
-> [Name]
-> Q Match
makeFunctorFunForArgs ff z tvMap conName tys args =
match (conP conName $ map varP args)
(normalB $ functorFunCombine ff conName z args mappedArgs)
[]
where
mappedArgs :: Q [Either Exp Exp]
mappedArgs = zipWithM (makeFunctorFunForArg ff tvMap conName) tys args
makeFunctorFunForArg :: FunctorFun
-> TyVarMap1
-> Name
-> Type
-> Name
-> Q (Either Exp Exp)
makeFunctorFunForArg ff tvMap conName ty tyExpName =
makeFunctorFunForType ff tvMap conName True ty `appEitherE` varE tyExpName
makeFunctorFunForType :: FunctorFun
-> TyVarMap1
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType ff tvMap conName covariant (VarT tyName) =
case Map.lookup tyName tvMap of
Just (OneName mapName) ->
fmap Right $ if covariant
then varE mapName
else contravarianceError conName
Nothing -> fmap Left $ functorFunTriv ff
makeFunctorFunForType ff tvMap conName covariant (SigT ty _) =
makeFunctorFunForType ff tvMap conName covariant ty
makeFunctorFunForType ff tvMap conName covariant (ForallT _ _ ty) =
makeFunctorFunForType ff tvMap conName covariant ty
makeFunctorFunForType ff tvMap conName covariant ty =
let tyCon :: Type
tyArgs :: [Type]
tyCon:tyArgs = unapplyTy ty
numLastArgs :: Int
numLastArgs = min 1 $ length tyArgs
lhsArgs, rhsArgs :: [Type]
(lhsArgs, rhsArgs) = splitAt (length tyArgs numLastArgs) tyArgs
tyVarNames :: [Name]
tyVarNames = Map.keys tvMap
mentionsTyArgs :: Bool
mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs
makeFunctorFunTuple :: ([Q Pat] -> Q Pat) -> (Int -> Name) -> Int
-> Q (Either Exp Exp)
makeFunctorFunTuple mkTupP mkTupleDataName n = do
args <- mapM newName $ catMaybes [ Just "x"
, guard (ff == Foldr) >> Just "z"
]
xs <- newNameList "_tup" n
let x = head args
z = last args
fmap Right $ lamE (map varP args) $ caseE (varE x)
[ match (mkTupP $ map varP xs)
(normalB $ functorFunCombine ff
(mkTupleDataName n)
z
xs
(zipWithM makeFunctorFunTupleField tyArgs xs)
)
[]
]
makeFunctorFunTupleField :: Type -> Name -> Q (Either Exp Exp)
makeFunctorFunTupleField fieldTy fieldName =
makeFunctorFunForType ff tvMap conName covariant fieldTy
`appEitherE` varE fieldName
fc :: FunctorClass
fc = functorFunToClass ff
in case tyCon of
ArrowT
| not (allowFunTys fc) -> noFunctionsError conName
| mentionsTyArgs, [argTy, resTy] <- tyArgs ->
do x <- newName "x"
b <- newName "b"
fmap Right . lamE [varP x, varP b] $
covFunctorFun covariant resTy `appE` (varE x `appE`
(covFunctorFun (not covariant) argTy `appE` varE b))
where
covFunctorFun :: Bool -> Type -> Q Exp
covFunctorFun cov = fmap fromEither . makeFunctorFunForType ff tvMap conName cov
#if MIN_VERSION_template_haskell(2,6,0)
UnboxedTupleT n
| n > 0 && mentionsTyArgs -> makeFunctorFunTuple unboxedTupP unboxedTupleDataName n
#endif
TupleT n
| n > 0 && mentionsTyArgs -> makeFunctorFunTuple tupP tupleDataName n
_ -> do
itf <- isTyFamily tyCon
if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs)
then outOfPlaceTyVarError fc conName
else if any (`mentionsName` tyVarNames) rhsArgs
then fmap Right . functorFunApp ff . appsE $
( varE (functorFunName ff)
: map (fmap fromEither . makeFunctorFunForType ff tvMap conName covariant)
rhsArgs
)
else fmap Left $ functorFunTriv ff
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 | Foldr | FoldMap | Traverse
deriving Eq
instance Show FunctorFun where
showsPrec _ Fmap = showString "fmap"
showsPrec _ Foldr = showString "foldr"
showsPrec _ FoldMap = showString "foldMap"
showsPrec _ Traverse = showString "traverse"
functorFunConstName :: FunctorFun -> Name
functorFunConstName Fmap = fmapConstValName
functorFunConstName Foldr = foldrConstValName
functorFunConstName FoldMap = foldMapConstValName
functorFunConstName Traverse = traverseConstValName
functorFunName :: FunctorFun -> Name
functorFunName Fmap = fmapValName
functorFunName Foldr = foldrValName
functorFunName FoldMap = foldMapValName
functorFunName Traverse = traverseValName
functorClassToFuns :: FunctorClass -> [FunctorFun]
functorClassToFuns Functor = [Fmap]
functorClassToFuns Foldable = [Foldr, FoldMap]
functorClassToFuns Traversable = [Traverse]
functorFunToClass :: FunctorFun -> FunctorClass
functorFunToClass Fmap = Functor
functorFunToClass Foldr = Foldable
functorFunToClass FoldMap = Foldable
functorFunToClass Traverse = Traversable
allowFunTys :: FunctorClass -> Bool
allowFunTys Functor = True
allowFunTys _ = False
functorFunTriv :: FunctorFun -> Q Exp
functorFunTriv Fmap = do
x <- newName "x"
lam1E (varP x) $ varE x
functorFunTriv ff = return . error $ "functorFunTriv: " ++ show ff
functorFunApp :: FunctorFun -> Q Exp -> Q Exp
functorFunApp Foldr e = do
x <- newName "x"
z <- newName "z"
lamE [varP x, varP z] $ appsE [e, varE z, varE x]
functorFunApp _ e = e
functorFunCombine :: FunctorFun
-> Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
functorFunCombine Fmap = fmapCombine
functorFunCombine Foldr = foldrCombine
functorFunCombine FoldMap = foldMapCombine
functorFunCombine Traverse = traverseCombine
fmapCombine :: Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
fmapCombine conName _ _ = fmap (foldl' AppE (ConE conName) . fmap fromEither)
foldrCombine :: Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
foldrCombine _ zName _ = fmap (foldr AppE (VarE zName) . rights)
foldMapCombine :: Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
foldMapCombine _ _ _ = fmap (go . rights)
where
go :: [Exp] -> Exp
go [] = VarE memptyValName
go es = foldr1 (AppE . AppE (VarE mappendValName)) es
traverseCombine :: Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
traverseCombine conName _ args essQ = do
ess <- essQ
let argTysTyVarInfo :: [Bool]
argTysTyVarInfo = map isRight ess
argsWithTyVar, argsWithoutTyVar :: [Name]
(argsWithTyVar, argsWithoutTyVar) = partitionByList argTysTyVarInfo args
conExpQ :: Q Exp
conExpQ
| null argsWithTyVar
= appsE (conE conName:map varE argsWithoutTyVar)
| otherwise = do
bs <- newNameList "b" $ length args
let bs' = filterByList argTysTyVarInfo bs
vars = filterByLists argTysTyVarInfo
(map varE bs) (map varE args)
lamE (map varP bs') (appsE (conE conName:vars))
conExp <- conExpQ
let go :: [Exp] -> Exp
go [] = VarE pureValName `AppE` conExp
go (e:es) = foldl' (\e1 e2 -> InfixE (Just e1) (VarE apValName) (Just e2))
(VarE fmapValName `AppE` conExp `AppE` e) es
return . go . rights $ ess