Implement -Woperator-whitespace (#18834)

This patch implements two related warnings:

  -Woperator-whitespace-ext-conflict
      warns on uses of infix operators that would be parsed
      differently were a particular GHC extension enabled

  -Woperator-whitespace
      warns on prefix, suffix, and tight infix uses of infix
      operators

Updates submodules: haddock, containers.

3 files changed, 91 insertions, 24 deletions

diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs
index b67bf32baf..cf93890532 100644
--- a/compiler/GHC/Parser/Errors.hs
+++ b/compiler/GHC/Parser/Errors.hs
@@ -1,6 +1,8 @@
 module GHC.Parser.Errors
    ( Warning(..)
    , TransLayoutReason(..)
+   , OperatorWhitespaceSymbol(..)
+   , OperatorWhitespaceOccurrence(..)
    , NumUnderscoreReason(..)
    , Error(..)
    , ErrorDesc(..)
@@ -57,6 +59,20 @@ data Warning
    | WarnImportPreQualified !SrcSpan
       -- ^ Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled
 
+   | WarnOperatorWhitespaceExtConflict !SrcSpan !OperatorWhitespaceSymbol
+   | WarnOperatorWhitespace !SrcSpan !FastString !OperatorWhitespaceOccurrence
+
+-- | The operator symbol in the 'WarnOperatorWhitespaceExtConflict' warning.
+data OperatorWhitespaceSymbol
+   = OperatorWhitespaceSymbol_PrefixPercent
+   | OperatorWhitespaceSymbol_PrefixDollar
+   | OperatorWhitespaceSymbol_PrefixDollarDollar
+
+-- | The operator occurrence type in the 'WarnOperatorWhitespace' warning.
+data OperatorWhitespaceOccurrence
+   = OperatorWhitespaceOccurrence_Prefix
+   | OperatorWhitespaceOccurrence_Suffix
+   | OperatorWhitespaceOccurrence_TightInfix
 
 data TransLayoutReason
    = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block"
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index f99cac90a4..c4b411b1c3 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -102,6 +102,34 @@ pprWarning = \case
              <+> text "after the module name instead."
          $$ text "To allow this, enable language extension 'ImportQualifiedPost'"
 
+   WarnOperatorWhitespaceExtConflict loc sym
+      -> mkParserWarn Opt_WarnOperatorWhitespaceExtConflict loc $
+         let mk_prefix_msg operator_symbol extension_name syntax_meaning =
+                  text "The prefix use of a" <+> quotes (text operator_symbol)
+                    <+> text "would denote" <+> text syntax_meaning
+               $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.")
+               $$ text "Suggested fix: add whitespace after the"
+                    <+> quotes (text operator_symbol) <> char '.'
+         in
+         case sym of
+           OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "%" "LinearTypes" "a multiplicity annotation"
+           OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "$" "TemplateHaskell" "an untyped splice"
+           OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "$$" "TemplateHaskell" "a typed splice"
+
+
+   WarnOperatorWhitespace loc sym occ_type
+      -> mkParserWarn Opt_WarnOperatorWhitespace loc $
+         let mk_msg occ_type_str =
+                  text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym)
+                    <+> text "might be repurposed as special syntax"
+               $$ nest 2 (text "by a future language extension.")
+               $$ text "Suggested fix: add whitespace around it."
+         in
+         case occ_type of
+           OperatorWhitespaceOccurrence_Prefix -> mk_msg "prefix"
+           OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"
+           OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix"
+
 pprError :: Error -> ErrMsg
 pprError err = mkParserErr (errLoc err) $ vcat
    (pp_err (errDesc err) : map pp_hint (errHints err))
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 654db86651..17f6dd0e65 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -1572,42 +1572,65 @@ qconsym buf len = ITqconsym $! splitQualName buf len False
 
 -- See Note [Whitespace-sensitive operator parsing]
 varsym_prefix :: Action
-varsym_prefix = sym $ \exts s ->
-  if | s == fsLit "@"  -- regardless of TypeApplications for better error messages
-     -> return ITtypeApp
-     | LinearTypesBit `xtest` exts, s == fsLit "%"
-     -> return ITpercent
-     | ThQuotesBit `xtest` exts, s == fsLit "$"
-     -> 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
+varsym_prefix = sym $ \span exts s ->
+  let warnExtConflict errtok =
+        do { addWarning Opt_WarnOperatorWhitespaceExtConflict $
+               WarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok
+           ; return (ITvarsym s) }
+  in
+  if | s == fsLit "@" ->
+         return ITtypeApp  -- regardless of TypeApplications for better error messages
+     | s == fsLit "%" ->
+         if xtest LinearTypesBit exts
+         then return ITpercent
+         else warnExtConflict OperatorWhitespaceSymbol_PrefixPercent
+     | s == fsLit "$" ->
+         if xtest ThQuotesBit exts
+         then return ITdollar
+         else warnExtConflict OperatorWhitespaceSymbol_PrefixDollar
+     | s == fsLit "$$" ->
+         if xtest ThQuotesBit exts
+         then return ITdollardollar
+         else warnExtConflict OperatorWhitespaceSymbol_PrefixDollarDollar
+     | s == fsLit "-" ->
+         return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus
+                              -- and don't hit this code path. See Note [Minus tokens]
      | s == fsLit "!" -> return ITbang
      | s == fsLit "~" -> return ITtilde
-     | otherwise -> return (ITvarsym s)
+     | otherwise ->
+         do { addWarning Opt_WarnOperatorWhitespace $
+                WarnOperatorWhitespace (mkSrcSpanPs span) s
+                  OperatorWhitespaceOccurrence_Prefix
+            ; return (ITvarsym s) }
 
 -- See Note [Whitespace-sensitive operator parsing]
 varsym_suffix :: Action
-varsym_suffix = sym $ \_ s ->
+varsym_suffix = sym $ \span _ s ->
   if | s == fsLit "@" -> failMsgP (Error ErrSuffixAT [])
-     | otherwise      -> return (ITvarsym s)
+     | otherwise ->
+         do { addWarning Opt_WarnOperatorWhitespace $
+                WarnOperatorWhitespace (mkSrcSpanPs span) s
+                  OperatorWhitespaceOccurrence_Suffix
+            ; return (ITvarsym s) }
 
 -- See Note [Whitespace-sensitive operator parsing]
 varsym_tight_infix :: Action
-varsym_tight_infix = sym $ \_ s ->
+varsym_tight_infix = sym $ \span _ s ->
   if | s == fsLit "@" -> return ITat
-     | otherwise -> return (ITvarsym s)
+     | otherwise ->
+         do { addWarning Opt_WarnOperatorWhitespace $
+                WarnOperatorWhitespace (mkSrcSpanPs span) s
+                  OperatorWhitespaceOccurrence_TightInfix
+            ;  return (ITvarsym s) }
 
 -- See Note [Whitespace-sensitive operator parsing]
 varsym_loose_infix :: Action
-varsym_loose_infix = sym (\_ s -> return $ ITvarsym s)
+varsym_loose_infix = sym (\_ _ s -> return $ ITvarsym s)
 
 consym :: Action
-consym = sym (\_exts s -> return $ ITconsym s)
+consym = sym (\_span _exts s -> return $ ITconsym s)
 
-sym :: (ExtsBitmap -> FastString -> P Token) -> Action
+sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action
 sym con span buf len =
   case lookupUFM reservedSymsFM fs of
     Just (keyword, NormalSyntax, 0) ->
@@ -1616,20 +1639,20 @@ sym con span buf len =
       exts <- getExts
       if exts .&. i /= 0
         then return $ L span keyword
-        else L span <$!> con exts fs
+        else L span <$!> con span exts fs
     Just (keyword, UnicodeSyntax, 0) -> do
       exts <- getExts
       if xtest UnicodeSyntaxBit exts
         then return $ L span keyword
-        else L span <$!> con exts fs
+        else L span <$!> con span exts fs
     Just (keyword, UnicodeSyntax, i) -> do
       exts <- getExts
       if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts
         then return $ L span keyword
-        else L span <$!> con exts fs
+        else L span <$!> con span exts fs
     Nothing -> do
       exts <- getExts
-      L span <$!> con exts fs
+      L span <$!> con span exts fs
   where
     !fs = lexemeToFastString buf len