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

-- | 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
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) 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 <- 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q DatatypeInfo
reifyDatatype [Name]
names
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Role] -> DatatypeInfo -> Q Dec
deriveLiftOne) forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Role] -> DatatypeInfo -> Q Dec
deriveLiftOne [Role]
roles 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' = 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 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 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 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 = forall a.
DatatypeInfo
-> (Cxt -> Name -> Cxt -> [ConstructorInfo] -> Q a) -> Q a
withInfo DatatypeInfo
i 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 = 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 = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
            forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Type
t Role
role -> if Role
role forall a. Eq a => a -> a -> Bool
== Role
PhantomR then forall a. a -> Maybe a
Just Type
t else forall a. Maybe a
Nothing)
                    Cxt
tys
                    [Role]
roles
#else /* MIN_VERSION_template_haskell(2,9,0) */
      let phtys = []
#endif
      Name
_x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
      forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall {f :: * -> *} {t :: * -> *}.
(Quote f, Foldable t) =>
Cxt -> t Type -> Cxt -> f Cxt
ctxt Cxt
dcx Cxt
phtys Cxt
tys)
                (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Lift forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall {m :: * -> *}. Quote m => Name -> Cxt -> m Type
typ Name
n Cxt
tys)
                [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'lift [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (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 = forall (m :: * -> *). Quote m => Name -> m Exp
varE 'unsafeSpliceCoerce forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                              (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'lift forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_x) in
                  forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'liftTyped [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_x] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
rhs) []]
#endif
                ]
    typ :: Name -> Cxt -> m Type
typ Name
n = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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 -> f Cxt
ctxt Cxt
dcx t Type
phtys =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Cxt
dcx forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {m :: * -> *}. Quote m => Type -> [m Type]
liftPred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (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 forall a. Eq a => a -> a -> Bool
== Type
Lib.starK -> forall {m :: * -> *}. Quote m => Type -> [m Type]
mkLift Type
t
          | Bool
otherwise      -> []
        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 = [forall (m :: * -> *). Quote m => Name -> m Type
conT ''Lift forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (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 forall a. Eq a => a -> a -> Bool
== Type
Lib.starK = forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
    unKind Type
t           = 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"e"
  forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
e) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
e) 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 [] = [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
e) []]
  where
    e :: Q Exp
e = forall (m :: * -> *). Quote m => Name -> m Exp
varE 'errorQuoteExp forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
             (forall (m :: * -> *). Quote m => String -> m Exp
stringE forall a b. (a -> b) -> a -> b
$ String
"Can't lift value of empty datatype " forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
n)
consMatches Name
_ [ConstructorInfo]
cons = 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
                        }) = (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ do
    [Name]
ns <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Type
_ Int
i -> forall (m :: * -> *). Quote m => String -> m Name
newName (Char
'x'forall a. a -> [a] -> [a]
: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 = forall (m :: * -> *). Quote m => Name -> m Exp
varE 'infixApp forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Type -> Q Exp
liftVar Name
x0 Type
t0 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
con forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Type -> Q Exp
liftVar Name
x1 Type
t1
        in forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
infixP (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x0) Name
c (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x1)) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
e) []
      (ConstructorVariant
_, [Name]
_, Cxt
_) ->
        let e :: Q Exp
e = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
e1 Q Exp
e2 -> forall (m :: * -> *). Quote m => Name -> m Exp
varE 'appE forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
e1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
e2) Q Exp
con forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Type -> Q Exp
liftVar [Name]
ns Cxt
ts
        in forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
c (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
ns)) (forall (m :: * -> *). Quote m => m Exp -> m Body
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
  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 forall a. Eq a => a -> a -> Bool
== ''Addr#   = [Q Exp] -> Q Exp
apps
    [ forall (m :: * -> *). Quote m => Name -> m Exp
varE 'litE, forall (m :: * -> *). Quote m => Name -> m Exp
varE 'stringPrimL
    , forall (m :: * -> *). Quote m => Name -> m Exp
varE 'map forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
        forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'fromIntegral) (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(.)) (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'ord)
    , 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 forall a. Eq a => a -> a -> Bool
== ''Char#   = [Q Exp] -> Q Exp
apps [ forall (m :: * -> *). Quote m => Name -> m Exp
varE 'litE, forall (m :: * -> *). Quote m => Name -> m Exp
varE 'charPrimL, forall (m :: * -> *). Quote m => Name -> m Exp
conE 'C# ]
#endif  /* !(MIN_VERSION_template_haskell(2,11,0)) */
  | Name
tyName forall a. Eq a => a -> a -> Bool
== ''Double# = [Q Exp] -> Q Exp
apps [ forall (m :: * -> *). Quote m => Name -> m Exp
varE 'litE, forall (m :: * -> *). Quote m => Name -> m Exp
varE 'doublePrimL, forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toRational, forall (m :: * -> *). Quote m => Name -> m Exp
conE 'D# ]
  | Name
tyName forall a. Eq a => a -> a -> Bool
== ''Float#  = [Q Exp] -> Q Exp
apps [ forall (m :: * -> *). Quote m => Name -> m Exp
varE 'litE, forall (m :: * -> *). Quote m => Name -> m Exp
varE 'floatPrimL,  forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toRational, forall (m :: * -> *). Quote m => Name -> m Exp
conE 'F# ]
  | Name
tyName forall a. Eq a => a -> a -> Bool
== ''Int#    = [Q Exp] -> Q Exp
apps [ forall (m :: * -> *). Quote m => Name -> m Exp
varE 'litE, forall (m :: * -> *). Quote m => Name -> m Exp
varE 'intPrimL,    forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toInteger,  forall (m :: * -> *). Quote m => Name -> m Exp
conE 'I# ]
  | Name
tyName forall a. Eq a => a -> a -> Bool
== ''Word#   = [Q Exp] -> Q Exp
apps [ forall (m :: * -> *). Quote m => Name -> m Exp
varE 'litE, forall (m :: * -> *). Quote m => Name -> m Exp
varE 'wordPrimL,   forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toInteger,  forall (m :: * -> *). Quote m => Name -> m Exp
conE 'W# ]

  where
    apps :: [Q Exp] -> Q Exp
apps  = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE Q Exp
var

    var :: Q Exp
    var :: Q Exp
var = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
varName

liftVar Name
varName Type
_ = forall (m :: * -> *). Quote m => Name -> m Exp
varE 'lift forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` 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 -> forall a. Name -> Q a
typeDataError Name
n
#endif
        DatatypeVariant
_ -> 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)
-- | We cannot define implementations for @lift@ at the term level for
-- @type data@ declarations, which only exist at the type level.
typeDataError :: Name -> Q a
typeDataError :: forall a. Name -> Q a
typeDataError Name
dataName = forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Cannot derive instance for ‘"
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (Name -> String
nameBase Name
dataName)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘, which is a ‘type data‘ declaration"
  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 = forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeSpliceCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift
#endif

instance Lift OccName where
  lift :: forall (m :: * -> *). Quote m => OccName -> m Exp
lift OccName
n = [| mkOccName |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall t (m :: * -> *). (Lift t, Quote m) => t -> 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 = forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeSpliceCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift
#endif

instance Lift PkgName where
  lift :: forall (m :: * -> *). Quote m => PkgName -> m Exp
lift PkgName
n = [| mkPkgName |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall t (m :: * -> *). (Lift t, Quote m) => t -> 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 = forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeSpliceCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift
#endif

instance Lift ModName where
  lift :: forall (m :: * -> *). Quote m => ModName -> m Exp
lift ModName
n = [| mkModName |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall t (m :: * -> *). (Lift t, Quote m) => t -> 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 = forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeSpliceCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *). (Lift t, Quote m) => t -> 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 = forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeSpliceCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *). (Lift t, Quote m) => t -> 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 = forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeSpliceCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift
#endif