{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
#if !(MIN_VERSION_base(4,9,0))
# if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
# else
{-# LANGUAGE TemplateHaskell #-}
# endif
#endif
module Data.Deriving.Internal where
import Control.Monad (liftM, when, unless)
import Data.Foldable (foldr')
#if !(MIN_VERSION_base(4,9,0))
import Data.Functor.Classes (Eq1(..), Ord1(..), Read1(..), Show1(..))
# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)
import Data.Functor.Classes (Eq2(..), Ord2(..), Read2(..), Show2(..))
# endif
#endif
import Data.List
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import qualified Data.Set as Set
import Data.Set (Set)
import Text.ParserCombinators.ReadPrec (ReadPrec)
#if !(MIN_VERSION_base(4,7,0))
import GHC.Read (lexP)
import Text.Read (pfail)
import Text.Read.Lex (Lexeme)
#endif
#if MIN_VERSION_ghc_prim(0,3,1)
import GHC.Prim (Int#, tagToEnum#)
#endif
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr (pprint)
import Language.Haskell.TH.Syntax
import Data.Functor ()
import Data.Functor.Classes ()
import Data.Foldable ()
import Data.Traversable ()
#ifndef CURRENT_PACKAGE_KEY
import Data.Version (showVersion)
import Paths_deriving_compat (version)
#endif
expandSyn :: Type -> Q Type
expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t
expandSyn t@AppT{} = expandSynApp t []
expandSyn t@ConT{} = expandSynApp t []
expandSyn (SigT t k) = do t' <- expandSyn t
k' <- expandSynKind k
return (SigT t' k')
expandSyn t = return t
expandSynKind :: Kind -> Q Kind
#if MIN_VERSION_template_haskell(2,8,0)
expandSynKind = expandSyn
#else
expandSynKind = return
#endif
expandSynApp :: Type -> [Type] -> Q Type
expandSynApp (AppT t1 t2) ts = do
t2' <- expandSyn t2
expandSynApp t1 (t2':ts)
expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts
expandSynApp t@(ConT n) ts = do
info <- reify n
case info of
TyConI (TySynD _ tvs rhs) ->
let (ts', ts'') = splitAt (length tvs) ts
subs = mkSubst tvs ts'
rhs' = substType subs rhs
in expandSynApp rhs' ts''
_ -> return $ foldl' AppT t ts
expandSynApp t ts = do
t' <- expandSyn t
return $ foldl' AppT t' ts
type TypeSubst = Map Name Type
type KindSubst = Map Name Kind
mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst
mkSubst vs ts =
let vs' = map un vs
un (PlainTV v) = v
un (KindedTV v _) = v
in Map.fromList $ zip vs' ts
substType :: TypeSubst -> Type -> Type
substType subs (ForallT v c t) = ForallT v c $ substType subs t
substType subs t@(VarT n) = Map.findWithDefault t n subs
substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2)
substType subs (SigT t k) = SigT (substType subs t)
#if MIN_VERSION_template_haskell(2,8,0)
(substType subs k)
#else
k
#endif
substType _ t = t
substKind :: KindSubst -> Type -> Type
#if MIN_VERSION_template_haskell(2,8,0)
substKind = substType
#else
substKind _ = id
#endif
substNameWithKind :: Name -> Kind -> Type -> Type
substNameWithKind n k = substKind (Map.singleton n k)
substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns
fmapConst :: f b -> (a -> b) -> f a -> f b
fmapConst x _ _ = x
{-# INLINE fmapConst #-}
foldrConst :: b -> (a -> b -> b) -> b -> t a -> b
foldrConst x _ _ _ = x
{-# INLINE foldrConst #-}
foldMapConst :: m -> (a -> m) -> t a -> m
foldMapConst x _ _ = x
{-# INLINE foldMapConst #-}
traverseConst :: f (t b) -> (a -> f b) -> t a -> f (t b)
traverseConst x _ _ = x
{-# INLINE traverseConst #-}
eqConst :: Bool
-> a -> a -> Bool
eqConst x _ _ = x
{-# INLINE eqConst #-}
eq1Const :: Bool
-> f a -> f a-> Bool
eq1Const x _ _ = x
{-# INLINE eq1Const #-}
liftEqConst :: Bool
-> (a -> b -> Bool) -> f a -> f b -> Bool
liftEqConst x _ _ _ = x
{-# INLINE liftEqConst #-}
liftEq2Const :: Bool
-> (a -> b -> Bool) -> (c -> d -> Bool)
-> f a c -> f b d -> Bool
liftEq2Const x _ _ _ _ = x
{-# INLINE liftEq2Const #-}
compareConst :: Ordering -> a -> a -> Ordering
compareConst x _ _ = x
{-# INLINE compareConst #-}
ltConst :: Bool -> a -> a -> Bool
ltConst x _ _ = x
{-# INLINE ltConst #-}
compare1Const :: Ordering -> f a -> f a -> Ordering
compare1Const x _ _ = x
{-# INLINE compare1Const #-}
liftCompareConst :: Ordering
-> (a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompareConst x _ _ _ = x
{-# INLINE liftCompareConst #-}
liftCompare2Const :: Ordering
-> (a -> b -> Ordering) -> (c -> d -> Ordering)
-> f a c -> f b d -> Ordering
liftCompare2Const x _ _ _ _ = x
{-# INLINE liftCompare2Const #-}
readsPrecConst :: ReadS a -> Int -> ReadS a
readsPrecConst x _ = x
{-# INLINE readsPrecConst #-}
readPrecConst :: ReadPrec a -> ReadPrec a
readPrecConst x = x
{-# INLINE readPrecConst #-}
readsPrec1Const :: ReadS (f a) -> Int -> ReadS (f a)
readsPrec1Const x _ = x
{-# INLINE readsPrec1Const #-}
liftReadsPrecConst :: ReadS (f a)
-> (Int -> ReadS a) -> ReadS [a]
-> Int -> ReadS (f a)
liftReadsPrecConst x _ _ _ = x
{-# INLINE liftReadsPrecConst #-}
liftReadPrecConst :: ReadPrec (f a)
-> ReadPrec a -> ReadPrec [a]
-> ReadPrec (f a)
liftReadPrecConst x _ _ = x
{-# INLINE liftReadPrecConst #-}
liftReadsPrec2Const :: ReadS (f a b)
-> (Int -> ReadS a) -> ReadS [a]
-> (Int -> ReadS b) -> ReadS [b]
-> Int -> ReadS (f a b)
liftReadsPrec2Const x _ _ _ _ _ = x
{-# INLINE liftReadsPrec2Const #-}
liftReadPrec2Const :: ReadPrec (f a b)
-> ReadPrec a -> ReadPrec [a]
-> ReadPrec b -> ReadPrec [b]
-> ReadPrec (f a b)
liftReadPrec2Const x _ _ _ _ = x
{-# INLINE liftReadPrec2Const #-}
showsPrecConst :: ShowS
-> Int -> a -> ShowS
showsPrecConst x _ _ = x
{-# INLINE showsPrecConst #-}
showsPrec1Const :: ShowS
-> Int -> f a -> ShowS
showsPrec1Const x _ _ = x
{-# INLINE showsPrec1Const #-}
liftShowsPrecConst :: ShowS
-> (Int -> a -> ShowS) -> ([a] -> ShowS)
-> Int -> f a -> ShowS
liftShowsPrecConst x _ _ _ _ = x
{-# INLINE liftShowsPrecConst #-}
liftShowsPrec2Const :: ShowS
-> (Int -> a -> ShowS) -> ([a] -> ShowS)
-> (Int -> b -> ShowS) -> ([b] -> ShowS)
-> Int -> f a b -> ShowS
liftShowsPrec2Const x _ _ _ _ _ _ = x
{-# INLINE liftShowsPrec2Const #-}
data StarKindStatus = NotKindStar
| KindStar
| IsKindVar Name
deriving Eq
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar t
| hasKindStar t = KindStar
| otherwise = case t of
#if MIN_VERSION_template_haskell(2,8,0)
SigT _ (VarT k) -> IsKindVar k
#endif
_ -> NotKindStar
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName (IsKindVar n) = Just n
starKindStatusToName _ = Nothing
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames = mapMaybe starKindStatusToName
class ClassRep a where
arity :: a -> Int
allowExQuant :: a -> Bool
fullClassName :: a -> Name
classConstraint :: a -> Int -> Maybe Name
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.Deriving.Internal.withType: "
buildTypeInstance :: ClassRep a
=> a
-> Name
-> Cxt
-> [TyVarBndr]
-> Maybe [Type]
-> Q (Cxt, Type)
buildTypeInstance cRep tyConName dataCxt tvbs Nothing =
let varTys :: [Type]
varTys = map tvbToType tvbs
in buildTypeInstanceFromTys cRep tyConName dataCxt varTys False
buildTypeInstance cRep 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 cRep parentName dataCxt instTys True
buildTypeInstanceFromTys :: ClassRep a
=> a
-> Name
-> Cxt
-> [Type]
-> Bool
-> Q (Cxt, Type)
buildTypeInstanceFromTys cRep tyConName dataCxt varTysOrig isDataFamily = do
varTysExp <- mapM expandSyn varTysOrig
let remainingLength :: Int
remainingLength = length varTysOrig - arity cRep
droppedTysExp :: [Type]
droppedTysExp = drop remainingLength varTysExp
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = map canRealizeKindStar droppedTysExp
when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $
derivingKindError cRep 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 cRep tyConName
let preds :: [Maybe Pred]
kvNames :: [[Name]]
kvNames' :: [Name]
(preds, kvNames) = unzip $ map (deriveConstraint cRep) 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 (fullClassName cRep))
$ applyTyCon tyConName remainingTysOrigSubst'
when (any (`predMentionsName` droppedTyVarNames) dataCxt) $
datatypeContextError tyConName instanceType
unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $
etaReductionError instanceType
return (instanceCxt, instanceType)
deriveConstraint :: ClassRep a => a -> Type -> (Maybe Pred, [Name])
deriveConstraint cRep t
| not (isTyVar t) = (Nothing, [])
| hasKindStar t = ((`applyClass` tName) `fmap` classConstraint cRep 0, [])
| otherwise = case hasKindVarChain 1 t of
Just ns | cRepArity >= 1
-> ((`applyClass` tName) `fmap` classConstraint cRep 1, ns)
_ -> case hasKindVarChain 2 t of
Just ns | cRepArity == 2
-> ((`applyClass` tName) `fmap` classConstraint cRep 2, ns)
_ -> (Nothing, [])
where
tName :: Name
tName = varTToName t
cRepArity :: Int
cRepArity = arity cRep
reifyConTys :: ClassRep a
=> a
-> [OneOrTwoNames b]
-> Name
-> Q ([Type], TyVarMap b)
reifyConTys cRep auxs conName = do
info <- reify conName
(ctxt, uncTy) <- case info of
DataConI _ ty _
#if !(MIN_VERSION_template_haskell(2,11,0))
_
#endif
-> fmap uncurryTy (expandSyn ty)
_ -> error "Must be a data constructor"
let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy
unapResTy = unapplyTy resTy
cRepArity = arity cRep
mbTvNames = map varTToName_maybe $
drop (length unapResTy - cRepArity) unapResTy
tvMap = Map.fromList
. catMaybes
$ zipWith (\mbTvName aux ->
fmap (\tvName -> (tvName, aux)) mbTvName)
mbTvNames auxs
if (any (`predMentionsName` Map.keys tvMap) ctxt
|| Map.size tvMap < cRepArity)
&& not (allowExQuant cRep)
then existentialContextError conName
else return (argTys, tvMap)
reifyConTys1 :: ClassRep a
=> a
-> [Name]
-> Name
-> Q ([Type], TyVarMap1)
reifyConTys1 cRep auxs = reifyConTys cRep (map OneName auxs)
reifyConTys2 :: ClassRep a
=> a
-> [(Name, Name)]
-> Name
-> Q ([Type], TyVarMap2)
reifyConTys2 cRep auxs = reifyConTys cRep (map (\(x, y) -> TwoNames x y) auxs)
noConstructorsError :: Q a
noConstructorsError = fail "Must have at least one data constructor"
derivingKindError :: ClassRep a => a -> Name -> Q b
derivingKindError cRep 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 "
. showString (pprint . createKindChain $ arity cRep)
$ ""
where
className :: String
className = nameBase $ fullClassName cRep
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"
$ ""
etaReductionError :: Type -> Q a
etaReductionError instanceType = fail $
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
++ pprint instanceType
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 :: ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError cRep conName = fail
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must only use its last "
. shows n
. showString " type variable(s) within the last "
. shows n
. showString " argument(s) of a data type"
$ ""
where
n :: Int
n = arity cRep
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.)"
$ ""
type TyVarMap a = Map Name (OneOrTwoNames a)
type TyVarMap1 = TyVarMap One
type TyVarMap2 = TyVarMap Two
data OneOrTwoNames a where
OneName :: Name -> OneOrTwoNames One
TwoNames :: Name -> Name -> OneOrTwoNames Two
data One
data Two
interleave :: [a] -> [a] -> [a]
interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s
interleave _ _ = []
#if MIN_VERSION_ghc_prim(0,3,1)
tagToEnum :: Int# -> Bool
tagToEnum x = tagToEnum# x
#else
tagToEnum :: Bool -> Bool
tagToEnum x = x
#endif
{-# INLINE tagToEnum #-}
isRight :: Either l r -> Bool
isRight Right{} = True; isRight _ = False
fromEither :: Either a a -> a
fromEither = either id id
filterByList :: [Bool] -> [a] -> [a]
filterByList (True:bs) (x:xs) = x : filterByList bs xs
filterByList (False:bs) (_:xs) = filterByList bs xs
filterByList _ _ = []
filterByLists :: [Bool] -> [a] -> [a] -> [a]
filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys
filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys
filterByLists _ _ _ = []
partitionByList :: [Bool] -> [a] -> ([a], [a])
partitionByList = go [] []
where
go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs
go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs
go trues falses _ _ = (reverse trues, reverse falses)
appEitherE :: Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
appEitherE e1Q e2Q = do
e2 <- e2Q
let e2' :: Exp -> Exp
e2' = (`AppE` e2)
either (Left . e2') (Right . e2') `fmap` e1Q
integerE :: Int -> Q Exp
integerE = litE . integerL . fromIntegral
hasKindStar :: Type -> Bool
hasKindStar VarT{} = True
#if MIN_VERSION_template_haskell(2,8,0)
hasKindStar (SigT _ StarT) = True
#else
hasKindStar (SigT _ StarK) = True
#endif
hasKindStar _ = False
isStarOrVar :: Kind -> Bool
#if MIN_VERSION_template_haskell(2,8,0)
isStarOrVar StarT = True
isStarOrVar VarT{} = True
#else
isStarOrVar StarK = True
#endif
isStarOrVar _ = False
tyVarNamesOfType :: Type -> [Name]
tyVarNamesOfType = go
where
go :: Type -> [Name]
go (AppT t1 t2) = go t1 ++ go t2
go (SigT t _k) = go t
#if MIN_VERSION_template_haskell(2,8,0)
++ go _k
#endif
go (VarT n) = [n]
go _ = []
tyVarNamesOfKind :: Kind -> [Name]
#if MIN_VERSION_template_haskell(2,8,0)
tyVarNamesOfKind = tyVarNamesOfType
#else
tyVarNamesOfKind _ = []
#endif
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain kindArrows t =
let uk = uncurryKind (tyKind t)
in if (length uk - 1 == kindArrows) && all isStarOrVar uk
then Just (concatMap tyVarNamesOfKind uk)
else Nothing
tyKind :: Type -> Kind
tyKind (SigT _ k) = k
tyKind _ = starK
stealKindForType :: TyVarBndr -> Type -> Type
stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)
stealKindForType _ t = t
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM f xs = concat `liftM` mapM f xs
zipWithAndUnzipM :: Monad m
=> (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])
zipWithAndUnzipM f (x:xs) (y:ys) = do
(c, d) <- f x y
(cs, ds) <- zipWithAndUnzipM f xs ys
return (c:cs, d:ds)
zipWithAndUnzipM _ _ _ = return ([], [])
{-# INLINE zipWithAndUnzipM #-}
zipWith3AndUnzipM :: Monad m
=> (a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c]
-> m ([d], [e])
zipWith3AndUnzipM f (x:xs) (y:ys) (z:zs) = do
(d, e) <- f x y z
(ds, es) <- zipWith3AndUnzipM f xs ys zs
return (d:ds, e:es)
zipWith3AndUnzipM _ _ _ _ = return ([], [])
{-# INLINE zipWith3AndUnzipM #-}
thd3 :: (a, b, c) -> c
thd3 (_, _, c) = c
constructorName :: Con -> Name
constructorName (NormalC name _ ) = name
constructorName (RecC name _ ) = name
constructorName (InfixC _ name _ ) = name
constructorName (ForallC _ _ con) = constructorName con
#if MIN_VERSION_template_haskell(2,11,0)
constructorName (GadtC names _ _) = head names
constructorName (RecGadtC names _ _) = head names
#endif
isNullaryCon :: Con -> Bool
isNullaryCon (NormalC _ []) = True
isNullaryCon (RecC _ []) = True
isNullaryCon InfixC{} = False
isNullaryCon (ForallC _ _ con) = isNullaryCon con
#if MIN_VERSION_template_haskell(2,11,0)
isNullaryCon (GadtC _ [] _) = True
isNullaryCon (RecGadtC _ [] _) = True
#endif
isNullaryCon _ = False
newNameList :: String -> Int -> Q [Name]
newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]
tvbKind :: TyVarBndr -> Kind
tvbKind (PlainTV _) = starK
tvbKind (KindedTV _ k) = k
tvbToType :: TyVarBndr -> Type
tvbToType (PlainTV n) = VarT n
tvbToType (KindedTV n k) = SigT (VarT n) k
applyClass :: Name -> Name -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
applyClass con t = AppT (ConT con) (VarT t)
#else
applyClass con t = ClassP con [VarT t]
#endif
createKindChain :: Int -> Kind
createKindChain = go starK
where
go :: Kind -> Int -> Kind
go k !0 = k
#if MIN_VERSION_template_haskell(2,8,0)
go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)
#else
go k !n = go (ArrowK StarK k) (n - 1)
#endif
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce remaining dropped =
all isTyVar dropped
&& allDistinct droppedNames
&& not (any (`mentionsName` droppedNames) remaining)
where
droppedNames :: [Name]
droppedNames = map varTToName dropped
conTToName :: Type -> Name
conTToName (ConT n) = n
conTToName (SigT t _) = conTToName t
conTToName _ = error "Not a type constructor!"
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe (VarT n) = Just n
varTToName_maybe (SigT t _) = varTToName_maybe t
varTToName_maybe _ = Nothing
varTToName :: Type -> Name
varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe
unSigT :: Type -> Type
unSigT (SigT t _) = t
unSigT t = t
isTyVar :: Type -> Bool
isTyVar (VarT _) = True
isTyVar (SigT t _) = isTyVar t
isTyVar _ = False
isTyFamily :: Type -> Q Bool
isTyFamily (ConT n) = do
info <- reify n
return $ case info of
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI OpenTypeFamilyD{} _ -> True
#elif MIN_VERSION_template_haskell(2,7,0)
FamilyI (FamilyD TypeFam _ _ _) _ -> True
#else
TyConI (FamilyD TypeFam _ _ _) -> True
#endif
#if MIN_VERSION_template_haskell(2,9,0)
FamilyI ClosedTypeFamilyD{} _ -> True
#endif
_ -> False
isTyFamily _ = return False
allDistinct :: Ord a => [a] -> Bool
allDistinct = allDistinct' Set.empty
where
allDistinct' :: Ord a => Set a -> [a] -> Bool
allDistinct' uniqs (x:xs)
| x `Set.member` uniqs = False
| otherwise = allDistinct' (Set.insert x uniqs) xs
allDistinct' _ _ = True
mentionsName :: Type -> [Name] -> Bool
mentionsName = go
where
go :: Type -> [Name] -> Bool
go (AppT t1 t2) names = go t1 names || go t2 names
go (SigT t _k) names = go t names
#if MIN_VERSION_template_haskell(2,8,0)
|| go _k names
#endif
go (VarT n) names = n `elem` names
go _ _ = False
predMentionsName :: Pred -> [Name] -> Bool
#if MIN_VERSION_template_haskell(2,10,0)
predMentionsName = mentionsName
#else
predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys
predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names
#endif
applyTy :: Type -> [Type] -> Type
applyTy = foldl' AppT
applyTyCon :: Name -> [Type] -> Type
applyTyCon = applyTy . ConT
unapplyTy :: Type -> [Type]
unapplyTy = reverse . go
where
go :: Type -> [Type]
go (AppT t1 t2) = t2:go t1
go (SigT t _) = go t
go (ForallT _ _ t) = go t
go t = [t]
uncurryTy :: Type -> (Cxt, [Type])
uncurryTy (AppT (AppT ArrowT t1) t2) =
let (ctxt, tys) = uncurryTy t2
in (ctxt, t1:tys)
uncurryTy (SigT t _) = uncurryTy t
uncurryTy (ForallT _ ctxt t) =
let (ctxt', tys) = uncurryTy t
in (ctxt ++ ctxt', tys)
uncurryTy t = ([], [t])
uncurryKind :: Kind -> [Kind]
#if MIN_VERSION_template_haskell(2,8,0)
uncurryKind = snd . uncurryTy
#else
uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2
uncurryKind k = [k]
#endif
untagExpr :: [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [] e = e
untagExpr ((untagThis, putTagHere) : more) e =
caseE (varE getTagValName `appE` varE untagThis)
[match (varP putTagHere)
(normalB $ untagExpr more e)
[]]
primOpAppExpr :: Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr e1 op e2 = varE tagToEnumValName `appE`
infixApp e1 (varE op) e2
isNonUnitTuple :: Name -> Bool
isNonUnitTuple = isNonUnitTupleString . nameBase
isNonUnitTupleString :: String -> Bool
isNonUnitTupleString ('(':',':_) = True
isNonUnitTupleString _ = False
derivingCompatPackageKey :: String
#ifdef CURRENT_PACKAGE_KEY
derivingCompatPackageKey = CURRENT_PACKAGE_KEY
#else
derivingCompatPackageKey = "deriving-compat-" ++ showVersion version
#endif
mkDerivingCompatName_v :: String -> Name
mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal"
fmapConstValName :: Name
fmapConstValName = mkDerivingCompatName_v "fmapConst"
foldrConstValName :: Name
foldrConstValName = mkDerivingCompatName_v "foldrConst"
foldMapConstValName :: Name
foldMapConstValName = mkDerivingCompatName_v "foldMapConst"
traverseConstValName :: Name
traverseConstValName = mkDerivingCompatName_v "traverseConst"
eqConstValName :: Name
eqConstValName = mkDerivingCompatName_v "eqConst"
eq1ConstValName :: Name
eq1ConstValName = mkDerivingCompatName_v "eq1Const"
liftEqConstValName :: Name
liftEqConstValName = mkDerivingCompatName_v "liftEqConst"
liftEq2ConstValName :: Name
liftEq2ConstValName = mkDerivingCompatName_v "liftEq2Const"
compareConstValName :: Name
compareConstValName = mkDerivingCompatName_v "compareConst"
ltConstValName :: Name
ltConstValName = mkDerivingCompatName_v "ltConst"
compare1ConstValName :: Name
compare1ConstValName = mkDerivingCompatName_v "compare1Const"
liftCompareConstValName :: Name
liftCompareConstValName = mkDerivingCompatName_v "liftCompareConst"
liftCompare2ConstValName :: Name
liftCompare2ConstValName = mkDerivingCompatName_v "liftCompare2Const"
readsPrecConstValName :: Name
readsPrecConstValName = mkDerivingCompatName_v "readsPrecConst"
readPrecConstValName :: Name
readPrecConstValName = mkDerivingCompatName_v "readPrecConst"
readsPrec1ConstValName :: Name
readsPrec1ConstValName = mkDerivingCompatName_v "readsPrec1Const"
liftReadsPrecConstValName :: Name
liftReadsPrecConstValName = mkDerivingCompatName_v "liftReadsPrecConst"
liftReadPrecConstValName :: Name
liftReadPrecConstValName = mkDerivingCompatName_v "liftReadPrecConst"
liftReadsPrec2ConstValName :: Name
liftReadsPrec2ConstValName = mkDerivingCompatName_v "liftReadsPrec2Const"
liftReadPrec2ConstValName :: Name
liftReadPrec2ConstValName = mkDerivingCompatName_v "liftReadPrec2Const"
showsPrecConstValName :: Name
showsPrecConstValName = mkDerivingCompatName_v "showsPrecConst"
showsPrec1ConstValName :: Name
showsPrec1ConstValName = mkDerivingCompatName_v "showsPrec1Const"
liftShowsPrecConstValName :: Name
liftShowsPrecConstValName = mkDerivingCompatName_v "liftShowsPrecConst"
liftShowsPrec2ConstValName :: Name
liftShowsPrec2ConstValName = mkDerivingCompatName_v "liftShowsPrec2Const"
tagToEnumValName :: Name
tagToEnumValName = mkDerivingCompatName_v "tagToEnum"
cHashDataName :: Name
cHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "C#"
dHashDataName :: Name
dHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "D#"
dualDataName :: Name
dualDataName = mkNameG_d "base" "Data.Monoid" "Dual"
endoDataName :: Name
endoDataName = mkNameG_d "base" "Data.Monoid" "Endo"
fHashDataName :: Name
fHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "F#"
identDataName :: Name
identDataName = mkNameG_d "base" "Text.Read.Lex" "Ident"
iHashDataName :: Name
iHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "I#"
puncDataName :: Name
puncDataName = mkNameG_d "base" "Text.Read.Lex" "Punc"
symbolDataName :: Name
symbolDataName = mkNameG_d "base" "Text.Read.Lex" "Symbol"
wrapMonadDataName :: Name
wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad"
addrHashTypeName :: Name
addrHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Addr#"
charHashTypeName :: Name
charHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Char#"
doubleHashTypeName :: Name
doubleHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Double#"
floatHashTypeName :: Name
floatHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Float#"
foldableTypeName :: Name
foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable"
functorTypeName :: Name
functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor"
intHashTypeName :: Name
intHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int#"
readTypeName :: Name
readTypeName = mkNameG_tc "base" "GHC.Read" "Read"
showTypeName :: Name
showTypeName = mkNameG_tc "base" "GHC.Show" "Show"
traversableTypeName :: Name
traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable"
wordHashTypeName :: Name
wordHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word#"
altValName :: Name
altValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "+++"
appEndoValName :: Name
appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo"
chooseValName :: Name
chooseValName = mkNameG_v "base" "GHC.Read" "choose"
composeValName :: Name
composeValName = mkNameG_v "base" "GHC.Base" "."
constValName :: Name
constValName = mkNameG_v "base" "GHC.Base" "const"
eqAddrHashValName :: Name
eqAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqAddr#"
eqCharHashValName :: Name
eqCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqChar#"
eqDoubleHashValName :: Name
eqDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==##"
eqFloatHashValName :: Name
eqFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqFloat#"
eqIntHashValName :: Name
eqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==#"
eqWordHashValName :: Name
eqWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord#"
errorValName :: Name
errorValName = mkNameG_v "base" "GHC.Err" "error"
flipValName :: Name
flipValName = mkNameG_v "base" "GHC.Base" "flip"
fmapValName :: Name
fmapValName = mkNameG_v "base" "GHC.Base" "fmap"
foldrValName :: Name
foldrValName = mkNameG_v "base" "Data.Foldable" "foldr"
foldMapValName :: Name
foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap"
geAddrHashValName :: Name
geAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geAddr#"
geCharHashValName :: Name
geCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geChar#"
geDoubleHashValName :: Name
geDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=##"
geFloatHashValName :: Name
geFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geFloat#"
geIntHashValName :: Name
geIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=#"
getDualValName :: Name
getDualValName = mkNameG_v "base" "Data.Monoid" "getDual"
getTagValName :: Name
getTagValName = mkNameG_v "base" "GHC.Base" "getTag"
geWordHashValName :: Name
geWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord#"
gtAddrHashValName :: Name
gtAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtAddr#"
gtCharHashValName :: Name
gtCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtChar#"
gtDoubleHashValName :: Name
gtDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">##"
gtFloatHashValName :: Name
gtFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtFloat#"
gtIntHashValName :: Name
gtIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">#"
gtWordHashValName :: Name
gtWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord#"
idValName :: Name
idValName = mkNameG_v "base" "GHC.Base" "id"
leAddrHashValName :: Name
leAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leAddr#"
leCharHashValName :: Name
leCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leChar#"
leDoubleHashValName :: Name
leDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=##"
leFloatHashValName :: Name
leFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leFloat#"
leIntHashValName :: Name
leIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=#"
leWordHashValName :: Name
leWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord#"
liftReadListPrecDefaultValName :: Name
liftReadListPrecDefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrecDefault"
liftReadListPrec2DefaultValName :: Name
liftReadListPrec2DefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2Default"
liftReadListPrecValName :: Name
liftReadListPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec"
liftReadListPrec2ValName :: Name
liftReadListPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2"
liftReadPrecValName :: Name
liftReadPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec"
liftReadPrec2ValName :: Name
liftReadPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec2"
listValName :: Name
listValName = mkNameG_v "base" "GHC.Read" "list"
ltAddrHashValName :: Name
ltAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltAddr#"
ltCharHashValName :: Name
ltCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltChar#"
ltDoubleHashValName :: Name
ltDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<##"
ltFloatHashValName :: Name
ltFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltFloat#"
ltIntHashValName :: Name
ltIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<#"
ltWordHashValName :: Name
ltWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord#"
parenValName :: Name
parenValName = mkNameG_v "base" "GHC.Read" "paren"
parensValName :: Name
parensValName = mkNameG_v "base" "GHC.Read" "parens"
pfailValName :: Name
pfailValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "pfail"
precValName :: Name
precValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "prec"
readListValName :: Name
readListValName = mkNameG_v "base" "GHC.Read" "readList"
readListPrecDefaultValName :: Name
readListPrecDefaultValName = mkNameG_v "base" "GHC.Read" "readListPrecDefault"
readListPrecValName :: Name
readListPrecValName = mkNameG_v "base" "GHC.Read" "readListPrec"
readPrec_to_SValName :: Name
readPrec_to_SValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readPrec_to_S"
readPrecValName :: Name
readPrecValName = mkNameG_v "base" "GHC.Read" "readPrec"
readS_to_PrecValName :: Name
readS_to_PrecValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readS_to_Prec"
readsPrecValName :: Name
readsPrecValName = mkNameG_v "base" "GHC.Read" "readsPrec"
resetValName :: Name
resetValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "reset"
returnValName :: Name
returnValName = mkNameG_v "base" "GHC.Base" "return"
showCharValName :: Name
showCharValName = mkNameG_v "base" "GHC.Show" "showChar"
showListValName :: Name
showListValName = mkNameG_v "base" "GHC.Show" "showList"
showListWithValName :: Name
showListWithValName = mkNameG_v "base" "Text.Show" "showListWith"
showParenValName :: Name
showParenValName = mkNameG_v "base" "GHC.Show" "showParen"
showsPrecValName :: Name
showsPrecValName = mkNameG_v "base" "GHC.Show" "showsPrec"
showSpaceValName :: Name
showSpaceValName = mkNameG_v "base" "GHC.Show" "showSpace"
showStringValName :: Name
showStringValName = mkNameG_v "base" "GHC.Show" "showString"
stepValName :: Name
stepValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "step"
traverseValName :: Name
traverseValName = mkNameG_v "base" "Data.Traversable" "traverse"
unwrapMonadValName :: Name
unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad"
#if MIN_VERSION_base(4,4,0)
boolTypeName :: Name
boolTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Bool"
falseDataName :: Name
falseDataName = mkNameG_v "ghc-prim" "GHC.Types" "False"
trueDataName :: Name
trueDataName = mkNameG_v "ghc-prim" "GHC.Types" "True"
#else
boolTypeName :: Name
boolTypeName = mkNameG_tc "ghc-prim" "GHC.Bool" "Bool"
falseDataName :: Name
falseDataName = mkNameG_v "ghc-prim" "GHC.Bool" "False"
trueDataName :: Name
trueDataName = mkNameG_v "ghc-prim" "GHC.Bool" "True"
#endif
#if MIN_VERSION_base(4,5,0)
eqDataName :: Name
eqDataName = mkNameG_d "ghc-prim" "GHC.Types" "EQ"
gtDataName :: Name
gtDataName = mkNameG_d "ghc-prim" "GHC.Types" "GT"
ltDataName :: Name
ltDataName = mkNameG_d "ghc-prim" "GHC.Types" "LT"
eqTypeName :: Name
eqTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Eq"
ordTypeName :: Name
ordTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Ord"
andValName :: Name
andValName = mkNameG_v "ghc-prim" "GHC.Classes" "&&"
compareValName :: Name
compareValName = mkNameG_v "ghc-prim" "GHC.Classes" "compare"
eqValName :: Name
eqValName = mkNameG_v "ghc-prim" "GHC.Classes" "=="
geValName :: Name
geValName = mkNameG_v "ghc-prim" "GHC.Classes" "<="
gtValName :: Name
gtValName = mkNameG_v "ghc-prim" "GHC.Classes" "<"
leValName :: Name
leValName = mkNameG_v "ghc-prim" "GHC.Classes" ">="
ltValName :: Name
ltValName = mkNameG_v "ghc-prim" "GHC.Classes" ">"
notValName :: Name
notValName = mkNameG_v "ghc-prim" "GHC.Classes" "not"
#else
eqDataName :: Name
eqDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "EQ"
gtDataName :: Name
gtDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "GT"
ltDataName :: Name
ltDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "LT"
eqTypeName :: Name
eqTypeName = mkNameG_tc "base" "GHC.Classes" "Eq"
ordTypeName :: Name
ordTypeName = mkNameG_tc "base" "GHC.Classes" "Ord"
andValName :: Name
andValName = mkNameG_v "base" "GHC.Classes" "&&"
compareValName :: Name
compareValName = mkNameG_v "base" "GHC.Classes" "compare"
eqValName :: Name
eqValName = mkNameG_v "base" "GHC.Classes" "=="
geValName :: Name
geValName = mkNameG_v "base" "GHC.Classes" "<="
gtValName :: Name
gtValName = mkNameG_v "base" "GHC.Classes" "<"
leValName :: Name
leValName = mkNameG_v "base" "GHC.Classes" ">="
ltValName :: Name
ltValName = mkNameG_v "base" "GHC.Classes" ">"
notValName :: Name
notValName = mkNameG_v "base" "GHC.Classes" "not"
#endif
#if MIN_VERSION_base(4,6,0)
wHashDataName :: Name
wHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "W#"
#else
wHashDataName :: Name
wHashDataName = mkNameG_d "base" "GHC.Word" "W#"
#endif
#if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,9,0))
starKindName :: Name
starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"
#endif
#if MIN_VERSION_base(4,7,0)
expectPValName :: Name
expectPValName = mkNameG_v "base" "GHC.Read" "expectP"
#else
expectP :: Lexeme -> ReadPrec ()
expectP lexeme = do
thing <- lexP
if thing == lexeme then return () else pfail
expectPValName :: Name
expectPValName = mkDerivingCompatName_v "expectP"
#endif
#if MIN_VERSION_base(4,8,0)
pureValName :: Name
pureValName = mkNameG_v "base" "GHC.Base" "pure"
apValName :: Name
apValName = mkNameG_v "base" "GHC.Base" "<*>"
mappendValName :: Name
mappendValName = mkNameG_v "base" "GHC.Base" "mappend"
memptyValName :: Name
memptyValName = mkNameG_v "base" "GHC.Base" "mempty"
#else
pureValName :: Name
pureValName = mkNameG_v "base" "Control.Applicative" "pure"
apValName :: Name
apValName = mkNameG_v "base" "Control.Applicative" "<*>"
mappendValName :: Name
mappendValName = mkNameG_v "base" "Data.Monoid" "mappend"
memptyValName :: Name
memptyValName = mkNameG_v "base" "Data.Monoid" "mempty"
#endif
#if MIN_VERSION_base(4,9,0)
eq1TypeName :: Name
eq1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq1"
eq2TypeName :: Name
eq2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq2"
liftEqValName :: Name
liftEqValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq"
liftEq2ValName :: Name
liftEq2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq2"
ord1TypeName :: Name
ord1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord1"
ord2TypeName :: Name
ord2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord2"
liftCompareValName :: Name
liftCompareValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare"
liftCompare2ValName :: Name
liftCompare2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare2"
read1TypeName :: Name
read1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read1"
read2TypeName :: Name
read2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read2"
liftReadsPrecValName :: Name
liftReadsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec"
liftReadListValName :: Name
liftReadListValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList"
liftReadsPrec2ValName :: Name
liftReadsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec2"
liftReadList2ValName :: Name
liftReadList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList2"
show1TypeName :: Name
show1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show1"
show2TypeName :: Name
show2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show2"
liftShowListValName :: Name
liftShowListValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList"
liftShowsPrecValName :: Name
liftShowsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec"
liftShowList2ValName :: Name
liftShowList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList2"
liftShowsPrec2ValName :: Name
liftShowsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec2"
#else
# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)
eq1TypeName :: Name
eq1TypeName = ''Eq1
eq2TypeName :: Name
eq2TypeName = ''Eq2
liftEqValName :: Name
liftEqValName = 'liftEq
liftEq2ValName :: Name
liftEq2ValName = 'liftEq2
ord1TypeName :: Name
ord1TypeName = ''Ord1
ord2TypeName :: Name
ord2TypeName = ''Ord2
liftCompareValName :: Name
liftCompareValName = 'liftCompare
liftCompare2ValName :: Name
liftCompare2ValName = 'liftCompare2
read1TypeName :: Name
read1TypeName = ''Read1
read2TypeName :: Name
read2TypeName = ''Read2
liftReadsPrecValName :: Name
liftReadsPrecValName = 'liftReadsPrec
liftReadListValName :: Name
liftReadListValName = 'liftReadList
liftReadsPrec2ValName :: Name
liftReadsPrec2ValName = 'liftReadsPrec2
liftReadList2ValName :: Name
liftReadList2ValName = 'liftReadList2
show1TypeName :: Name
show1TypeName = ''Show1
show2TypeName :: Name
show2TypeName = ''Show2
liftShowListValName :: Name
liftShowListValName = 'liftShowList
liftShowsPrecValName :: Name
liftShowsPrecValName = 'liftShowsPrec
liftShowList2ValName :: Name
liftShowList2ValName = 'liftShowList2
liftShowsPrec2ValName :: Name
liftShowsPrec2ValName = 'liftShowsPrec2
# else
eq1TypeName :: Name
eq1TypeName = ''Eq1
eq1ValName :: Name
eq1ValName = 'eq1
ord1TypeName :: Name
ord1TypeName = ''Ord1
compare1ValName :: Name
compare1ValName = 'compare1
read1TypeName :: Name
read1TypeName = ''Read1
readsPrec1ValName :: Name
readsPrec1ValName = 'readsPrec1
show1TypeName :: Name
show1TypeName = ''Show1
showsPrec1ValName :: Name
showsPrec1ValName = 'showsPrec1
newtype Apply f a = Apply { unApply :: f a }
instance (Eq1 f, Eq a) => Eq (Apply f a) where
Apply x == Apply y = eq1 x y
instance (Ord1 g, Ord a) => Ord (Apply g a) where
compare (Apply x) (Apply y) = compare1 x y
instance (Read1 f, Read a) => Read (Apply f a) where
readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s]
instance (Show1 f, Show a) => Show (Apply f a) where
showsPrec p (Apply x) = showsPrec1 p x
makeFmapApplyNeg :: ClassRep a => a -> Name -> Type -> Name -> Q Exp
makeFmapApplyNeg = makeFmapApply False
makeFmapApplyPos :: ClassRep a => a -> Name -> Type -> Name -> Q Exp
makeFmapApplyPos = makeFmapApply True
makeFmapApply :: ClassRep a => Bool -> a -> Name -> Type -> Name -> Q Exp
makeFmapApply pos cRep conName (SigT ty _) name = makeFmapApply pos cRep conName ty name
makeFmapApply pos cRep conName t name = do
let tyCon :: Type
tyArgs :: [Type]
tyCon:tyArgs = unapplyTy t
numLastArgs :: Int
numLastArgs = min (arity cRep) (length tyArgs)
lhsArgs, rhsArgs :: [Type]
(lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs
inspectTy :: Type -> Q Exp
inspectTy (SigT ty _) = inspectTy ty
inspectTy (VarT a) | a == name = varE idValName
inspectTy beta = varE fmapValName `appE`
infixApp (if pos then makeFmapApply pos cRep conName beta name
else conE applyDataName)
(varE composeValName)
(if pos then varE unApplyValName
else makeFmapApply pos cRep conName beta name)
itf <- isTyFamily tyCon
if any (`mentionsName` [name]) lhsArgs
|| itf && any (`mentionsName` [name]) tyArgs
then outOfPlaceTyVarError cRep conName
else inspectTy (head rhsArgs)
applyDataName :: Name
applyDataName = mkNameG_d derivingCompatPackageKey "Data.Deriving.Internal" "Apply"
unApplyValName :: Name
unApplyValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "unApply"
# endif
#endif