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.

16 files changed, 229 insertions, 14 deletions

diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index a439dbe9aa..0a45d96621 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/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,
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 618fc2d393..041b25d586 100644
--- a/compiler/GHC/Parser.y
+++ b/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 $
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index d9c2b09b8f..7fd5a218d0 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/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@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
diff --git a/docs/users_guide/8.12.1-notes.rst b/docs/users_guide/8.12.1-notes.rst
index d324fbdbac..1eb577c36e 100644
--- a/docs/users_guide/8.12.1-notes.rst
+++ 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
 ~~~~~~~~
 
diff --git a/docs/users_guide/exts/lexical_negation.rst b/docs/users_guide/exts/lexical_negation.rst
new file mode 100644
index 0000000000..1060d950e4
--- /dev/null
+++ b/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`.
diff --git a/docs/users_guide/exts/negative_literals.rst b/docs/users_guide/exts/negative_literals.rst
index 74fcc87a21..237fabf044 100644
--- a/docs/users_guide/exts/negative_literals.rst
+++ b/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.
 
diff --git a/docs/users_guide/exts/syntax.rst b/docs/users_guide/exts/syntax.rst
index 781e65b9d3..bb29b55772 100644
--- a/docs/users_guide/exts/syntax.rst
+++ b/docs/users_guide/exts/syntax.rst
@@ -25,3 +25,4 @@ Syntax
     block_arguments
     typed_holes
     arrows
+    lexical_negation
diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
index e7ef699c68..b455fab533 100644
--- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
+++ b/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
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index 9a11780dc5..a0bcebf889 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -42,6 +42,7 @@ expectedGhcOnlyExtensions =
     , "AlternativeLayoutRuleTransitional"
     , "LinearTypes"
     , "QualifiedDo"
+    , "LexicalNegation"
     ]
 
 expectedCabalOnlyExtensions :: [String]
diff --git a/testsuite/tests/parser/should_compile/LexNegVsNegLit.hs b/testsuite/tests/parser/should_compile/LexNegVsNegLit.hs
new file mode 100644
index 0000000000..665893e95b
--- /dev/null
+++ b/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
diff --git a/testsuite/tests/parser/should_compile/LexicalNegation.hs b/testsuite/tests/parser/should_compile/LexicalNegation.hs
new file mode 100644
index 0000000000..e3e3491aed
--- /dev/null
+++ b/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)
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index 8c7f058062..fb2bd6b587 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/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
diff --git a/testsuite/tests/parser/should_run/LexNegLit.hs b/testsuite/tests/parser/should_run/LexNegLit.hs
new file mode 100644
index 0000000000..7c8b0b0f19
--- /dev/null
+++ b/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)
diff --git a/testsuite/tests/parser/should_run/LexNegLit.stdout b/testsuite/tests/parser/should_run/LexNegLit.stdout
new file mode 100644
index 0000000000..b178fc8394
--- /dev/null
+++ b/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)
diff --git a/testsuite/tests/parser/should_run/all.T b/testsuite/tests/parser/should_run/all.T
index fa639de734..2fa6fce766 100644
--- a/testsuite/tests/parser/should_run/all.T
+++ b/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, [''])
diff --git a/utils/haddock b/utils/haddock
-Subproject 54ed6ae2556dc787916e2d56ce0e99808af14e6
+Subproject 9bd65ee47a43529af2ad8e350fdd0c372bc5964