'warnSpaceAfterBang' only in patterns (#16619)

5 files changed, 30 insertions, 24 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 80e197e039..e6f639edb3 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2601,14 +2601,8 @@ infixexp_top :: { ECP }
                                          $2 >>= \ $2 ->
                                          runECP_PV $1 >>= \ $1 ->
                                          runECP_PV $3 >>= \ $3 ->
-                                         do { when (srcSpanEnd (getLoc $2)
-                                                == srcSpanStart (getLoc $3)
-                                                && checkIfBang (unLoc $2)) $
-                                                warnSpaceAfterBang (comb2 $2 $3);
-                                              amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3)
-                                                   [mj AnnVal $2]
-                                            }
-                                      }
+                                         amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3)
+                                              [mj AnnVal $2] }
 
 exp10_top :: { ECP }
         : '-' fexp                      { ECP $
@@ -3963,17 +3957,6 @@ hintExplicitForall tok = do
   where
     forallSymDoc = text (forallSym (isUnicode tok))
 
--- | Warn about missing space after bang
-warnSpaceAfterBang :: SrcSpan -> PV ()
-warnSpaceAfterBang span = do
-    bang_on <- getBit BangPatBit
-    unless bang_on $
-      addWarning Opt_WarnSpaceAfterBang span msg
-    where
-      msg = text "Did you forget to enable BangPatterns?" $$
-            text "If you mean to bind (!) then perhaps you want" $$
-            text "to add a space after the bang for clarity."
-
 -- When two single quotes don't followed by tyvar or gtycon, we report the
 -- error as empty character literal, or TH quote that missing proper type
 -- variable or constructor. See #13450.
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 8d15cb317b..7c457f83d1 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -1847,20 +1847,16 @@ ecpFromCmd a = ECP (ecpFromCmd' a)
 -- | Disambiguate infix operators.
 -- See Note [Ambiguous syntactic categories]
 class DisambInfixOp b where
-  checkIfBang :: b -> Bool
   mkHsVarOpPV :: Located RdrName -> PV (Located b)
   mkHsConOpPV :: Located RdrName -> PV (Located b)
   mkHsInfixHolePV :: SrcSpan -> PV (Located b)
 
 instance p ~ GhcPs => DisambInfixOp (HsExpr p) where
-  checkIfBang (HsVar _ (unLoc -> op)) = isBangRdr op
-  checkIfBang _ = False
   mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExt v)
   mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExt v)
   mkHsInfixHolePV l = return $ cL l hsHoleExpr
 
 instance DisambInfixOp RdrName where
-  checkIfBang = isBangRdr
   mkHsConOpPV (dL->L l v) = return $ cL l v
   mkHsVarOpPV (dL->L l v) = return $ cL l v
   mkHsInfixHolePV l =
@@ -2132,7 +2128,9 @@ instance p ~ GhcPs => DisambECP (PatBuilder p) where
   mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern"
   type InfixOp (PatBuilder p) = RdrName
   superInfixOp m = m
-  mkHsOpAppPV l p1 op p2 = return $ cL l $ PatBuilderOpApp p1 op p2
+  mkHsOpAppPV l p1 op p2 = do
+    warnSpaceAfterBang op (getLoc p2)
+    return $ cL l $ PatBuilderOpApp p1 op p2
   mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern"
   type FunArg (PatBuilder p) = PatBuilder p
   superFunArg m = m
@@ -2193,6 +2191,19 @@ mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd)
 mkPatRec p _ =
   addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p
 
+-- | Warn about missing space after bang
+warnSpaceAfterBang :: Located RdrName -> SrcSpan -> PV ()
+warnSpaceAfterBang (dL->L opLoc op) argLoc = do
+    bang_on <- getBit BangPatBit
+    when (not bang_on && noSpace && isBangRdr op) $
+      addWarning Opt_WarnSpaceAfterBang span msg
+    where
+      span = combineSrcSpans opLoc argLoc
+      noSpace = srcSpanEnd opLoc == srcSpanStart argLoc
+      msg = text "Did you forget to enable BangPatterns?" $$
+            text "If you mean to bind (!) then perhaps you want" $$
+            text "to add a space after the bang for clarity."
+
 {- Note [Ambiguous syntactic categories]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
diff --git a/testsuite/tests/parser/should_compile/T16619.hs b/testsuite/tests/parser/should_compile/T16619.hs
new file mode 100644
index 0000000000..296e23cc9a
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T16619.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS -Wmissing-space-after-bang #-}
+
+module T16619 where
+
+import T16619a
+
+1!2
diff --git a/testsuite/tests/parser/should_compile/T16619a.hs b/testsuite/tests/parser/should_compile/T16619a.hs
new file mode 100644
index 0000000000..e1af0d3ae6
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T16619a.hs
@@ -0,0 +1,3 @@
+module T16619a where
+
+(!) _ _ = return []
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index 1c5c225d65..4fdc359f13 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -142,3 +142,4 @@ test('T15457', normal, compile, [''])
 test('T15675', normal, compile, [''])
 test('T15781', normal, compile, [''])
 test('T16339', normal, compile, [''])
+test('T16619', [], multimod_compile, ['T16619', '-v0'])