[Git][ghc/ghc][wip/lexical-negation] Implement -XLexicalNegation (GHC Proposal #229)

Vladislav Zavialov gitlab at gitlab.haskell.org
Fri Jun 19 15:28:30 UTC 2020



Vladislav Zavialov pushed to branch wip/lexical-negation at Glasgow Haskell Compiler / GHC


Commits:
98a8a3b4 by Vladislav Zavialov at 2020-06-19T18:27:43+03: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.

- - - - -


14 changed files:

- compiler/GHC/Driver/Session.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/syntax.rst
- libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
- testsuite/tests/driver/T4437.hs
- + testsuite/tests/parser/should_compile/LexicalNegation.hs
- testsuite/tests/parser/should_compile/all.T
- + testsuite/tests/parser/should_run/LexNegVsNegLit.hs
- + testsuite/tests/parser/should_run/LexNegVsNegLit.stdout
- testsuite/tests/parser/should_run/all.T
- utils/haddock


Changes:

=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3794,6 +3794,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/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: 04 June 2018
 
@@ -547,6 +547,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
@@ -692,10 +693,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 }
@@ -2727,12 +2739,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)
@@ -2778,6 +2790,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
=====================================
@@ -764,7 +764,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
@@ -864,6 +865,38 @@ 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
 -- provided to the compiler; if the extension corresponding to *any* of the
@@ -967,7 +1000,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)
 
@@ -1464,6 +1497,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)
@@ -2480,6 +2516,7 @@ data ExtBits
   | GadtSyntaxBit
   | ImportQualifiedPostBit
   | LinearTypesBit
+  | NoLexicalNegationBit   -- See Note [Why not LexicalNegationBit]
 
   -- Flags that are updated once parsing starts
   | InRulePragBit
@@ -2567,12 +2604,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
=====================================
@@ -145,6 +145,16 @@ Language
     data U a where
       MkU :: (Show a => U a)
 
+* :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,50 @@
+.. _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``.
+
+* ``-x`` is never subtraction; it's a negation of ``x`` for any syntactically
+  atomic expression ``x`` (variable, literal, or parenthesized expression),
+  therefore ``f -x`` is parsed as ``f (-x)``.
+
+This means that ``(- x)`` is the right operator section of subtraction, whereas
+``(-x)`` is the negation of ``x``.
+
+When both :extension:`NegativeLiterals` and :extension:`LexicalNegation` are
+enabled, :extension:`NegativeLiterals` takes precedence: ``-123`` is desugared
+as ``fromInteger (-123)``, whereas ``-x`` is desugared as ``negate x``.


=====================================
docs/users_guide/exts/syntax.rst
=====================================
@@ -24,3 +24,4 @@ Syntax
     block_arguments
     typed_holes
     arrows
+    lexical_negation


=====================================
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
=====================================
@@ -145,6 +145,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
=====================================
@@ -41,6 +41,7 @@ expectedGhcOnlyExtensions =
     , "AlternativeLayoutRule"
     , "AlternativeLayoutRuleTransitional"
     , "LinearTypes"
+    , "LexicalNegation"
     ]
 
 expectedCabalOnlyExtensions :: [String]


=====================================
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  ==  x


=====================================
testsuite/tests/parser/should_compile/all.T
=====================================
@@ -152,6 +152,7 @@ test('proposal-229a', normal, compile, [''])
 test('proposal-229b', normal, compile, [''])
 test('proposal-229d', normal, compile, [''])
 test('proposal-229e', normal, compile, [''])
+test('LexicalNegation', normal, compile, [''])
 
 # We omit 'profasm' because it fails with:
 # Cannot load -prof objects when GHC is built with -dynamic


=====================================
testsuite/tests/parser/should_run/LexNegVsNegLit.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE LexicalNegation, NegativeLiterals #-}
+
+-- LexicalNegation vs NegativeLiterals
+
+data FreeNum
+  = FromInteger Integer
+  | Negate FreeNum
+  deriving (Show)
+
+instance Num FreeNum where
+  fromInteger = FromInteger
+  negate = Negate
+
+main = do
+  let x = 5
+  print (-123 :: FreeNum)
+  print (-x :: FreeNum)


=====================================
testsuite/tests/parser/should_run/LexNegVsNegLit.stdout
=====================================
@@ -0,0 +1,2 @@
+FromInteger (-123)
+Negate (FromInteger 5)


=====================================
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('LexNegVsNegLit', normal, compile_and_run, [''])


=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 02a1def8d147da88a0433726590f8586f486c760
+Subproject commit 5d726ee45374bdb95ae23e84b9b3b44d83b0dd73



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/98a8a3b41bc4e50293e95b33aaeb9a6a46af78b4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/98a8a3b41bc4e50293e95b33aaeb9a6a46af78b4
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/20200619/102f1e78/attachment-0001.html>


More information about the ghc-commits mailing list