Implement -Woperator-whitespace (#18834)wip/warn-operator-whitespace

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.

8 files changed, 107 insertions, 35 deletions

diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs
index 5d591a0dd3..0f65ef2157 100644
--- a/compiler/GHC/Cmm/CallConv.hs
+++ b/compiler/GHC/Cmm/CallConv.hs
@@ -207,14 +207,14 @@ nodeOnly = ([VanillaReg 1], [], [], [], [])
 realArgRegsCover :: Platform -> [GlobalReg]
 realArgRegsCover platform
     | passFloatArgsInXmm platform
-    = map ($VGcPtr) (realVanillaRegs platform) ++
+    = map ($ VGcPtr) (realVanillaRegs platform) ++
       realLongRegs platform ++
       realDoubleRegs platform -- we only need to save the low Double part of XMM registers.
                               -- Moreover, the NCG can't load/store full XMM
                               -- registers for now...
 
     | otherwise
-    = map ($VGcPtr) (realVanillaRegs platform) ++
+    = map ($ VGcPtr) (realVanillaRegs platform) ++
       realFloatRegs  platform ++
       realDoubleRegs platform ++
       realLongRegs   platform
diff --git a/compiler/GHC/CmmToLlvm/Regs.hs b/compiler/GHC/CmmToLlvm/Regs.hs
index 411ec22bbb..c4d9d12a48 100644
--- a/compiler/GHC/CmmToLlvm/Regs.hs
+++ b/compiler/GHC/CmmToLlvm/Regs.hs
@@ -50,12 +50,12 @@ lmGlobalReg platform suf reg
         VanillaReg 9 _ -> wordGlobal $ "R9" ++ suf
         VanillaReg 10 _ -> wordGlobal $ "R10" ++ suf
         SpLim          -> wordGlobal $ "SpLim" ++ suf
-        FloatReg 1     -> floatGlobal $"F1" ++ suf
-        FloatReg 2     -> floatGlobal $"F2" ++ suf
-        FloatReg 3     -> floatGlobal $"F3" ++ suf
-        FloatReg 4     -> floatGlobal $"F4" ++ suf
-        FloatReg 5     -> floatGlobal $"F5" ++ suf
-        FloatReg 6     -> floatGlobal $"F6" ++ suf
+        FloatReg 1     -> floatGlobal $ "F1" ++ suf
+        FloatReg 2     -> floatGlobal $ "F2" ++ suf
+        FloatReg 3     -> floatGlobal $ "F3" ++ suf
+        FloatReg 4     -> floatGlobal $ "F4" ++ suf
+        FloatReg 5     -> floatGlobal $ "F5" ++ suf
+        FloatReg 6     -> floatGlobal $ "F6" ++ suf
         DoubleReg 1    -> doubleGlobal $ "D1" ++ suf
         DoubleReg 2    -> doubleGlobal $ "D2" ++ suf
         DoubleReg 3    -> doubleGlobal $ "D3" ++ suf
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 661253b856..e228c416be 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -501,6 +501,8 @@ data WarningFlag =
    | Opt_WarnCompatUnqualifiedImports     -- Since 8.10
    | Opt_WarnDerivingDefaults
    | Opt_WarnInvalidHaddock               -- Since 8.12
+   | Opt_WarnOperatorWhitespaceExtConflict  -- Since 9.2
+   | Opt_WarnOperatorWhitespace             -- Since 9.2
    deriving (Eq, Show, Enum)
 
 -- | Used when outputting warnings: if a reason is given, it is
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index ed29aa812c..2a4319ed1e 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3330,7 +3330,9 @@ wWarningFlagsDeps = [
                                          Opt_WarnPrepositiveQualifiedModule,
   flagSpec "unused-packages"             Opt_WarnUnusedPackages,
   flagSpec "compat-unqualified-imports"  Opt_WarnCompatUnqualifiedImports,
-  flagSpec "invalid-haddock"             Opt_WarnInvalidHaddock
+  flagSpec "invalid-haddock"             Opt_WarnInvalidHaddock,
+  flagSpec "operator-whitespace-ext-conflict"  Opt_WarnOperatorWhitespaceExtConflict,
+  flagSpec "operator-whitespace"         Opt_WarnOperatorWhitespace
  ]
 
 -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
@@ -4087,7 +4089,8 @@ standardWarnings -- see Note [Documenting warning flags]
         Opt_WarnInaccessibleCode,
         Opt_WarnSpaceAfterBang,
         Opt_WarnNonCanonicalMonadInstances,
-        Opt_WarnNonCanonicalMonoidInstances
+        Opt_WarnNonCanonicalMonoidInstances,
+        Opt_WarnOperatorWhitespaceExtConflict
       ]
 
 -- | Things you get with -W
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
 
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index fa9e80ecfd..68d2908dbb 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -427,7 +427,7 @@ resumeExec canLogSpan step
                     hist' = case mb_brkpt of
                        Nothing -> prevHistoryLst
                        Just bi
-                         | not $canLogSpan span -> prevHistoryLst
+                         | not $ canLogSpan span -> prevHistoryLst
                          | otherwise -> mkHistory hsc_env apStack bi `consBL`
                                                         fromListBL 50 hist
                 handleRunStatus step expr bindings final_ids status hist'