{-# 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 as Datatype
import qualified Language.Haskell.TH.Lib as Lib (starK)
import Language.Haskell.TH.Lift.Internal
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 a b. (a -> b) -> Q a -> Q b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a b. (a -> b) -> Q a -> Q b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
Name
_x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (Cxt -> Cxt -> Cxt -> Q Cxt
forall {f :: * -> *} {t :: * -> *}.
(Quote f, Foldable t) =>
Cxt -> t Type -> Cxt -> f Cxt
ctxt Cxt
dcx Cxt
phtys Cxt
tys)
(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Lift Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Cxt -> Q Type
forall {m :: * -> *}. Quote m => Name -> Cxt -> m Type
typ Name
n Cxt
tys)
[ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'lift [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> [ConstructorInfo] -> Q Exp
makeLiftOne Name
n [ConstructorInfo]
cons)) []]
#if MIN_VERSION_template_haskell(2,16,0)
, let rhs :: Q Exp
rhs = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'unsafeSpliceCoerce Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'lift Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_x) in
Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'liftTyped [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_x] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
rhs) []]
#endif
]
typ :: Name -> Cxt -> m Type
typ Name
n = (m Type -> m Type -> m Type) -> m Type -> [m Type] -> m Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
n) ([m Type] -> m Type) -> (Cxt -> [m Type]) -> Cxt -> m Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> m Type) -> Cxt -> [m Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> m Type
forall {m :: * -> *}. Monad m => Type -> m Type
unKind
ctxt :: Cxt -> t Type -> Cxt -> f Cxt
ctxt Cxt
dcx t Type
phtys =
(Cxt -> Cxt) -> f Cxt -> f Cxt
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Cxt
dcx Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++) (f Cxt -> f Cxt) -> (Cxt -> f Cxt) -> Cxt -> f Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [f Type] -> f Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt ([f Type] -> f Cxt) -> (Cxt -> [f Type]) -> Cxt -> f Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> [f Type]) -> Cxt -> [f Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [f Type]
forall {m :: * -> *}. Quote m => Type -> [m Type]
liftPred (Cxt -> [f Type]) -> (Cxt -> Cxt) -> Cxt -> [f Type]
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 -> [m Type]
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 -> [m Type]
forall {m :: * -> *}. Quote m => Type -> [m Type]
mkLift Type
t
| Bool
otherwise -> []
Type
_ -> Type -> [m Type]
forall {m :: * -> *}. Quote m => Type -> [m Type]
mkLift Type
ty
#if MIN_VERSION_template_haskell(2,10,0)
mkLift :: Type -> [m Type]
mkLift Type
ty = [Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Lift m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Type -> m Type
forall a. a -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
unKind Type
t = Type -> m Type
forall a. a -> m a
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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"e"
Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
e) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
e) ([Q Match] -> Q Exp) -> [Q Match] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> [ConstructorInfo] -> [Q Match]
consMatches Name
n [ConstructorInfo]
cons
consMatches :: Name -> [ConstructorInfo] -> [Q Match]
consMatches :: Name -> [ConstructorInfo] -> [Q Match]
consMatches Name
n [] = [Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
e) []]
where
e :: Q Exp
e = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'errorQuoteExp Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m 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 -> [Q Match]) -> [ConstructorInfo] -> [Q Match]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructorInfo -> [Q Match]
doCons [ConstructorInfo]
cons
doCons :: ConstructorInfo -> [Q Match]
doCons :: ConstructorInfo -> [Q Match]
doCons (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
c
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
ts
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
variant
}) = (Q Match -> [Q Match] -> [Q Match]
forall a. a -> [a] -> [a]
:[]) (Q Match -> [Q Match]) -> Q Match -> [Q Match]
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
forall (m :: * -> *). Quote m => String -> m 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
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'infixApp Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Type -> Q Exp
liftVar Name
x0 Type
t0 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
con Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Type -> Q Exp
liftVar Name
x1 Type
t1
in Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Q Pat -> Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
infixP (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x0) Name
c (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x1)) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
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 b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
e1 Q Exp
e2 -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'appE Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
e1 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m 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 Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
c ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
ns)) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
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
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'litE, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'stringPrimL
, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'map Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'fromIntegral) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(.)) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'ord)
, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'litE, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'charPrimL, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'litE, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'doublePrimL, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toRational, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'D# ]
| Name
tyName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Float# = [Q Exp] -> Q Exp
apps [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'litE, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'floatPrimL, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toRational, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'F# ]
| Name
tyName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Int# = [Q Exp] -> Q Exp
apps [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'litE, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'intPrimL, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toInteger, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'I# ]
| Name
tyName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Word# = [Q Exp] -> Q Exp
apps [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'litE, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'wordPrimL, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toInteger, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'W# ]
where
apps :: [Q Exp] -> Q Exp
apps = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE Q Exp
var
var :: Q Exp
var :: Q Exp
var = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
varName
liftVar Name
varName Type
_ = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'lift Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
varName
withInfo :: DatatypeInfo
-> (Cxt -> Name -> [Type] -> [ConstructorInfo] -> Q a)
-> Q a
withInfo :: forall a.
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
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
vs
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
} -> do
case DatatypeVariant
variant of
#if MIN_VERSION_th_abstraction(0,5,0)
DatatypeVariant
Datatype.TypeData -> Name -> Q ()
forall a. Name -> Q a
typeDataError Name
n
#endif
DatatypeVariant
_ -> () -> Q ()
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q a
f Cxt
dcx Name
n Cxt
vs [ConstructorInfo]
cons
#if MIN_VERSION_th_abstraction(0,5,0)
typeDataError :: Name -> Q a
typeDataError :: forall a. Name -> Q a
typeDataError Name
dataName = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Q a) -> (String -> String) -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Cannot derive instance for ‘"
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (Name -> String
nameBase Name
dataName)
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘, which is a ‘type data‘ declaration"
(String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""
#endif
instance Lift Name where
lift :: forall (m :: * -> *). Quote m => Name -> m Exp
lift (Name OccName
occName NameFlavour
nameFlavour) = [| Name occName nameFlavour |]
#if MIN_VERSION_template_haskell(2,16,0)
liftTyped :: forall (m :: * -> *). Quote m => Name -> Code m Name
liftTyped = m Exp -> Code m Name
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeSpliceCoerce (m Exp -> Code m Name) -> (Name -> m Exp) -> Name -> Code m Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
lift
#endif
instance Lift OccName where
lift :: forall (m :: * -> *). Quote m => OccName -> m Exp
lift OccName
n = [| mkOccName |] m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (OccName -> String
occString OccName
n)
#if MIN_VERSION_template_haskell(2,16,0)
liftTyped :: forall (m :: * -> *). Quote m => OccName -> Code m OccName
liftTyped = m Exp -> Code m OccName
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeSpliceCoerce (m Exp -> Code m OccName)
-> (OccName -> m Exp) -> OccName -> Code m OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => OccName -> m Exp
lift
#endif
instance Lift PkgName where
lift :: forall (m :: * -> *). Quote m => PkgName -> m Exp
lift PkgName
n = [| mkPkgName |] m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (PkgName -> String
pkgString PkgName
n)
#if MIN_VERSION_template_haskell(2,16,0)
liftTyped :: forall (m :: * -> *). Quote m => PkgName -> Code m PkgName
liftTyped = m Exp -> Code m PkgName
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeSpliceCoerce (m Exp -> Code m PkgName)
-> (PkgName -> m Exp) -> PkgName -> Code m PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgName -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => PkgName -> m Exp
lift
#endif
instance Lift ModName where
lift :: forall (m :: * -> *). Quote m => ModName -> m Exp
lift ModName
n = [| mkModName |] m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (ModName -> String
modString ModName
n)
#if MIN_VERSION_template_haskell(2,16,0)
liftTyped :: forall (m :: * -> *). Quote m => ModName -> Code m ModName
liftTyped = m Exp -> Code m ModName
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeSpliceCoerce (m Exp -> Code m ModName)
-> (ModName -> m Exp) -> ModName -> Code m ModName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModName -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => ModName -> m Exp
lift
#endif
instance Lift NameFlavour where
lift :: forall (m :: * -> *). Quote m => NameFlavour -> m 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 :: forall (m :: * -> *). Quote m => NameFlavour -> Code m NameFlavour
liftTyped = m Exp -> Code m NameFlavour
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeSpliceCoerce (m Exp -> Code m NameFlavour)
-> (NameFlavour -> m Exp) -> NameFlavour -> Code m NameFlavour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameFlavour -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => NameFlavour -> m Exp
lift
#endif
instance Lift NameSpace where
lift :: forall (m :: * -> *). Quote m => NameSpace -> m Exp
lift NameSpace
VarName = [| VarName |]
lift NameSpace
DataName = [| DataName |]
lift NameSpace
TcClsName = [| TcClsName |]
#if MIN_VERSION_template_haskell(2,21,0)
lift (FldName parent) = [| FldName parent |]
#endif
#if MIN_VERSION_template_haskell(2,16,0)
liftTyped :: forall (m :: * -> *). Quote m => NameSpace -> Code m NameSpace
liftTyped = m Exp -> Code m NameSpace
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeSpliceCoerce (m Exp -> Code m NameSpace)
-> (NameSpace -> m Exp) -> NameSpace -> Code m NameSpace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => NameSpace -> m Exp
lift
#endif