module Data.Functor.Deriving.Internal (
deriveFoldable
, makeFoldMap
, makeFoldr
, makeFold
, makeFoldl
, deriveFunctor
, makeFmap
, deriveTraversable
, makeTraverse
, makeSequenceA
, makeMapM
, makeSequence
) where
import Control.Monad (guard, unless, when, zipWithM)
import Data.Deriving.Internal
import Data.Either (rights)
#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))
import Data.Foldable (foldr')
#endif
import Data.List
import qualified Data.Map as Map (fromList, keys, lookup, size)
import Data.Maybe
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
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) <- reifyConTys ff conName mapFun
argNames <- newNameList "_arg" $ length ts
makeFunctorFunForArgs ff z tvMap conName ts argNames
makeFunctorFunForArgs :: FunctorFun
-> Name
-> TyVarMap
-> 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
-> TyVarMap
-> Name
-> Type
-> Name
-> Q (Either Exp Exp)
makeFunctorFunForArg ff tvMap conName ty tyExpName =
makeFunctorFunForType ff tvMap conName True ty `appEitherE` varE tyExpName
makeFunctorFunForType :: FunctorFun
-> TyVarMap
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeFunctorFunForType ff tvMap conName covariant (VarT tyName) =
case Map.lookup tyName tvMap of
Just 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 :: Type -> Name -> Q (Either Exp Exp)
makeFunctorFunTuple fieldTy fieldName =
makeFunctorFunForType ff tvMap conName covariant fieldTy
`appEitherE` varE fieldName
in case tyCon of
ArrowT
| not (allowFunTys (functorFunToClass ff)) -> 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
TupleT n
| n > 0 && mentionsTyArgs -> 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 (tupP $ map varP xs)
(normalB $ functorFunCombine ff
(tupleDataName n)
z
xs
(zipWithM makeFunctorFunTuple tyArgs xs)
)
[]
]
_ -> do
itf <- isTyFamily tyCon
if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs)
then outOfPlaceTyVarError 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
withType :: Name
-> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)
-> Q a
withType name f = do
info <- reify name
case info of
TyConI dec ->
case dec of
DataD ctxt _ tvbs
#if MIN_VERSION_template_haskell(2,11,0)
_
#endif
cons _ -> f name ctxt tvbs cons Nothing
NewtypeD ctxt _ tvbs
#if MIN_VERSION_template_haskell(2,11,0)
_
#endif
con _ -> f name ctxt tvbs [con] Nothing
_ -> fail $ ns ++ "Unsupported type: " ++ show dec
#if MIN_VERSION_template_haskell(2,7,0)
# if MIN_VERSION_template_haskell(2,11,0)
DataConI _ _ parentName -> do
# else
DataConI _ _ parentName _ -> do
# endif
parentInfo <- reify parentName
case parentInfo of
# if MIN_VERSION_template_haskell(2,11,0)
FamilyI (DataFamilyD _ tvbs _) decs ->
# else
FamilyI (FamilyD DataFam _ tvbs _) decs ->
# endif
let instDec = flip find decs $ \dec -> case dec of
DataInstD _ _ _
# if MIN_VERSION_template_haskell(2,11,0)
_
# endif
cons _ -> any ((name ==) . constructorName) cons
NewtypeInstD _ _ _
# if MIN_VERSION_template_haskell(2,11,0)
_
# endif
con _ -> name == constructorName con
_ -> error $ ns ++ "Must be a data or newtype instance."
in case instDec of
Just (DataInstD ctxt _ instTys
# if MIN_VERSION_template_haskell(2,11,0)
_
# endif
cons _)
-> f parentName ctxt tvbs cons $ Just instTys
Just (NewtypeInstD ctxt _ instTys
# if MIN_VERSION_template_haskell(2,11,0)
_
# endif
con _)
-> f parentName ctxt tvbs [con] $ Just instTys
_ -> fail $ ns ++
"Could not find data or newtype instance constructor."
_ -> fail $ ns ++ "Data constructor " ++ show name ++
" is not from a data family instance constructor."
# if MIN_VERSION_template_haskell(2,11,0)
FamilyI DataFamilyD{} _ ->
# else
FamilyI (FamilyD DataFam _ _ _) _ ->
# endif
fail $ ns ++
"Cannot use a data family name. Use a data family instance constructor instead."
_ -> fail $ ns ++ "The name must be of a plain data type constructor, "
++ "or a data family instance constructor."
#else
DataConI{} -> dataConIError
_ -> fail $ ns ++ "The name must be of a plain type constructor."
#endif
where
ns :: String
ns = "Data.Functor.Deriving.Internal.withType: "
buildTypeInstance :: FunctorClass
-> Name
-> Cxt
-> [TyVarBndr]
-> Maybe [Type]
-> Q (Cxt, Type)
buildTypeInstance fc tyConName dataCxt tvbs Nothing =
let varTys :: [Type]
varTys = map tvbToType tvbs
in buildTypeInstanceFromTys fc tyConName dataCxt varTys False
buildTypeInstance fc parentName dataCxt tvbs (Just instTysAndKinds) = do
#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)
let instTys :: [Type]
instTys = zipWith stealKindForType tvbs instTysAndKinds
#else
let kindVarNames :: [Name]
kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs
numKindVars :: Int
numKindVars = length kindVarNames
givenKinds, givenKinds' :: [Kind]
givenTys :: [Type]
(givenKinds, givenTys) = splitAt numKindVars instTysAndKinds
givenKinds' = map sanitizeStars givenKinds
sanitizeStars :: Kind -> Kind
sanitizeStars = go
where
go :: Kind -> Kind
go (AppT t1 t2) = AppT (go t1) (go t2)
go (SigT t k) = SigT (go t) (go k)
go (ConT n) | n == starKindName = StarT
go t = t
xTypeNames <- newNameList "tExtra" (length tvbs length givenTys)
let xTys :: [Type]
xTys = map VarT xTypeNames
substNamesWithKinds :: [(Name, Kind)] -> Type -> Type
substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks
instTys :: [Type]
instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))
$ zipWith stealKindForType tvbs (givenTys ++ xTys)
#endif
buildTypeInstanceFromTys fc parentName dataCxt instTys True
buildTypeInstanceFromTys :: FunctorClass
-> Name
-> Cxt
-> [Type]
-> Bool
-> Q (Cxt, Type)
buildTypeInstanceFromTys fc tyConName dataCxt varTysOrig isDataFamily = do
varTysExp <- mapM expandSyn varTysOrig
let remainingLength :: Int
remainingLength = length varTysOrig 1
droppedTysExp :: [Type]
droppedTysExp = drop remainingLength varTysExp
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = map canRealizeKindStar droppedTysExp
when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $
derivingKindError fc tyConName
let droppedKindVarNames :: [Name]
droppedKindVarNames = catKindVarNames droppedStarKindStati
varTysExpSubst :: [Type]
varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp
remainingTysExpSubst, droppedTysExpSubst :: [Type]
(remainingTysExpSubst, droppedTysExpSubst) =
splitAt remainingLength varTysExpSubst
droppedTyVarNames :: [Name]
droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst
unless (all hasKindStar droppedTysExpSubst) $
derivingKindError fc tyConName
let preds :: [Maybe Pred]
kvNames :: [[Name]]
kvNames' :: [Name]
(preds, kvNames) = unzip $ map (deriveConstraint fc) remainingTysExpSubst
kvNames' = concat kvNames
remainingTysExpSubst' :: [Type]
remainingTysExpSubst' =
map (substNamesWithKindStar kvNames') remainingTysExpSubst
remainingTysOrigSubst :: [Type]
remainingTysOrigSubst =
map (substNamesWithKindStar (union droppedKindVarNames kvNames'))
$ take remainingLength varTysOrig
remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' =
if isDataFamily
then remainingTysOrigSubst
else map unSigT remainingTysOrigSubst
instanceCxt :: Cxt
instanceCxt = catMaybes preds
instanceType :: Type
instanceType = AppT (ConT $ functorClassName fc)
$ applyTyCon tyConName remainingTysOrigSubst'
when (any (`predMentionsName` droppedTyVarNames) dataCxt) $
datatypeContextError tyConName instanceType
unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $
etaReductionError instanceType
return (instanceCxt, instanceType)
deriveConstraint :: FunctorClass -> Type -> (Maybe Pred, [Name])
deriveConstraint fc t
| not (isTyVar t) = (Nothing, [])
| otherwise = case hasKindVarChain 1 t of
Just ns -> (Just (applyClass (functorClassName fc) tName), ns)
Nothing -> (Nothing, [])
where
tName :: Name
tName = varTToName t
reifyConTys :: FunctorFun
-> Name
-> Name
-> Q ([Type], TyVarMap)
reifyConTys ff conName mapFun = do
info <- reify conName
(ctxt, uncTy) <- case info of
DataConI _ ty _
#if !(MIN_VERSION_template_haskell(2,11,0))
_
#endif
-> fmap uncurryTy (expandSyn ty)
_ -> fail "Must be a data constructor"
let (argTys, [resTy]) = splitAt (length uncTy 1) uncTy
unapResTy = unapplyTy resTy
mbTvNames = map varTToName_maybe $
drop (length unapResTy 1) unapResTy
tvMap = Map.fromList
. catMaybes
$ zipWith (\mbTvName sp ->
fmap (\tvName -> (tvName, sp)) mbTvName)
mbTvNames [mapFun]
if (any (`predMentionsName` Map.keys tvMap) ctxt
|| Map.size tvMap < 1)
&& not (allowExQuant (functorFunToClass ff))
then existentialContextError conName
else return (argTys, tvMap)
derivingKindError :: FunctorClass -> Name -> Q a
derivingKindError fc tyConName = fail
. showString "Cannot derive well-kinded instance of form ‘"
. showString className
. showChar ' '
. showParen True
( showString (nameBase tyConName)
. showString " ..."
)
. showString "‘\n\tClass "
. showString className
. showString " expects an argument of kind * -> *"
$ ""
where
className :: String
className = nameBase $ functorClassName fc
contravarianceError :: Name -> Q a
contravarianceError conName = fail
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must not use the last type variable in a function argument"
$ ""
noFunctionsError :: Name -> Q a
noFunctionsError conName = fail
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must not contain function types"
$ ""
datatypeContextError :: Name -> Type -> Q a
datatypeContextError dataName instanceType = fail
. showString "Can't make a derived instance of ‘"
. showString (pprint instanceType)
. showString "‘:\n\tData type ‘"
. showString (nameBase dataName)
. showString "‘ must not have a class context involving the last type argument(s)"
$ ""
existentialContextError :: Name -> Q a
existentialContextError conName = fail
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must be truly polymorphic in the last argument(s) of the data type"
$ ""
outOfPlaceTyVarError :: Name -> Q a
outOfPlaceTyVarError conName = fail
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must only use its last two type variable(s) within"
. showString " the last two argument(s) of a data type"
$ ""
etaReductionError :: Type -> Q a
etaReductionError instanceType = fail $
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
++ pprint instanceType
#if !(MIN_VERSION_template_haskell(2,7,0))
dataConIError :: Q a
dataConIError = fail
. showString "Cannot use a data constructor."
. showString "\n\t(Note: if you are trying to derive for a data family instance,"
. showString "\n\tuse GHC >= 7.4 instead.)"
$ ""
#endif
data FunctorClass = Functor | Foldable | Traversable
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
functorClassName :: FunctorClass -> Name
functorClassName Functor = functorTypeName
functorClassName Foldable = foldableTypeName
functorClassName Traversable = traversableTypeName
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
allowExQuant :: FunctorClass -> Bool
allowExQuant Foldable = True
allowExQuant _ = 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