[Git][ghc/ghc][wip/T18494] 4 commits: Improve NegativeLiterals (#18022, GHC Proposal #344)
Simon Peyton Jones
gitlab at gitlab.haskell.org
Mon Jul 27 23:07:32 UTC 2020
Simon Peyton Jones pushed to branch wip/T18494 at Glasgow Haskell Compiler / GHC
Commits:
aee45d9e by Vladislav Zavialov at 2020-07-27T07:06:56-04:00
Improve NegativeLiterals (#18022, GHC Proposal #344)
Before this patch, NegativeLiterals used to parse x-1 as x (-1).
This may not be what the user expects, and now it is fixed:
x-1 is parsed as (-) x 1.
We achieve this by the following requirement:
* When lexing a negative literal,
it must not be preceded by a 'closing token'.
This also applies to unboxed literals, e.g. -1#.
See GHC Proposal #229 for the definition of a closing token.
A nice consequence of this change is that -XNegativeLiterals becomes a
subset of -XLexicalNegation. In other words, enabling both of those
extensions has the same effect as enabling -XLexicalNegation alone.
- - - - -
667ab69e by leiftw at 2020-07-27T07:07:32-04:00
fix typo referring to non-existent `-ohidir` flag, should be `-hidir` I think
- - - - -
6ff89c17 by Vladislav Zavialov at 2020-07-27T07:08:07-04:00
Refactor the parser a little
* Create a dedicated production for type operators
* Create a dedicated type for the UNPACK pragma
* Remove an outdated part of Note [Parsing data constructors is hard]
- - - - -
5c60e073 by Simon Peyton Jones at 2020-07-28T00:07:11+01:00
Kill off sc_mult and as_mult fields
They are readily derivable from other fields, so this is more
efficient, and less error prone.
Fixes #18494
- - - - -
12 changed files:
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- docs/users_guide/8.12.1-notes.rst
- docs/users_guide/exts/negative_literals.rst
- docs/users_guide/separate_compilation.rst
- − testsuite/tests/parser/should_compile/LexNegVsNegLit.hs
- + testsuite/tests/parser/should_compile/NegativeLiterals.hs
- + testsuite/tests/parser/should_compile/NegativeLiteralsNoExt.hs
- testsuite/tests/parser/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -1002,7 +1002,7 @@ simplExprF1 env (App fun arg) cont
, sc_hole_ty = hole'
, sc_cont = cont } }
_ ->
- -- crucially, these are /lazy/ bindings. They will
+ -- Crucially, sc_hole_ty is a /lazy/ binding. It will
-- be forced only if we need to run contHoleType.
-- When these are forced, we might get quadratic behavior;
-- this quadratic blowup could be avoided by drilling down
@@ -1010,13 +1010,10 @@ simplExprF1 env (App fun arg) cont
-- (instead of one-at-a-time). But in practice, we have not
-- observed the quadratic behavior, so this extra entanglement
-- seems not worthwhile.
- let fun_ty = exprType fun
- (m, _, _) = splitFunTy fun_ty
- in
simplExprF env fun $
ApplyToVal { sc_arg = arg, sc_env = env
, sc_hole_ty = substTy env (exprType fun)
- , sc_dup = NoDup, sc_cont = cont, sc_mult = m }
+ , sc_dup = NoDup, sc_cont = cont }
simplExprF1 env expr@(Lam {}) cont
= {-#SCC "simplExprF1-Lam" #-}
@@ -1321,8 +1318,8 @@ rebuild env expr cont
Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }
-> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont
- StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m }
- -> rebuildCall env (addValArgTo fun (m, expr) fun_ty ) cont
+ StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }
+ -> rebuildCall env (addValArgTo fun expr fun_ty ) cont
StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body
, sc_env = se, sc_cont = cont }
-> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr
@@ -1414,7 +1411,7 @@ simplCast env body co0 cont0
-- co1 :: t1 ~ s1
-- co2 :: s2 ~ t2
addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
- , sc_dup = dup, sc_cont = tail, sc_mult = m })
+ , sc_dup = dup, sc_cont = tail })
| Just (co1, m_co2) <- pushCoValArg co
, let new_ty = coercionRKind co1
, not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg
@@ -1438,8 +1435,7 @@ simplCast env body co0 cont0
, sc_env = arg_se'
, sc_dup = dup'
, sc_cont = tail'
- , sc_hole_ty = coercionLKind co
- , sc_mult = m }) } }
+ , sc_hole_ty = coercionLKind co }) } }
addCoerce co cont
| isReflexiveCo co = return cont -- Having this at the end makes a huge
@@ -1975,17 +1971,18 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c
-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
-- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ])
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args })
- (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont, sc_mult = m })
+ (ApplyToVal { sc_arg = arg, sc_env = arg_se
+ , sc_cont = cont, sc_hole_ty = fun_ty })
| fun `hasKey` runRWKey
, not (contIsStop cont) -- Don't fiddle around if the continuation is boring
, [ TyArg {}, TyArg {} ] <- rev_args
= do { s <- newId (fsLit "s") Many realWorldStatePrimTy
- ; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
+ ; let (m,_,_) = splitFunTy fun_ty
+ env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
ty' = contResultType cont
cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
, sc_env = env', sc_cont = cont
- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty'
- , sc_mult = m }
+ , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }
-- cont' applies to s, then K
; body' <- simplExprC env' arg cont'
; let arg' = Lam s body'
@@ -1997,10 +1994,10 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
, ai_strs = str:strs, ai_discs = disc:discs })
(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup_flag, sc_hole_ty = fun_ty
- , sc_cont = cont, sc_mult = m })
+ , sc_cont = cont })
-- Argument is already simplified
| isSimplified dup_flag -- See Note [Avoid redundant simplification]
- = rebuildCall env (addValArgTo info' (m, arg) fun_ty) cont
+ = rebuildCall env (addValArgTo info' arg fun_ty) cont
-- Strict arguments
| str
@@ -2009,7 +2006,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
simplExprF (arg_se `setInScopeFromE` env) arg
(StrictArg { sc_fun = info', sc_cci = cci_strict
, sc_dup = Simplified, sc_fun_ty = fun_ty
- , sc_cont = cont, sc_mult = m })
+ , sc_cont = cont })
-- Note [Shadowing]
-- Lazy arguments
@@ -2020,7 +2017,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
-- floating a demanded let.
= do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg
(mkLazyArgStop arg_ty cci_lazy)
- ; rebuildCall env (addValArgTo info' (m, arg') fun_ty) cont }
+ ; rebuildCall env (addValArgTo info' arg' fun_ty) cont }
where
info' = info { ai_strs = strs, ai_discs = discs }
arg_ty = funArgTy fun_ty
@@ -2243,24 +2240,10 @@ trySeqRules in_env scrut rhs cont
, TyArg { as_arg_ty = rhs_ty
, as_hole_ty = res2_ty }
, ValArg { as_arg = no_cast_scrut
- , as_hole_ty = res3_ty
- , as_mult = Many } ]
- -- The multiplicity of the scrutiny above is Many because the type
- -- of seq requires that its first argument is unrestricted. The
- -- typing rule of case also guarantees it though. In a more
- -- general world, where the first argument of seq would have
- -- affine multiplicity, then we could use the multiplicity of
- -- the case (held in the case binder) instead.
+ , as_hole_ty = res3_ty } ]
rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs
, sc_env = in_env, sc_cont = cont
- , sc_hole_ty = res4_ty, sc_mult = Many }
- -- The multiplicity in sc_mult above is the
- -- multiplicity of the second argument of seq. Since
- -- seq's type, as it stands, imposes that its second
- -- argument be unrestricted, so is
- -- sc_mult. However, a more precise typing rule,
- -- for seq, would be to have it be linear. In which
- -- case, sc_mult should be 1.
+ , sc_hole_ty = res4_ty }
-- Lazily evaluated, so we don't do most of this
@@ -3318,7 +3301,7 @@ mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
, sc_cont = mkBoringStop res_ty } ) }
mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci
- , sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m })
+ , sc_cont = cont, sc_fun_ty = fun_ty })
-- See Note [Duplicating StrictArg]
-- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
= do { (floats1, cont') <- mkDupableCont env cont
@@ -3329,7 +3312,6 @@ mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci
, sc_cont = cont'
, sc_cci = cci
, sc_fun_ty = fun_ty
- , sc_mult = m
, sc_dup = OkToDup} ) }
mkDupableCont env (ApplyToTy { sc_cont = cont
@@ -3340,7 +3322,7 @@ mkDupableCont env (ApplyToTy { sc_cont = cont
mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup
, sc_env = se, sc_cont = cont
- , sc_hole_ty = hole_ty, sc_mult = mult })
+ , sc_hole_ty = hole_ty })
= -- e.g. [...hole...] (...arg...)
-- ==>
-- let a = ...arg...
@@ -3359,7 +3341,7 @@ mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup
-- has turned arg'' into a fresh variable
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
, sc_dup = OkToDup, sc_cont = cont'
- , sc_hole_ty = hole_ty, sc_mult = mult }) }
+ , sc_hole_ty = hole_ty }) }
mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
, sc_env = se, sc_cont = cont })
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -124,8 +124,7 @@ data SimplCont
-- See Note [The hole type in ApplyToTy/Val]
, sc_arg :: InExpr -- The argument,
, sc_env :: StaticEnv -- see Note [StaticEnv invariant]
- , sc_cont :: SimplCont
- , sc_mult :: Mult }
+ , sc_cont :: SimplCont }
| ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ]
{ sc_arg_ty :: OutType -- Argument type
@@ -158,8 +157,7 @@ data SimplCont
, sc_fun_ty :: OutType -- Type of the function (f e1 .. en),
-- presumably (arg_ty -> res_ty)
-- where res_ty is expected by sc_cont
- , sc_cont :: SimplCont
- , sc_mult :: Mult }
+ , sc_cont :: SimplCont }
| TickIt -- (TickIt t K)[e] = K[ tick t e ]
(Tickish Id) -- Tick tickish <hole>
@@ -278,23 +276,22 @@ data ArgInfo
}
data ArgSpec
- = ValArg { as_mult :: Mult
- , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal
+ = ValArg { as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal
, as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2)
| TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy
, as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah)
| CastBy OutCoercion -- Cast by this; c.f. CastIt
instance Outputable ArgSpec where
- ppr (ValArg { as_mult = mult, as_arg = arg }) = text "ValArg" <+> ppr mult <+> ppr arg
+ ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg
ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty
ppr (CastBy c) = text "CastBy" <+> ppr c
-addValArgTo :: ArgInfo -> (Mult, OutExpr) -> OutType -> ArgInfo
-addValArgTo ai (w, arg) hole_ty = ai { ai_args = arg_spec : ai_args ai
- , ai_rules = decRules (ai_rules ai) }
+addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo
+addValArgTo ai arg hole_ty = ai { ai_args = arg_spec : ai_args ai
+ , ai_rules = decRules (ai_rules ai) }
where
- arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w }
+ arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty }
addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo
addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai
@@ -317,9 +314,9 @@ pushSimplifiedArgs env (arg : args) k
= case arg of
TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }
-> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }
- ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w }
+ ValArg { as_arg = arg, as_hole_ty = hole_ty }
-> ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified
- , sc_hole_ty = hole_ty, sc_cont = rest, sc_mult = w }
+ , sc_hole_ty = hole_ty, sc_cont = rest }
CastBy c -> CastIt c rest
where
rest = pushSimplifiedArgs env args k
@@ -418,7 +415,7 @@ contHoleType (TickIt _ k) = contHoleType k
contHoleType (CastIt co _) = coercionLKind co
contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })
= perhapsSubstTy dup se (idType b)
-contHoleType (StrictArg { sc_fun_ty = ty, sc_mult = _m }) = funArgTy ty
+contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty
contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy]
contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy/Val]
contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se })
@@ -436,12 +433,14 @@ contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se })
contHoleScaling :: SimplCont -> Mult
contHoleScaling (Stop _ _) = One
contHoleScaling (CastIt _ k) = contHoleScaling k
-contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) =
- (idMult id) `mkMultMul` contHoleScaling k
-contHoleScaling (StrictArg { sc_mult = w, sc_cont = k }) =
- w `mkMultMul` contHoleScaling k
-contHoleScaling (Select { sc_bndr = id, sc_cont = k }) =
- (idMult id) `mkMultMul` contHoleScaling k
+contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k })
+ = idMult id `mkMultMul` contHoleScaling k
+contHoleScaling (Select { sc_bndr = id, sc_cont = k })
+ = idMult id `mkMultMul` contHoleScaling k
+contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k })
+ = w `mkMultMul` contHoleScaling k
+ where
+ (w, _, _) = splitFunTy fun_ty
contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k
contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k
contHoleScaling (TickIt _ k) = contHoleScaling k
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1884,9 +1884,9 @@ sigtypes1 :: { (OrdList (LHsSigType GhcPs)) }
-----------------------------------------------------------------------------
-- Types
-unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) }
- : '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getUNPACK_PRAGs $1, SrcUnpack) }
- | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) }
+unpackedness :: { Located UnpackednessPragma }
+ : '{-# UNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getUNPACK_PRAGs $1) SrcUnpack) }
+ | '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getNOUNPACK_PRAGs $1) SrcNoUnpack) }
forall_telescope :: { Located ([AddAnn], HsForAllTelescope GhcPs) }
: 'forall' tv_bndrs '.' {% do { hintExplicitForall $1
@@ -1980,13 +1980,16 @@ tyapp :: { Located TyEl }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
| PREFIX_AT atype { sLL $1 $> $ (TyElKindApp (comb2 $1 $2) $2) }
- | qtyconop { sL1 $1 $ TyElOpr (unLoc $1) }
- | tyvarop { sL1 $1 $ TyElOpr (unLoc $1) }
- | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
+ | tyop { mapLoc TyElOpr $1 }
+ | unpackedness { sL1 $1 $ TyElUnpackedness (unLoc $1) }
+
+tyop :: { Located RdrName }
+ : qtyconop { $1 }
+ | tyvarop { $1 }
+ | SIMPLEQUOTE qconop {% ams (sLL $1 $> (unLoc $2))
[mj AnnSimpleQuote $1,mj AnnVal $2] }
- | SIMPLEQUOTE varop {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
+ | SIMPLEQUOTE varop {% ams (sLL $1 $> (unLoc $2))
[mj AnnSimpleQuote $1,mj AnnVal $2] }
- | unpackedness { sL1 $1 $ TyElUnpackedness (unLoc $1) }
atype :: { LHsType GhcPs }
: ntgtycon { sL1 $1 (HsTyVar noExtField NotPromoted $1) } -- Not including unit tuples
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -199,7 +199,6 @@ $docsym = [\| \^ \* \$]
-- normal signed numerical literals can only be explicitly negative,
-- not explicitly positive (contrast @exponent)
@negative = \-
- at signed = @negative ?
-- -----------------------------------------------------------------------------
@@ -531,12 +530,12 @@ $tab { warnTab }
ifExtension BinaryLiteralsBit } { tok_primint positive 2 3 binary }
0[oO] @numspc @octal \# / { ifExtension MagicHashBit } { tok_primint positive 2 3 octal }
0[xX] @numspc @hexadecimal \# / { ifExtension MagicHashBit } { tok_primint positive 2 3 hexadecimal }
- @negative @decimal \# / { ifExtension MagicHashBit } { tok_primint negative 1 2 decimal }
- @negative 0[bB] @numspc @binary \# / { ifExtension MagicHashBit `alexAndPred`
+ @negative @decimal \# / { negHashLitPred } { tok_primint negative 1 2 decimal }
+ @negative 0[bB] @numspc @binary \# / { negHashLitPred `alexAndPred`
ifExtension BinaryLiteralsBit } { tok_primint negative 3 4 binary }
- @negative 0[oO] @numspc @octal \# / { ifExtension MagicHashBit } { tok_primint negative 3 4 octal }
+ @negative 0[oO] @numspc @octal \# / { negHashLitPred } { tok_primint negative 3 4 octal }
@negative 0[xX] @numspc @hexadecimal \#
- / { ifExtension MagicHashBit } { tok_primint negative 3 4 hexadecimal }
+ / { negHashLitPred } { tok_primint negative 3 4 hexadecimal }
@decimal \# \# / { ifExtension MagicHashBit } { tok_primword 0 2 decimal }
0[bB] @numspc @binary \# \# / { ifExtension MagicHashBit `alexAndPred`
@@ -546,8 +545,11 @@ $tab { warnTab }
-- Unboxed floats and doubles (:: Float#, :: Double#)
-- prim_{float,double} work with signed literals
- @signed @floating_point \# / { ifExtension MagicHashBit } { tok_frac 1 tok_primfloat }
- @signed @floating_point \# \# / { ifExtension MagicHashBit } { tok_frac 2 tok_primdouble }
+ @floating_point \# / { ifExtension MagicHashBit } { tok_frac 1 tok_primfloat }
+ @floating_point \# \# / { ifExtension MagicHashBit } { tok_frac 2 tok_primdouble }
+
+ @negative @floating_point \# / { negHashLitPred } { tok_frac 1 tok_primfloat }
+ @negative @floating_point \# \# / { negHashLitPred } { tok_frac 2 tok_primdouble }
}
-- Strings and chars are lexed by hand-written code. The reason is
@@ -1192,8 +1194,8 @@ 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)
+ prefix_minus `alexAndPred`
+ (negative_literals `alexOrPred` lexical_negation)
where
negative_literals = ifExtension NegativeLiteralsBit
@@ -1202,14 +1204,33 @@ negLitPred =
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.
+ -- Note [prefix_minus in negLitPred and negHashLitPred]
+ alexNotPred precededByClosingToken
+
+-- Check if we should parse an unboxed negative literal (e.g. -123#) as a single token.
+negHashLitPred :: AlexAccPred ExtsBitmap
+negHashLitPred = prefix_minus `alexAndPred` magic_hash
+ where
+ magic_hash = ifExtension MagicHashBit
+ prefix_minus =
+ -- Note [prefix_minus in negLitPred and negHashLitPred]
alexNotPred precededByClosingToken
+{- Note [prefix_minus in negLitPred and negHashLitPred]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to parse -1 as a single token, but x-1 as three tokens.
+So in negLitPred (and negHashLitPred) we require that we have a prefix
+occurrence of the minus sign. See Note [Whitespace-sensitive operator parsing]
+for a detailed definition of a prefix occurrence.
+
+The condition for a prefix occurrence of an operator is:
+
+ not precededByClosingToken && followedByOpeningToken
+
+but we don't check followedByOpeningToken when parsing a negative literal.
+It holds simply because we immediately lex a literal after the minus.
+-}
+
ifExtension :: ExtBits -> AlexAccPred ExtsBitmap
ifExtension extBits bits _ _ _ = extBits `xtest` bits
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -70,6 +70,7 @@ module GHC.Parser.PostProcess (
addFatalError, hintBangPat,
TyEl(..), mergeOps, mergeDataCon,
mkBangTy,
+ UnpackednessPragma(..),
-- Help with processing exports
ImpExpSubSpec(..),
@@ -559,25 +560,6 @@ As the result, in order to determine whether (C t1 t2) declares a data
constructor, a type, or a context, we would need unlimited lookahead which
'happy' is not so happy with.
-To further complicate matters, the interpretation of (!) and (~) is different
-in constructors and types:
-
- (b1) type T = C ! D
- (b2) data T = C ! D
- (b3) data T = C ! D => E
-
-In (b1) and (b3), (!) is a type operator with two arguments: 'C' and 'D'. At
-the same time, in (b2) it is a strictness annotation: 'C' is a data constructor
-with a single strict argument 'D'. For the programmer, these cases are usually
-easy to tell apart due to whitespace conventions:
-
- (b2) data T = C !D -- no space after the bang hints that
- -- it is a strictness annotation
-
-For the parser, on the other hand, this whitespace does not matter. We cannot
-tell apart (b2) from (b3) until we encounter (=>), so it requires unlimited
-lookahead.
-
The solution that accounts for all of these issues is to initially parse data
declarations and types as a reversed list of TyEl:
@@ -1324,7 +1306,7 @@ isFunLhs e = go e [] []
data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
| TyElKindApp SrcSpan (LHsType GhcPs)
-- See Note [TyElKindApp SrcSpan interpretation]
- | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)
+ | TyElUnpackedness UnpackednessPragma
{- Note [TyElKindApp SrcSpan interpretation]
@@ -1345,20 +1327,15 @@ instance Outputable TyEl where
ppr (TyElOpr name) = ppr name
ppr (TyElOpd ty) = ppr ty
ppr (TyElKindApp _ ki) = text "@" <> ppr ki
- ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk
+ ppr (TyElUnpackedness (UnpackednessPragma _ _ unpk)) = ppr unpk
-- | Extract a strictness/unpackedness annotation from the front of a reversed
-- 'TyEl' list.
pUnpackedness
:: [Located TyEl] -- reversed TyEl
- -> Maybe ( SrcSpan
- , [AddAnn]
- , SourceText
- , SrcUnpackedness
- , [Located TyEl] {- remaining TyEl -})
-pUnpackedness (L l x1 : xs)
- | TyElUnpackedness (anns, prag, unpk) <- x1
- = Just (l, anns, prag, unpk, xs)
+ -> Maybe (SrcSpan, UnpackednessPragma,
+ [Located TyEl] {- remaining TyEl -})
+pUnpackedness (L l x1 : xs) | TyElUnpackedness up <- x1 = Just (l, up, xs)
pUnpackedness _ = Nothing
pBangTy
@@ -1371,7 +1348,7 @@ pBangTy
pBangTy lt@(L l1 _) xs =
case pUnpackedness xs of
Nothing -> (False, lt, pure (), xs)
- Just (l2, anns, prag, unpk, xs') ->
+ Just (l2, UnpackednessPragma anns prag unpk, xs') ->
let bl = combineSrcSpans l1 l2
bt = addUnpackedness (prag, unpk) lt
in (True, L bl bt, addAnnsAt bl anns, xs')
@@ -1380,6 +1357,10 @@ mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy strictness =
HsBangTy noExtField (HsSrcBang NoSourceText NoSrcUnpack strictness)
+-- Result of parsing {-# UNPACK #-} or {-# NOUNPACK #-}
+data UnpackednessPragma =
+ UnpackednessPragma [AddAnn] SourceText SrcUnpackedness
+
addUnpackedness :: (SourceText, SrcUnpackedness) -> LHsType GhcPs -> HsType GhcPs
addUnpackedness (prag, unpk) (L _ (HsBangTy x bang t))
| HsSrcBang NoSourceText NoSrcUnpack strictness <- bang
@@ -1411,7 +1392,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
-- clause [unpk]:
-- handle (NO)UNPACK pragmas
- go k acc ops_acc ((L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) =
+ go k acc ops_acc ((L l (TyElUnpackedness (UnpackednessPragma anns unpkSrc unpk))):xs) =
if not (null acc) && null xs
then do { acc' <- eitherToP $ mergeOpsAcc acc
; let a = ops_acc acc'
=====================================
docs/users_guide/8.12.1-notes.rst
=====================================
@@ -224,6 +224,13 @@ Language
f = (- x) -- operator section
c = (-x) -- negation
+* The behavior of :extension:`NegativeLiterals` changed, and now we require
+ that a negative literal must not be preceded by a closing token (see
+ `GHC Proposal #229 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst>`__
+ for the definition of a closing token). In other words, we parse ``f -123``
+ as ``f (-123)``, but ``x-123`` as ``(-) x 123``. Before this amendment,
+ :extension:`NegativeLiterals` caused ``x-123`` to be parsed as ``x(-123)``.
+
Compiler
~~~~~~~~
=====================================
docs/users_guide/exts/negative_literals.rst
=====================================
@@ -24,9 +24,11 @@ will elicit an unexpected integer-literal-overflow message.
Whitespace can be inserted, as in ``- 123``, to force interpretation
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. To avoid this, consider using :extension:`LexicalNegation`
-instead.
-
+In 8.12, the behavior of this extension changed, and now we require that a negative literal must not be preceded by a closing token (see
+`GHC Proposal #229 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst>`__
+for the definition of a closing token). In other words, we parse ``f -123`` as ``f (-123)``, but ``x-123`` as ``(-) x
+123``. Before this amendment, :extension:`NegativeLiterals` caused ``x-123`` to be parsed as ``x(-123)``.
+
+:extension:`NegativeLiterals` is a subset of :extension:`LexicalNegation`. That
+is, enabling both of those extensions has the same effect as enabling
+:extension:`LexicalNegation` alone.
=====================================
docs/users_guide/separate_compilation.rst
=====================================
@@ -758,7 +758,7 @@ There are several points to note here:
the same machine-generated binary format as any other
GHC-generated interface file (e.g. ``B.hi``). You can display its
contents with ``ghc --show-iface``. If you specify a directory for
- interface files, the ``-ohidir`` flag, then that affects ``hi-boot`` files
+ interface files, the ``-hidir`` flag, then that affects ``hi-boot`` files
too.
- If hs-boot files are considered distinct from their parent source
=====================================
testsuite/tests/parser/should_compile/LexNegVsNegLit.hs deleted
=====================================
@@ -1,17 +0,0 @@
-{-# 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/NegativeLiterals.hs
=====================================
@@ -0,0 +1,57 @@
+{-# LANGUAGE NegativeLiterals, MagicHash, BinaryLiterals #-}
+
+module NegativeLiterals where
+
+import GHC.Exts
+
+------------------------------------
+-- Prefix occurrence of the minus --
+------------------------------------
+
+p1 :: Bool
+p1 = even -2 -- parsed as: even (-2)
+
+p2 :: Int
+p2 = I# -1# -- parsed as: I# (-1#)
+
+p3 :: Int
+p3 = floor -2.4 -- parsed as: floor (-2.4)
+
+p4 :: Float
+p4 = F# -0.01# -- parsed as: F# (-0.01#)
+
+p5 :: Double
+p5 = D# -0.01## -- parsed as: D# (-0.01##)
+
+p6 :: Bool
+p6 = even -0b10 -- parsed as: even (-2)
+ || even -0o10 -- parsed as: even (-8)
+ || even -0x10 -- parsed as: even (-16)
+
+-----------------------------------------
+-- Tight infix occurrence of the minus --
+-----------------------------------------
+
+ti1 :: Integer -> Integer
+ti1 x = x-2 -- parsed as: (-) x 1
+
+ti2 :: Int# -> Int#
+ti2 x = x-1# -- parsed as: (-) x 1#
+ where (-) = (-#)
+
+ti3 :: Double -> Double
+ti3 x = x-2.4 -- parsed as: (-) x 2.4
+
+ti4 :: Float# -> Float#
+ti4 x = x-0.1# -- parsed as: (-) x 0.1#
+ where (-) = minusFloat#
+
+ti5 :: Double# -> Double#
+ti5 x = x-0.1## -- parsed as: (-) x 0.1##
+ where (-) = (-##)
+
+ti6 :: Integer -> [Integer]
+ti6 x =
+ [ x-0b10, -- parsed as: (-) x 2
+ x-0o10, -- parsed as: (-) x 8
+ x-0x10 ] -- parsed as: (-) x 16
=====================================
testsuite/tests/parser/should_compile/NegativeLiteralsNoExt.hs
=====================================
@@ -0,0 +1,39 @@
+{-# LANGUAGE NoNegativeLiterals, MagicHash, BinaryLiterals #-}
+
+-- Even when NegativeLiterals are disabled,
+-- we parse unboxed literals appropriately.
+module NegativeLiteralsNoExt where
+
+import GHC.Exts
+
+------------------------------------
+-- Prefix occurrence of the minus --
+------------------------------------
+
+p2 :: Int
+p2 = I# -1# -- parsed as: I# (-1#)
+
+p4 :: Float
+p4 = F# -0.01# -- parsed as: F# (-0.01#)
+
+p5 :: Double
+p5 = D# -0.01## -- parsed as: D# (-0.01##)
+
+-----------------------------------------
+-- Tight infix occurrence of the minus --
+-----------------------------------------
+
+ti2 :: Int# -> Int#
+ti2 x = x-1# -- parsed as: (-) x 1#
+ where (-) = (-#)
+
+ti3 :: Double -> Double
+ti3 x = x-2.4 -- parsed as: (-) x 2.4
+
+ti4 :: Float# -> Float#
+ti4 x = x-0.1# -- parsed as: (-) x 0.1#
+ where (-) = minusFloat#
+
+ti5 :: Double# -> Double#
+ti5 x = x-0.1## -- parsed as: (-) x 0.1##
+ where (-) = (-##)
=====================================
testsuite/tests/parser/should_compile/all.T
=====================================
@@ -153,7 +153,8 @@ test('proposal-229b', normal, compile, [''])
test('proposal-229d', normal, compile, [''])
test('proposal-229e', normal, compile, [''])
test('LexicalNegation', normal, compile, [''])
-test('LexNegVsNegLit', normal, compile, [''])
+test('NegativeLiterals', normal, compile, [''])
+test('NegativeLiteralsNoExt', normal, compile, [''])
# We omit 'profasm' because it fails with:
# Cannot load -prof objects when GHC is built with -dynamic
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b31c478d416a1abffb89104f00c7dc5f5d0b607f...5c60e07345176f14661fcf67dd15980879848442
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b31c478d416a1abffb89104f00c7dc5f5d0b607f...5c60e07345176f14661fcf67dd15980879848442
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/20200727/a7db058e/attachment-0001.html>
More information about the ghc-commits
mailing list