deriving-compat-0.6: src/Data/Functor/Deriving/Internal.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module: Data.Functor.Deriving.Internal
Copyright: (C) 2015-2017 Ryan Scott
License: BSD-style (see the file LICENSE)
Maintainer: Ryan Scott
Portability: Template Haskell
The machinery needed to derive 'Foldable', 'Functor', and 'Traversable' instances.
For more info on how deriving @Functor@ works, see
<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>.
Note: this is an internal module, and as such, the API presented here is not
guaranteed to be stable, even between minor releases of this library.
-}
module Data.Functor.Deriving.Internal (
-- * 'Foldable'
deriveFoldable
, deriveFoldableOptions
, makeFoldMap
, makeFoldMapOptions
, makeFoldr
, makeFoldrOptions
, makeFold
, makeFoldOptions
, makeFoldl
, makeFoldlOptions
, makeNull
, makeNullOptions
-- * 'Functor'
, deriveFunctor
, deriveFunctorOptions
, makeFmap
, makeFmapOptions
, makeReplace
, makeReplaceOptions
-- * 'Traversable'
, deriveTraversable
, deriveTraversableOptions
, makeTraverse
, makeTraverseOptions
, makeSequenceA
, makeSequenceAOptions
, makeMapM
, makeMapMOptions
, makeSequence
, makeSequenceOptions
-- * 'FFTOptions'
, FFTOptions(..)
, defaultFFTOptions
) where
import Control.Monad (guard)
import Data.Deriving.Internal
import qualified Data.List as List
import qualified Data.Map as Map ((!), keys, lookup, member, singleton)
import Data.Maybe
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
-- | Options that further configure how the functions in "Data.Functor.Deriving"
-- should behave. (@FFT@ stands for 'Functor'/'Foldable'/'Traversable'.)
newtype FFTOptions = FFTOptions
{ fftEmptyCaseBehavior :: Bool
-- ^ If 'True', derived instances for empty data types (i.e., ones with
-- no data constructors) will use the @EmptyCase@ language extension.
-- If 'False', derived instances will simply use 'seq' instead.
-- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only
-- available in 7.8 or later.)
} deriving (Eq, Ord, Read, Show)
-- | Conservative 'FFTOptions' that doesn't attempt to use @EmptyCase@ (to
-- prevent users from having to enable that extension at use sites.)
defaultFFTOptions :: FFTOptions
defaultFFTOptions = FFTOptions { fftEmptyCaseBehavior = False }
-- | Generates a 'Foldable' instance declaration for the given data type or data
-- family instance.
deriveFoldable :: Name -> Q [Dec]
deriveFoldable = deriveFoldableOptions defaultFFTOptions
-- | Like 'deriveFoldable', but takes an 'FFTOptions' argument.
deriveFoldableOptions :: FFTOptions -> Name -> Q [Dec]
deriveFoldableOptions = deriveFunctorClass Foldable
-- | Generates a lambda expression which behaves like 'foldMap' (without requiring a
-- 'Foldable' instance).
makeFoldMap :: Name -> Q Exp
makeFoldMap = makeFoldMapOptions defaultFFTOptions
-- | Like 'makeFoldMap', but takes an 'FFTOptions' argument.
makeFoldMapOptions :: FFTOptions -> Name -> Q Exp
makeFoldMapOptions = makeFunctorFun FoldMap
-- | Generates a lambda expression which behaves like 'null' (without requiring a
-- 'Foldable' instance).
makeNull :: Name -> Q Exp
makeNull = makeNullOptions defaultFFTOptions
-- | Like 'makeNull', but takes an 'FFTOptions' argument.
makeNullOptions :: FFTOptions -> Name -> Q Exp
makeNullOptions = makeFunctorFun Null
-- | Generates a lambda expression which behaves like 'foldr' (without requiring a
-- 'Foldable' instance).
makeFoldr :: Name -> Q Exp
makeFoldr = makeFoldrOptions defaultFFTOptions
-- | Like 'makeFoldr', but takes an 'FFTOptions' argument.
makeFoldrOptions :: FFTOptions -> Name -> Q Exp
makeFoldrOptions = makeFunctorFun Foldr
-- | Generates a lambda expression which behaves like 'fold' (without requiring a
-- 'Foldable' instance).
makeFold :: Name -> Q Exp
makeFold = makeFoldOptions defaultFFTOptions
-- | Like 'makeFold', but takes an 'FFTOptions' argument.
makeFoldOptions :: FFTOptions -> Name -> Q Exp
makeFoldOptions opts name = makeFoldMapOptions opts name `appE` varE idValName
-- | Generates a lambda expression which behaves like 'foldl' (without requiring a
-- 'Foldable' instance).
makeFoldl :: Name -> Q Exp
makeFoldl = makeFoldlOptions defaultFFTOptions
-- | Like 'makeFoldl', but takes an 'FFTOptions' argument.
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)
)
-- | Generates a 'Functor' instance declaration for the given data type or data
-- family instance.
deriveFunctor :: Name -> Q [Dec]
deriveFunctor = deriveFunctorOptions defaultFFTOptions
-- | Like 'deriveFunctor', but takes an 'FFTOptions' argument.
deriveFunctorOptions :: FFTOptions -> Name -> Q [Dec]
deriveFunctorOptions = deriveFunctorClass Functor
-- | Generates a lambda expression which behaves like 'fmap' (without requiring a
-- 'Functor' instance).
makeFmap :: Name -> Q Exp
makeFmap = makeFmapOptions defaultFFTOptions
-- | Like 'makeFmap', but takes an 'FFTOptions' argument.
makeFmapOptions :: FFTOptions -> Name -> Q Exp
makeFmapOptions = makeFunctorFun Fmap
-- | Generates a lambda expression which behaves like ('<$') (without requiring a
-- 'Functor' instance).
makeReplace :: Name -> Q Exp
makeReplace = makeReplaceOptions defaultFFTOptions
-- | Like 'makeReplace', but takes an 'FFTOptions' argument.
makeReplaceOptions :: FFTOptions -> Name -> Q Exp
makeReplaceOptions = makeFunctorFun Replace
-- | Generates a 'Traversable' instance declaration for the given data type or data
-- family instance.
deriveTraversable :: Name -> Q [Dec]
deriveTraversable = deriveTraversableOptions defaultFFTOptions
-- | Like 'deriveTraverse', but takes an 'FFTOptions' argument.
deriveTraversableOptions :: FFTOptions -> Name -> Q [Dec]
deriveTraversableOptions = deriveFunctorClass Traversable
-- | Generates a lambda expression which behaves like 'traverse' (without requiring a
-- 'Traversable' instance).
makeTraverse :: Name -> Q Exp
makeTraverse = makeTraverseOptions defaultFFTOptions
-- | Like 'makeTraverse', but takes an 'FFTOptions' argument.
makeTraverseOptions :: FFTOptions -> Name -> Q Exp
makeTraverseOptions = makeFunctorFun Traverse
-- | Generates a lambda expression which behaves like 'sequenceA' (without requiring a
-- 'Traversable' instance).
makeSequenceA :: Name -> Q Exp
makeSequenceA = makeSequenceAOptions defaultFFTOptions
-- | Like 'makeSequenceA', but takes an 'FFTOptions' argument.
makeSequenceAOptions :: FFTOptions -> Name -> Q Exp
makeSequenceAOptions opts name = makeTraverseOptions opts name `appE` varE idValName
-- | Generates a lambda expression which behaves like 'mapM' (without requiring a
-- 'Traversable' instance).
makeMapM :: Name -> Q Exp
makeMapM = makeMapMOptions defaultFFTOptions
-- | Like 'makeMapM', but takes an 'FFTOptions' argument.
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)
-- | Generates a lambda expression which behaves like 'sequence' (without requiring a
-- 'Traversable' instance).
makeSequence :: Name -> Q Exp
makeSequence = makeSequenceOptions defaultFFTOptions
-- | Like 'makeSequence', but takes an 'FFTOptions' argument.
makeSequenceOptions :: FFTOptions -> Name -> Q Exp
makeSequenceOptions opts name = makeMapMOptions opts name `appE` varE idValName
-------------------------------------------------------------------------------
-- Code generation
-------------------------------------------------------------------------------
-- | Derive a class instance declaration (depending on the FunctorClass argument's value).
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)
-- | Generates a declaration defining the primary function(s) corresponding to a
-- particular class (fmap for Functor, foldr and foldMap for Foldable, and
-- traverse for Traversable).
--
-- For why both foldr and foldMap are derived for Foldable, see Trac #7436.
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)
[]
]
-- | Generates a lambda expression which behaves like the FunctorFun argument.
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
-- We force buildTypeInstance here since it performs some checks for whether
-- or not the provided datatype can actually have fmap/foldr/traverse/etc.
-- implemented for it, and produces errors if it can't.
buildTypeInstance (functorFunToClass ff) parentName ctxt instTypes variant
>> makeFunctorFunForCons ff opts parentName instTypes cons
-- | Generates a lambda expression for the given constructors.
-- All constructors must be from the same type.
makeFunctorFunForCons
:: FunctorFun -> FFTOptions -> Name -> [Type] -> [ConstructorInfo]
-> Q Exp
makeFunctorFunForCons ff opts _parentName instTypes cons = do
mapFun <- newName "f"
z <- newName "z" -- Only used for deriving foldr
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
-- | Generates a match for a single constructor.
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
-- | Generates a match whose right-hand side implements @fmap@.
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
-- If the argument type is a bare occurrence of the
-- data type's last type variable, then we can
-- generate more efficient code.
-- This was inspired by GHC#17880.
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
}
-- | Generates a match whose right-hand side implements @(<$)@.
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
-- If the argument type is a bare occurrence of the
-- data type's last type variable, then we can
-- generate more efficient code.
-- This was inspired by GHC#17880.
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) -- Con x1 x2 ..
-- | Generates a match whose right-hand side implements @foldr@.
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
-- The Bool is True if the type mentions the last type parameter, False
-- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out
-- expressions that do not mention the last parameter by checking for False.
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
-- g1 v1 (g2 v2 (.. z))
mkFoldr :: [Exp] -> Exp
mkFoldr = foldr AppE zExp
-- | Generates a match whose right-hand side implements @foldMap@.
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
-- The Bool is True if the type mentions the last type parameter, False
-- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out
-- expressions that do not mention the last parameter by checking for False.
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
-- mappend v1 (mappend v2 ..)
mkFoldMap :: [Exp] -> Exp
mkFoldMap [] = VarE memptyValName
mkFoldMap es = foldr1 (AppE . AppE (VarE mappendValName)) es
-- | Generates a match whose right-hand side implements @null@.
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
-- If e definitely contains the parameter, then we can
-- test if (G e) contains it by simply checking if (G e)
-- is null
NotNull -> NullM $ VarE nullValName
-- This case is unreachable--it will actually be caught
-- by ft_triv
r@IsNull{} -> r
-- The general case uses (all null), (all (all null)),
-- etc.
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
-- v1 && v2 && ..
mkNull :: [Exp] -> Exp
mkNull [] = ConE trueDataName
mkNull xs = foldr1 (\x y -> VarE andValName `AppE` x `AppE` y) xs
-- Given a list of NullM results, produce Nothing if any of them is NotNull,
-- and otherwise produce a list of (Bool, a) with True entries representing
-- unknowns and False entries representing things that are definitely null.
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 -- Definitely null
| NotNull -- Definitely not null
| NullM a -- Unknown
-- | Generates a match whose right-hand side implements @traverse@.
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
-- The Bool is True if the type mentions the last type parameter, False
-- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out
-- expressions that do not mention the last parameter by checking for False.
ft_trav :: FFoldType (Q (Bool, Exp))
ft_trav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]
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
}
-- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
-- (g2 a2) <*> ...
match_for_con :: Name -> [(Bool, Exp)] -> Q Match
match_for_con = mkSimpleConMatch2 $ \conExp xs -> return $ mkApCon conExp xs
where
-- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
mkApCon :: Exp -> [Exp] -> Exp
mkApCon conExp [] = VarE pureValName `AppE` conExp
mkApCon conExp [e] = VarE fmapValName `AppE` conExp `AppE` e
mkApCon conExp (e1:e2:es) = List.foldl' appAp
(VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es
where appAp se1 se2 = InfixE (Just se1) (VarE apValName) (Just se2)
-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------
-- | A representation of which class is being derived.
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
-- | A representation of which function is being generated.
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
-------------------------------------------------------------------------------
-- Assorted utilities
-------------------------------------------------------------------------------
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 }) =
conPCompat conName $ replicate (length ts) WildP
-------------------------------------------------------------------------------
-- Generic traversal for functor-like deriving
-------------------------------------------------------------------------------
-- Much of the code below is cargo-culted from the TcGenFunctor module in GHC.
data FFoldType a -- Describes how to fold over a Type in a functor like way
= FT { ft_triv :: a
-- ^ Does not contain variable
, ft_var :: Name -> a
-- ^ The variable itself
, ft_co_var :: Name -> a
-- ^ The variable itself, contravariantly
, ft_fun :: a -> a -> a
-- ^ Function type
, ft_tup :: TupleSort -> [a] -> a
-- ^ Tuple type. The @[a]@ is the result of folding over the
-- arguments of the tuple.
, ft_ty_app :: Type -> a -> a
-- ^ Type app, variable only in last argument. The 'Type' is the
-- @arg_ty@ in @fun_ty arg_ty@.
, ft_bad_app :: a
-- ^ Type app, variable other than in last argument
, ft_forall :: [TyVarBndrSpec] -> a -> a
-- ^ Forall type
}
-- Note that in GHC, this function is pure. It must be monadic here since we:
--
-- (1) Expand type synonyms
-- (2) Detect type family applications
--
-- Which require reification in Template Haskell, but are pure in Core.
functorLikeTraverse :: forall a.
TyVarMap1 -- ^ Variable to look for
-> FFoldType a -- ^ How to fold
-> Type -- ^ Type to process
-> 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 -- Covariant or contravariant context
-> Type
-> Q (a, Bool) -- (result of type a, does type contain var)
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 -- Variable does not occur
-- At this point we know that xrs, xcs is not empty,
-- and at least one xr is True
| 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 -- T (..var..) ty
| otherwise -- T (..no var..) ty
-> do itf <- isInTypeFamilyApp tyVarNames f args
if itf -- We can't decompose type families, so
-- error if we encounter one here.
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
-- Fold over the arguments of a data constructor in a Functor-like way.
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
-- Make a 'LamE' using a fresh variable.
mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
mkSimpleLam lam = do
n <- newName "n"
body <- lam (VarE n)
return $ LamE [VarP n] body
-- Make a 'LamE' using two fresh variables.
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
-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
--
-- @mkSimpleConMatch fold conName insides@ produces a match clause in
-- which the LHS pattern-matches on @extraPats@, followed by a match on the
-- constructor @conName@ and its arguments. The RHS folds (with @fold@) over
-- @conName@ and its arguments, applying an expression (from @insides@) to each
-- of the respective arguments of @conName@.
mkSimpleConMatch :: (Name -> [a] -> Q Exp)
-> Name
-> [Exp -> a]
-> Q Match
mkSimpleConMatch fold conName insides = do
varsNeeded <- newNameList "_arg" $ length insides
let pat = conPCompat conName (map VarP varsNeeded)
rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded)
return $ Match pat (NormalB rhs) []
-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
--
-- @mkSimpleConMatch2 fold conName insides@ behaves very similarly to
-- 'mkSimpleConMatch', with two key differences:
--
-- 1. @insides@ is a @[(Bool, Exp)]@ instead of a @[Exp]@. This is because it
-- filters out the expressions corresponding to arguments whose types do not
-- mention the last type variable in a derived 'Foldable' or 'Traversable'
-- instance (i.e., those elements of @insides@ containing @False@).
--
-- 2. @fold@ takes an expression as its first argument instead of a
-- constructor name. This is because it uses a specialized
-- constructor function expression that only takes as many parameters as
-- there are argument types that mention the last type variable.
mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp)
-> Name
-> [(Bool, Exp)]
-> Q Match
mkSimpleConMatch2 fold conName insides = do
varsNeeded <- newNameList "_arg" lengthInsides
let pat = conPCompat conName (map VarP varsNeeded)
-- Make sure to zip BEFORE invoking catMaybes. We want the variable
-- indicies in each expression to match up with the argument indices
-- in conExpr (defined below).
exps = catMaybes $ zipWith (\(m, i) v -> if m then Just (i `AppE` VarE v)
else Nothing)
insides varsNeeded
-- An element of argTysTyVarInfo is True if the constructor argument
-- with the same index has a type which mentions the last type
-- variable.
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
-- Indicates whether a tuple is boxed or unboxed, as well as its number of
-- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #)
-- corresponds to @Unboxed 3@.
data TupleSort
= Boxed Int
#if MIN_VERSION_template_haskell(2,6,0)
| Unboxed Int
#endif
-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
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]
-- Adapt to the type of ConP changing in template-haskell-2.18.0.0.
conPCompat :: Name -> [Pat] -> Pat
conPCompat n pats = ConP n
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
pats