Fix -Woperator-whitespace for consym (part of #19372)

Due to an oversight, the initial specification and implementation of
-Woperator-whitespace focused on varsym exclusively and completely
ignored consym.

This meant that expressions such as "x+ y" would produce a warning,
while "x:+ y" would not.

The specification was corrected in ghc-proposals pull request #404,
and this patch updates the implementation accordingly.

Regression test included.

5 files changed, 63 insertions, 16 deletions

diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index e79fbf28b4..8e2efe48f0 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -496,7 +496,7 @@ $tab          { warnTab }
   @qvarsym                                         { idtoken qvarsym }
   @qconsym                                         { idtoken qconsym }
   @varsym                                          { with_op_ws varsym }
-  @consym                                          { consym }
+  @consym                                          { with_op_ws consym }
 }
 
 -- For the normal boxed literals we need to be careful
@@ -1681,7 +1681,7 @@ qconsym buf len = ITqconsym $! splitQualName buf len False
 
 -- See Note [Whitespace-sensitive operator parsing]
 varsym :: OpWs -> Action
-varsym OpWsPrefix = sym $ \span exts s ->
+varsym opws@OpWsPrefix = sym $ \span exts s ->
   let warnExtConflict errtok =
         do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok)
            ; return (ITvarsym s) }
@@ -1709,35 +1709,48 @@ varsym OpWsPrefix = sym $ \span exts s ->
      | s == fsLit "!" -> return ITbang
      | s == fsLit "~" -> return ITtilde
      | otherwise ->
-         do { addPsMessage
-                (mkSrcSpanPs span)
-                (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Prefix)
+         do { warnOperatorWhitespace opws span s
             ; return (ITvarsym s) }
-varsym OpWsSuffix = sym $ \span _ s ->
+varsym opws@OpWsSuffix = sym $ \span _ s ->
   if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT)
      | s == fsLit "." -> return ITdot
      | otherwise ->
-         do { addPsMessage
-                (mkSrcSpanPs span)
-                (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Suffix)
+         do { warnOperatorWhitespace opws span s
             ; return (ITvarsym s) }
-varsym OpWsTightInfix = sym $ \span exts s ->
+varsym opws@OpWsTightInfix = sym $ \span exts s ->
   if | s == fsLit "@" -> return ITat
      | s == fsLit ".", OverloadedRecordDotBit `xtest` exts  -> return (ITproj False)
      | s == fsLit "." -> return ITdot
      | otherwise ->
-         do { addPsMessage
-                (mkSrcSpanPs span)
-                (PsWarnOperatorWhitespace s (OperatorWhitespaceOccurrence_TightInfix))
-            ;  return (ITvarsym s) }
+         do { warnOperatorWhitespace opws span s
+            ; return (ITvarsym s) }
 varsym OpWsLooseInfix = sym $ \_ _ s ->
   if | s == fsLit "."
      -> return ITdot
      | otherwise
      -> return $ ITvarsym s
 
-consym :: Action
-consym = sym (\_span _exts s -> return $ ITconsym s)
+consym :: OpWs -> Action
+consym opws = sym $ \span _exts s ->
+  do { warnOperatorWhitespace opws span s
+     ; return (ITconsym s) }
+
+warnOperatorWhitespace :: OpWs -> PsSpan -> FastString -> P ()
+warnOperatorWhitespace opws span s =
+  whenIsJust (check_unusual_opws opws) $ \opws' ->
+    addPsMessage
+      (mkSrcSpanPs span)
+      (PsWarnOperatorWhitespace s opws')
+
+-- Check an operator occurrence for unusual whitespace (prefix, suffix, tight infix).
+-- This determines if -Woperator-whitespace is triggered.
+check_unusual_opws :: OpWs -> Maybe OperatorWhitespaceOccurrence
+check_unusual_opws opws =
+  case opws of
+    OpWsPrefix     -> Just OperatorWhitespaceOccurrence_Prefix
+    OpWsSuffix     -> Just OperatorWhitespaceOccurrence_Suffix
+    OpWsTightInfix -> Just OperatorWhitespaceOccurrence_TightInfix
+    OpWsLooseInfix -> Nothing
 
 sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action
 sym con span buf len _buf2 =
diff --git a/docs/users_guide/9.6.1-notes.rst b/docs/users_guide/9.6.1-notes.rst
index 4d71cda7bc..355fc63838 100644
--- a/docs/users_guide/9.6.1-notes.rst
+++ b/docs/users_guide/9.6.1-notes.rst
@@ -68,6 +68,9 @@ Compiler
 - The :extension:`TypeInType` is now marked as deprecated. Its meaning has been included
   in :extension:`PolyKinds` and :extension:`DataKinds`.
 
+- The :ghc-flag:`-Woperator-whitespace` warning no longer ignores constructor symbols
+  (operators starting with ``:``).
+
 GHCi
 ~~~~
 
diff --git a/testsuite/tests/parser/should_compile/T19372consym.hs b/testsuite/tests/parser/should_compile/T19372consym.hs
new file mode 100644
index 0000000000..6a8fd14d50
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T19372consym.hs
@@ -0,0 +1,15 @@
+{-# OPTIONS -Woperator-whitespace #-}
+
+module T19372consym where
+
+import Data.List.NonEmpty
+
+a_suffix      = \x y -> x: y
+a_prefix      = \x y -> x :y
+a_tight_infix = \x y -> x:y
+a_loose_infix = \x y -> x : y   -- Only this one should be without a warning.
+
+b_suffix      = \x y -> x:| y
+b_prefix      = \x y -> x :|y
+b_tight_infix = \x y -> x:|y
+b_loose_infix = \x y -> x :| y  -- Only this one should be without a warning.
diff --git a/testsuite/tests/parser/should_compile/T19372consym.stderr b/testsuite/tests/parser/should_compile/T19372consym.stderr
new file mode 100644
index 0000000000..f2a0998069
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T19372consym.stderr
@@ -0,0 +1,15 @@
+
+T19372consym.hs:12:26: warning: [GHC-40798] [-Woperator-whitespace]
+    The suffix use of a ‘:|’ might be repurposed as special syntax
+      by a future language extension.
+    Suggested fix: Add whitespace around ‘:|’.
+
+T19372consym.hs:13:27: warning: [GHC-40798] [-Woperator-whitespace]
+    The prefix use of a ‘:|’ might be repurposed as special syntax
+      by a future language extension.
+    Suggested fix: Add whitespace around ‘:|’.
+
+T19372consym.hs:14:26: warning: [GHC-40798] [-Woperator-whitespace]
+    The tight infix use of a ‘:|’ might be repurposed as special syntax
+      by a future language extension.
+    Suggested fix: Add whitespace around ‘:|’.
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index 53fd222576..5fc2a72566 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -193,3 +193,4 @@ test('T20718',  normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-c
 test('T20718b',  normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
 
 test('T21589', normal, compile, [''])
+test('T19372consym', normal, compile, [''])