{-# 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.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) */

-- | Derive a 'Lift' instance for the given datatype.
--
-- Note that 'deriveLift' uses a very simple technique for inferring the
-- instance context: it simply takes all visible type variables from the data
-- type declaration and adds a 'Lift' constraint for each one. For instance,
-- in the following example:
--
-- @
-- data Foo a b = ...
-- $(deriveLift ''Foo)
-- @
--
-- The following instance would be generated:
--
-- @
-- instance (Lift a, Lift b) => Lift (Foo a b) where ...
-- @
--
-- This will not work in all situations, however. For instance, there could
-- conceivably be type variables that are not of the appropriate kind. For
-- these other situations, the 'makeLift' function can provide a more
-- fine-grained approach that allows specifying the instance context precisely.
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

-- | Derive 'Lift' instances for many datatypes.
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

-- | Obtain 'Info' values through a custom reification function. This is useful
-- when generating instances for datatypes that have not yet been declared.
#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

-- | Generates a lambda expresson which behaves like 'lift' (without requiring
-- a 'Lift' instance). Example:
--
-- @
-- newtype Fix f = In { out :: f (Fix f) }
--
-- instance Lift (f (Fix f)) => Lift (Fix f) where
--   lift = $(makeLift ''Fix)
-- @
--
-- This can be useful when 'deriveLift' is not clever enough to infer the
-- correct instance context, such as in the example above.
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

-- | Like 'makeLift', but using a custom reification function.
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)
      -- roles <- reifyDatatypeRoles n
      -- Compute the set of phantom variables.
      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
newName String
"x"
      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)
                , let rhs :: Q Exp
rhs = Name -> Q Exp
varE 'unsafeSpliceCoerce Q Exp -> Q Exp -> Q Exp
`appE`
                              (Name -> Q Exp
varE 'lift Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
_x) in
                  Name -> [ClauseQ] -> Q Dec
funD 'liftTyped [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
_x] (Q Exp -> BodyQ
normalB Q Exp
rhs) []]
#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
    -- Only consider *-kinded type variables for now. Furthermore, filter out
    -- type variables that are obviously phantom.
    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 'errorQuoteExp 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)
-- Reify the roles of a data type. Note that the argument Name may correspond
-- to that of a data family instance constructor, so we need to go through
-- reifyDatatype to determine what the parent data family Name is.
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

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)
unsafeSpliceCoerce (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)
unsafeSpliceCoerce (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)
unsafeSpliceCoerce (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)
unsafeSpliceCoerce (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)
unsafeSpliceCoerce (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)
unsafeSpliceCoerce (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