{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeSynonymInstances #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.TH.Lift
( deriveLift
, deriveLiftMany
, deriveLift'
, deriveLiftMany'
, makeLift
, makeLift'
, Lift(..)
) where
import GHC.Base (unpackCString#)
import GHC.Exts (Double(..), Float(..), Int(..), Word(..))
import GHC.Prim (Addr#, Double#, Float#, Int#, Word#)
#if MIN_VERSION_template_haskell(2,11,0)
import GHC.Exts (Char(..))
import GHC.Prim (Char#)
#endif /* !(MIN_VERSION_template_haskell(2,11,0)) */
#if MIN_VERSION_template_haskell(2,8,0)
import Data.Char (ord)
#endif /* !(MIN_VERSION_template_haskell(2,8,0)) */
import Language.Haskell.TH
import Language.Haskell.TH.Datatype
import qualified Language.Haskell.TH.Lib as Lib (starK)
import Language.Haskell.TH.Syntax
import Control.Monad ((<=<), zipWithM)
#if MIN_VERSION_template_haskell(2,9,0)
import Data.Maybe (catMaybes)
#endif /* MIN_VERSION_template_haskell(2,9,0) */
deriveLift :: Name -> Q [Dec]
#if MIN_VERSION_template_haskell(2,9,0)
deriveLift :: Name -> Q [Dec]
deriveLift Name
name = do
[Role]
roles <- Name -> Q [Role]
reifyDatatypeRoles Name
name
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
(Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Q Dec -> Q [Dec]) -> Q Dec -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Role] -> DatatypeInfo -> Q Dec
deriveLiftOne [Role]
roles DatatypeInfo
info
#else
deriveLift = fmap (:[]) . deriveLiftOne <=< reifyDatatype
#endif
deriveLiftMany :: [Name] -> Q [Dec]
#if MIN_VERSION_template_haskell(2,9,0)
deriveLiftMany :: [Name] -> Q [Dec]
deriveLiftMany [Name]
names = do
[[Role]]
roles <- (Name -> Q [Role]) -> [Name] -> Q [[Role]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q [Role]
reifyDatatypeRoles [Name]
names
[DatatypeInfo]
infos <- (Name -> Q DatatypeInfo) -> [Name] -> Q [DatatypeInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q DatatypeInfo
reifyDatatype [Name]
names
(([Role], DatatypeInfo) -> Q Dec)
-> [([Role], DatatypeInfo)] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([Role] -> DatatypeInfo -> Q Dec)
-> ([Role], DatatypeInfo) -> Q Dec
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Role] -> DatatypeInfo -> Q Dec
deriveLiftOne) ([([Role], DatatypeInfo)] -> Q [Dec])
-> [([Role], DatatypeInfo)] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Role]] -> [DatatypeInfo] -> [([Role], DatatypeInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Role]]
roles [DatatypeInfo]
infos
#else
deriveLiftMany = mapM deriveLiftOne <=< mapM reifyDatatype
#endif
#if MIN_VERSION_template_haskell(2,9,0)
deriveLift' :: [Role] -> Info -> Q [Dec]
deriveLift' :: [Role] -> Info -> Q [Dec]
deriveLift' [Role]
roles = (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Q Dec -> Q [Dec])
-> (DatatypeInfo -> Q Dec) -> DatatypeInfo -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Role] -> DatatypeInfo -> Q Dec
deriveLiftOne [Role]
roles (DatatypeInfo -> Q [Dec])
-> (Info -> Q DatatypeInfo) -> Info -> Q [Dec]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Info -> Q DatatypeInfo
normalizeInfo
deriveLiftMany' :: [([Role], Info)] -> Q [Dec]
deriveLiftMany' :: [([Role], Info)] -> Q [Dec]
deriveLiftMany' = (([Role], Info) -> Q Dec) -> [([Role], Info)] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\([Role]
rs, Info
i) -> [Role] -> DatatypeInfo -> Q Dec
deriveLiftOne [Role]
rs (DatatypeInfo -> Q Dec) -> Q DatatypeInfo -> Q Dec
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Info -> Q DatatypeInfo
normalizeInfo Info
i)
#else
deriveLift' :: Info -> Q [Dec]
deriveLift' = fmap (:[]) . deriveLiftOne <=< normalizeInfo
deriveLiftMany' :: [Info] -> Q [Dec]
deriveLiftMany' = mapM (deriveLiftOne <=< normalizeInfo)
#endif
makeLift :: Name -> Q Exp
makeLift :: Name -> Q Exp
makeLift = DatatypeInfo -> Q Exp
makeLiftInternal (DatatypeInfo -> Q Exp)
-> (Name -> Q DatatypeInfo) -> Name -> Q Exp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q DatatypeInfo
reifyDatatype
makeLift' :: Info -> Q Exp
makeLift' :: Info -> Q Exp
makeLift' = DatatypeInfo -> Q Exp
makeLiftInternal (DatatypeInfo -> Q Exp)
-> (Info -> Q DatatypeInfo) -> Info -> Q Exp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Info -> Q DatatypeInfo
normalizeInfo
makeLiftInternal :: DatatypeInfo -> Q Exp
makeLiftInternal :: DatatypeInfo -> Q Exp
makeLiftInternal DatatypeInfo
i = DatatypeInfo
-> (Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q Exp) -> Q Exp
forall a.
DatatypeInfo
-> (Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q a) -> Q a
withInfo DatatypeInfo
i ((Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q Exp) -> Q Exp)
-> (Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Cxt
_ Name
n Cxt
_ [ConstructorInfo]
cons -> Name -> [ConstructorInfo] -> Q Exp
makeLiftOne Name
n [ConstructorInfo]
cons
#if MIN_VERSION_template_haskell(2,9,0)
deriveLiftOne :: [Role] -> DatatypeInfo -> Q Dec
deriveLiftOne :: [Role] -> DatatypeInfo -> Q Dec
deriveLiftOne [Role]
roles DatatypeInfo
i = DatatypeInfo
-> (Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q Dec) -> Q Dec
forall a.
DatatypeInfo
-> (Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q a) -> Q a
withInfo DatatypeInfo
i Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q Dec
liftInstance
#else
deriveLiftOne :: DatatypeInfo -> Q Dec
deriveLiftOne i = withInfo i liftInstance
#endif
where
liftInstance :: Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q Dec
liftInstance Cxt
dcx Name
n Cxt
tys [ConstructorInfo]
cons = do
#if MIN_VERSION_template_haskell(2,9,0)
let phtys :: Cxt
phtys = [Maybe Type] -> Cxt
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Type] -> Cxt) -> [Maybe Type] -> Cxt
forall a b. (a -> b) -> a -> b
$
(Type -> Role -> Maybe Type) -> Cxt -> [Role] -> [Maybe Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Type
t Role
role -> if Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
PhantomR then Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t else Maybe Type
forall a. Maybe a
Nothing)
Cxt
tys
[Role]
roles
#else /* MIN_VERSION_template_haskell(2,9,0) */
let phtys = []
#endif
CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> Cxt -> Cxt -> CxtQ
forall (t :: * -> *). Foldable t => Cxt -> t Type -> Cxt -> CxtQ
ctxt Cxt
dcx Cxt
phtys Cxt
tys)
(Name -> TypeQ
conT ''Lift TypeQ -> TypeQ -> TypeQ
`appT` Name -> Cxt -> TypeQ
typ Name
n Cxt
tys)
[ Name -> [ClauseQ] -> Q Dec
funD 'lift [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (Q Exp -> BodyQ
normalB (Name -> [ConstructorInfo] -> Q Exp
makeLiftOne Name
n [ConstructorInfo]
cons)) []]
#if MIN_VERSION_template_haskell(2,16,0)
, Name -> [ClauseQ] -> Q Dec
funD 'liftTyped [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (Q Exp -> BodyQ
normalB [| unsafeTExpCoerce . lift |]) []]
#endif
]
typ :: Name -> Cxt -> TypeQ
typ Name
n = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
n) ([TypeQ] -> TypeQ) -> (Cxt -> [TypeQ]) -> Cxt -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *). Monad m => Type -> m Type
unKind
ctxt :: Cxt -> t Type -> Cxt -> CxtQ
ctxt Cxt
dcx t Type
phtys =
(Cxt -> Cxt) -> CxtQ -> CxtQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Cxt
dcx Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++) (CxtQ -> CxtQ) -> (Cxt -> CxtQ) -> Cxt -> CxtQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeQ] -> CxtQ
cxt ([TypeQ] -> CxtQ) -> (Cxt -> [TypeQ]) -> Cxt -> CxtQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> [TypeQ]) -> Cxt -> [TypeQ]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [TypeQ]
liftPred (Cxt -> [TypeQ]) -> (Cxt -> Cxt) -> Cxt -> [TypeQ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Bool) -> Cxt -> Cxt
forall a. (a -> Bool) -> [a] -> [a]
filter (Type -> t Type -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t Type
phtys)
liftPred :: Type -> [TypeQ]
liftPred Type
ty =
case Type
ty of
SigT Type
t Type
k
| Type
k Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
Lib.starK -> Type -> [TypeQ]
mkLift Type
t
| Bool
otherwise -> []
Type
_ -> Type -> [TypeQ]
mkLift Type
ty
#if MIN_VERSION_template_haskell(2,10,0)
mkLift :: Type -> [TypeQ]
mkLift Type
ty = [Name -> TypeQ
conT ''Lift TypeQ -> TypeQ -> TypeQ
`appT` (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)]
#else
mkLift ty = [classP ''Lift [return ty]]
#endif
unKind :: Type -> m Type
unKind (SigT Type
t Type
k)
| Type
k Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
Lib.starK = Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
unKind Type
t = Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
makeLiftOne :: Name -> [ConstructorInfo] -> Q Exp
makeLiftOne :: Name -> [ConstructorInfo] -> Q Exp
makeLiftOne Name
n [ConstructorInfo]
cons = do
Name
e <- String -> Q Name
newName String
"e"
PatQ -> Q Exp -> Q Exp
lam1E (Name -> PatQ
varP Name
e) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
e) ([MatchQ] -> Q Exp) -> [MatchQ] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> [ConstructorInfo] -> [MatchQ]
consMatches Name
n [ConstructorInfo]
cons
consMatches :: Name -> [ConstructorInfo] -> [Q Match]
consMatches :: Name -> [ConstructorInfo] -> [MatchQ]
consMatches Name
n [] = [PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (Q Exp -> BodyQ
normalB Q Exp
e) []]
where
e :: Q Exp
e = Name -> Q Exp
varE 'errorQExp Q Exp -> Q Exp -> Q Exp
`appE` (String -> Q Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Can't lift value of empty datatype " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
n)
consMatches Name
_ [ConstructorInfo]
cons = (ConstructorInfo -> [MatchQ]) -> [ConstructorInfo] -> [MatchQ]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructorInfo -> [MatchQ]
doCons [ConstructorInfo]
cons
doCons :: ConstructorInfo -> [Q Match]
doCons :: ConstructorInfo -> [MatchQ]
doCons (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
c
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
ts
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
variant
}) = (MatchQ -> [MatchQ] -> [MatchQ]
forall a. a -> [a] -> [a]
:[]) (MatchQ -> [MatchQ]) -> MatchQ -> [MatchQ]
forall a b. (a -> b) -> a -> b
$ do
[Name]
ns <- (Type -> Int -> Q Name) -> Cxt -> [Int] -> Q [Name]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Type
_ Int
i -> String -> Q Name
newName (Char
'x'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show (Int
i :: Int))) Cxt
ts [Int
0..]
let con :: Q Exp
con = [| conE c |]
case (ConstructorVariant
variant, [Name]
ns, Cxt
ts) of
(ConstructorVariant
InfixConstructor, [Name
x0, Name
x1], [Type
t0, Type
t1]) ->
let e :: Q Exp
e = Name -> Q Exp
varE 'infixApp Q Exp -> Q Exp -> Q Exp
`appE` Name -> Type -> Q Exp
liftVar Name
x0 Type
t0 Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
con Q Exp -> Q Exp -> Q Exp
`appE` Name -> Type -> Q Exp
liftVar Name
x1 Type
t1
in PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (PatQ -> Name -> PatQ -> PatQ
infixP (Name -> PatQ
varP Name
x0) Name
c (Name -> PatQ
varP Name
x1)) (Q Exp -> BodyQ
normalB Q Exp
e) []
(ConstructorVariant
_, [Name]
_, Cxt
_) ->
let e :: Q Exp
e = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
e1 Q Exp
e2 -> Name -> Q Exp
varE 'appE Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
e1 Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
e2) Q Exp
con ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Type -> Q Exp) -> [Name] -> Cxt -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Type -> Q Exp
liftVar [Name]
ns Cxt
ts
in PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
c ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
ns)) (Q Exp -> BodyQ
normalB Q Exp
e) []
#if MIN_VERSION_template_haskell(2,9,0)
reifyDatatypeRoles :: Name -> Q [Role]
reifyDatatypeRoles :: Name -> Q [Role]
reifyDatatypeRoles Name
n = do
DatatypeInfo { datatypeName :: DatatypeInfo -> Name
datatypeName = Name
dn } <- Name -> Q DatatypeInfo
reifyDatatype Name
n
Name -> Q [Role]
forall (m :: * -> *). Quasi m => Name -> m [Role]
qReifyRoles Name
dn
#endif
liftVar :: Name -> Type -> Q Exp
liftVar :: Name -> Type -> Q Exp
liftVar Name
varName (ConT Name
tyName)
#if MIN_VERSION_template_haskell(2,8,0)
| Name
tyName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Addr# = [Q Exp] -> Q Exp
apps
[ Name -> Q Exp
varE 'litE, Name -> Q Exp
varE 'stringPrimL
, Name -> Q Exp
varE 'map Q Exp -> Q Exp -> Q Exp
`appE`
Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE 'fromIntegral) (Name -> Q Exp
varE '(.)) (Name -> Q Exp
varE 'ord)
, Name -> Q Exp
varE 'unpackCString# ]
#else /* !(MIN_VERSION_template_haskell(2,8,0)) */
| tyName == ''Addr# = apps
[ varE 'litE, varE 'stringPrimL, varE 'unpackCString# ]
#endif
#if MIN_VERSION_template_haskell(2,11,0)
| Name
tyName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Char# = [Q Exp] -> Q Exp
apps [ Name -> Q Exp
varE 'litE, Name -> Q Exp
varE 'charPrimL, Name -> Q Exp
conE 'C# ]
#endif /* !(MIN_VERSION_template_haskell(2,11,0)) */
| Name
tyName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Double# = [Q Exp] -> Q Exp
apps [ Name -> Q Exp
varE 'litE, Name -> Q Exp
varE 'doublePrimL, Name -> Q Exp
varE 'toRational, Name -> Q Exp
conE 'D# ]
| Name
tyName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Float# = [Q Exp] -> Q Exp
apps [ Name -> Q Exp
varE 'litE, Name -> Q Exp
varE 'floatPrimL, Name -> Q Exp
varE 'toRational, Name -> Q Exp
conE 'F# ]
| Name
tyName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Int# = [Q Exp] -> Q Exp
apps [ Name -> Q Exp
varE 'litE, Name -> Q Exp
varE 'intPrimL, Name -> Q Exp
varE 'toInteger, Name -> Q Exp
conE 'I# ]
| Name
tyName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Word# = [Q Exp] -> Q Exp
apps [ Name -> Q Exp
varE 'litE, Name -> Q Exp
varE 'wordPrimL, Name -> Q Exp
varE 'toInteger, Name -> Q Exp
conE 'W# ]
where
apps :: [Q Exp] -> Q Exp
apps = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Q Exp -> Q Exp -> Q Exp
appE Q Exp
var
var :: Q Exp
var :: Q Exp
var = Name -> Q Exp
varE Name
varName
liftVar Name
varName Type
_ = Name -> Q Exp
varE 'lift Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
varName
withInfo :: DatatypeInfo
-> (Cxt -> Name -> [Type] -> [ConstructorInfo] -> Q a)
-> Q a
withInfo :: DatatypeInfo
-> (Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q a) -> Q a
withInfo DatatypeInfo
i Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q a
f = case DatatypeInfo
i of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
dcx
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
n
#if MIN_VERSION_th_abstraction(0,3,0)
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
vs
#else
, datatypeVars = vs
#endif
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} ->
Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q a
f Cxt
dcx Name
n Cxt
vs [ConstructorInfo]
cons
errorQExp :: String -> Q Exp
errorQExp :: String -> Q Exp
errorQExp = String -> Q Exp
forall a. HasCallStack => String -> a
error
{-# INLINE errorQExp #-}
instance Lift Name where
lift :: Name -> Q Exp
lift (Name OccName
occName NameFlavour
nameFlavour) = [| Name occName nameFlavour |]
#if MIN_VERSION_template_haskell(2,16,0)
liftTyped :: Name -> Q (TExp Name)
liftTyped = Q Exp -> Q (TExp Name)
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp Name))
-> (Name -> Q Exp) -> Name -> Q (TExp Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif
instance Lift OccName where
lift :: OccName -> Q Exp
lift OccName
n = [| mkOccName |] Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
forall t. Lift t => t -> Q Exp
lift (OccName -> String
occString OccName
n)
#if MIN_VERSION_template_haskell(2,16,0)
liftTyped :: OccName -> Q (TExp OccName)
liftTyped = Q Exp -> Q (TExp OccName)
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp OccName))
-> (OccName -> Q Exp) -> OccName -> Q (TExp OccName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif
instance Lift PkgName where
lift :: PkgName -> Q Exp
lift PkgName
n = [| mkPkgName |] Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
forall t. Lift t => t -> Q Exp
lift (PkgName -> String
pkgString PkgName
n)
#if MIN_VERSION_template_haskell(2,16,0)
liftTyped :: PkgName -> Q (TExp PkgName)
liftTyped = Q Exp -> Q (TExp PkgName)
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp PkgName))
-> (PkgName -> Q Exp) -> PkgName -> Q (TExp PkgName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgName -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif
instance Lift ModName where
lift :: ModName -> Q Exp
lift ModName
n = [| mkModName |] Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
forall t. Lift t => t -> Q Exp
lift (ModName -> String
modString ModName
n)
#if MIN_VERSION_template_haskell(2,16,0)
liftTyped :: ModName -> Q (TExp ModName)
liftTyped = Q Exp -> Q (TExp ModName)
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp ModName))
-> (ModName -> Q Exp) -> ModName -> Q (TExp ModName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModName -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif
instance Lift NameFlavour where
lift :: NameFlavour -> Q Exp
lift NameFlavour
NameS = [| NameS |]
lift (NameQ ModName
modnam) = [| NameQ modnam |]
#if __GLASGOW_HASKELL__ >= 710
lift (NameU Uniq
i) = [| NameU i |]
lift (NameL Uniq
i) = [| NameL i |]
#else /* __GLASGOW_HASKELL__ < 710 */
lift (NameU i) = [| case $( lift (I# i) ) of
I# i' -> NameU i' |]
lift (NameL i) = [| case $( lift (I# i) ) of
I# i' -> NameL i' |]
#endif /* __GLASGOW_HASKELL__ < 710 */
lift (NameG NameSpace
nameSpace' PkgName
pkgName ModName
modnam)
= [| NameG nameSpace' pkgName modnam |]
#if MIN_VERSION_template_haskell(2,16,0)
liftTyped :: NameFlavour -> Q (TExp NameFlavour)
liftTyped = Q Exp -> Q (TExp NameFlavour)
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp NameFlavour))
-> (NameFlavour -> Q Exp) -> NameFlavour -> Q (TExp NameFlavour)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameFlavour -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif
instance Lift NameSpace where
lift :: NameSpace -> Q Exp
lift NameSpace
VarName = [| VarName |]
lift NameSpace
DataName = [| DataName |]
lift NameSpace
TcClsName = [| TcClsName |]
#if MIN_VERSION_template_haskell(2,16,0)
liftTyped :: NameSpace -> Q (TExp NameSpace)
liftTyped = Q Exp -> Q (TExp NameSpace)
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp NameSpace))
-> (NameSpace -> Q Exp) -> NameSpace -> Q (TExp NameSpace)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif