[Git][ghc/ghc][wip/tagless-parser] 4 commits: Hadrian: fix the value we pass to the test driver for config.compiler_debugged
Vladislav Zavialov
gitlab at gitlab.haskell.org
Fri Apr 19 15:45:04 UTC 2019
Vladislav Zavialov pushed to branch wip/tagless-parser 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.
- - - - -
0fc80bda by Vladislav Zavialov at 2019-04-19T15:44:02Z
Tagless final encoding of ExpCmdI in the parser
Before this change, we used a roundabout encoding:
1. a GADT (ExpCmdG)
2. a class to pass it around (ExpCmdI)
3. helpers to match on it (ecHsApp, ecHsIf, ecHsCase, ...)
It is more straightforward to turn these helpers into class methods,
removing the need for a GADT.
- - - - -
19 changed files:
- compiler/parser/RdrHsSyn.hs
- 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
- 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/parser/RdrHsSyn.hs
=====================================
@@ -50,7 +50,6 @@ module RdrHsSyn (
-- Bunch of functions in the parser monad for
-- checking and constructing values
- checkBlockArguments,
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPattern, -- HsExp -> P HsPat
@@ -61,7 +60,6 @@ module RdrHsSyn (
checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
- checkDoAndIfThenElse,
LRuleTyTmVar, RuleTyTmVar(..),
mkRuleBndrs, mkRuleTyVarBndrs,
checkRuleTyVarBndrNames,
@@ -94,14 +92,6 @@ module RdrHsSyn (
ExpCmdI(..),
ecFromExp,
ecFromCmd,
- ecHsLam,
- ecHsLet,
- ecOpApp,
- ecHsCase,
- ecHsApp,
- ecHsIf,
- ecHsDo,
- ecHsPar,
) where
@@ -1004,8 +994,9 @@ checkTyClHdr is_cls ty
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
-checkBlockArguments :: forall b. ExpCmdI b => Located (b GhcPs) -> PV ()
-checkBlockArguments = case expCmdG @b of { ExpG -> checkExpr; CmdG -> checkCmd }
+checkExpBlockArguments :: LHsExpr GhcPs -> P ()
+checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
+(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)
where
checkExpr :: LHsExpr GhcPs -> P ()
checkExpr expr = case unLoc expr of
@@ -1315,19 +1306,6 @@ checkValSigLhs lhs@(dL->L l _)
default_RDR = mkUnqual varName (fsLit "default")
pattern_RDR = mkUnqual varName (fsLit "pattern")
-checkDoAndIfThenElse
- :: forall b. ExpCmdI b =>
- LHsExpr GhcPs
- -> Bool
- -> Located (b GhcPs)
- -> Bool
- -> Located (b GhcPs)
- -> P ()
-checkDoAndIfThenElse =
- case expCmdG @b of
- ExpG -> checkDoAndIfThenElse'
- CmdG -> checkDoAndIfThenElse'
-
checkDoAndIfThenElse'
:: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
=> a -> Bool -> b -> Bool -> c -> P ()
@@ -1924,73 +1902,78 @@ checkMonadComp = do
newtype ExpCmdP =
ExpCmdP { runExpCmdP :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
--- See Note [Ambiguous syntactic categories]
-data ExpCmdG b where
- ExpG :: ExpCmdG HsExpr
- CmdG :: ExpCmdG HsCmd
-
--- See Note [Ambiguous syntactic categories]
-class ExpCmdI b where expCmdG :: ExpCmdG b
-instance ExpCmdI HsExpr where expCmdG = ExpG
-instance ExpCmdI HsCmd where expCmdG = CmdG
-
-ecFromCmd :: LHsCmd GhcPs -> ExpCmdP
-ecFromCmd c@(getLoc -> l) = ExpCmdP onB
- where
- onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))
- onB = case expCmdG @b of { ExpG -> onExp; CmdG -> return c }
- onExp :: P (LHsExpr GhcPs)
- onExp = do
- addError l $ vcat
- [ text "Arrow command found where an expression was expected:",
- nest 2 (ppr c) ]
- return (cL l hsHoleExpr)
-
ecFromExp :: LHsExpr GhcPs -> ExpCmdP
-ecFromExp e@(getLoc -> l) = ExpCmdP onB
- where
- onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))
- onB = case expCmdG @b of { ExpG -> return e; CmdG -> onCmd }
- onCmd :: P (LHsCmd GhcPs)
- onCmd =
- addFatalError l $
- text "Parse error in command:" <+> ppr e
+ecFromExp a = ExpCmdP (ecFromExp' a)
-hsHoleExpr :: HsExpr (GhcPass id)
-hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
-
-ecHsLam :: forall b. ExpCmdI b => MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
-ecHsLam = case expCmdG @b of { ExpG -> HsLam noExt; CmdG -> HsCmdLam noExt }
-
-ecHsLet :: forall b. ExpCmdI b => LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs
-ecHsLet = case expCmdG @b of { ExpG -> HsLet noExt; CmdG -> HsCmdLet noExt }
+ecFromCmd :: LHsCmd GhcPs -> ExpCmdP
+ecFromCmd a = ExpCmdP (ecFromCmd' a)
-ecOpApp :: forall b. ExpCmdI b => Located (b GhcPs) -> LHsExpr GhcPs
- -> Located (b GhcPs) -> b GhcPs
-ecOpApp = case expCmdG @b of { ExpG -> OpApp noExt; CmdG -> cmdOpApp }
- where
- cmdOpApp c1 op c2 =
+-- See Note [Ambiguous syntactic categories]
+class ExpCmdI b where
+ -- | Return a command without ambiguity, or fail in a non-command context.
+ ecFromCmd' :: LHsCmd GhcPs -> PV (Located (b GhcPs))
+ -- | Return an expression without ambiguity, or fail in a non-expression context.
+ ecFromExp' :: LHsExpr GhcPs -> PV (Located (b GhcPs))
+ -- | Disambiguate "\... -> ..." (lambda)
+ ecHsLam :: MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
+ -- | Disambiguate "let ... in ..."
+ ecHsLet :: LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs
+ -- | Disambiguate "f # x" (infix operator)
+ ecOpApp :: Located (b GhcPs) -> LHsExpr GhcPs -> Located (b GhcPs) -> b GhcPs
+ -- | Disambiguate "case ... of ..."
+ ecHsCase :: LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
+ -- | Disambiguate "f x" (function application)
+ ecHsApp :: Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs
+ -- | Disambiguate "if ... then ... else ..."
+ ecHsIf :: LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs
+ -- | Disambiguate "do { ... }" (do notation)
+ ecHsDo :: Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs
+ -- | Disambiguate "( ... )" (parentheses)
+ ecHsPar :: Located (b GhcPs) -> b GhcPs
+ -- | Check if the argument requires -XBlockArguments.
+ checkBlockArguments :: Located (b GhcPs) -> PV ()
+ -- | Check if -XDoAndIfThenElse is enabled.
+ checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs)
+ -> Bool -> Located (b GhcPs) -> P ()
+
+instance ExpCmdI HsCmd where
+ ecFromCmd' = return
+ ecFromExp' (dL-> L l e) =
+ addFatalError l $
+ text "Parse error in command:" <+> ppr e
+ ecHsLam = HsCmdLam noExt
+ ecHsLet = HsCmdLet noExt
+ ecOpApp c1 op c2 =
let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c in
HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2]
+ ecHsCase = HsCmdCase noExt
+ ecHsApp = HsCmdApp noExt
+ ecHsIf = mkHsCmdIf
+ ecHsDo = HsCmdDo noExt
+ ecHsPar = HsCmdPar noExt
+ checkBlockArguments = checkCmdBlockArguments
+ checkDoAndIfThenElse = checkDoAndIfThenElse'
+
+instance ExpCmdI HsExpr where
+ ecFromCmd' (dL -> L l c) = do
+ addError l $ vcat
+ [ text "Arrow command found where an expression was expected:",
+ nest 2 (ppr c) ]
+ return (cL l hsHoleExpr)
+ ecFromExp' = return
+ ecHsLam = HsLam noExt
+ ecHsLet = HsLet noExt
+ ecOpApp = OpApp noExt
+ ecHsCase = HsCase noExt
+ ecHsApp = HsApp noExt
+ ecHsIf = mkHsIf
+ ecHsDo = HsDo noExt DoExpr
+ ecHsPar = HsPar noExt
+ checkBlockArguments = checkExpBlockArguments
+ checkDoAndIfThenElse = checkDoAndIfThenElse'
-ecHsCase :: forall b. ExpCmdI b =>
- LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
-ecHsCase = case expCmdG @b of { ExpG -> HsCase noExt; CmdG -> HsCmdCase noExt }
-
-ecHsApp :: forall b. ExpCmdI b =>
- Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs
-ecHsApp = case expCmdG @b of { ExpG -> HsApp noExt; CmdG -> HsCmdApp noExt }
-
-ecHsIf :: forall b. ExpCmdI b =>
- LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs
-ecHsIf = case expCmdG @b of { ExpG -> mkHsIf; CmdG -> mkHsCmdIf }
-
-ecHsDo :: forall b. ExpCmdI b =>
- Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs
-ecHsDo = case expCmdG @b of { ExpG -> HsDo noExt DoExpr; CmdG -> HsCmdDo noExt }
-
-ecHsPar :: forall b. ExpCmdI b => Located (b GhcPs) -> b GhcPs
-ecHsPar = case expCmdG @b of { ExpG -> HsPar noExt; CmdG -> HsCmdPar noExt }
+hsHoleExpr :: HsExpr (GhcPass id)
+hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
{- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2043,19 +2026,12 @@ we decided against, see Note [Resolving parsing ambiguities: non-taken alternati
The solution that keeps basic definitions (such as HsExpr) clean, keeps the
concerns local to the parser, and does not require duplication of hsSyn types,
-or an extra pass over the entire AST, is to parse into a function from a GADT
-to a parser-validator:
-
- data ExpCmdG b where
- ExpG :: ExpCmdG HsExpr
- CmdG :: ExpCmdG HsCmd
-
- type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))
+or an extra pass over the entire AST, is to parse into an overloaded
+parser-validator (a so-called tagless final encoding):
- checkExp :: ExpCmd -> PV (LHsExpr GhcPs)
- checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)
- checkExp f = f ExpG -- interpret as an expression
- checkCmd f = f CmdG -- interpret as a command
+ class ExpCmdI b where ...
+ instance ExpCmdI HsCmd where ...
+ instance ExpCmdI HsExp where ...
Consider the 'alts' production used to parse case-of alternatives:
@@ -2065,30 +2041,6 @@ Consider the 'alts' production used to parse case-of alternatives:
We abstract over LHsExpr, and it becomes:
- alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
- : alts1
- { \tag -> $1 tag >>= \ $1 ->
- return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
- | ';' alts
- { \tag -> $2 tag >>= \ $2 ->
- return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
-
-Note that 'ExpCmdG' is a singleton type, the value is completely
-determined by the type:
-
- when (b~HsExpr), tag = ExpG
- when (b~HsCmd), tag = CmdG
-
-This is a clear indication that we can use a class to pass this value behind
-the scenes:
-
- class ExpCmdI b where expCmdG :: ExpCmdG b
- instance ExpCmdI HsExpr where expCmdG = ExpG
- instance ExpCmdI HsCmd where expCmdG = CmdG
-
-And now the 'alts' production is simplified, as we no longer need to
-thread 'tag' explicitly:
-
alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
: alts1 { $1 >>= \ $1 ->
return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
@@ -2331,6 +2283,63 @@ each reduction rule:
And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',
'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!
+Alternative VIII, a function from a GADT
+----------------------------------------
+We could avoid code duplication of the Alternative VII by representing the product
+as a function from a GADT:
+
+ data ExpCmdG b where
+ ExpG :: ExpCmdG HsExpr
+ CmdG :: ExpCmdG HsCmd
+
+ type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))
+
+ checkExp :: ExpCmd -> PV (LHsExpr GhcPs)
+ checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)
+ checkExp f = f ExpG -- interpret as an expression
+ checkCmd f = f CmdG -- interpret as a command
+
+Consider the 'alts' production used to parse case-of alternatives:
+
+ alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
+ : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
+ | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
+
+We abstract over LHsExpr, and it becomes:
+
+ alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
+ : alts1
+ { \tag -> $1 tag >>= \ $1 ->
+ return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
+ | ';' alts
+ { \tag -> $2 tag >>= \ $2 ->
+ return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
+
+Note that 'ExpCmdG' is a singleton type, the value is completely
+determined by the type:
+
+ when (b~HsExpr), tag = ExpG
+ when (b~HsCmd), tag = CmdG
+
+This is a clear indication that we can use a class to pass this value behind
+the scenes:
+
+ class ExpCmdI b where expCmdG :: ExpCmdG b
+ instance ExpCmdI HsExpr where expCmdG = ExpG
+ instance ExpCmdI HsCmd where expCmdG = CmdG
+
+And now the 'alts' production is simplified, as we no longer need to
+thread 'tag' explicitly:
+
+ alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
+ : alts1 { $1 >>= \ $1 ->
+ return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
+ | ';' alts { $2 >>= \ $2 ->
+ return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
+
+This encoding works well enough for two cases (Exp vs Cmd), but it does not scale well to
+more cases (Exp vs Cmd vs Pat), as we would need multiple GADTs for all possible ambiguities.
+
-}
---------------------------------------------------------------------------
=====================================
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 ||]
-}
=====================================
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/955dd9da75f668f48b7d9ddfd7800a321619d0ea...0fc80bda21c08e7f747062ac5c959e0cf2026242
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/955dd9da75f668f48b7d9ddfd7800a321619d0ea...0fc80bda21c08e7f747062ac5c959e0cf2026242
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/5162b5e3/attachment-0001.html>
More information about the ghc-commits
mailing list