{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE BangPatterns #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Unsafe #-}
#endif
#ifndef MIN_VERSION_template_haskell
#define MIN_VERSION_template_haskell(x,y,z) 1
#endif
module Data.Bifunctor.TH (
deriveBifunctor
, deriveBifunctorOptions
, makeBimap
, makeBimapOptions
, deriveBifoldable
, deriveBifoldableOptions
, makeBifold
, makeBifoldOptions
, makeBifoldMap
, makeBifoldMapOptions
, makeBifoldr
, makeBifoldrOptions
, makeBifoldl
, makeBifoldlOptions
, deriveBitraversable
, deriveBitraversableOptions
, makeBitraverse
, makeBitraverseOptions
, makeBisequenceA
, makeBisequenceAOptions
, makeBimapM
, makeBimapMOptions
, makeBisequence
, makeBisequenceOptions
, Options(..)
, defaultOptions
) where
import Control.Monad (guard, unless, when, zipWithM)
import Data.Bifunctor.TH.Internal
import Data.Either (rights)
import Data.List
import qualified Data.Map as Map (fromList, keys, lookup, size)
import Data.Maybe
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Syntax
newtype Options = Options
{ emptyCaseBehavior :: Bool
} deriving (Eq, Ord, Read, Show)
defaultOptions :: Options
defaultOptions = Options { emptyCaseBehavior = False }
deriveBifunctor :: Name -> Q [Dec]
deriveBifunctor = deriveBifunctorOptions defaultOptions
deriveBifunctorOptions :: Options -> Name -> Q [Dec]
deriveBifunctorOptions = deriveBiClass Bifunctor
makeBimap :: Name -> Q Exp
makeBimap = makeBimapOptions defaultOptions
makeBimapOptions :: Options -> Name -> Q Exp
makeBimapOptions = makeBiFun Bimap
deriveBifoldable :: Name -> Q [Dec]
deriveBifoldable = deriveBifoldableOptions defaultOptions
deriveBifoldableOptions :: Options -> Name -> Q [Dec]
deriveBifoldableOptions = deriveBiClass Bifoldable
makeBifold :: Name -> Q Exp
makeBifold = makeBifoldOptions defaultOptions
makeBifoldOptions :: Options -> Name -> Q Exp
makeBifoldOptions opts name = appsE [ makeBifoldMapOptions opts name
, varE idValName
, varE idValName
]
makeBifoldMap :: Name -> Q Exp
makeBifoldMap = makeBifoldMapOptions defaultOptions
makeBifoldMapOptions :: Options -> Name -> Q Exp
makeBifoldMapOptions = makeBiFun BifoldMap
makeBifoldr :: Name -> Q Exp
makeBifoldr = makeBifoldrOptions defaultOptions
makeBifoldrOptions :: Options -> Name -> Q Exp
makeBifoldrOptions = makeBiFun Bifoldr
makeBifoldl :: Name -> Q Exp
makeBifoldl = makeBifoldlOptions defaultOptions
makeBifoldlOptions :: Options -> Name -> Q Exp
makeBifoldlOptions opts name = do
f <- newName "f"
g <- newName "g"
z <- newName "z"
t <- newName "t"
lamE [varP f, varP g, varP z, varP t] $
appsE [ varE appEndoValName
, appsE [ varE getDualValName
, appsE [ makeBifoldMapOptions opts name
, foldFun f
, foldFun g
, 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)
)
deriveBitraversable :: Name -> Q [Dec]
deriveBitraversable = deriveBitraversableOptions defaultOptions
deriveBitraversableOptions :: Options -> Name -> Q [Dec]
deriveBitraversableOptions = deriveBiClass Bitraversable
makeBitraverse :: Name -> Q Exp
makeBitraverse = makeBitraverseOptions defaultOptions
makeBitraverseOptions :: Options -> Name -> Q Exp
makeBitraverseOptions = makeBiFun Bitraverse
makeBisequenceA :: Name -> Q Exp
makeBisequenceA = makeBisequenceAOptions defaultOptions
makeBisequenceAOptions :: Options -> Name -> Q Exp
makeBisequenceAOptions opts name = appsE [ makeBitraverseOptions opts name
, varE idValName
, varE idValName
]
makeBimapM :: Name -> Q Exp
makeBimapM = makeBimapMOptions defaultOptions
makeBimapMOptions :: Options -> Name -> Q Exp
makeBimapMOptions opts name = do
f <- newName "f"
g <- newName "g"
lamE [varP f, varP g] . infixApp (varE unwrapMonadValName) (varE composeValName) $
appsE [ makeBitraverseOptions opts name
, wrapMonadExp f
, wrapMonadExp g
]
where
wrapMonadExp :: Name -> Q Exp
wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n)
makeBisequence :: Name -> Q Exp
makeBisequence = makeBisequenceOptions defaultOptions
makeBisequenceOptions :: Options -> Name -> Q Exp
makeBisequenceOptions opts name = appsE [ makeBimapMOptions opts name
, varE idValName
, varE idValName
]
deriveBiClass :: BiClass -> Options -> Name -> Q [Dec]
deriveBiClass biClass opts name = do
info <- reifyDatatype name
case info of
DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
, datatypeInstTypes = instTys
, datatypeVariant = variant
, datatypeCons = cons
} -> do
(instanceCxt, instanceType)
<- buildTypeInstance biClass parentName ctxt instTys variant
(:[]) `fmap` instanceD (return instanceCxt)
(return instanceType)
(biFunDecs biClass opts parentName instTys cons)
biFunDecs :: BiClass -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
biFunDecs biClass opts parentName instTys cons =
map makeFunD $ biClassToFuns biClass
where
makeFunD :: BiFun -> Q Dec
makeFunD biFun =
funD (biFunName biFun)
[ clause []
(normalB $ makeBiFunForCons biFun opts parentName instTys cons)
[]
]
makeBiFun :: BiFun -> Options -> Name -> Q Exp
makeBiFun biFun opts name = do
info <- reifyDatatype name
case info of
DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
, datatypeInstTypes = instTys
, datatypeVariant = variant
, datatypeCons = cons
} ->
buildTypeInstance (biFunToClass biFun) parentName ctxt instTys variant
>> makeBiFunForCons biFun opts parentName instTys cons
makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
makeBiFunForCons biFun opts _parentName instTys cons = do
argNames <- mapM newName $ catMaybes [ Just "f"
, Just "g"
, guard (biFun == Bifoldr) >> Just "z"
, Just "value"
]
let ([map1, map2], others) = splitAt 2 argNames
z = head others
value = last others
lastTyVars = map varTToName $ drop (length instTys - 2) instTys
tvMap = Map.fromList $ zip lastTyVars [map1, map2]
lamE (map varP argNames)
. appsE
$ [ varE $ biFunConstName biFun
, makeFun z value tvMap
] ++ map varE argNames
where
makeFun :: Name -> Name -> TyVarMap -> 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 (rs, PhantomR) <- unsnoc roles
, Just (_, PhantomR) <- unsnoc rs
-> biFunPhantom z value
#endif
| null cons && emptyCaseBehavior opts && ghc7'8OrLater
-> biFunEmptyCase biFun z value
| null cons
-> biFunNoCons biFun z value
| otherwise
-> caseE (varE value)
(map (makeBiFunForCon biFun z tvMap) cons)
ghc7'8OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 708
ghc7'8OrLater = True
#else
ghc7'8OrLater = False
#endif
#if MIN_VERSION_template_haskell(2,9,0)
biFunPhantom :: Name -> Name -> Q Exp
biFunPhantom z value =
biFunTrivial coerce
(varE pureValName `appE` coerce)
biFun z
where
coerce :: Q Exp
coerce = varE coerceValName `appE` varE value
#endif
makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match
makeBiFunForCon biFun z tvMap
(ConstructorInfo { constructorName = conName
, constructorContext = ctxt
, constructorFields = ts }) = do
ts' <- mapM resolveTypeSynonyms ts
argNames <- newNameList "_arg" $ length ts'
if (any (`predMentionsName` Map.keys tvMap) ctxt
|| Map.size tvMap < 2)
&& not (allowExQuant (biFunToClass biFun))
then existentialContextError conName
else makeBiFunForArgs biFun z tvMap conName ts' argNames
makeBiFunForArgs :: BiFun
-> Name
-> TyVarMap
-> Name
-> [Type]
-> [Name]
-> Q Match
makeBiFunForArgs biFun z tvMap conName tys args =
match (conP conName $ map varP args)
(normalB $ biFunCombine biFun conName z args mappedArgs)
[]
where
mappedArgs :: Q [Either Exp Exp]
mappedArgs = zipWithM (makeBiFunForArg biFun tvMap conName) tys args
makeBiFunForArg :: BiFun
-> TyVarMap
-> Name
-> Type
-> Name
-> Q (Either Exp Exp)
makeBiFunForArg biFun tvMap conName ty tyExpName =
makeBiFunForType biFun tvMap conName True ty `appEitherE` varE tyExpName
makeBiFunForType :: BiFun
-> TyVarMap
-> Name
-> Bool
-> Type
-> Q (Either Exp Exp)
makeBiFunForType biFun tvMap conName covariant (VarT tyName) =
case Map.lookup tyName tvMap of
Just mapName -> fmap Right . varE $
if covariant
then mapName
else contravarianceError conName
Nothing -> fmap Left $ biFunTriv biFun
makeBiFunForType biFun tvMap conName covariant (SigT ty _) =
makeBiFunForType biFun tvMap conName covariant ty
makeBiFunForType biFun tvMap conName covariant (ForallT _ _ ty) =
makeBiFunForType biFun tvMap conName covariant ty
makeBiFunForType biFun tvMap conName covariant ty =
let tyCon :: Type
tyArgs :: [Type]
tyCon:tyArgs = unapplyTy ty
numLastArgs :: Int
numLastArgs = min 2 $ 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
makeBiFunTuple :: ([Q Pat] -> Q Pat) -> (Int -> Name) -> Int
-> Q (Either Exp Exp)
makeBiFunTuple mkTupP mkTupleDataName n = do
args <- mapM newName $ catMaybes [ Just "x"
, guard (biFun == Bifoldr) >> 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 $ biFunCombine biFun
(mkTupleDataName n)
z
xs
(zipWithM makeBiFunTupleField tyArgs xs)
)
[]
]
makeBiFunTupleField :: Type -> Name -> Q (Either Exp Exp)
makeBiFunTupleField fieldTy fieldName =
makeBiFunForType biFun tvMap conName covariant fieldTy
`appEitherE` varE fieldName
in case tyCon of
ArrowT
| not (allowFunTys (biFunToClass biFun)) -> noFunctionsError conName
| mentionsTyArgs, [argTy, resTy] <- tyArgs ->
do x <- newName "x"
b <- newName "b"
fmap Right . lamE [varP x, varP b] $
covBiFun covariant resTy `appE` (varE x `appE`
(covBiFun (not covariant) argTy `appE` varE b))
where
covBiFun :: Bool -> Type -> Q Exp
covBiFun cov = fmap fromEither . makeBiFunForType biFun tvMap conName cov
#if MIN_VERSION_template_haskell(2,6,0)
UnboxedTupleT n
| n > 0 && mentionsTyArgs -> makeBiFunTuple unboxedTupP unboxedTupleDataName n
#endif
TupleT n
| n > 0 && mentionsTyArgs -> makeBiFunTuple tupP tupleDataName n
_ -> do
itf <- isTyFamily tyCon
if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs)
then outOfPlaceTyVarError conName
else if any (`mentionsName` tyVarNames) rhsArgs
then fmap Right . biFunApp biFun . appsE $
( varE (fromJust $ biFunArity biFun numLastArgs)
: map (fmap fromEither . makeBiFunForType biFun tvMap conName covariant)
rhsArgs
)
else fmap Left $ biFunTriv biFun
buildTypeInstance :: BiClass
-> Name
-> Cxt
-> [Type]
-> DatatypeVariant
-> Q (Cxt, Type)
buildTypeInstance biClass tyConName dataCxt instTysOrig variant = do
varTysExp <- mapM resolveTypeSynonyms instTysOrig
let remainingLength :: Int
remainingLength = length instTysOrig - 2
droppedTysExp :: [Type]
droppedTysExp = drop remainingLength varTysExp
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = map canRealizeKindStar droppedTysExp
when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $
derivingKindError biClass 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 = freeVariables droppedTysExpSubst
unless (all hasKindStar droppedTysExpSubst) $
derivingKindError biClass tyConName
let preds :: [Maybe Pred]
kvNames :: [[Name]]
kvNames' :: [Name]
(preds, kvNames) = unzip $ map (deriveConstraint biClass) remainingTysExpSubst
kvNames' = concat kvNames
remainingTysExpSubst' :: [Type]
remainingTysExpSubst' =
map (substNamesWithKindStar kvNames') remainingTysExpSubst
remainingTysOrigSubst :: [Type]
remainingTysOrigSubst =
map (substNamesWithKindStar (union droppedKindVarNames kvNames'))
$ take remainingLength instTysOrig
isDataFamily :: Bool
isDataFamily = case variant of
Datatype -> False
Newtype -> False
DataInstance -> True
NewtypeInstance -> True
remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' =
if isDataFamily
then remainingTysOrigSubst
else map unSigT remainingTysOrigSubst
instanceCxt :: Cxt
instanceCxt = catMaybes preds
instanceType :: Type
instanceType = AppT (ConT $ biClassName biClass)
$ applyTyCon tyConName remainingTysOrigSubst'
when (any (`predMentionsName` droppedTyVarNames) dataCxt) $
datatypeContextError tyConName instanceType
unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $
etaReductionError instanceType
return (instanceCxt, instanceType)
deriveConstraint :: BiClass -> Type -> (Maybe Pred, [Name])
deriveConstraint biClass t
| not (isTyVar t) = (Nothing, [])
| otherwise = case hasKindVarChain 1 t of
Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 1, ns)
_ -> case hasKindVarChain 2 t of
Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 2, ns)
_ -> (Nothing, [])
where
tName :: Name
tName = varTToName t
derivingKindError :: BiClass -> Name -> a
derivingKindError biClass tyConName = error
. 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 $ biClassName biClass
contravarianceError :: Name -> a
contravarianceError conName = error
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must not use the last type variable(s) in a function argument"
$ ""
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(s)"
$ ""
existentialContextError :: Name -> a
existentialContextError conName = error
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must be truly polymorphic in the last argument(s) of the data type"
$ ""
outOfPlaceTyVarError :: Name -> a
outOfPlaceTyVarError conName = error
. 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 -> a
etaReductionError instanceType = error $
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
++ pprint instanceType
data BiClass = Bifunctor | Bifoldable | Bitraversable
data BiFun = Bimap | Bifoldr | BifoldMap | Bitraverse
deriving Eq
biFunConstName :: BiFun -> Name
biFunConstName Bimap = bimapConstValName
biFunConstName Bifoldr = bifoldrConstValName
biFunConstName BifoldMap = bifoldMapConstValName
biFunConstName Bitraverse = bitraverseConstValName
biClassName :: BiClass -> Name
biClassName Bifunctor = bifunctorTypeName
biClassName Bifoldable = bifoldableTypeName
biClassName Bitraversable = bitraversableTypeName
biFunName :: BiFun -> Name
biFunName Bimap = bimapValName
biFunName Bifoldr = bifoldrValName
biFunName BifoldMap = bifoldMapValName
biFunName Bitraverse = bitraverseValName
biClassToFuns :: BiClass -> [BiFun]
biClassToFuns Bifunctor = [Bimap]
biClassToFuns Bifoldable = [Bifoldr, BifoldMap]
biClassToFuns Bitraversable = [Bitraverse]
biFunToClass :: BiFun -> BiClass
biFunToClass Bimap = Bifunctor
biFunToClass Bifoldr = Bifoldable
biFunToClass BifoldMap = Bifoldable
biFunToClass Bitraverse = Bitraversable
biClassConstraint :: BiClass -> Int -> Maybe Name
biClassConstraint Bifunctor 1 = Just functorTypeName
biClassConstraint Bifoldable 1 = Just foldableTypeName
biClassConstraint Bitraversable 1 = Just traversableTypeName
biClassConstraint biClass 2 = Just $ biClassName biClass
biClassConstraint _ _ = Nothing
biFunArity :: BiFun -> Int -> Maybe Name
biFunArity Bimap 1 = Just fmapValName
biFunArity Bifoldr 1 = Just foldrValName
biFunArity BifoldMap 1 = Just foldMapValName
biFunArity Bitraverse 1 = Just traverseValName
biFunArity biFun 2 = Just $ biFunName biFun
biFunArity _ _ = Nothing
allowFunTys :: BiClass -> Bool
allowFunTys Bifunctor = True
allowFunTys _ = False
allowExQuant :: BiClass -> Bool
allowExQuant Bifoldable = True
allowExQuant _ = False
biFunTriv :: BiFun -> Q Exp
biFunTriv Bimap = do
x <- newName "x"
lamE [varP x] $ varE x
biFunTriv Bifoldr = do
z <- newName "z"
lamE [wildP, varP z] $ varE z
biFunTriv BifoldMap = lamE [wildP] $ varE memptyValName
biFunTriv Bitraverse = varE pureValName
biFunApp :: BiFun -> Q Exp -> Q Exp
biFunApp Bifoldr e = do
x <- newName "x"
z <- newName "z"
lamE [varP x, varP z] $ appsE [e, varE z, varE x]
biFunApp _ e = e
biFunCombine :: BiFun
-> Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
biFunCombine Bimap = bimapCombine
biFunCombine Bifoldr = bifoldrCombine
biFunCombine BifoldMap = bifoldMapCombine
biFunCombine Bitraverse = bitraverseCombine
bimapCombine :: Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
bimapCombine conName _ _ = fmap (foldl' AppE (ConE conName) . fmap fromEither)
bifoldrCombine :: Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
bifoldrCombine _ zName _ = fmap (foldr AppE (VarE zName) . rights)
bifoldMapCombine :: Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
bifoldMapCombine _ _ _ = fmap (go . rights)
where
go :: [Exp] -> Exp
go [] = VarE memptyValName
go es = foldr1 (AppE . AppE (VarE mappendValName)) es
bitraverseCombine :: Name
-> Name
-> [Name]
-> Q [Either Exp Exp]
-> Q Exp
bitraverseCombine 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] = VarE fmapValName `AppE` conExp `AppE` e
go (e1:e2:es) = foldl' (\se1 se2 -> InfixE (Just se1) (VarE apValName) (Just se2))
(VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es
return . go . rights $ ess
biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp
biFunEmptyCase biFun z value =
biFunTrivial emptyCase
(varE pureValName `appE` emptyCase)
biFun z
where
emptyCase :: Q Exp
emptyCase = caseE (varE value) []
biFunNoCons :: BiFun -> Name -> Name -> Q Exp
biFunNoCons biFun z value =
biFunTrivial seqAndError
(varE pureValName `appE` seqAndError)
biFun z
where
seqAndError :: Q Exp
seqAndError = appE (varE seqValName) (varE value) `appE`
appE (varE errorValName)
(stringE $ "Void " ++ nameBase (biFunName biFun))
biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
biFunTrivial bimapE bitraverseE biFun z = go biFun
where
go :: BiFun -> Q Exp
go Bimap = bimapE
go Bifoldr = varE z
go BifoldMap = varE memptyValName
go Bitraverse = bitraverseE