Commit 57cf1133 authored by Alec Theriault's avatar Alec Theriault Committed by Marge Bot
Browse files

TH: make `Lift` and `TExp` levity-polymorphic

Besides the obvious benefits of being able to manipulate `TExp`'s of
unboxed types, this also simplified `-XDeriveLift` all while making
it more capable.

  * `ghc-prim` is explicitly depended upon by `template-haskell`

  * The following TH things are parametrized over `RuntimeRep`:

      - `TExp(..)`
      - `unTypeQ`
      - `unsafeTExpCoerce`
      - `Lift(..)`

  * The following instances have been added to `Lift`:

      - `Int#`, `Word#`, `Float#`, `Double#`, `Char#`, `Addr#`
      - unboxed tuples of lifted types up to arity 7
      - unboxed sums of lifted types up to arity 7

    Ideally we would have levity-polymorphic _instances_ of unboxed
    tuples and sums.

  * The code generated by `-XDeriveLift` uses expression quotes
    instead of generating large amounts of TH code and having
    special hard-coded cases for some unboxed types.
parent 5988f17a
......@@ -27,7 +27,7 @@ templateHaskellNames :: [Name]
-- Should stay in sync with the import list of DsMeta
templateHaskellNames = [
returnQName, bindQName, sequenceQName, newNameName, liftName,
returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
mkNameSName,
liftStringName,
......@@ -206,7 +206,7 @@ overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,
unsafeTExpCoerceName :: Name
unsafeTExpCoerceName, liftTypedName :: Name
returnQName = thFun (fsLit "returnQ") returnQIdKey
bindQName = thFun (fsLit "bindQ") bindQIdKey
sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
......@@ -222,6 +222,7 @@ mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey
unTypeName = thFun (fsLit "unType") unTypeIdKey
unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey
unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey
-------------------- TH.Lib -----------------------
......@@ -726,7 +727,7 @@ incoherentDataConKey = mkPreludeDataConUnique 212
returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,
unsafeTExpCoerceIdKey :: Unique
unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique
returnQIdKey = mkPreludeMiscIdUnique 200
bindQIdKey = mkPreludeMiscIdUnique 201
sequenceQIdKey = mkPreludeMiscIdUnique 202
......@@ -741,6 +742,7 @@ mkNameSIdKey = mkPreludeMiscIdUnique 210
unTypeIdKey = mkPreludeMiscIdUnique 211
unTypeQIdKey = mkPreludeMiscIdUnique 212
unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213
liftTypedIdKey = mkPreludeMiscIdUnique 214
-- data Lit = ...
......@@ -1078,8 +1080,9 @@ viaStrategyIdKey = mkPreludeDataConUnique 497
************************************************************************
-}
lift_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName
lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName
lift_RDR = nameRdrName liftName
liftTyped_RDR = nameRdrName liftTypedName
mkNameG_dRDR = nameRdrName mkNameG_dName
mkNameG_vRDR = nameRdrName mkNameG_vName
......
......@@ -78,24 +78,30 @@ import Control.Monad( unless )
************************************************************************
-}
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr GhcTcId)
-- Used when Name is the wired-in name for a wired-in class method,
newMethodFromName
:: CtOrigin -- ^ why do we need this?
-> Name -- ^ name of the method
-> [TcRhoType] -- ^ types with which to instantiate the class
-> TcM (HsExpr GhcTcId)
-- ^ Used when 'Name' is the wired-in name for a wired-in class method,
-- so the caller knows its type for sure, which should be of form
-- forall a. C a => <blah>
-- newMethodFromName is supposed to instantiate just the outer
--
-- > forall a. C a => <blah>
--
-- 'newMethodFromName' is supposed to instantiate just the outer
-- type variable and constraint
newMethodFromName origin name inst_ty
newMethodFromName origin name ty_args
= do { id <- tcLookupId name
-- Use tcLookupId not tcLookupGlobalId; the method is almost
-- always a class op, but with -XRebindableSyntax GHC is
-- meant to find whatever thing is in scope, and that may
-- be an ordinary function.
; let ty = piResultTy (idType id) inst_ty
; let ty = piResultTys (idType id) ty_args
(theta, _caller_knows_this) = tcSplitPhiTy ty
; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
instCall origin [inst_ty] theta
instCall origin ty_args theta
; return (mkHsWrap wrap (HsVar noExt (noLoc id))) }
......@@ -607,7 +613,7 @@ tcSyntaxName :: CtOrigin
tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
| std_nm == user_nm
= do rhs <- newMethodFromName orig std_nm ty
= do rhs <- newMethodFromName orig std_nm [ty]
return (std_nm, rhs)
tcSyntaxName orig ty (std_nm, user_nm_expr) = do
......
......@@ -335,6 +335,8 @@ renameDeriv is_boot inst_infos bagBinds
-- (See Note [Newtype-deriving instances] in TcGenDeriv)
unsetXOptM LangExt.RebindableSyntax $
-- See Note [Avoid RebindableSyntax when deriving]
setXOptM LangExt.TemplateHaskellQuotes $
-- DeriveLift makes uses of quotes
do {
-- Bring the extra deriving stuff into scope
-- before renaming the instances themselves
......
......@@ -738,8 +738,10 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond`
(cond_isProduct `andCond` cond_args cls)
cond_args :: Class -> Condition
-- For some classes (eg Eq, Ord) we allow unlifted arg types
-- by generating specialised code. For others (eg Data) we don't.
-- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types
-- by generating specialised code. For others (eg 'Data') we don't.
-- For even others (eg 'Lift'), unlifted types aren't even a special
-- consideration!
cond_args cls _ _ rep_tc
= case bad_args of
[] -> IsValid
......@@ -748,7 +750,7 @@ cond_args cls _ _ rep_tc
where
bad_args = [ arg_ty | con <- tyConDataCons rep_tc
, arg_ty <- dataConOrigArgTys con
, isUnliftedType arg_ty
, isLiftedType_maybe arg_ty /= Just True
, not (ok_ty arg_ty) ]
cls_key = classKey cls
......@@ -756,7 +758,7 @@ cond_args cls _ _ rep_tc
| cls_key == eqClassKey = check_in arg_ty ordOpTbl
| cls_key == ordClassKey = check_in arg_ty ordOpTbl
| cls_key == showClassKey = check_in arg_ty boxConTbl
| cls_key == liftClassKey = check_in arg_ty litConTbl
| cls_key == liftClassKey = True -- Lift is levity-polymorphic
| otherwise = False -- Read, Ix etc
check_in :: Type -> [(Type,a)] -> Bool
......
......@@ -639,7 +639,8 @@ tcExpr (HsStatic fvs expr) res_ty
; emitStaticConstraints lie
-- Wrap the static form with the 'fromStaticPtr' call.
; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty
; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName
[p_ty]
; let wrap = mkWpTyApps [expr_ty]
; loc <- getSrcSpanM
; return $ mkHsWrapCo co $ HsApp noExt
......@@ -1040,7 +1041,7 @@ tcArithSeq witness seq@(From expr) res_ty
= do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
; expr' <- tcPolyExpr expr elt_ty
; enum_from <- newMethodFromName (ArithSeqOrigin seq)
enumFromName elt_ty
enumFromName [elt_ty]
; return $ mkHsWrap wrap $
ArithSeq enum_from wit' (From expr') }
......@@ -1049,7 +1050,7 @@ tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenName elt_ty
enumFromThenName [elt_ty]
; return $ mkHsWrap wrap $
ArithSeq enum_from_then wit' (FromThen expr1' expr2') }
......@@ -1058,7 +1059,7 @@ tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
enumFromToName elt_ty
enumFromToName [elt_ty]
; return $ mkHsWrap wrap $
ArithSeq enum_from_to wit' (FromTo expr1' expr2') }
......@@ -1068,7 +1069,7 @@ tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenToName elt_ty
enumFromThenToName [elt_ty]
; return $ mkHsWrap wrap $
ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
......@@ -2041,7 +2042,8 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var))
setConstraintVar lie_var $
-- Put the 'lift' constraint into the right LIE
newMethodFromName (OccurrenceOf id_name)
THNames.liftName id_ty
THNames.liftName
[getRuntimeRep id_ty, id_ty]
-- Update the pending splices
; ps <- readMutVar ps_var
......
......@@ -54,8 +54,6 @@ import FamInst
import FamInstEnv
import PrelNames
import THNames
import Module ( moduleName, moduleNameString
, moduleUnitId, unitIdString )
import MkId ( coerceId )
import PrimOp
import SrcLoc
......@@ -1559,68 +1557,36 @@ Example:
==>
instance (Lift a) => Lift (Foo a) where
lift (Foo a)
= appE
(conE
(mkNameG_d "package-name" "ModuleName" "Foo"))
(lift a)
lift (u :^: v)
= infixApp
(lift u)
(conE
(mkNameG_d "package-name" "ModuleName" ":^:"))
(lift v)
Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
'Foo would be when using the -XTemplateHaskell extension. To make sure that
-XDeriveLift can be used on stage-1 compilers, however, we explicitly invoke
makeG_d.
lift (Foo a) = [| Foo a |]
lift ((:^:) u v) = [| (:^:) u v |]
liftTyped (Foo a) = [|| Foo a ||]
liftTyped ((:^:) u v) = [|| (:^:) u v ||]
-}
gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag)
gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)
where
lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
(map pats_etc data_cons)
(map (pats_etc mk_exp) data_cons)
liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr)
(map (pats_etc mk_texp) data_cons)
mk_exp = ExpBr NoExt
mk_texp = TExpBr NoExt
data_cons = tyConDataCons tycon
pats_etc data_con
pats_etc mk_bracket data_con
= ([con_pat], lift_Expr)
where
con_pat = nlConVarPat data_con_RDR as_needed
data_con_RDR = getRdrName data_con
con_arity = dataConSourceArity data_con
as_needed = take con_arity as_RDRs
lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
tys_needed as_needed
tycon_name = tyConName tycon
is_infix = dataConIsInfix data_con
tys_needed = dataConOrigArgTys data_con
mk_lift_app ty a
| not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
(nlHsVar a)
| otherwise = nlHsApp (nlHsVar litE_RDR)
(primLitOp (mkBoxExp (nlHsVar a)))
where (primLitOp, mkBoxExp) = primLitOps "Lift" ty
pkg_name = unitIdString . moduleUnitId
. nameModule $ tycon_name
mod_name = moduleNameString . moduleName . nameModule $ tycon_name
con_name = occNameString . nameOccName . dataConName $ data_con
conE_Expr = nlHsApp (nlHsVar conE_RDR)
(nlHsApps mkNameG_dRDR
(map (nlHsLit . mkHsString)
[pkg_name, mod_name, con_name]))
lift_Expr
| is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
| otherwise = foldl' mk_appE_app conE_Expr lifted_as
(a1:a2:_) = lifted_as
mk_appE_app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mk_appE_app a b = nlHsApps appE_RDR [a, b]
lift_Expr = noLoc (HsBracket NoExt (mk_bracket br_body))
br_body = nlHsApps (Exact (dataConName data_con))
(map nlHsVar as_needed)
{-
************************************************************************
......@@ -2134,17 +2100,6 @@ primOrdOps :: String -- The class involved
-- See Note [Deriving and unboxed types] in TcDerivInfer
primOrdOps str ty = assoc_ty_id str ordOpTbl ty
primLitOps :: String -- The class involved
-> Type -- The type
-> ( LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a Q Exp value
, LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a boxed value
)
primLitOps str ty = (assoc_ty_id str litConTbl ty, \v -> boxed v)
where
boxed v
| ty `eqType` addrPrimTy = nlHsVar unpackCString_RDR `nlHsApp` v
| otherwise = assoc_ty_id str boxConTbl ty v
ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl
= [(charPrimTy , (ltChar_RDR , leChar_RDR
......
......@@ -177,13 +177,14 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
tcInferRhoNC expr
-- NC for no context; tcBracket does that
; let rep = getRuntimeRep expr_ty
; meta_ty <- tcTExpTy expr_ty
; ps' <- readMutVar ps_ref
; texpco <- tcLookupId unsafeTExpCoerceName
; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
rn_expr
(unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
(unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty])
(noLoc (HsTcBracketOut noExt brack ps'))))
meta_ty res_ty }
tcTypedBracket _ other_brack _
......@@ -230,7 +231,8 @@ tcTExpTy exp_ty
= do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)
; q <- tcLookupTyCon qTyConName
; texp <- tcLookupTyCon tExpTyConName
; return (mkTyConApp q [mkTyConApp texp [exp_ty]]) }
; let rep = getRuntimeRep exp_ty
; return (mkTyConApp q [mkTyConApp texp [rep, exp_ty]]) }
where
err_msg ty
= vcat [ text "Illegal polytype:" <+> ppr ty
......@@ -469,12 +471,13 @@ tcNestedSplice :: ThStage -> PendingStuff -> Name
-- A splice inside brackets
tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty
= do { res_ty <- expTypeToType res_ty
; let rep = getRuntimeRep res_ty
; meta_exp_ty <- tcTExpTy res_ty
; expr' <- setStage pop_stage $
setConstraintVar lie_var $
tcMonoExpr expr (mkCheckExpType meta_exp_ty)
; untypeq <- tcLookupId unTypeQName
; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr'
; let expr'' = mkHsApp (nlHsTyApp untypeq [rep, res_ty]) expr'
; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
......
......@@ -73,6 +73,12 @@ Runtime system
Template Haskell
~~~~~~~~~~~~~~~~
- The ``Lift`` typeclass is now levity-polymorphic and has a ``liftTyped``
method. Previously disallowed instances for unboxed tuples, unboxed sums, an
primitive unboxed types have also been added. Finally, the code generated by
:ghc-flags:`-XDeriveLift` has been simplified to take advantage of expression
quotations.
``ghc-prim`` library
~~~~~~~~~~~~~~~~~~~~
......
......@@ -4531,7 +4531,8 @@ Deriving ``Lift`` instances
The class ``Lift``, unlike other derivable classes, lives in
``template-haskell`` instead of ``base``. Having a data type be an instance of
``Lift`` permits its values to be promoted to Template Haskell expressions (of
type ``ExpQ``), which can then be spliced into Haskell source code.
type ``ExpQ`` and ``TExpQ a``), which can then be spliced into Haskell source
code.
 
Here is an example of how one can derive ``Lift``:
 
......@@ -4546,17 +4547,11 @@ Here is an example of how one can derive ``Lift``:
 
{-
instance (Lift a) => Lift (Foo a) where
lift (Foo a)
= appE
(conE
(mkNameG_d "package-name" "Bar" "Foo"))
(lift a)
lift (u :^: v)
= infixApp
(lift u)
(conE
(mkNameG_d "package-name" "Bar" ":^:"))
(lift v)
lift (Foo a) = [| Foo a |]
lift ((:^:) u v) = [| (:^:) u v |]
liftTyped (Foo a) = [|| Foo a ||]
liftTyped ((:^:) u v) = [|| (:^:) u v ||]
-}
 
-----
......@@ -4572,8 +4567,9 @@ Here is an example of how one can derive ``Lift``:
fooExp :: Lift a => Foo a -> Q Exp
fooExp f = [| f |]
 
:extension:`DeriveLift` also works for certain unboxed types (``Addr#``, ``Char#``,
``Double#``, ``Float#``, ``Int#``, and ``Word#``):
Note that the ``Lift`` typeclass takes advantage of :ref:`runtime-rep` in order
to support instances involving unboxed types. This means :extension:`DeriveLift`
also works for these types:
 
::
 
......@@ -4587,12 +4583,8 @@ Here is an example of how one can derive ``Lift``:
 
{-
instance Lift IntHash where
lift (IntHash i)
= appE
(conE
(mkNameG_d "package-name" "Unboxed" "IntHash"))
(litE
(intPrimL (toInteger (I# i))))
lift (IntHash i) = [| IntHash i |]
liftTyped (IntHash i) = [|| IntHash i ||]
-}
 
 
......
{-# LANGUAGE CPP, DeriveDataTypeable,
DeriveGeneric, FlexibleInstances, DefaultSignatures,
RankNTypes, RoleAnnotations, ScopedTypeVariables,
MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds,
GADTs, UnboxedTuples, UnboxedSums, TypeInType,
Trustworthy #-}
{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}
......@@ -32,13 +34,17 @@ import System.IO.Unsafe ( unsafePerformIO )
import Control.Monad (liftM)
import Control.Monad.IO.Class (MonadIO (..))
import System.IO ( hPutStrLn, stderr )
import Data.Char ( isAlpha, isAlphaNum, isUpper )
import Data.Char ( isAlpha, isAlphaNum, isUpper, ord )
import Data.Int
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Void ( Void, absurd )
import Data.Word
import Data.Ratio
import GHC.CString ( unpackCString# )
import GHC.Generics ( Generic )
import GHC.Types ( Int(..), Word(..), Char(..), Double(..), Float(..),
TYPE, RuntimeRep(..) )
import GHC.Prim ( Int#, Word#, Char#, Double#, Float#, Addr# )
import GHC.Lexeme ( startsVarSym, startsVarId )
import GHC.ForeignSrcLang.Type
import Language.Haskell.TH.LanguageExtensions
......@@ -201,7 +207,7 @@ instance Applicative Q where
-----------------------------------------------------
type role TExp nominal -- See Note [Role of TExp]
newtype TExp a = TExp
newtype TExp (a :: TYPE (r :: RuntimeRep)) = TExp
{ unType :: Exp -- ^ Underlying untyped Template Haskell expression
}
-- ^ Represents an expression which has type @a@. Built on top of 'Exp', typed
......@@ -240,7 +246,9 @@ newtype TExp a = TExp
-- | Discard the type annotation and produce a plain Template Haskell
-- expression
unTypeQ :: Q (TExp a) -> Q Exp
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r). Q (TExp a) -> Q Exp
unTypeQ m = do { TExp e <- m
; return e }
......@@ -248,7 +256,9 @@ unTypeQ m = do { TExp e <- m
--
-- This is unsafe because GHC cannot check for you that the expression
-- really does have the type you claim it has.
unsafeTExpCoerce :: Q Exp -> Q (TExp a)
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r). Q Exp -> Q (TExp a)
unsafeTExpCoerce m = do { e <- m
; return (TExp e) }
......@@ -651,17 +661,18 @@ sequenceQ = sequence
-- | A 'Lift' instance can have any of its values turned into a Template
-- Haskell expression. This is needed when a value used within a Template
-- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@) but not
-- at the top level. As an example:
-- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@ or
-- @[|| ... ||]@) but not at the top level. As an example:
--
-- > add1 :: Int -> Q Exp
-- > add1 x = [| x + 1 |]
-- > add1 :: Int -> Q (TExp Int)
-- > add1 x = [|| x + 1 ||]
--
-- Template Haskell has no way of knowing what value @x@ will take on at
-- splice-time, so it requires the type of @x@ to be an instance of 'Lift'.
--
-- A 'Lift' instance must satisfy @$(lift x) ≡ x@ for all @x@, where @$(...)@
-- is a Template Haskell splice.
-- A 'Lift' instance must satisfy @$(lift x) ≡ x@ and @$$(liftTyped x) ≡ x@
-- for all @x@, where @$(...)@ and @$$(...)@ are Template Haskell splices.
-- It is additionally expected that @'lift' x ≡ 'unTypeQ' ('liftTyped' x)@.
--
-- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@
-- GHC language extension:
......@@ -673,10 +684,13 @@ sequenceQ = sequence
-- >
-- > data Bar a = Bar1 a (Bar a) | Bar2 String
-- > deriving Lift
class Lift t where
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
class Lift (t :: TYPE r) where
-- | Turn a value into a Template Haskell expression, suitable for use in
-- a splice.
lift :: t -> Q Exp
default lift :: (r ~ 'LiftedRep) => t -> Q Exp
lift = unTypeQ . liftTyped
-- | Turn a value into a Template Haskell typed expression, suitable for use
......@@ -684,73 +698,127 @@ class Lift t where
--
-- @since 2.16.0.0
liftTyped :: t -> Q (TExp t)
liftTyped = unsafeTExpCoerce . lift
{-# MINIMAL lift | liftTyped #-}
-- If you add any instances here, consider updating test th/TH_Lift
instance Lift Integer where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntegerL x))
instance Lift Int where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
-- | @since 2.16.0.0
instance Lift Int# where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntPrimL (fromIntegral (I# x))))
instance Lift Int8 where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Int16 where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Int32 where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Int64 where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
-- | @since 2.16.0.0
instance Lift Word# where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (WordPrimL (fromIntegral (W# x))))
instance Lift Word where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Word8 where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Word16 where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Word32 where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Word64 where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Natural where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Integral a => Lift (Ratio a) where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (RationalL (toRational x)))
instance Lift Float where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (RationalL (toRational x)))
-- | @since 2.16.0.0
instance Lift Float# where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (FloatPrimL (toRational (F# x))))
instance Lift Double where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (RationalL (toRational x)))
-- | @since 2.16.0.0
instance Lift Double# where
liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (DoublePrimL (toRational (D# x))))