[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Hadrian: fix the value we pass to the test driver for config.compiler_debugged
Marge Bot
gitlab at gitlab.haskell.org
Fri Apr 19 15:31:35 UTC 2019
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
5988f17a by Alp Mestanogullari at 2019-04-19T02:46:12Z
Hadrian: fix the value we pass to the test driver for config.compiler_debugged
We used to pass YES/NO, while that particular field is set to True/False. This
happens to fix an unexpected pass, T9208.
- - - - -
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.
- - - - -
489fb3e6 by Michal Terepeta at 2019-04-19T15:31:25Z
StgCmmPrim: remove an unnecessary instruction in doNewArrayOp
Previously we would generate a local variable pointing after the array
header and use it to initialize the array elements. But we already use
stores with offset, so it's easy to just add the header to those offsets
during compilation and avoid generating the local variable (which would
become a LEA instruction when using native codegen; LLVM already
optimizes it away).
Signed-off-by: Michal Terepeta <michal.terepeta at gmail.com>
- - - - -
7c3c8295 by klebinger.andreas at gmx.at at 2019-04-19T15:31:26Z
Don't indent single alternative case expressions for STG.
Makes the width of STG dumps slightly saner.
Especially for things like unboxing.
Fixes #16580
- - - - -
20 changed files:
- compiler/codeGen/StgCmmPrim.hs
- compiler/prelude/THNames.hs
- compiler/stgSyn/StgSyn.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
- hadrian/src/Settings/Builders/RunTest.hs
- 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/codeGen/StgCmmPrim.hs
=====================================
@@ -2143,11 +2143,8 @@ doNewArrayOp res_r rep info payload n init = do
emit $ mkAssign arr base
-- Initialise all elements of the array
- p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep)
- let initialization =
- [ mkStore (cmmOffsetW dflags (CmmReg (CmmLocal p)) off) init
- | off <- [0.. n - 1]
- ]
+ let mkOff off = cmmOffsetW dflags (CmmReg arr) (hdrSizeW dflags rep + off)
+ initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]
emit (catAGraphs initialization)
emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
=====================================
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/stgSyn/StgSyn.hs
=====================================
@@ -831,18 +831,31 @@ pprStgExpr (StgTick tickish expr)
else sep [ ppr tickish, pprStgExpr expr ]
+-- Don't indent for a single case alternative.
+pprStgExpr (StgCase expr bndr alt_type [alt])
+ = sep [sep [text "case",
+ nest 4 (hsep [pprStgExpr expr,
+ whenPprDebug (dcolon <+> ppr alt_type)]),
+ text "of", pprBndr CaseBind bndr, char '{'],
+ pprStgAlt False alt,
+ char '}']
+
pprStgExpr (StgCase expr bndr alt_type alts)
= sep [sep [text "case",
nest 4 (hsep [pprStgExpr expr,
whenPprDebug (dcolon <+> ppr alt_type)]),
text "of", pprBndr CaseBind bndr, char '{'],
- nest 2 (vcat (map pprStgAlt alts)),
+ nest 2 (vcat (map (pprStgAlt True) alts)),
char '}']
-pprStgAlt :: OutputablePass pass => GenStgAlt pass -> SDoc
-pprStgAlt (con, params, expr)
- = hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
- 4 (ppr expr <> semi)
+
+pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc
+pprStgAlt indent (con, params, expr)
+ | indent = hang altPattern 4 (ppr expr <> semi)
+ | otherwise = sep [altPattern, ppr expr <> semi]
+ where
+ altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
+
pprStgOp :: StgOp -> SDoc
pprStgOp (StgPrimOp op) = ppr op
=====================================
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 ||]
-}
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -68,7 +68,7 @@ runTestBuilderArgs = builder RunTest ? do
withInterpreter <- getBooleanSetting TestGhcWithInterpreter
unregisterised <- getBooleanSetting TestGhcUnregisterised
withSMP <- getBooleanSetting TestGhcWithSMP
- debugged <- read <$> getTestSetting TestGhcDebugged
+ debugged <- readBool <$> getTestSetting TestGhcDebugged
keepFiles <- expr (testKeepFiles <$> userSetting defaultTestArgs)
accept <- expr (testAccept <$> userSetting defaultTestArgs)
@@ -104,8 +104,8 @@ runTestBuilderArgs = builder RunTest ? do
, arg "-e", arg $ "config.accept_platform=" ++ show acceptPlatform
, arg "-e", arg $ "config.accept_os=" ++ show acceptOS
, arg "-e", arg $ "config.exeext=" ++ quote exe
- , arg "-e", arg $ "config.compiler_debugged=" ++ quote (yesNo debugged)
- , arg "-e", arg $ "ghc_debugged=" ++ quote (yesNo debugged)
+ , arg "-e", arg $ "config.compiler_debugged=" ++
+ show debugged
, arg "-e", arg $ asZeroOne "ghc_with_native_codegen=" withNativeCodeGen
, arg "-e", arg $ "config.have_interp=" ++ show withInterpreter
@@ -136,6 +136,8 @@ runTestBuilderArgs = builder RunTest ? do
, getTestArgs -- User-provided arguments from command line.
]
+ where readBool x = read x :: Bool
+
-- | Command line arguments for running GHC's test script.
getTestArgs :: Args
getTestArgs = do
=====================================
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/a752ef6f112851669e18f4323df4f05f0457e502...7c3c8295f225ae7c733538fa6e6853e07a360980
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/a752ef6f112851669e18f4323df4f05f0457e502...7c3c8295f225ae7c733538fa6e6853e07a360980
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/20190419/cac3a2df/attachment-0001.html>
More information about the ghc-commits
mailing list