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] ...@@ -27,7 +27,7 @@ templateHaskellNames :: [Name]
-- Should stay in sync with the import list of DsMeta -- Should stay in sync with the import list of DsMeta
templateHaskellNames = [ templateHaskellNames = [
returnQName, bindQName, sequenceQName, newNameName, liftName, returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
mkNameSName, mkNameSName,
liftStringName, liftStringName,
...@@ -206,7 +206,7 @@ overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey ...@@ -206,7 +206,7 @@ overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
returnQName, bindQName, sequenceQName, newNameName, liftName, returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName, mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,
unsafeTExpCoerceName :: Name unsafeTExpCoerceName, liftTypedName :: Name
returnQName = thFun (fsLit "returnQ") returnQIdKey returnQName = thFun (fsLit "returnQ") returnQIdKey
bindQName = thFun (fsLit "bindQ") bindQIdKey bindQName = thFun (fsLit "bindQ") bindQIdKey
sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
...@@ -222,6 +222,7 @@ mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey ...@@ -222,6 +222,7 @@ mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey
unTypeName = thFun (fsLit "unType") unTypeIdKey unTypeName = thFun (fsLit "unType") unTypeIdKey
unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey
unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey
-------------------- TH.Lib ----------------------- -------------------- TH.Lib -----------------------
...@@ -726,7 +727,7 @@ incoherentDataConKey = mkPreludeDataConUnique 212 ...@@ -726,7 +727,7 @@ incoherentDataConKey = mkPreludeDataConUnique 212
returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey, mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,
unsafeTExpCoerceIdKey :: Unique unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique
returnQIdKey = mkPreludeMiscIdUnique 200 returnQIdKey = mkPreludeMiscIdUnique 200
bindQIdKey = mkPreludeMiscIdUnique 201 bindQIdKey = mkPreludeMiscIdUnique 201
sequenceQIdKey = mkPreludeMiscIdUnique 202 sequenceQIdKey = mkPreludeMiscIdUnique 202
...@@ -741,6 +742,7 @@ mkNameSIdKey = mkPreludeMiscIdUnique 210 ...@@ -741,6 +742,7 @@ mkNameSIdKey = mkPreludeMiscIdUnique 210
unTypeIdKey = mkPreludeMiscIdUnique 211 unTypeIdKey = mkPreludeMiscIdUnique 211
unTypeQIdKey = mkPreludeMiscIdUnique 212 unTypeQIdKey = mkPreludeMiscIdUnique 212
unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213 unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213
liftTypedIdKey = mkPreludeMiscIdUnique 214
-- data Lit = ... -- data Lit = ...
...@@ -1078,8 +1080,9 @@ viaStrategyIdKey = mkPreludeDataConUnique 497 ...@@ -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 lift_RDR = nameRdrName liftName
liftTyped_RDR = nameRdrName liftTypedName
mkNameG_dRDR = nameRdrName mkNameG_dName mkNameG_dRDR = nameRdrName mkNameG_dName
mkNameG_vRDR = nameRdrName mkNameG_vName mkNameG_vRDR = nameRdrName mkNameG_vName
......
...@@ -78,24 +78,30 @@ import Control.Monad( unless ) ...@@ -78,24 +78,30 @@ import Control.Monad( unless )
************************************************************************ ************************************************************************
-} -}
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr GhcTcId) newMethodFromName
-- Used when Name is the wired-in name for a wired-in class method, :: 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 -- 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 -- type variable and constraint
newMethodFromName origin name inst_ty newMethodFromName origin name ty_args
= do { id <- tcLookupId name = do { id <- tcLookupId name
-- Use tcLookupId not tcLookupGlobalId; the method is almost -- Use tcLookupId not tcLookupGlobalId; the method is almost
-- always a class op, but with -XRebindableSyntax GHC is -- always a class op, but with -XRebindableSyntax GHC is
-- meant to find whatever thing is in scope, and that may -- meant to find whatever thing is in scope, and that may
-- be an ordinary function. -- be an ordinary function.
; let ty = piResultTy (idType id) inst_ty ; let ty = piResultTys (idType id) ty_args
(theta, _caller_knows_this) = tcSplitPhiTy ty (theta, _caller_knows_this) = tcSplitPhiTy ty
; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
instCall origin [inst_ty] theta instCall origin ty_args theta
; return (mkHsWrap wrap (HsVar noExt (noLoc id))) } ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) }
...@@ -607,7 +613,7 @@ tcSyntaxName :: CtOrigin ...@@ -607,7 +613,7 @@ tcSyntaxName :: CtOrigin
tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm)) tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
| std_nm == user_nm | std_nm == user_nm
= do rhs <- newMethodFromName orig std_nm ty = do rhs <- newMethodFromName orig std_nm [ty]
return (std_nm, rhs) return (std_nm, rhs)
tcSyntaxName orig ty (std_nm, user_nm_expr) = do tcSyntaxName orig ty (std_nm, user_nm_expr) = do
......
...@@ -335,6 +335,8 @@ renameDeriv is_boot inst_infos bagBinds ...@@ -335,6 +335,8 @@ renameDeriv is_boot inst_infos bagBinds
-- (See Note [Newtype-deriving instances] in TcGenDeriv) -- (See Note [Newtype-deriving instances] in TcGenDeriv)
unsetXOptM LangExt.RebindableSyntax $ unsetXOptM LangExt.RebindableSyntax $
-- See Note [Avoid RebindableSyntax when deriving] -- See Note [Avoid RebindableSyntax when deriving]
setXOptM LangExt.TemplateHaskellQuotes $
-- DeriveLift makes uses of quotes
do { do {
-- Bring the extra deriving stuff into scope -- Bring the extra deriving stuff into scope
-- before renaming the instances themselves -- before renaming the instances themselves
......
...@@ -738,8 +738,10 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond` ...@@ -738,8 +738,10 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond`
(cond_isProduct `andCond` cond_args cls) (cond_isProduct `andCond` cond_args cls)
cond_args :: Class -> Condition cond_args :: Class -> Condition
-- For some classes (eg Eq, Ord) we allow unlifted arg types -- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types
-- by generating specialised code. For others (eg Data) we don't. -- 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 cond_args cls _ _ rep_tc
= case bad_args of = case bad_args of
[] -> IsValid [] -> IsValid
...@@ -748,7 +750,7 @@ cond_args cls _ _ rep_tc ...@@ -748,7 +750,7 @@ cond_args cls _ _ rep_tc
where where
bad_args = [ arg_ty | con <- tyConDataCons rep_tc bad_args = [ arg_ty | con <- tyConDataCons rep_tc
, arg_ty <- dataConOrigArgTys con , arg_ty <- dataConOrigArgTys con
, isUnliftedType arg_ty , isLiftedType_maybe arg_ty /= Just True
, not (ok_ty arg_ty) ] , not (ok_ty arg_ty) ]
cls_key = classKey cls cls_key = classKey cls
...@@ -756,7 +758,7 @@ cond_args cls _ _ rep_tc ...@@ -756,7 +758,7 @@ cond_args cls _ _ rep_tc
| cls_key == eqClassKey = check_in arg_ty ordOpTbl | cls_key == eqClassKey = check_in arg_ty ordOpTbl
| cls_key == ordClassKey = check_in arg_ty ordOpTbl | cls_key == ordClassKey = check_in arg_ty ordOpTbl
| cls_key == showClassKey = check_in arg_ty boxConTbl | 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 | otherwise = False -- Read, Ix etc
check_in :: Type -> [(Type,a)] -> Bool check_in :: Type -> [(Type,a)] -> Bool
......
...@@ -639,7 +639,8 @@ tcExpr (HsStatic fvs expr) res_ty ...@@ -639,7 +639,8 @@ tcExpr (HsStatic fvs expr) res_ty
; emitStaticConstraints lie ; emitStaticConstraints lie
-- Wrap the static form with the 'fromStaticPtr' call. -- 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] ; let wrap = mkWpTyApps [expr_ty]
; loc <- getSrcSpanM ; loc <- getSrcSpanM
; return $ mkHsWrapCo co $ HsApp noExt ; return $ mkHsWrapCo co $ HsApp noExt
...@@ -1040,7 +1041,7 @@ tcArithSeq witness seq@(From expr) res_ty ...@@ -1040,7 +1041,7 @@ tcArithSeq witness seq@(From expr) res_ty
= do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
; expr' <- tcPolyExpr expr elt_ty ; expr' <- tcPolyExpr expr elt_ty
; enum_from <- newMethodFromName (ArithSeqOrigin seq) ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
enumFromName elt_ty enumFromName [elt_ty]
; return $ mkHsWrap wrap $ ; return $ mkHsWrap wrap $
ArithSeq enum_from wit' (From expr') } ArithSeq enum_from wit' (From expr') }
...@@ -1049,7 +1050,7 @@ tcArithSeq witness seq@(FromThen expr1 expr2) res_ty ...@@ -1049,7 +1050,7 @@ tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
; expr1' <- tcPolyExpr expr1 elt_ty ; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenName elt_ty enumFromThenName [elt_ty]
; return $ mkHsWrap wrap $ ; return $ mkHsWrap wrap $
ArithSeq enum_from_then wit' (FromThen expr1' expr2') } ArithSeq enum_from_then wit' (FromThen expr1' expr2') }
...@@ -1058,7 +1059,7 @@ tcArithSeq witness seq@(FromTo expr1 expr2) res_ty ...@@ -1058,7 +1059,7 @@ tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
; expr1' <- tcPolyExpr expr1 elt_ty ; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
enumFromToName elt_ty enumFromToName [elt_ty]
; return $ mkHsWrap wrap $ ; return $ mkHsWrap wrap $
ArithSeq enum_from_to wit' (FromTo expr1' expr2') } ArithSeq enum_from_to wit' (FromTo expr1' expr2') }
...@@ -1068,7 +1069,7 @@ tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty ...@@ -1068,7 +1069,7 @@ tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
; expr2' <- tcPolyExpr expr2 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty
; expr3' <- tcPolyExpr expr3 elt_ty ; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (ArithSeqOrigin seq) ; eft <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenToName elt_ty enumFromThenToName [elt_ty]
; return $ mkHsWrap wrap $ ; return $ mkHsWrap wrap $
ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
...@@ -2041,7 +2042,8 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var)) ...@@ -2041,7 +2042,8 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var))
setConstraintVar lie_var $ setConstraintVar lie_var $
-- Put the 'lift' constraint into the right LIE -- Put the 'lift' constraint into the right LIE
newMethodFromName (OccurrenceOf id_name) newMethodFromName (OccurrenceOf id_name)
THNames.liftName id_ty THNames.liftName
[getRuntimeRep id_ty, id_ty]
-- Update the pending splices -- Update the pending splices
; ps <- readMutVar ps_var ; ps <- readMutVar ps_var
......
...@@ -54,8 +54,6 @@ import FamInst ...@@ -54,8 +54,6 @@ import FamInst
import FamInstEnv import FamInstEnv
import PrelNames import PrelNames
import THNames import THNames
import Module ( moduleName, moduleNameString
, moduleUnitId, unitIdString )
import MkId ( coerceId ) import MkId ( coerceId )
import PrimOp import PrimOp
import SrcLoc import SrcLoc
...@@ -1559,68 +1557,36 @@ Example: ...@@ -1559,68 +1557,36 @@ Example:
==> ==>
instance (Lift a) => Lift (Foo a) where instance (Lift a) => Lift (Foo a) where
lift (Foo a) lift (Foo a) = [| Foo a |]
= appE lift ((:^:) u v) = [| (:^:) u v |]
(conE
(mkNameG_d "package-name" "ModuleName" "Foo")) liftTyped (Foo a) = [|| Foo a ||]
(lift a) liftTyped ((:^:) u v) = [|| (:^:) u v ||]
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.
-} -}
gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) 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 where
lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) 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 data_cons = tyConDataCons tycon
pats_etc data_con pats_etc mk_bracket data_con
= ([con_pat], lift_Expr) = ([con_pat], lift_Expr)
where where
con_pat = nlConVarPat data_con_RDR as_needed con_pat = nlConVarPat data_con_RDR as_needed
data_con_RDR = getRdrName data_con data_con_RDR = getRdrName data_con
con_arity = dataConSourceArity data_con con_arity = dataConSourceArity data_con
as_needed = take con_arity as_RDRs as_needed = take con_arity as_RDRs
lifted_as = zipWithEqual "mk_lift_app" mk_lift_app lift_Expr = noLoc (HsBracket NoExt (mk_bracket br_body))
tys_needed as_needed br_body = nlHsApps (Exact (dataConName data_con))
tycon_name = tyConName tycon (map nlHsVar as_needed)
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]
{- {-
************************************************************************ ************************************************************************
...@@ -2134,17 +2100,6 @@ primOrdOps :: String -- The class involved ...@@ -2134,17 +2100,6 @@ primOrdOps :: String -- The class involved
-- See Note [Deriving and unboxed types] in TcDerivInfer -- See Note [Deriving and unboxed types] in TcDerivInfer
primOrdOps str ty = assoc_ty_id str ordOpTbl ty 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 :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl ordOpTbl
= [(charPrimTy , (ltChar_RDR , leChar_RDR = [(charPrimTy , (ltChar_RDR , leChar_RDR
......
...@@ -177,13 +177,14 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty ...@@ -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)) $ ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
tcInferRhoNC expr tcInferRhoNC expr
-- NC for no context; tcBracket does that -- NC for no context; tcBracket does that
; let rep = getRuntimeRep expr_ty
; meta_ty <- tcTExpTy expr_ty ; meta_ty <- tcTExpTy expr_ty
; ps' <- readMutVar ps_ref ; ps' <- readMutVar ps_ref
; texpco <- tcLookupId unsafeTExpCoerceName ; texpco <- tcLookupId unsafeTExpCoerceName
; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
rn_expr rn_expr
(unLoc (mkHsApp (nlHsTyApp texpco [expr_ty]) (unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty])
(noLoc (HsTcBracketOut noExt brack ps')))) (noLoc (HsTcBracketOut noExt brack ps'))))
meta_ty res_ty } meta_ty res_ty }
tcTypedBracket _ other_brack _ tcTypedBracket _ other_brack _
...@@ -230,7 +231,8 @@ tcTExpTy exp_ty ...@@ -230,7 +231,8 @@ tcTExpTy exp_ty
= do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty) = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)
; q <- tcLookupTyCon qTyConName ; q <- tcLookupTyCon qTyConName
; texp <- tcLookupTyCon tExpTyConName ; texp <- tcLookupTyCon tExpTyConName
; return (mkTyConApp q [mkTyConApp texp [exp_ty]]) } ; let rep = getRuntimeRep exp_ty
; return (mkTyConApp q [mkTyConApp texp [rep, exp_ty]]) }
where where
err_msg ty err_msg ty
= vcat [ text "Illegal polytype:" <+> ppr ty = vcat [ text "Illegal polytype:" <+> ppr ty
...@@ -469,12 +471,13 @@ tcNestedSplice :: ThStage -> PendingStuff -> Name ...@@ -469,12 +471,13 @@ tcNestedSplice :: ThStage -> PendingStuff -> Name
-- A splice inside brackets -- A splice inside brackets
tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty
= do { res_ty <- expTypeToType res_ty = do { res_ty <- expTypeToType res_ty
; let rep = getRuntimeRep res_ty
; meta_exp_ty <- tcTExpTy res_ty ; meta_exp_ty <- tcTExpTy res_ty
; expr' <- setStage pop_stage $ ; expr' <- setStage pop_stage $
setConstraintVar lie_var $ setConstraintVar lie_var $
tcMonoExpr expr (mkCheckExpType meta_exp_ty) tcMonoExpr expr (mkCheckExpType meta_exp_ty)
; untypeq <- tcLookupId unTypeQName ; untypeq <- tcLookupId unTypeQName
; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr' ; let expr'' = mkHsApp (nlHsTyApp untypeq [rep, res_ty]) expr'
; ps <- readMutVar ps_var ; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
......
...@@ -73,6 +73,12 @@ Runtime system ...@@ -73,6 +73,12 @@ Runtime system
Template Haskell 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 ``ghc-prim`` library
~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~
......
...@@ -4531,7 +4531,8 @@ Deriving ``Lift`` instances ...@@ -4531,7 +4531,8 @@ Deriving ``Lift`` instances
The class ``Lift``, unlike other derivable classes, lives in The class ``Lift``, unlike other derivable classes, lives in
``template-haskell`` instead of ``base``. Having a data type be an instance of ``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 ``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``: Here is an example of how one can derive ``Lift``:
   
...@@ -4546,17 +4547,11 @@ 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 instance (Lift a) => Lift (Foo a) where
lift (Foo a) lift (Foo a) = [| Foo a |]
= appE lift ((:^:) u v) = [| (:^:) u v |]
(conE
(mkNameG_d "package-name" "Bar" "Foo")) liftTyped (Foo a) = [|| Foo a ||]
(lift a) liftTyped ((:^:) u v) = [|| (:^:) u v ||]
lift (u :^: v)
= infixApp
(lift u)
(conE
(mkNameG_d "package-name" "Bar" ":^:"))
(lift v)
-} -}
   
----- -----
...@@ -4572,8 +4567,9 @@ Here is an example of how one can derive ``Lift``: ...@@ -4572,8 +4567,9 @@ Here is an example of how one can derive ``Lift``:
fooExp :: Lift a => Foo a -> Q Exp fooExp :: Lift a => Foo a -> Q Exp
fooExp f = [| f |] fooExp f = [| f |]
   
:extension:`DeriveLift` also works for certain unboxed types (``Addr#``, ``Char#``, Note that the ``Lift`` typeclass takes advantage of :ref:`runtime-rep` in order
``Double#``, ``Float#``, ``Int#``, and ``Word#``): 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``: ...@@ -4587,12 +4583,8 @@ Here is an example of how one can derive ``Lift``:
   
{- {-
instance Lift IntHash where instance Lift IntHash where
lift (IntHash i) lift (IntHash i) = [| IntHash i |]
= appE liftTyped (IntHash i) = [|| IntHash i ||]
(conE
(mkNameG_d "package-name" "Unboxed" "IntHash"))
(litE
(intPrimL (toInteger (I# i))))
-} -}
   
   
......
{-# LANGUAGE CPP, DeriveDataTypeable, {-# LANGUAGE CPP, DeriveDataTypeable,
DeriveGeneric, FlexibleInstances, DefaultSignatures, DeriveGeneric, FlexibleInstances, DefaultSignatures,
RankNTypes, RoleAnnotations, ScopedTypeVariables, RankNTypes, RoleAnnotations, ScopedTypeVariables,
MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds,
GADTs, UnboxedTuples, UnboxedSums, TypeInType,
Trustworthy #-} Trustworthy #-}
{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}
...@@ -32,13 +34,17 @@ import System.IO.Unsafe ( unsafePerformIO ) ...@@ -32,13 +34,17 @@ import System.IO.Unsafe ( unsafePerformIO )
import Control.Monad (liftM) import Control.Monad (liftM)
import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.IO.Class (MonadIO (..))
import System.IO ( hPutStrLn, stderr ) import System.IO ( hPutStrLn, stderr )
import Data.Char ( isAlpha, isAlphaNum, isUpper ) import Data.Char ( isAlpha, isAlphaNum, isUpper, ord )
import Data.Int