[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Implement -XLexicalNegation (GHC Proposal #229)
Marge Bot
gitlab at gitlab.haskell.org
Wed Jul 1 11:41:38 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
573cd33e by Vladislav Zavialov at 2020-07-01T07:41:24-04:00
Implement -XLexicalNegation (GHC Proposal #229)
This patch introduces a new extension, -XLexicalNegation, which detects
whether the minus sign stands for negation or subtraction using the
whitespace-based rules described in GHC Proposal #229.
Updates haddock submodule.
- - - - -
fe93d94f by Martin Handley at 2020-07-01T07:41:27-04:00
#17169: Clarify Fixed's Enum instance.
- - - - -
fa904335 by Simon Peyton Jones at 2020-07-01T07:41:28-04:00
Improve debug tracing for substitution
This patch improves debug tracing a bit (#18395)
* Remove the ancient SDoc argument to substitution, replacing it
with a HasDebugCallStack constraint. The latter does the same
job (indicate the call site) but much better.
* Add HasDebugCallStack to simpleOptExpr, exprIsConApp_maybe
I needed this to help nail the lookupIdSubst panic in
#18326, #17784
- - - - -
127ee5cb by Hécate at 2020-07-01T07:41:30-04:00
Add most common return values for `os` and `arch`
- - - - -
a19466b0 by Ryan Scott at 2020-07-01T07:41:30-04:00
Desugar quoted uses of DerivingVia and expression type signatures properly
The way that `GHC.HsToCore.Quote` desugared quoted `via` types (e.g.,
`deriving via forall a. [a] instance Eq a => Eq (List a)`) and
explicit type annotations in signatures (e.g.,
`f = id @a :: forall a. a -> a`) was completely wrong, as it did not
implement the scoping guidelines laid out in
`Note [Scoped type variables in bindings]`. This is easily fixed.
While I was in town, I did some minor cleanup of related Notes:
* `Note [Scoped type variables in bindings]` and
`Note [Scoped type variables in class and instance declarations]`
say very nearly the same thing. I decided to just consolidate the
two Notes into `Note [Scoped type variables in quotes]`.
* `Note [Don't quantify implicit type variables in quotes]` is
somewhat outdated, as it predates GHC 8.10, where the
`forall`-or-nothing rule requires kind variables to be explicitly
quantified in the presence of an explicit `forall`. As a result,
the running example in that Note doesn't even compile. I have
changed the example to something simpler that illustrates the
same point that the original Note was making.
Fixes #18388.
- - - - -
30 changed files:
- aclocal.m4
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Lexer.x
- docs/users_guide/8.12.1-notes.rst
- + docs/users_guide/exts/lexical_negation.rst
- docs/users_guide/exts/negative_literals.rst
- docs/users_guide/exts/syntax.rst
- libraries/base/Data/Fixed.hs
- libraries/base/System/Info.hs
- libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
- testsuite/tests/driver/T4437.hs
- + testsuite/tests/parser/should_compile/LexNegVsNegLit.hs
- + testsuite/tests/parser/should_compile/LexicalNegation.hs
- testsuite/tests/parser/should_compile/all.T
- + testsuite/tests/parser/should_run/LexNegLit.hs
- + testsuite/tests/parser/should_run/LexNegLit.stdout
- testsuite/tests/parser/should_run/all.T
- + testsuite/tests/th/T18388.hs
- testsuite/tests/th/all.T
- utils/haddock
Changes:
=====================================
aclocal.m4
=====================================
@@ -1919,7 +1919,9 @@ AC_MSG_CHECKING(for path to top of build tree)
# GHC_CONVERT_CPU(cpu, target_var)
# --------------------------------
-# converts cpu from gnu to ghc naming, and assigns the result to $target_var
+# Converts cpu from gnu to ghc naming, and assigns the result to $target_var.
+# Should you modify this list, you are invited to reflect the changes in
+# `libraries/base/System/Info.hs`'s documentation.
AC_DEFUN([GHC_CONVERT_CPU],[
case "$1" in
aarch64*)
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -1023,7 +1023,7 @@ etaInfoApp subst (Tick t e) eis
etaInfoApp subst expr _
| (Var fun, _) <- collectArgs expr
- , Var fun' <- lookupIdSubst (text "etaInfoApp" <+> ppr fun) subst fun
+ , Var fun' <- lookupIdSubst subst fun
, isJoinId fun'
= subst_expr subst expr
@@ -1132,13 +1132,16 @@ mkEtaWW orig_n ppr_orig_expr in_scope orig_ty
---------------
--- Don't use short-cutting substitution - we may be changing the types of join
--- points, so applying the in-scope set is necessary
--- TODO Check if we actually *are* changing any join points' types
-
+------------
subst_expr :: Subst -> CoreExpr -> CoreExpr
-subst_expr = substExpr (text "GHC.Core.Opt.Arity:substExpr")
+-- Apply a substitution to an expression. We use substExpr
+-- not substExprSC (short-cutting substitution) because
+-- we may be changing the types of join points, so applying
+-- the in-scope set is necessary.
+--
+-- ToDo: we could instead check if we actually *are*
+-- changing any join points' types, and if not use substExprSC.
+subst_expr = substExpr
--------------
=====================================
compiler/GHC/Core/Opt/CSE.hs
=====================================
@@ -775,7 +775,7 @@ csEnvSubst :: CSEnv -> Subst
csEnvSubst = cs_subst
lookupSubst :: CSEnv -> Id -> OutExpr
-lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
+lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst sub x
extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv
extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1804,7 +1804,7 @@ abstractFloats dflags top_lvl main_tvs floats body
= ASSERT( notNull body_floats )
ASSERT( isNilOL (sfJoinFloats floats) )
do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
- ; return (float_binds, GHC.Core.Subst.substExpr (text "abstract_floats1") subst body) }
+ ; return (float_binds, GHC.Core.Subst.substExpr subst body) }
where
is_top_lvl = isTopLevel top_lvl
main_tv_set = mkVarSet main_tvs
@@ -1818,7 +1818,7 @@ abstractFloats dflags top_lvl main_tvs floats body
subst' = GHC.Core.Subst.extendIdSubst subst id poly_app
; return (subst', NonRec poly_id2 poly_rhs) }
where
- rhs' = GHC.Core.Subst.substExpr (text "abstract_floats2") subst rhs
+ rhs' = GHC.Core.Subst.substExpr subst rhs
-- tvs_here: see Note [Which type variables to abstract over]
tvs_here = scopedSort $
@@ -1831,8 +1831,7 @@ abstractFloats dflags top_lvl main_tvs floats body
; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)
poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
| (poly_id, rhs) <- poly_ids `zip` rhss
- , let rhs' = GHC.Core.Subst.substExpr (text "abstract_floats")
- subst' rhs ]
+ , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
; return (subst', Rec poly_pairs) }
where
(ids,rhss) = unzip prs
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -860,7 +860,7 @@ lookupHowBound :: ScEnv -> Id -> Maybe HowBound
lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
scSubstId :: ScEnv -> Id -> CoreExpr
-scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
+scSubstId env v = lookupIdSubst (sc_subst env) v
scSubstTy :: ScEnv -> Type -> Type
scSubstTy env ty = substTy (sc_subst env) ty
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1008,7 +1008,7 @@ instance Outputable SpecEnv where
, text "interesting =" <+> ppr interesting ])
specVar :: SpecEnv -> Id -> CoreExpr
-specVar env v = Core.lookupIdSubst (text "specVar") (se_subst env) v
+specVar env v = Core.lookupIdSubst (se_subst env) v
specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -917,7 +917,7 @@ match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env })
Var v2 | v1' == rnOccR rn_env v2
-> Just subst
- | Var v2' <- lookupIdSubst (text "match_var") flt_env v2
+ | Var v2' <- lookupIdSubst flt_env v2
, v1' == v2'
-> Just subst
@@ -965,7 +965,7 @@ match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })
where
-- e2' is the result of applying flt_env to e2
e2' | isEmptyVarSet let_bndrs = e2
- | otherwise = substExpr (text "match_tmpl_var") flt_env e2
+ | otherwise = substExpr flt_env e2
id_subst' = extendVarEnv (rs_id_subst subst) v1' e2'
-- No further renaming to do on e2',
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -93,7 +93,7 @@ little dance in action; the full Simplifier is a lot more complicated.
-}
-simpleOptExpr :: DynFlags -> CoreExpr -> CoreExpr
+simpleOptExpr :: HasDebugCallStack => DynFlags -> CoreExpr -> CoreExpr
-- See Note [The simple optimiser]
-- Do simple optimisation on an expression
-- The optimisation is very straightforward: just
@@ -125,7 +125,7 @@ simpleOptExpr dflags expr
-- It's a bit painful to call exprFreeVars, because it makes
-- three passes instead of two (occ-anal, and go)
-simpleOptExprWith :: DynFlags -> Subst -> InExpr -> OutExpr
+simpleOptExprWith :: HasDebugCallStack => DynFlags -> Subst -> InExpr -> OutExpr
-- See Note [The simple optimiser]
simpleOptExprWith dflags subst expr
= simple_opt_expr init_env (occurAnalyseExpr expr)
@@ -218,7 +218,7 @@ simple_opt_expr env expr
| Just clo <- lookupVarEnv (soe_inl env) v
= simple_opt_clo env clo
| otherwise
- = lookupIdSubst (text "simpleOptExpr") (soe_subst env) v
+ = lookupIdSubst (soe_subst env) v
go (App e1 e2) = simple_app env e1 [(env,e2)]
go (Type ty) = Type (substTy subst ty)
@@ -293,7 +293,7 @@ mk_cast e co | isReflexiveCo co = e
----------------------
-- simple_app collects arguments for beta reduction
-simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr
+simple_app :: HasDebugCallStack => SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr
simple_app env (Var v) as
| Just (env', e) <- lookupVarEnv (soe_inl env) v
@@ -306,7 +306,7 @@ simple_app env (Var v) as
= simple_app (soeZapSubst env) (unfoldingTemplate unf) as
| otherwise
- , let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v
+ , let out_fn = lookupIdSubst (soe_subst env) v
= finish_app env out_fn as
simple_app env (App e1 e2) as
@@ -1064,7 +1064,8 @@ data ConCont = CC [CoreExpr] Coercion
--
-- We also return the incoming InScopeSet, augmented with
-- the binders from any [FloatBind] that we return
-exprIsConApp_maybe :: InScopeEnv -> CoreExpr
+exprIsConApp_maybe :: HasDebugCallStack
+ => InScopeEnv -> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe (in_scope, id_unf) expr
= go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr)))
@@ -1118,7 +1119,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr
go (Right sub) floats (Var v) cont
= go (Left (substInScope sub))
floats
- (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v)
+ (lookupIdSubst sub v)
cont
go (Left in_scope) floats (Var fun) cont@(CC args co)
@@ -1141,7 +1142,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr
, bndrs `equalLength` args -- See Note [DFun arity check]
, let subst = mkOpenSubst in_scope (bndrs `zip` args)
= succeedWith in_scope floats $
- pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co
+ pushCoDataCon con (map (substExpr subst) dfun_args) co
-- Look through unfoldings, but only arity-zero one;
-- if arity > 0 we are effectively inlining a function call,
@@ -1180,7 +1181,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr
subst_co (Right s) co = GHC.Core.Subst.substCo s co
subst_expr (Left {}) e = e
- subst_expr (Right s) e = substExpr (text "exprIsConApp2") s e
+ subst_expr (Right s) e = substExpr s e
subst_bndr msubst bndr
= (Right subst', bndr')
@@ -1461,7 +1462,7 @@ pushCoercionIntoLambda in_scope x e co
subst = extendIdSubst (mkEmptySubst in_scope')
x
(mkCast (Var x') co1)
- in Just (x', substExpr (text "pushCoercionIntoLambda") subst e `mkCast` co2)
+ in Just (x', substExpr subst e `mkCast` co2)
| otherwise
= pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e))
Nothing
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -246,13 +246,13 @@ extendSubstList subst [] = subst
extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs
-- | Find the substitution for an 'Id' in the 'Subst'
-lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr
-lookupIdSubst doc (Subst in_scope ids _ _) v
+lookupIdSubst :: HasDebugCallStack => Subst -> Id -> CoreExpr
+lookupIdSubst (Subst in_scope ids _ _) v
| not (isLocalId v) = Var v
| Just e <- lookupVarEnv ids v = e
| Just v' <- lookupInScope in_scope v = Var v'
-- Vital! See Note [Extending the Subst]
- | otherwise = WARN( True, text "GHC.Core.Subst.lookupIdSubst" <+> doc <+> ppr v
+ | otherwise = WARN( True, text "GHC.Core.Subst.lookupIdSubst" <+> ppr v
$$ ppr in_scope)
Var v
@@ -338,26 +338,25 @@ instance Outputable Subst where
************************************************************************
-}
--- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only
--- apply the substitution /once/:
+substExprSC :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr
+-- Just like substExpr, but a no-op if the substitution is empty
+substExprSC subst orig_expr
+ | isEmptySubst subst = orig_expr
+ | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $
+ substExpr subst orig_expr
+
+-- | substExpr applies a substitution to an entire 'CoreExpr'. Remember,
+-- you may only apply the substitution /once/:
-- See Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst"
--
-- Do *not* attempt to short-cut in the case of an empty substitution!
-- See Note [Extending the Subst]
-substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr
-substExprSC doc subst orig_expr
- | isEmptySubst subst = orig_expr
- | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $
- subst_expr doc subst orig_expr
-
-substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr
-substExpr doc subst orig_expr = subst_expr doc subst orig_expr
-
-subst_expr :: SDoc -> Subst -> CoreExpr -> CoreExpr
-subst_expr doc subst expr
+substExpr :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr
+ -- HasDebugCallStack so we can track failures in lookupIdSubst
+substExpr subst expr
= go expr
where
- go (Var v) = lookupIdSubst (doc $$ text "subst_expr") subst v
+ go (Var v) = lookupIdSubst subst v
go (Type ty) = Type (substTy subst ty)
go (Coercion co) = Coercion (substCo subst co)
go (Lit lit) = Lit lit
@@ -370,11 +369,11 @@ subst_expr doc subst expr
-- lose a binder. We optimise the LHS of rules at
-- construction time
- go (Lam bndr body) = Lam bndr' (subst_expr doc subst' body)
+ go (Lam bndr body) = Lam bndr' (substExpr subst' body)
where
(subst', bndr') = substBndr subst bndr
- go (Let bind body) = Let bind' (subst_expr doc subst' body)
+ go (Let bind body) = Let bind' (substExpr subst' body)
where
(subst', bind') = substBind subst bind
@@ -382,13 +381,13 @@ subst_expr doc subst expr
where
(subst', bndr') = substBndr subst bndr
- go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr doc subst' rhs)
+ go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
where
(subst', bndrs') = substBndrs subst bndrs
-- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst'
-- that should be used by subsequent substitutions.
-substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind)
+substBind, substBindSC :: HasDebugCallStack => Subst -> CoreBind -> (Subst, CoreBind)
substBindSC subst bind -- Short-cut if the substitution is empty
| not (isEmptySubst subst)
@@ -405,10 +404,10 @@ substBindSC subst bind -- Short-cut if the substitution is empty
rhss' | isEmptySubst subst'
= rhss
| otherwise
- = map (subst_expr (text "substBindSC") subst') rhss
+ = map (substExpr subst') rhss
substBind subst (NonRec bndr rhs)
- = (subst', NonRec bndr' (subst_expr (text "substBind") subst rhs))
+ = (subst', NonRec bndr' (substExpr subst rhs))
where
(subst', bndr') = substBndr subst bndr
@@ -417,7 +416,7 @@ substBind subst (Rec pairs)
where
(bndrs, rhss) = unzip pairs
(subst', bndrs') = substRecBndrs subst bndrs
- rhss' = map (subst_expr (text "substBind") subst') rhss
+ rhss' = map (substExpr subst') rhss
-- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply
-- by running over the bindings with an empty substitution, because substitution
@@ -638,7 +637,7 @@ substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
= df { df_bndrs = bndrs', df_args = args' }
where
(subst',bndrs') = substBndrs subst bndrs
- args' = map (substExpr (text "subst-unf:dfun") subst') args
+ args' = map (substExpr subst') args
substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
-- Retain an InlineRule!
@@ -648,14 +647,14 @@ substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
= seqExpr new_tmpl `seq`
unf { uf_tmpl = new_tmpl }
where
- new_tmpl = substExpr (text "subst-unf") subst tmpl
+ new_tmpl = substExpr subst tmpl
substUnfolding _ unf = unf -- NoUnfolding, OtherCon
------------------
substIdOcc :: Subst -> Id -> Id
-- These Ids should not be substituted to non-Ids
-substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of
+substIdOcc subst v = case lookupIdSubst subst v of
Var v' -> v'
other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst])
@@ -693,12 +692,11 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
, ru_fn = if is_local
then subst_ru_fn fn_name
else fn_name
- , ru_args = map (substExpr doc subst') args
- , ru_rhs = substExpr (text "foo") subst' rhs }
+ , ru_args = map (substExpr subst') args
+ , ru_rhs = substExpr subst' rhs }
-- Do NOT optimise the RHS (previously we did simplOptExpr here)
-- See Note [Substitute lazily]
where
- doc = text "subst-rule" <+> ppr fn_name
(subst', bndrs') = substBndrs subst bndrs
------------------
@@ -707,7 +705,7 @@ substDVarSet subst fvs
= mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs
where
subst_fv subst fv acc
- | isId fv = expr_fvs (lookupIdSubst (text "substDVarSet") subst fv) isLocalVar emptyVarSet $! acc
+ | isId fv = expr_fvs (lookupIdSubst subst fv) isLocalVar emptyVarSet $! acc
| otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc
------------------
@@ -715,7 +713,7 @@ substTickish :: Subst -> Tickish Id -> Tickish Id
substTickish subst (Breakpoint n ids)
= Breakpoint n (map do_one ids)
where
- do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst
+ do_one = getIdFromTrivialExpr . lookupIdSubst subst
substTickish _subst other = other
{- Note [Substitute lazily]
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3784,6 +3784,7 @@ xFlagsDeps = [
flagSpec "JavaScriptFFI" LangExt.JavaScriptFFI,
flagSpec "KindSignatures" LangExt.KindSignatures,
flagSpec "LambdaCase" LangExt.LambdaCase,
+ flagSpec "LexicalNegation" LangExt.LexicalNegation,
flagSpec "LiberalTypeSynonyms" LangExt.LiberalTypeSynonyms,
flagSpec "LinearTypes" LangExt.LinearTypes,
flagSpec "MagicHash" LangExt.MagicHash,
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -332,7 +332,7 @@ repTopDs group@(HsGroup { hs_valds = valds
= notHandledL loc "Haddock documentation" empty
hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
--- See Note [Scoped type variables in bindings]
+-- See Note [Scoped type variables in quotes]
hsScopedTvBinders binds
= concatMap get_scoped_tvs sigs
where
@@ -350,58 +350,60 @@ get_scoped_tvs (L _ signature)
= get_scoped_tvs_from_sig sig
| otherwise
= []
- where
- get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name]
- get_scoped_tvs_from_sig sig
- -- Both implicit and explicit quantified variables
- -- We need the implicit ones for f :: forall (a::k). blah
- -- here 'k' scopes too
- | HsIB { hsib_ext = implicit_vars
- , hsib_body = hs_ty } <- sig
- , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty
- = implicit_vars ++ hsLTyVarNames explicit_vars
+
+get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name]
+get_scoped_tvs_from_sig sig
+ -- Collect both implicit and explicit quantified variables, since
+ -- the types in instance heads, as well as `via` types in DerivingVia, can
+ -- bring implicitly quantified type variables into scope, e.g.,
+ --
+ -- instance Foo [a] where
+ -- m = n @a
+ --
+ -- See also Note [Scoped type variables in quotes]
+ | HsIB { hsib_ext = implicit_vars
+ , hsib_body = hs_ty } <- sig
+ , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty
+ = implicit_vars ++ hsLTyVarNames explicit_vars
{- Notes
-Note [Scoped type variables in bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- f :: forall a. a -> a
- f x = x::a
-Here the 'forall a' brings 'a' into scope over the binding group.
-To achieve this we
+Note [Scoped type variables in quotes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Quoting declarations with scoped type variables requires some care. Consider:
- a) Gensym a binding for 'a' at the same time as we do one for 'f'
- collecting the relevant binders with hsScopedTvBinders
+ $([d| f :: forall a. a -> a
+ f x = x::a
+ |])
- b) When processing the 'forall', don't gensym
+Here, the `forall a` brings `a` into scope over the binding group. This has
+ramifications when desugaring the quote, as we must ensure that that the
+desugared code binds `a` with `Language.Haskell.TH.newName` and refers to the
+bound `a` type variable in the type signature and in the body of `f`. As a
+result, the call to `newName` must occur before any part of the declaration for
+`f` is processed. To achieve this, we:
-The relevant places are signposted with references to this Note
+ (a) Gensym a binding for `a` at the same time as we do one for `f`,
+ collecting the relevant binders with the hsScopedTvBinders family of
+ functions.
-Note [Scoped type variables in class and instance declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Scoped type variables may occur in default methods and default
-signatures. We need to bring the type variables in 'foralls'
-into the scope of the method bindings.
+ (b) Use `addBinds` to bring these gensymmed bindings into scope over any
+ part of the code where the type variables scope. In the `f` example,
+ above, that means the type signature and the body of `f`.
-Consider
- class Foo a where
- foo :: forall (b :: k). a -> Proxy b -> Proxy b
- foo _ x = (x :: Proxy b)
+ (c) When processing the `forall`, /don't/ gensym the type variables. We have
+ already brought the type variables into scope in part (b), after all, so
+ gensymming them again would lead to shadowing. We use the rep_ty_sig
+ family of functions for processing types without gensymming the type
+ variables again.
-We want to ensure that the 'b' in the type signature and the default
-implementation are the same, so we do the following:
+ (d) Finally, we use wrapGenSyms to generate the Core for these scoped type
+ variables:
- a) Before desugaring the signature and binding of 'foo', use
- get_scoped_tvs to collect type variables in 'forall' and
- create symbols for them.
- b) Use 'addBinds' to bring these symbols into the scope of the type
- signatures and bindings.
- c) Use these symbols to generate Core for the class/instance declaration.
+ newName "a" >>= \a ->
+ ... -- process the type signature and body of `f`
-Note that when desugaring the signatures, we lookup the type variables
-from the scope rather than recreate symbols for them. See more details
-in "rep_ty_sig" and in Trac#14885.
+The relevant places are signposted with references to this Note.
Note [Binders and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -429,16 +431,16 @@ Note [Don't quantify implicit type variables in quotes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you're not careful, it's surprisingly easy to take this quoted declaration:
- [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b
- idProxy x = x
+ [d| id :: a -> a
+ id x = x
|]
and have Template Haskell turn it into this:
- idProxy :: forall k proxy (b :: k). proxy b -> proxy b
- idProxy x = x
+ id :: forall a. a -> a
+ id x = x
-Notice that we explicitly quantified the variable `k`! The latter declaration
+Notice that we explicitly quantified the variable `a`! The latter declaration
isn't what the user wrote in the first place.
Usually, the culprit behind these bugs is taking implicitly quantified type
@@ -474,8 +476,8 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
= do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
; dec <- addQTyVarBinds tvs $ \bndrs ->
do { cxt1 <- repLContext cxt
- -- See Note [Scoped type variables in class and instance declarations]
- ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds
+ -- See Note [Scoped type variables in quotes]
+ ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs meth_binds
; fds1 <- repLFunDeps fds
; ats1 <- repFamilyDecls ats
; atds1 <- mapM (repAssocTyFamDefaultD . unLoc) atds
@@ -650,8 +652,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
--
do { cxt1 <- repLContext cxt
; inst_ty1 <- repLTy inst_ty
- -- See Note [Scoped type variables in class and instance declarations]
- ; (ss, sigs_binds) <- rep_sigs_binds sigs binds
+ -- See Note [Scoped type variables in quotes]
+ ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs binds
; ats1 <- mapM (repTyFamInstD . unLoc) ats
; adts1 <- mapM (repDataFamInstD . unLoc) adts
; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds)
@@ -664,9 +666,9 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
, deriv_type = ty }))
- = do { dec <- addSimpleTyVarBinds tvs $
+ = do { dec <- repDerivStrategy strat $ \strat' ->
+ addSimpleTyVarBinds tvs $
do { cxt' <- repLContext cxt
- ; strat' <- repDerivStrategy strat
; inst_ty' <- repLTy inst_ty
; repDeriv strat' cxt' inst_ty' }
; return (loc, dec) }
@@ -943,23 +945,23 @@ repDerivClause :: LHsDerivingClause GhcRn
repDerivClause (L _ (HsDerivingClause
{ deriv_clause_strategy = dcs
, deriv_clause_tys = L _ dct }))
- = do MkC dcs' <- repDerivStrategy dcs
- MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct
+ = repDerivStrategy dcs $ \(MkC dcs') ->
+ do MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct
rep2 derivClauseName [dcs',dct']
where
rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type))
rep_deriv_ty ty = repLTy ty
-rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
- -> MetaM ([GenSymBind], [Core (M TH.Dec)])
+rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
+ -> MetaM ([GenSymBind], [Core (M TH.Dec)])
-- Represent signatures and methods in class/instance declarations.
--- See Note [Scoped type variables in class and instance declarations]
+-- See Note [Scoped type variables in quotes]
--
-- Why not use 'repBinds': we have already created symbols for methods in
-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate
-- these fun_id via 'collectHsValBinders decs', which would lead to the
-- instance declarations failing in TH.
-rep_sigs_binds sigs binds
+rep_meth_sigs_binds sigs binds
= do { let tvs = concatMap get_scoped_tvs sigs
; ss <- mkGenSyms tvs
; sigs1 <- addBinds ss $ rep_sigs sigs
@@ -993,30 +995,47 @@ rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
rep_sig (L loc (CompleteMatchSig _ _st cls mty))
= rep_complete_sig cls mty loc
+-- Desugar the explicit type variable binders in an 'LHsSigType', making
+-- sure not to gensym them.
+-- See Note [Scoped type variables in quotes]
+-- and Note [Don't quantify implicit type variables in quotes]
+rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn]
+ -> MetaM (Core [M TH.TyVarBndrSpec])
+rep_ty_sig_tvs explicit_tvs
+ = let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
+ ; repTyVarBndrWithKind tv name } in
+ repListM tyVarBndrSpecTyConName rep_in_scope_tv
+ explicit_tvs
+ -- NB: Don't pass any implicit type variables to repList above
+ -- See Note [Don't quantify implicit type variables in quotes]
+
+-- Desugar a top-level type signature. Unlike 'repHsSigType', this
+-- deliberately avoids gensymming the type variables.
+-- See Note [Scoped type variables in quotes]
+-- and Note [Don't quantify implicit type variables in quotes]
rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
-> MetaM (SrcSpan, Core (M TH.Dec))
--- Don't create the implicit and explicit variables when desugaring signatures,
--- see Note [Scoped type variables in class and instance declarations].
--- and Note [Don't quantify implicit type variables in quotes]
rep_ty_sig mk_sig loc sig_ty nm
- | HsIB { hsib_body = hs_ty } <- sig_ty
- , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty
= do { nm1 <- lookupLOcc nm
- ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
- ; repTyVarBndrWithKind tv name }
- ; th_explicit_tvs <- repListM tyVarBndrSpecTyConName rep_in_scope_tv
- explicit_tvs
-
- -- NB: Don't pass any implicit type variables to repList above
- -- See Note [Don't quantify implicit type variables in quotes]
+ ; ty1 <- rep_ty_sig' sig_ty
+ ; sig <- repProto mk_sig nm1 ty1
+ ; return (loc, sig) }
+-- Desugar an 'LHsSigType', making sure not to gensym the type variables at
+-- the front of the type signature.
+-- See Note [Scoped type variables in quotes]
+-- and Note [Don't quantify implicit type variables in quotes]
+rep_ty_sig' :: LHsSigType GhcRn
+ -> MetaM (Core (M TH.Type))
+rep_ty_sig' sig_ty
+ | HsIB { hsib_body = hs_ty } <- sig_ty
+ , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty
+ = do { th_explicit_tvs <- rep_ty_sig_tvs explicit_tvs
; th_ctxt <- repLContext ctxt
; th_ty <- repLTy ty
- ; ty1 <- if null explicit_tvs && null (unLoc ctxt)
- then return th_ty
- else repTForall th_explicit_tvs th_ctxt th_ty
- ; sig <- repProto mk_sig nm1 ty1
- ; return (loc, sig) }
+ ; if null explicit_tvs && null (unLoc ctxt)
+ then return th_ty
+ else repTForall th_explicit_tvs th_ctxt th_ty }
rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
-> MetaM (SrcSpan, Core (M TH.Dec))
@@ -1024,19 +1043,14 @@ rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
-- see Note [Pattern synonym type signatures and Template Haskell] in "GHC.ThToHs"
--
-- Don't create the implicit and explicit variables when desugaring signatures,
--- see Note [Scoped type variables in class and instance declarations]
+-- see Note [Scoped type variables in quotes]
-- and Note [Don't quantify implicit type variables in quotes]
rep_patsyn_ty_sig loc sig_ty nm
| HsIB { hsib_body = hs_ty } <- sig_ty
, (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty
= do { nm1 <- lookupLOcc nm
- ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
- ; repTyVarBndrWithKind tv name }
- ; th_univs <- repListM tyVarBndrSpecTyConName rep_in_scope_tv univs
- ; th_exis <- repListM tyVarBndrSpecTyConName rep_in_scope_tv exis
-
- -- NB: Don't pass any implicit type variables to repList above
- -- See Note [Don't quantify implicit type variables in quotes]
+ ; th_univs <- rep_ty_sig_tvs univs
+ ; th_exis <- rep_ty_sig_tvs exis
; th_reqs <- repLContext reqs
; th_provs <- repLContext provs
@@ -1253,10 +1267,6 @@ repHsSigType (HsIB { hsib_ext = implicit_tvs
then return th_ty
else repTForall th_explicit_tvs th_ctxt th_ty }
-repHsSigWcType :: LHsSigWcType GhcRn -> MetaM (Core (M TH.Type))
-repHsSigWcType (HsWC { hswc_body = sig1 })
- = repHsSigType sig1
-
-- yield the representation of a list of types
repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]
repLTys tys = mapM repLTy tys
@@ -1528,10 +1538,13 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
fs <- repUpdFields flds;
repRecUpd x fs }
-repE (ExprWithTySig _ e ty)
- = do { e1 <- repLE e
- ; t1 <- repHsSigWcType ty
+repE (ExprWithTySig _ e wc_ty)
+ = addSimpleTyVarBinds (get_scoped_tvs_from_sig sig_ty) $
+ do { e1 <- repLE e
+ ; t1 <- rep_ty_sig' sig_ty
; repSigExp e1 t1 }
+ where
+ sig_ty = dropWildCards wc_ty
repE (ArithSeq _ _ aseq) =
case aseq of
@@ -1734,7 +1747,7 @@ repBinds (HsValBinds _ decs)
-- the binding group, because we are talking Names
-- here, so we can safely treat it as a mutually
-- recursive group
- -- For hsScopedTvBinders see Note [Scoped type variables in bindings]
+ -- For hsScopedTvBinders see Note [Scoped type variables in quotes]
; ss <- mkGenSyms bndrs
; prs <- addBinds ss (rep_val_binds decs)
; core_list <- coreListM decTyConName
@@ -2427,18 +2440,21 @@ repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
[o, cxt, ty, ds]
repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
- -> MetaM (Core (Maybe (M TH.DerivStrategy)))
-repDerivStrategy mds =
+ -> (Core (Maybe (M TH.DerivStrategy)) -> MetaM (Core (M a)))
+ -> MetaM (Core (M a))
+repDerivStrategy mds thing_inside =
case mds of
- Nothing -> nothing
+ Nothing -> thing_inside =<< nothing
Just ds ->
case unLoc ds of
- StockStrategy -> just =<< repStockStrategy
- AnyclassStrategy -> just =<< repAnyclassStrategy
- NewtypeStrategy -> just =<< repNewtypeStrategy
- ViaStrategy ty -> do ty' <- repLTy (hsSigType ty)
+ StockStrategy -> thing_inside =<< just =<< repStockStrategy
+ AnyclassStrategy -> thing_inside =<< just =<< repAnyclassStrategy
+ NewtypeStrategy -> thing_inside =<< just =<< repNewtypeStrategy
+ ViaStrategy ty -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $
+ do ty' <- rep_ty_sig' ty
via_strat <- repViaStrategy ty'
- just via_strat
+ m_via_strat <- just via_strat
+ thing_inside m_via_strat
where
nothing = coreNothingM derivStrategyTyConName
just = coreJustM derivStrategyTyConName
=====================================
compiler/GHC/Parser.y
=====================================
@@ -93,7 +93,7 @@ import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nil
manyDataConTyCon)
}
-%expect 232 -- shift/reduce conflicts
+%expect 234 -- shift/reduce conflicts
{- Last updated: 08 June 2020
@@ -553,6 +553,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
'-' { L _ ITminus }
PREFIX_TILDE { L _ ITtilde }
PREFIX_BANG { L _ ITbang }
+ PREFIX_MINUS { L _ ITprefixminus }
'*' { L _ (ITstar _) }
'-<' { L _ (ITlarrowtail _) } -- for arrow notation
'>-' { L _ (ITrarrowtail _) } -- for arrow notation
@@ -703,10 +704,21 @@ litpkgname_segment :: { Located FastString }
| CONID { sL1 $1 $ getCONID $1 }
| special_id { $1 }
+-- Parse a minus sign regardless of whether -XLexicalNegation is turned on or off.
+-- See Note [Minus tokens] in GHC.Parser.Lexer
+HYPHEN :: { [AddAnn] }
+ : '-' { [mj AnnMinus $1 ] }
+ | PREFIX_MINUS { [mj AnnMinus $1 ] }
+ | VARSYM {% if (getVARSYM $1 == fsLit "-")
+ then return [mj AnnMinus $1]
+ else do { addError (getLoc $1) $ text "Expected a hyphen"
+ ; return [] } }
+
+
litpkgname :: { Located FastString }
: litpkgname_segment { $1 }
-- a bit of a hack, means p - b is parsed same as p-b, enough for now.
- | litpkgname_segment '-' litpkgname { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) }
+ | litpkgname_segment HYPHEN litpkgname { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) }
mayberns :: { Maybe [LRenaming] }
: {- empty -} { Nothing }
@@ -2738,12 +2750,12 @@ prag_e :: { Located ([AddAnn], HsPragE GhcPs) }
HsPragSCC noExtField
(getSCC_PRAGs $1)
(StringLiteral NoSourceText (getVARID $2))) }
- | '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
+ | '{-# GENERATED' STRING INTEGER ':' INTEGER HYPHEN INTEGER ':' INTEGER '#-}'
{ let getINT = fromInteger . il_value . getINTEGER in
sLL $1 $> $ ([mo $1,mj AnnVal $2
,mj AnnVal $3,mj AnnColon $4
- ,mj AnnVal $5,mj AnnMinus $6
- ,mj AnnVal $7,mj AnnColon $8
+ ,mj AnnVal $5] ++ $6 ++
+ [mj AnnVal $7,mj AnnColon $8
,mj AnnVal $9,mc $10],
HsPragTick noExtField
(getGENERATED_PRAGs $1)
@@ -2789,6 +2801,9 @@ aexp :: { ECP }
| PREFIX_BANG aexp { ECP $
runECP_PV $2 >>= \ $2 ->
amms (mkHsBangPatPV (comb2 $1 $>) $2) [mj AnnBang $1] }
+ | PREFIX_MINUS aexp { ECP $
+ runECP_PV $2 >>= \ $2 ->
+ amms (mkHsNegAppPV (comb2 $1 $>) $2) [mj AnnMinus $1] }
| '\\' apat apats '->' exp
{ ECP $
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -505,19 +505,19 @@ $tab { warnTab }
0[bB] @numspc @binary / { ifExtension BinaryLiteralsBit } { tok_num positive 2 2 binary }
0[oO] @numspc @octal { tok_num positive 2 2 octal }
0[xX] @numspc @hexadecimal { tok_num positive 2 2 hexadecimal }
- @negative @decimal / { ifExtension NegativeLiteralsBit } { tok_num negative 1 1 decimal }
- @negative 0[bB] @numspc @binary / { ifExtension NegativeLiteralsBit `alexAndPred`
+ @negative @decimal / { negLitPred } { tok_num negative 1 1 decimal }
+ @negative 0[bB] @numspc @binary / { negLitPred `alexAndPred`
ifExtension BinaryLiteralsBit } { tok_num negative 3 3 binary }
- @negative 0[oO] @numspc @octal / { ifExtension NegativeLiteralsBit } { tok_num negative 3 3 octal }
- @negative 0[xX] @numspc @hexadecimal / { ifExtension NegativeLiteralsBit } { tok_num negative 3 3 hexadecimal }
+ @negative 0[oO] @numspc @octal / { negLitPred } { tok_num negative 3 3 octal }
+ @negative 0[xX] @numspc @hexadecimal / { negLitPred } { tok_num negative 3 3 hexadecimal }
-- Normal rational literals (:: Fractional a => a, from Rational)
@floating_point { tok_frac 0 tok_float }
- @negative @floating_point / { ifExtension NegativeLiteralsBit } { tok_frac 0 tok_float }
+ @negative @floating_point / { negLitPred } { tok_frac 0 tok_float }
0[xX] @numspc @hex_floating_point / { ifExtension HexFloatLiteralsBit } { tok_frac 0 tok_hex_float }
@negative 0[xX] @numspc @hex_floating_point
/ { ifExtension HexFloatLiteralsBit `alexAndPred`
- ifExtension NegativeLiteralsBit } { tok_frac 0 tok_hex_float }
+ negLitPred } { tok_frac 0 tok_hex_float }
}
<0> {
@@ -771,7 +771,8 @@ data Token
| ITrarrow IsUnicodeSyntax
| ITlolly IsUnicodeSyntax
| ITdarrow IsUnicodeSyntax
- | ITminus
+ | ITminus -- See Note [Minus tokens]
+ | ITprefixminus -- See Note [Minus tokens]
| ITbang -- Prefix (!) only, e.g. f !x = rhs
| ITtilde -- Prefix (~) only, e.g. f ~x = rhs
| ITat -- Tight infix (@) only, e.g. f x at pat = rhs
@@ -871,6 +872,37 @@ instance Outputable Token where
ppr x = text (show x)
+{- Note [Minus tokens]
+~~~~~~~~~~~~~~~~~~~~~~
+A minus sign can be used in prefix form (-x) and infix form (a - b).
+
+When LexicalNegation is on:
+ * ITprefixminus represents the prefix form
+ * ITvarsym "-" represents the infix form
+ * ITminus is not used
+
+When LexicalNegation is off:
+ * ITminus represents all forms
+ * ITprefixminus is not used
+ * ITvarsym "-" is not used
+-}
+
+{- Note [Why not LexicalNegationBit]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One might wonder why we define NoLexicalNegationBit instead of
+LexicalNegationBit. The problem lies in the following line in reservedSymsFM:
+
+ ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit)
+
+We want to generate ITminus only when LexicalNegation is off. How would one
+do it if we had LexicalNegationBit? I (int-index) tried to use bitwise
+complement:
+
+ ,("-", ITminus, NormalSyntax, complement (xbit LexicalNegationBit))
+
+This did not work, so I opted for NoLexicalNegationBit instead.
+-}
+
-- the bitmap provided as the third component indicates whether the
-- corresponding extension keyword is valid under the extension options
@@ -975,7 +1007,7 @@ reservedSymsFM = listToUFM $
,("<-", ITlarrow NormalSyntax, NormalSyntax, 0 )
,("->", ITrarrow NormalSyntax, NormalSyntax, 0 )
,("=>", ITdarrow NormalSyntax, NormalSyntax, 0 )
- ,("-", ITminus, NormalSyntax, 0 )
+ ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit)
,("*", ITstar NormalSyntax, NormalSyntax, xbit StarIsTypeBit)
@@ -1156,6 +1188,27 @@ afterOptionalSpace buf p
atEOL :: AlexAccPred ExtsBitmap
atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'
+-- Check if we should parse a negative literal (e.g. -123) as a single token.
+negLitPred :: AlexAccPred ExtsBitmap
+negLitPred =
+ negative_literals `alexOrPred`
+ (lexical_negation `alexAndPred` prefix_minus)
+ where
+ negative_literals = ifExtension NegativeLiteralsBit
+
+ lexical_negation =
+ -- See Note [Why not LexicalNegationBit]
+ alexNotPred (ifExtension NoLexicalNegationBit)
+
+ prefix_minus =
+ -- The condition for a prefix occurrence of an operator is:
+ --
+ -- not precededByClosingToken && followedByOpeningToken
+ --
+ -- but we don't check followedByOpeningToken here as it holds
+ -- simply because we immediately lex a literal after the minus.
+ alexNotPred precededByClosingToken
+
ifExtension :: ExtBits -> AlexAccPred ExtsBitmap
ifExtension extBits bits _ _ _ = extBits `xtest` bits
@@ -1483,6 +1536,9 @@ varsym_prefix = sym $ \exts s ->
-> return ITdollar
| ThQuotesBit `xtest` exts, s == fsLit "$$"
-> return ITdollardollar
+ | s == fsLit "-" -- Only when LexicalNegation is on, otherwise we get ITminus and
+ -- don't hit this code path. See Note [Minus tokens]
+ -> return ITprefixminus
| s == fsLit "!" -> return ITbang
| s == fsLit "~" -> return ITtilde
| otherwise -> return (ITvarsym s)
@@ -2500,6 +2556,7 @@ data ExtBits
| GadtSyntaxBit
| ImportQualifiedPostBit
| LinearTypesBit
+ | NoLexicalNegationBit -- See Note [Why not LexicalNegationBit]
-- Flags that are updated once parsing starts
| InRulePragBit
@@ -2588,12 +2645,14 @@ mkParserFlags' warningFlags extensionFlags homeUnitId
.|. GadtSyntaxBit `xoptBit` LangExt.GADTSyntax
.|. ImportQualifiedPostBit `xoptBit` LangExt.ImportQualifiedPost
.|. LinearTypesBit `xoptBit` LangExt.LinearTypes
+ .|. NoLexicalNegationBit `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit]
optBits =
HaddockBit `setBitIf` isHaddock
.|. RawTokenStreamBit `setBitIf` rawTokStream
.|. UsePosPragsBit `setBitIf` usePosPrags
xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags
+ xoptNotBit bit ext = bit `setBitIf` not (EnumSet.member ext extensionFlags)
setBitIf :: ExtBits -> Bool -> ExtsBitmap
b `setBitIf` cond | cond = xbit b
=====================================
docs/users_guide/8.12.1-notes.rst
=====================================
@@ -203,6 +203,16 @@ Language
See :ref:`qualified-do-notation` for more details.
+* :extension:`LexicalNegation` is a new extension that detects whether the
+ minus sign stands for negation during lexical analysis by checking for the
+ surrounding whitespace: ::
+
+ a = x - y -- subtraction
+ b = f -x -- negation
+
+ f = (- x) -- operator section
+ c = (-x) -- negation
+
Compiler
~~~~~~~~
=====================================
docs/users_guide/exts/lexical_negation.rst
=====================================
@@ -0,0 +1,57 @@
+.. _lexical-negation:
+
+Lexical negation
+----------------
+
+.. extension:: LexicalNegation
+ :shortdesc: Use whitespace to determine whether the minus sign stands for
+ negation or subtraction.
+
+ :since: 8.12.1
+
+ Detect if the minus sign stands for negation during lexical analysis by
+ checking for the surrounding whitespace.
+
+In Haskell 2010, the minus sign stands for negation when it has no left-hand
+side. Consider ``x = - 5`` and ``y = 2 - 5``. In ``x``, there's no expression
+between the ``=`` and ``-``, so the minus stands for negation, whereas in
+``y``, there's ``2`` to the left of the minus, therefore it stands for
+subtraction.
+
+This leads to certain syntactic anomalies:
+
+* ``(% x)`` is an operator section for any operator ``(%)`` except for ``(-)``.
+ ``(- x)`` is negated ``x`` rather than the right operator section of
+ subtraction. Consequently, it is impossible to write such a section, and
+ users are advised to write ``(subtract x)`` instead.
+
+* Negative numbers must be parenthesized when they appear in function argument
+ position. ``f (-5)`` is correct, whereas ``f -5`` is parsed as ``(-) f 5``.
+
+The latter issue is partly mitigated by :extension:`NegativeLiterals`. When it
+is enabled, ``-5`` is parsed as negative 5 regardless of context, so ``f
+-5`` works as expected. However, it only applies to literals, so ``f -x`` or
+``f -(a*2)`` are still parsed as subtraction.
+
+With :extension:`LexicalNegation`, both anomalies are resolved:
+
+* ``(% x)`` is an operator section for any operator ``(%)``, no exceptions, as
+ long as there's whitespace between ``%`` and ``x``.
+
+* In ``f -x``, the ``-x`` is parsed as the negation of ``x`` for any
+ syntactically atomic expression ``x`` (variable, literal, or parenthesized
+ expression).
+
+* The prefix ``-`` binds tighter than any infix operator. ``-a % b`` is parsed
+ as ``(-a) % b`` regardless of the fixity of ``%``.
+
+This means that ``(- x)`` is the right operator section of subtraction, whereas
+``(-x)`` is the negation of ``x``. Note that these expressions will often have
+different types (``(- x)`` might have type ``Int -> Int`` while ``(-x)`` will
+have type ``Int``), and so users mistaking one for the other will likely get a
+compile error.
+
+Under :extension:`LexicalNegation`, negated literals are desugared without
+``negate``. That is, ``-123`` stands for ``fromInteger (-123)`` rather than
+``negate (fromInteger 123)``. This makes :extension:`LexicalNegation` a valid
+replacement for :extension:`NegativeLiterals`.
=====================================
docs/users_guide/exts/negative_literals.rst
=====================================
@@ -27,5 +27,6 @@ as two tokens.
One pitfall is that with :extension:`NegativeLiterals`, ``x-1`` will
be parsed as ``x`` applied to the argument ``-1``, which is usually
not what you want. ``x - 1`` or even ``x- 1`` can be used instead
-for subtraction.
+for subtraction. To avoid this, consider using :extension:`LexicalNegation`
+instead.
=====================================
docs/users_guide/exts/syntax.rst
=====================================
@@ -25,3 +25,4 @@ Syntax
block_arguments
typed_holes
arrows
+ lexical_negation
=====================================
libraries/base/Data/Fixed.hs
=====================================
@@ -94,6 +94,64 @@ withResolution :: (HasResolution a) => (Integer -> f a) -> f a
withResolution foo = withType (foo . resolution)
-- | @since 2.01
+--
+-- Recall that, for numeric types, 'succ' and 'pred' typically add and subtract
+-- @1@, respectively. This is not true in the case of 'Fixed', whose successor
+-- and predecessor functions intuitively return the "next" and "previous" values
+-- in the enumeration. The results of these functions thus depend on the
+-- resolution of the 'Fixed' value. For example, when enumerating values of
+-- resolution @10^-3@ of @type Milli = Fixed E3@,
+--
+-- @
+-- succ (0.000 :: Milli) == 1.001
+-- @
+--
+--
+-- and likewise
+--
+-- @
+-- pred (0.000 :: Milli) == -0.001
+-- @
+--
+--
+-- In other words, 'succ' and 'pred' increment and decrement a fixed-precision
+-- value by the least amount such that the value's resolution is unchanged.
+-- For example, @10^-12@ is the smallest (positive) amount that can be added to
+-- a value of @type Pico = Fixed E12@ without changing its resolution, and so
+--
+-- @
+-- succ (0.000000000000 :: Pico) == 0.000000000001
+-- @
+--
+--
+-- and similarly
+--
+-- @
+-- pred (0.000000000000 :: Pico) == -0.000000000001
+-- @
+--
+--
+-- This is worth bearing in mind when defining 'Fixed' arithmetic sequences. In
+-- particular, you may be forgiven for thinking the sequence
+--
+-- @
+-- [1..10] :: [Pico]
+-- @
+--
+--
+-- evaluates to @[1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Pico]@.
+--
+-- However, this is not true. On the contrary, similarly to the above
+-- implementations of 'succ' and 'pred', @enumFromTo :: Pico -> Pico -> [Pico]@
+-- has a "step size" of @10^-12 at . Hence, the list @[1..10] :: [Pico]@ has
+-- the form
+--
+-- @
+-- [1.000000000000, 1.00000000001, 1.00000000002, ..., 10.000000000000]
+-- @
+--
+--
+-- and contains @9 * 10^12 + 1@ values.
instance Enum (Fixed a) where
succ (MkFixed a) = MkFixed (succ a)
pred (MkFixed a) = MkFixed (pred a)
=====================================
libraries/base/System/Info.hs
=====================================
@@ -11,9 +11,11 @@
-- Stability : experimental
-- Portability : portable
--
--- Information about the characteristics of the host
+-- Information about the characteristics of the host
-- system lucky enough to run your program.
--
+-- For a comprehensive listing of supported platforms, please refer to
+-- https://gitlab.haskell.org/ghc/ghc/-/wikis/platforms
-----------------------------------------------------------------------------
module System.Info
@@ -28,6 +30,10 @@ import Data.Version
-- | The version of 'compilerName' with which the program was compiled
-- or is being interpreted.
+--
+-- ==== __Example__
+-- > ghci> compilerVersion
+-- > Version {versionBranch = [8,8], versionTags = []}
compilerVersion :: Version
compilerVersion = Version [major, minor] []
where (major, minor) = compilerVersionRaw `divMod` 100
@@ -35,15 +41,52 @@ compilerVersion = Version [major, minor] []
#include "ghcplatform.h"
-- | The operating system on which the program is running.
+-- Common values include:
+--
+-- * "darwin" — macOS
+-- * "freebsd"
+-- * "linux"
+-- * "linux-android"
+-- * "mingw32" — Windows
+-- * "netbsd"
+-- * "openbsd"
os :: String
os = HOST_OS
-- | The machine architecture on which the program is running.
+-- Common values include:
+--
+-- * "aarch64"
+-- * "alpha"
+-- * "arm"
+-- * "hppa"
+-- * "hppa1_1"
+-- * "i386"
+-- * "ia64"
+-- * "m68k"
+-- * "mips"
+-- * "mipseb"
+-- * "mipsel"
+-- * "nios2"
+-- * "powerpc"
+-- * "powerpc64"
+-- * "powerpc64le"
+-- * "riscv32"
+-- * "riscv64"
+-- * "rs6000"
+-- * "s390"
+-- * "s390x"
+-- * "sh4"
+-- * "sparc"
+-- * "sparc64"
+-- * "vax"
+-- * "x86_64"
arch :: String
arch = HOST_ARCH
-- | The Haskell implementation with which the program was compiled
-- or is being interpreted.
+-- On the GHC platform, the value is "ghc".
compilerName :: String
compilerName = "ghc"
=====================================
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
=====================================
@@ -146,6 +146,7 @@ data Extension
| ImportQualifiedPost
| CUSKs
| StandaloneKindSignatures
+ | LexicalNegation
deriving (Eq, Enum, Show, Generic, Bounded)
-- 'Ord' and 'Bounded' are provided for GHC API users (see discussions
-- in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707 and
=====================================
testsuite/tests/driver/T4437.hs
=====================================
@@ -42,6 +42,7 @@ expectedGhcOnlyExtensions =
, "AlternativeLayoutRuleTransitional"
, "LinearTypes"
, "QualifiedDo"
+ , "LexicalNegation"
]
expectedCabalOnlyExtensions :: [String]
=====================================
testsuite/tests/parser/should_compile/LexNegVsNegLit.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE NegativeLiterals, LexicalNegation #-}
+
+module LexNegVsNegLit where
+
+-- NegativeLiterals specifies that we parse x-1 as x (-1), even though it's
+-- considered a shortcoming.
+--
+-- LexicalNegation does not change that.
+--
+b :: Bool
+b = even-1 -- parsed as: even (-1)
+ -- so it is well-typed.
+ --
+ -- with LexicalNegation alone, we'd get (-) even 1,
+ -- but NegativeLiterals takes precedence here.
+
+-- See also: GHC Proposal #344
=====================================
testsuite/tests/parser/should_compile/LexicalNegation.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE LexicalNegation #-}
+
+module LexicalNegation where
+
+x :: Int
+x = 42
+
+negx :: Int
+negx = f -x where f = (- 5)
+
+subx :: Int -> Int
+subx = (- x)
+
+assertion1 :: Bool
+assertion1 = (- x) -x == -(2*x)
=====================================
testsuite/tests/parser/should_compile/all.T
=====================================
@@ -152,6 +152,8 @@ test('proposal-229a', normal, compile, [''])
test('proposal-229b', normal, compile, [''])
test('proposal-229d', normal, compile, [''])
test('proposal-229e', normal, compile, [''])
+test('LexicalNegation', normal, compile, [''])
+test('LexNegVsNegLit', normal, compile, [''])
# We omit 'profasm' because it fails with:
# Cannot load -prof objects when GHC is built with -dynamic
=====================================
testsuite/tests/parser/should_run/LexNegLit.hs
=====================================
@@ -0,0 +1,26 @@
+{-# LANGUAGE LexicalNegation #-}
+
+data FreeNum
+ = FromInteger Integer
+ | FromRational Rational
+ | Negate FreeNum
+ | FreeNum `Subtract` FreeNum
+ deriving (Show)
+
+instance Num FreeNum where
+ fromInteger = FromInteger
+ negate = Negate
+ (-) = Subtract
+
+instance Fractional FreeNum where
+ fromRational = FromRational
+
+main = do
+ print (-123 :: FreeNum)
+ print (-1.5 :: FreeNum)
+ print (let x = 5 in -x :: FreeNum)
+ print (5-1 :: FreeNum) -- unlike NegativeLiterals, we parse it as (5 - 1), not (5 (-1))
+ print (-0 :: FreeNum)
+ print (-0.0 :: FreeNum)
+ print (-0o10 :: FreeNum)
+ print (-0x10 :: FreeNum)
=====================================
testsuite/tests/parser/should_run/LexNegLit.stdout
=====================================
@@ -0,0 +1,8 @@
+FromInteger (-123)
+FromRational ((-3) % 2)
+Negate (FromInteger 5)
+FromInteger 5 `Subtract` FromInteger 1
+Negate (FromInteger 0)
+Negate (FromRational (0 % 1))
+FromInteger (-8)
+FromInteger (-16)
=====================================
testsuite/tests/parser/should_run/all.T
=====================================
@@ -18,3 +18,4 @@ test('CountParserDeps',
[ only_ways(['normal']), extra_run_opts('"' + config.libdir + '"') ],
compile_and_run,
['-package ghc'])
+test('LexNegLit', normal, compile_and_run, [''])
=====================================
testsuite/tests/th/T18388.hs
=====================================
@@ -0,0 +1,29 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+module T18388 where
+
+class C x y where
+ m :: x -> y -> y
+
+newtype Tagged x a = MkTagged a
+instance C x (Tagged x a) where
+ m _ = id
+
+$([d| newtype Id1 a = MkId1 a
+ deriving (C x) via forall x. Tagged x a
+
+ newtype Id2 a = MkId2 a
+ deriving (C x) via Tagged x a
+ |])
+
+newtype List1 a = MkList1 [a]
+newtype List2 a = MkList2 [a]
+$([d| deriving via forall a. [a] instance Eq a => Eq (List1 a) |])
+$([d| deriving via [a] instance Eq a => Eq (List2 a) |])
+
+$([d| f = id @a :: forall a. a -> a |])
=====================================
testsuite/tests/th/all.T
=====================================
@@ -510,3 +510,4 @@ test('TH_StringLift', normal, compile, [''])
test('TH_BytesShowEqOrd', normal, compile_and_run, [''])
test('T18121', normal, compile, [''])
test('T18123', normal, compile, [''])
+test('T18388', normal, compile, [''])
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 54ed6ae2556dc787916e2d56ce0e99808af14e61
+Subproject commit 9bd65ee47a43529af2ad8e350fdd0c372bc5964c
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/85310fb83fdb7d7294bd453026102fc42000bf14...a19466b036afae760728876855b434635314c4da
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/85310fb83fdb7d7294bd453026102fc42000bf14...a19466b036afae760728876855b434635314c4da
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/20200701/3ddb675d/attachment-0001.html>
More information about the ghc-commits
mailing list