[Git][ghc/ghc][master] 2 commits: TH: make `Lift` and `TExp` levity-polymorphic
Marge Bot
gitlab at gitlab.haskell.org
Fri Apr 19 02:58:38 UTC 2019
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
57cf1133 by Alec Theriault at 2019-04-19T02:52:25Z
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.
- - - - -
fdfd9731 by Alec Theriault at 2019-04-19T02:52:25Z
Add test case for #16384
Now that `TExp` accepts unlifted types, #16384 is fixed. Since the real
issue there was GHC letting through an ill-kinded type which
`-dcore-lint` rightly rejected, a reasonable regression test is that
the program from #16384 can now be accepted without `-dcore-lint`
complaining.
- - - - -
17 changed files:
- compiler/prelude/THNames.hs
- compiler/typecheck/Inst.hs
- compiler/typecheck/TcDeriv.hs
- compiler/typecheck/TcDerivUtils.hs
- compiler/typecheck/TcExpr.hs
- compiler/typecheck/TcGenDeriv.hs
- compiler/typecheck/TcSplice.hs
- docs/users_guide/8.10.1-notes.rst
- docs/users_guide/glasgow_exts.rst
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- libraries/template-haskell/template-haskell.cabal.in
- testsuite/tests/deriving/should_compile/T14682.stderr
- testsuite/tests/deriving/should_compile/drv-empty-data.stderr
- + testsuite/tests/quotes/T16384.hs
- testsuite/tests/quotes/TH_localname.stderr
- testsuite/tests/quotes/all.T
Changes:
=====================================
compiler/prelude/THNames.hs
=====================================
@@ -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
=====================================
compiler/typecheck/Inst.hs
=====================================
@@ -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
=====================================
compiler/typecheck/TcDeriv.hs
=====================================
@@ -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
=====================================
compiler/typecheck/TcDerivUtils.hs
=====================================
@@ -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
=====================================
compiler/typecheck/TcExpr.hs
=====================================
@@ -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
=====================================
compiler/typecheck/TcGenDeriv.hs
=====================================
@@ -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)
+ lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
+ (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
=====================================
compiler/typecheck/TcSplice.hs
=====================================
@@ -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)
=====================================
docs/users_guide/8.10.1-notes.rst
=====================================
@@ -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
~~~~~~~~~~~~~~~~~~~~
=====================================
docs/users_guide/glasgow_exts.rst
=====================================
@@ -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 ||]
-}
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -1,6 +1,8 @@
{-# 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 at . 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))))
+
instance Lift Char where
+ liftTyped x = unsafeTExpCoerce (lift x)
lift x = return (LitE (CharL x))
+-- | @since 2.16.0.0
+instance Lift Char# where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift x = return (LitE (CharPrimL (C# x)))
+
instance Lift Bool where
+ liftTyped x = unsafeTExpCoerce (lift x)
+
lift True = return (ConE trueName)
lift False = return (ConE falseName)
+-- | Produces an 'Addr#' literal from the NUL-terminated C-string starting at
+-- the given memory address.
+--
+-- @since 2.16.0.0
+instance Lift Addr# where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift x
+ = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x))))
+
instance Lift a => Lift (Maybe a) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+
lift Nothing = return (ConE nothingName)
lift (Just x) = liftM (ConE justName `AppE`) (lift x)
instance (Lift a, Lift b) => Lift (Either a b) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+
lift (Left x) = liftM (ConE leftName `AppE`) (lift x)
lift (Right y) = liftM (ConE rightName `AppE`) (lift y)
instance Lift a => Lift [a] where
+ liftTyped x = unsafeTExpCoerce (lift x)
lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
liftString :: String -> Q Exp
@@ -759,6 +827,8 @@ liftString s = return (LitE (StringL s))
-- | @since 2.15.0.0
instance Lift a => Lift (NonEmpty a) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+
lift (x :| xs) = do
x' <- lift x
xs' <- lift xs
@@ -766,38 +836,166 @@ instance Lift a => Lift (NonEmpty a) where
-- | @since 2.15.0.0
instance Lift Void where
+ liftTyped = pure . absurd
lift = pure . absurd
instance Lift () where
+ liftTyped x = unsafeTExpCoerce (lift x)
lift () = return (ConE (tupleDataName 0))
instance (Lift a, Lift b) => Lift (a, b) where
+ liftTyped x = unsafeTExpCoerce (lift x)
lift (a, b)
= liftM TupE $ sequence [lift a, lift b]
instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where
+ liftTyped x = unsafeTExpCoerce (lift x)
lift (a, b, c)
= liftM TupE $ sequence [lift a, lift b, lift c]
instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where
+ liftTyped x = unsafeTExpCoerce (lift x)
lift (a, b, c, d)
= liftM TupE $ sequence [lift a, lift b, lift c, lift d]
instance (Lift a, Lift b, Lift c, Lift d, Lift e)
=> Lift (a, b, c, d, e) where
+ liftTyped x = unsafeTExpCoerce (lift x)
lift (a, b, c, d, e)
= liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e]
instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
=> Lift (a, b, c, d, e, f) where
+ liftTyped x = unsafeTExpCoerce (lift x)
lift (a, b, c, d, e, f)
= liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
=> Lift (a, b, c, d, e, f, g) where
+ liftTyped x = unsafeTExpCoerce (lift x)
lift (a, b, c, d, e, f, g)
= liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
+-- | @since 2.16.0.0
+instance Lift (# #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift (# #) = return (ConE (unboxedTupleTypeName 0))
+
+-- | @since 2.16.0.0
+instance (Lift a) => Lift (# a #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift (# a #)
+ = liftM UnboxedTupE $ sequence [lift a]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b) => Lift (# a, b #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift (# a, b #)
+ = liftM UnboxedTupE $ sequence [lift a, lift b]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c)
+ => Lift (# a, b, c #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift (# a, b, c #)
+ = liftM UnboxedTupE $ sequence [lift a, lift b, lift c]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d)
+ => Lift (# a, b, c, d #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift (# a, b, c, d #)
+ = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e)
+ => Lift (# a, b, c, d, e #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift (# a, b, c, d, e #)
+ = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
+ => Lift (# a, b, c, d, e, f #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift (# a, b, c, d, e, f #)
+ = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
+ => Lift (# a, b, c, d, e, f, g #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift (# a, b, c, d, e, f, g #)
+ = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b) => Lift (# a | b #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift x
+ = case x of
+ (# y | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 2
+ (# | y #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 2
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c)
+ => Lift (# a | b | c #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift x
+ = case x of
+ (# y | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 3
+ (# | y | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 3
+ (# | | y #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 3
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d)
+ => Lift (# a | b | c | d #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift x
+ = case x of
+ (# y | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 4
+ (# | y | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 4
+ (# | | y | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 4
+ (# | | | y #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 4
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e)
+ => Lift (# a | b | c | d | e #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift x
+ = case x of
+ (# y | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 5
+ (# | y | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 5
+ (# | | y | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 5
+ (# | | | y | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 5
+ (# | | | | y #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 5
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
+ => Lift (# a | b | c | d | e | f #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift x
+ = case x of
+ (# y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 6
+ (# | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 6
+ (# | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 6
+ (# | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 6
+ (# | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 6
+ (# | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 6
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
+ => Lift (# a | b | c | d | e | f | g #) where
+ liftTyped x = unsafeTExpCoerce (lift x)
+ lift x
+ = case x of
+ (# y | | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 7
+ (# | y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 7
+ (# | | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 7
+ (# | | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 7
+ (# | | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 7
+ (# | | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 7
+ (# | | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 7 <*> pure 7
+
-- TH has a special form for literal strings,
-- which we should take advantage of.
-- NB: the lhs of the rule has no args, so that
@@ -1619,8 +1817,8 @@ data Lit = CharL Char
| WordPrimL Integer
| FloatPrimL Rational
| DoublePrimL Rational
- | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr#
- | BytesPrimL Bytes -- ^ Some raw bytes, type Addr#:
+ | StringPrimL [Word8] -- ^ A primitive C-style string, type 'Addr#'
+ | BytesPrimL Bytes -- ^ Some raw bytes, type 'Addr#':
| CharPrimL Char
deriving( Show, Eq, Ord, Data, Generic )
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -3,7 +3,7 @@
## 2.16.0.0 *TBA*
* Introduce a `liftTyped` method to the `Lift` class and set the default
- implementations of `lift`/`liftTyped` to be in terms of each other.
+ implementations of `lift` in terms of `liftTyped`.
* Add a `ForallVisT` constructor to `Type` to represent visible, dependent
quantification.
@@ -11,6 +11,9 @@
* Introduce support for `Bytes` literals (raw bytes embedded into the output
binary)
+ * Make the `Lift` typeclass levity-polymorphic and add instances for unboxed
+ tuples, unboxed sums, `Int#`, `Word#`, `Addr#`, `Float#`, and `Double#`.
+
## 2.15.0.0 *TBA*
* In `Language.Haskell.TH.Syntax`, `DataInstD`, `NewTypeInstD`, `TySynEqn`,
=====================================
libraries/template-haskell/template-haskell.cabal.in
=====================================
@@ -57,6 +57,7 @@ Library
build-depends:
base >= 4.11 && < 4.14,
ghc-boot-th == @ProjectVersionMunged@,
+ ghc-prim,
pretty == 1.1.*
ghc-options: -Wall
=====================================
testsuite/tests/deriving/should_compile/T14682.stderr
=====================================
@@ -13,13 +13,12 @@ Derived class instances:
instance Language.Haskell.TH.Syntax.Lift T14682.Foo where
Language.Haskell.TH.Syntax.lift (T14682.Foo a1 a2)
- = Language.Haskell.TH.Lib.Internal.appE
- (Language.Haskell.TH.Lib.Internal.appE
- (Language.Haskell.TH.Lib.Internal.conE
- (Language.Haskell.TH.Syntax.mkNameG_d "main" "T14682" "Foo"))
- (Language.Haskell.TH.Syntax.lift a1))
- (Language.Haskell.TH.Syntax.lift a2)
-
+ = [| T14682.Foo a1 a2 |]
+ pending(rn) [<a2, Language.Haskell.TH.Syntax.lift a2>,
+ <a1, Language.Haskell.TH.Syntax.lift a1>]
+ Language.Haskell.TH.Syntax.liftTyped (T14682.Foo a1 a2)
+ = [|| T14682.Foo a1 a2 ||]
+
instance Data.Data.Data T14682.Foo where
Data.Data.gfoldl k z (T14682.Foo a1 a2)
= ((z T14682.Foo `k` a1) `k` a2)
@@ -97,13 +96,6 @@ GHC.Show.Show [T14682.Foo]
-==================== Filling in method body ====================
-Language.Haskell.TH.Syntax.Lift [T14682.Foo]
- Language.Haskell.TH.Syntax.liftTyped = Language.Haskell.TH.Syntax.$dmliftTyped
- @(T14682.Foo)
-
-
-
==================== Filling in method body ====================
Data.Data.Data [T14682.Foo]
Data.Data.dataCast1 = Data.Data.$dmdataCast1 @(T14682.Foo)
=====================================
testsuite/tests/deriving/should_compile/drv-empty-data.stderr
=====================================
@@ -46,6 +46,7 @@ Derived class instances:
instance Language.Haskell.TH.Syntax.Lift
(DrvEmptyData.Void a) where
Language.Haskell.TH.Syntax.lift z = GHC.Base.pure (case z of)
+ Language.Haskell.TH.Syntax.liftTyped z = GHC.Base.pure (case z of)
DrvEmptyData.$tVoid :: Data.Data.DataType
DrvEmptyData.$tVoid = Data.Data.mkDataType "Void" []
=====================================
testsuite/tests/quotes/T16384.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TemplateHaskell #-}
+module T16384 where
+
+import GHC.Exts
+
+wat :: () -> Int#
+wat _ = $$([|| 1# ||])
+
=====================================
testsuite/tests/quotes/TH_localname.stderr
=====================================
@@ -9,17 +9,7 @@ TH_localname.hs:3:11: error:
(bound at TH_localname.hs:3:1)
Probable fix: use a type annotation to specify what ‘t0’ should be.
These potential instances exist:
- instance (Language.Haskell.TH.Syntax.Lift a,
- Language.Haskell.TH.Syntax.Lift b) =>
- Language.Haskell.TH.Syntax.Lift (Either a b)
- -- Defined in ‘Language.Haskell.TH.Syntax’
- instance Language.Haskell.TH.Syntax.Lift Integer
- -- Defined in ‘Language.Haskell.TH.Syntax’
- instance Language.Haskell.TH.Syntax.Lift a =>
- Language.Haskell.TH.Syntax.Lift (Maybe a)
- -- Defined in ‘Language.Haskell.TH.Syntax’
- ...plus 14 others
- ...plus 12 instances involving out-of-scope types
+ 29 instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In the expression: Language.Haskell.TH.Syntax.lift y
In the expression:
=====================================
testsuite/tests/quotes/all.T
=====================================
@@ -15,6 +15,7 @@ test('T8633', normal, compile_and_run, [''])
test('T8759a', normal, compile, ['-v0'])
test('T9824', normal, compile, ['-v0'])
test('T10384', normal, compile_fail, [''])
+test('T16384', normal, compile, [''])
test('TH_tf2', normal, compile, ['-v0'])
test('TH_ppr1', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/5988f17a799ba3416bb6ed539ae65e1f3fd9f2c0...fdfd97310128d82ac5316d357f0422c9939c1edc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/5988f17a799ba3416bb6ed539ae65e1f3fd9f2c0...fdfd97310128d82ac5316d357f0422c9939c1edc
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190418/49ac8372/attachment-0001.html>
More information about the ghc-commits
mailing list