module Data.Foldable.Deriving (
deriveFoldable
, makeFoldMap
, makeFoldr
) where
import Control.Monad (guard)
import Data.Deriving.Internal
#if MIN_VERSION_template_haskell(2,7,0)
import Data.List (find)
#endif
import Data.Maybe
#if __GLASGOW_HASKELL__ < 710 && MIN_VERSION_template_haskell(2,8,0)
import qualified Data.Set as Set
#endif
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Syntax
deriveFoldable :: Name -> Q [Dec]
deriveFoldable tyConName = do
info <- reify tyConName
case info of
TyConI{} -> deriveFoldablePlainTy tyConName
#if MIN_VERSION_template_haskell(2,7,0)
DataConI{} -> deriveFoldableDataFamInst tyConName
FamilyI (FamilyD DataFam _ _ _) _ ->
error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."
FamilyI (FamilyD TypeFam _ _ _) _ ->
error $ ns ++ "Cannot use a type family name."
_ -> error $ ns ++ "The name must be of a plain type constructor or data family instance constructor."
#else
DataConI{} -> dataConIError
_ -> error $ ns ++ "The name must be of a plain type constructor."
#endif
where
ns :: String
ns = "Data.Foldable.Deriving.deriveFoldable: "
deriveFoldablePlainTy :: Name -> Q [Dec]
deriveFoldablePlainTy tyConName = withTyCon tyConName fromCons where
fromCons :: Cxt -> [TyVarBndr] -> [Con] -> Q [Dec]
fromCons ctxt tvbs cons = (:[]) `fmap`
instanceD (return instanceCxt)
(return $ AppT (ConT foldableTypeName) instanceType)
(foldFunDecs droppedNb cons)
where
(instanceCxt, instanceType, droppedNb:_) =
cxtAndTypePlainTy tyConName ctxt tvbs
#if MIN_VERSION_template_haskell(2,7,0)
deriveFoldableDataFamInst :: Name -> Q [Dec]
deriveFoldableDataFamInst dataFamInstName = withDataFamInstCon dataFamInstName fromDec where
fromDec :: [TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q [Dec]
fromDec famTvbs ctxt parentName instTys cons = (:[]) `fmap`
instanceD (return instanceCxt)
(return $ AppT (ConT foldableTypeName) instanceType)
(foldFunDecs droppedNb cons)
where
(instanceCxt, instanceType, droppedNb:_) =
cxtAndTypeDataFamInstCon parentName ctxt famTvbs instTys
#endif
foldFunDecs :: NameBase -> [Con] -> [Q Dec]
foldFunDecs nb cons = map makeFunD [Foldr, FoldMap] where
makeFunD :: FoldFun -> Q Dec
makeFunD fun =
funD (foldFunName fun)
[ clause []
(normalB $ makeFoldFunForCons fun nb cons)
[]
]
makeFoldMap :: Name -> Q Exp
makeFoldMap = makeFoldFun FoldMap
makeFoldr :: Name -> Q Exp
makeFoldr = makeFoldFun Foldr
makeFoldFun :: FoldFun -> Name -> Q Exp
makeFoldFun fun tyConName = do
info <- reify tyConName
case info of
TyConI{} -> withTyCon tyConName $ \ctxt tvbs decs ->
let !nbs = thd3 $ cxtAndTypePlainTy tyConName ctxt tvbs
in makeFoldFunForCons fun (head nbs) decs
#if MIN_VERSION_template_haskell(2,7,0)
DataConI{} -> withDataFamInstCon tyConName $ \famTvbs ctxt parentName instTys cons ->
let !nbs = thd3 $ cxtAndTypeDataFamInstCon parentName ctxt famTvbs instTys
in makeFoldFunForCons fun (head nbs) cons
FamilyI (FamilyD DataFam _ _ _) _ ->
error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."
FamilyI (FamilyD TypeFam _ _ _) _ ->
error $ ns ++ "Cannot use a type family name."
_ -> error $ ns ++ "The name must be of a plain type constructor or data family instance constructor."
#else
DataConI{} -> dataConIError
_ -> error $ ns ++ "The name must be of a plain type constructor."
#endif
where
ns :: String
ns = "Data.Foldable.Deriving.makeFoldFun: "
makeFoldFunForCons :: FoldFun -> NameBase -> [Con] -> Q Exp
makeFoldFunForCons fun nb cons = do
argNames <- mapM newName $ catMaybes [ Just "f"
, guard (fun == Foldr) >> Just "z"
, Just "value"
]
let f:others = argNames
z = head others
value = last others
mbTvi = Just (nb, f)
lamE (map varP argNames)
. appsE
$ [ varE $ foldFunConstName fun
, if null cons
then appE (varE errorValName)
(stringE $ "Void " ++ nameBase (foldFunName fun))
else caseE (varE value)
(map (makeFoldFunForCon fun z mbTvi) cons)
] ++ map varE argNames
makeFoldFunForCon :: FoldFun -> Name -> Maybe TyVarInfo -> Con -> Q Match
makeFoldFunForCon fun z mbTvi (NormalC conName tys) = do
args <- newNameList "arg" $ length tys
let argTys = map snd tys
makeFoldFunForArgs fun z mbTvi conName argTys args
makeFoldFunForCon fun z mbTvi (RecC conName tys) = do
args <- newNameList "arg" $ length tys
let argTys = map thd3 tys
makeFoldFunForArgs fun z mbTvi conName argTys args
makeFoldFunForCon fun z mbTvi (InfixC (_, argTyL) conName (_, argTyR)) = do
argL <- newName "argL"
argR <- newName "argR"
makeFoldFunForArgs fun z mbTvi conName [argTyL, argTyR] [argL, argR]
makeFoldFunForCon fun z mbTvi (ForallC tvbs _ con)
= makeFoldFunForCon fun z (removeForalled tvbs mbTvi) con
makeFoldFunForArgs :: FoldFun
-> Name
-> Maybe TyVarInfo
-> Name
-> [Type]
-> [Name]
-> Q Match
makeFoldFunForArgs fun z mbTvi conName tys args =
match (conP conName $ map varP args)
(normalB $ foldFunCombine fun z mappedArgs)
[]
where
mappedArgs :: [Q Exp]
mappedArgs = zipWith (makeFoldFunForArg fun mbTvi conName) tys args
makeFoldFunForArg :: FoldFun
-> Maybe TyVarInfo
-> Name
-> Type
-> Name
-> Q Exp
makeFoldFunForArg fun mbTvi conName ty tyExpName = do
ty' <- expandSyn ty
makeFoldFunForType fun mbTvi conName ty' `appE` varE tyExpName
makeFoldFunForType :: FoldFun
-> Maybe TyVarInfo
-> Name
-> Type
-> Q Exp
makeFoldFunForType fun mbTvi _ (VarT tyName) =
maybe (foldFunTriv fun) (\(nb, mapName) ->
if NameBase tyName == nb
then varE mapName
else foldFunTriv fun) mbTvi
makeFoldFunForType fun mbTvi conName (SigT ty _) =
makeFoldFunForType fun mbTvi conName ty
makeFoldFunForType fun mbTvi conName (ForallT tvbs _ ty) =
makeFoldFunForType fun (removeForalled tvbs mbTvi) conName ty
makeFoldFunForType fun mbTvi conName 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
tyVarNameBase :: [NameBase]
tyVarNameBase = maybeToList $ fmap fst mbTvi
mentionsTyArgs :: Bool
mentionsTyArgs = any (`mentionsNameBase` tyVarNameBase) tyArgs
makeFoldFunTuple :: Type -> Name -> Q Exp
makeFoldFunTuple fieldTy fieldName =
makeFoldFunForType fun mbTvi conName fieldTy `appE` varE fieldName
in case tyCon of
ArrowT -> noFunctionsError conName
TupleT n
| n > 0 && mentionsTyArgs -> do
args <- mapM newName $ catMaybes [ Just "x"
, guard (fun == Foldr) >> Just "z"
]
xs <- newNameList "tup" n
let x = head args
z = last args
lamE (map varP args) $ caseE (varE x)
[ match (tupP $ map varP xs)
(normalB $ foldFunCombine fun
z
(zipWith makeFoldFunTuple tyArgs xs)
)
[]
]
_ -> do
itf <- isTyFamily tyCon
if any (`mentionsNameBase` tyVarNameBase) lhsArgs || (itf && mentionsTyArgs)
then outOfPlaceTyVarError conName (head tyVarNameBase)
else if any (`mentionsNameBase` tyVarNameBase) rhsArgs
then foldFunApp fun . appsE $
( varE (foldFunName fun)
: map (makeFoldFunForType fun mbTvi conName) rhsArgs
)
else foldFunTriv fun
withTyCon :: Name
-> (Cxt -> [TyVarBndr] -> [Con] -> Q a)
-> Q a
withTyCon name f = do
info <- reify name
case info of
TyConI dec ->
case dec of
DataD ctxt _ tvbs cons _ -> f ctxt tvbs cons
NewtypeD ctxt _ tvbs con _ -> f ctxt tvbs [con]
_ -> error $ ns ++ "Unsupported type " ++ show dec ++ ". Must be a data type or newtype."
_ -> error $ ns ++ "The name must be of a plain type constructor."
where
ns :: String
ns = "Data.Foldable.Deriving.withTyCon: "
#if MIN_VERSION_template_haskell(2,7,0)
withDataFam :: Name
-> ([TyVarBndr] -> [Dec] -> Q a)
-> Q a
withDataFam name f = do
info <- reify name
case info of
FamilyI (FamilyD DataFam _ tvbs _) decs -> f tvbs decs
FamilyI (FamilyD TypeFam _ _ _) _ -> error $ ns ++ "Cannot use a type family name."
_ -> error $ ns ++ "Unsupported type " ++ show info ++ ". Must be a data family name."
where
ns :: String
ns = "Data.Foldable.Deriving.withDataFam: "
withDataFamInstCon :: Name
-> ([TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q a)
-> Q a
withDataFamInstCon dficName f = do
dficInfo <- reify dficName
case dficInfo of
DataConI _ _ parentName _ -> do
parentInfo <- reify parentName
case parentInfo of
FamilyI (FamilyD DataFam _ _ _) _ -> withDataFam parentName $ \famTvbs decs ->
let sameDefDec = flip find decs $ \dec ->
case dec of
DataInstD _ _ _ cons' _ -> any ((dficName ==) . constructorName) cons'
NewtypeInstD _ _ _ con _ -> dficName == constructorName con
_ -> error $ ns ++ "Must be a data or newtype instance."
(ctxt, instTys, cons) = case sameDefDec of
Just (DataInstD ctxt' _ instTys' cons' _) -> (ctxt', instTys', cons')
Just (NewtypeInstD ctxt' _ instTys' con _) -> (ctxt', instTys', [con])
_ -> error $ ns ++ "Could not find data or newtype instance constructor."
in f famTvbs ctxt parentName instTys cons
_ -> error $ ns ++ "Data constructor " ++ show dficName ++ " is not from a data family instance."
_ -> error $ ns ++ "Unsupported type " ++ show dficInfo ++ ". Must be a data family instance constructor."
where
ns :: String
ns = "Data.Foldable.Deriving.withDataFamInstCon: "
#endif
cxtAndTypePlainTy :: Name
-> Cxt
-> [TyVarBndr]
-> (Cxt, Type, [NameBase])
cxtAndTypePlainTy tyConName dataCxt tvbs
| remainingLength < 0 || not (wellKinded droppedKinds)
= derivingKindError tyConName
| any (`predMentionsNameBase` droppedNbs) dataCxt
= datatypeContextError tyConName instanceType
| otherwise = (instanceCxt, instanceType, droppedNbs)
where
instanceCxt :: Cxt
instanceCxt = mapMaybe applyConstraint remaining
instanceType :: Type
instanceType = applyTyCon tyConName $ map (VarT . tvbName) remaining
remainingLength :: Int
remainingLength = length tvbs 1
remaining, dropped :: [TyVarBndr]
(remaining, dropped) = splitAt remainingLength tvbs
droppedKinds :: [Kind]
droppedKinds = map tvbKind dropped
droppedNbs :: [NameBase]
droppedNbs = map (NameBase . tvbName) dropped
#if MIN_VERSION_template_haskell(2,7,0)
cxtAndTypeDataFamInstCon :: Name
-> Cxt
-> [TyVarBndr]
-> [Type]
-> (Cxt, Type, [NameBase])
cxtAndTypeDataFamInstCon parentName dataCxt famTvbs instTysAndKinds
| remainingLength < 0 || not (wellKinded droppedKinds)
= derivingKindError parentName
| any (`predMentionsNameBase` droppedNbs) dataCxt
= datatypeContextError parentName instanceType
| canEtaReduce remaining dropped
= (instanceCxt, instanceType, droppedNbs)
| otherwise = etaReductionError instanceType
where
instanceCxt :: Cxt
instanceCxt = mapMaybe applyConstraint lhsTvbs
instanceType :: Type
instanceType = applyTyCon parentName
$ map unSigT remaining
remainingLength :: Int
remainingLength = length famTvbs 1
remaining, dropped :: [Type]
(remaining, dropped) = splitAt remainingLength rhsTypes
droppedKinds :: [Kind]
droppedKinds = map tvbKind . snd $ splitAt remainingLength famTvbs
droppedNbs :: [NameBase]
droppedNbs = map varTToNameBase dropped
instTypes :: [Type]
instTypes =
# if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))
instTysAndKinds
# else
drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) famTvbs)
instTysAndKinds
# endif
lhsTvbs :: [TyVarBndr]
lhsTvbs = map (uncurry replaceTyVarName)
. filter (isTyVar . snd)
. take remainingLength
$ zip famTvbs rhsTypes
rhsTypes :: [Type]
rhsTypes =
# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
instTypes ++ map tvbToType (drop (length instTypes) famTvbs)
# else
instTypes
# endif
#endif
applyConstraint :: TyVarBndr -> Maybe Pred
applyConstraint (PlainTV _) = Nothing
applyConstraint (KindedTV name kind) = do
guard $ numKindArrows kind == 1 && canRealizeKindStarChain kind
Just $ applyClass foldableTypeName name
derivingKindError :: Name -> a
derivingKindError tyConName = error
. showString "Cannot derive well-kinded instance of form ‘Foldable "
. showParen True
( showString (nameBase tyConName)
. showString " ..."
)
. showString "‘\n\tClass Foldable expects an argument of kind * -> *"
$ ""
noFunctionsError :: Name -> a
noFunctionsError conName = error
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must not contain function types"
$ ""
datatypeContextError :: Name -> Type -> a
datatypeContextError dataName instanceType = error
. 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"
$ ""
outOfPlaceTyVarError :: Name -> NameBase -> a
outOfPlaceTyVarError conName tyVarName = error
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must use the type variable "
. shows tyVarName
. showString " only in the last argument of a data type"
$ ""
#if MIN_VERSION_template_haskell(2,7,0)
etaReductionError :: Type -> a
etaReductionError instanceType = error $
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
++ pprint instanceType
#else
dataConIError :: a
dataConIError = error
. 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 FoldFun = Foldr | FoldMap
deriving Eq
foldFunConstName :: FoldFun -> Name
foldFunConstName Foldr = foldrConstValName
foldFunConstName FoldMap = foldMapConstValName
foldFunName :: FoldFun -> Name
foldFunName Foldr = foldrValName
foldFunName FoldMap = foldMapValName
foldFunTriv :: FoldFun -> Q Exp
foldFunTriv Foldr = do
z <- newName "z"
lamE [wildP, varP z] $ varE z
foldFunTriv FoldMap = lamE [wildP] $ varE memptyValName
foldFunApp :: FoldFun -> Q Exp -> Q Exp
foldFunApp Foldr e = do
x <- newName "x"
z <- newName "z"
lamE [varP x, varP z] $ appsE [e, varE z, varE x]
foldFunApp FoldMap e = e
foldFunCombine :: FoldFun -> Name -> [Q Exp] -> Q Exp
foldFunCombine Foldr = foldrCombine
foldFunCombine FoldMap = foldMapCombine
foldrCombine :: Name -> [Q Exp] -> Q Exp
foldrCombine zName = foldr appE (varE zName)
foldMapCombine :: Name -> [Q Exp] -> Q Exp
foldMapCombine _ [] = varE memptyValName
foldMapCombine _ es = foldr1 (appE . appE (varE mappendValName)) es