Surprising error message with bang pattern

Reviewers: bgamari, alanz

Reviewed By: bgamari

Subscribers: sgraf, mpickering, rwbarton, thomie, carter

GHC Trac Issues: #13600

Differential Revision: https://phabricator.haskell.org/D5040

9 files changed, 75 insertions, 6 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3a14b29806..8cc360fce2 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -816,6 +816,7 @@ data WarningFlag =
    | Opt_WarnStarIsType                   -- Since 8.6
    | Opt_WarnStarBinder                   -- Since 8.6
    | Opt_WarnImplicitKindVars             -- Since 8.6
+   | Opt_WarnSpaceAfterBang
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -3866,6 +3867,7 @@ wWarningFlagsDeps = [
   flagSpec "unrecognised-warning-flags"  Opt_WarnUnrecognisedWarningFlags,
   flagSpec "star-binder"                 Opt_WarnStarBinder,
   flagSpec "star-is-type"                Opt_WarnStarIsType,
+  flagSpec "missing-space-after-bang"    Opt_WarnSpaceAfterBang,
   flagSpec "partial-fields"              Opt_WarnPartialFields ]
 
 -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
@@ -4564,7 +4566,8 @@ standardWarnings -- see Note [Documenting warning flags]
         Opt_WarnUnrecognisedWarningFlags,
         Opt_WarnSimplifiableClassConstraints,
         Opt_WarnStarBinder,
-        Opt_WarnInaccessibleCode
+        Opt_WarnInaccessibleCode,
+        Opt_WarnSpaceAfterBang
       ]
 
 -- | Things you get with -W
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 74db997bbb..d7aef8d77f 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -29,7 +29,7 @@ module Parser (parseModule, parseSignature, parseImport, parseStatement, parseBa
                parseType, parseHeader) where
 
 -- base
-import Control.Monad    ( unless, liftM )
+import Control.Monad    ( unless, liftM, when )
 import GHC.Exts
 import Data.Char
 import Control.Monad    ( mplus )
@@ -2483,8 +2483,14 @@ infixexp :: { LHsExpr GhcPs }
 infixexp_top :: { LHsExpr GhcPs }
         : exp10_top               { $1 }
         | infixexp_top qop exp10_top
-                                  {% ams (sLL $1 $> (OpApp noExt $1 $2 $3))
-                                         [mj AnnVal $2] }
+                                  {% do { when (srcSpanEnd (getLoc $2)
+                                            == srcSpanStart (getLoc $3)
+                                            && checkIfBang $2) $
+                                            warnSpaceAfterBang (comb2 $2 $3);
+                                          ams (sLL $1 $> (OpApp noExt $1 $2 $3))
+                                               [mj AnnVal $2]
+                                        }
+                                  }
 
 
 exp10_top :: { LHsExpr GhcPs }
@@ -3705,6 +3711,21 @@ hintExplicitForall' span = do
         , text "extension to enable explicit-forall syntax: forall <tvs>. <type>"
         ]
 
+checkIfBang :: LHsExpr GhcPs -> Bool
+checkIfBang (L _ (HsVar _ (L _ op))) = op == bang_RDR
+checkIfBang _ = False
+
+-- | Warn about missing space after bang
+warnSpaceAfterBang :: SrcSpan -> P ()
+warnSpaceAfterBang span = do
+    bang_on <- extension bangPatEnabled
+    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 Trac #13450.
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index aeabbe9713..f603a4cf28 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -39,6 +39,7 @@ generally likely to indicate bugs in your program. These are:
     * :ghc-flag:`-Winaccessible-code`
     * :ghc-flag:`-Wstar-is-type`
     * :ghc-flag:`-Wstar-binder`
+    * :ghc-flag:`-Wspace-after-bang`
 
 The following flags are simple ways to select standard "packages" of warnings:
 
@@ -1256,6 +1257,12 @@ of ``-W(no-)*``.
     per-module basis with :ghc-flag:`-Wno-simplifiable-class-constraints
     <-Wsimplifiable-class-constraints>`.
 
+.. ghc-flag:: -Wspace-after-bang
+     :shortdesc: warn for missing space before the second argument
+        of an infix definition of ``(!)`` when
+        :ghc-flag:`-XBangPatterns` are not enabled
+     :type: dynamic
+     :reverse: -Wno-missing-space-after-bang
 .. ghc-flag:: -Wtabs
     :shortdesc: warn if there are tabs in the source file
     :type: dynamic
diff --git a/testsuite/tests/parser/should_compile/T13600a.hs b/testsuite/tests/parser/should_compile/T13600a.hs
new file mode 100644
index 0000000000..4768828a9f
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T13600a.hs
@@ -0,0 +1,7 @@
+module T13600a where
+
+f ! x = f !! x
+
+x = [1,2,3] ! 1
+  where
+    f ! x = f !! x
diff --git a/testsuite/tests/parser/should_compile/T13600a.stderr b/testsuite/tests/parser/should_compile/T13600a.stderr
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T13600a.stderr
diff --git a/testsuite/tests/parser/should_compile/T13600b.hs b/testsuite/tests/parser/should_compile/T13600b.hs
new file mode 100644
index 0000000000..e8fd2c183f
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T13600b.hs
@@ -0,0 +1,9 @@
+module T13600b where
+
+f !(Just x) = f !! x
+f !y = head f
+
+x = [1,2,3] ! Just 1
+  where
+    f !(Just x) = f !! x
+    f !y = head f
diff --git a/testsuite/tests/parser/should_compile/T13600b.stderr b/testsuite/tests/parser/should_compile/T13600b.stderr
new file mode 100644
index 0000000000..244b948e0e
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T13600b.stderr
@@ -0,0 +1,20 @@
+
+T13600b.hs:3:3: warning: [-Wmissing-space-after-bang (in -Wdefault)]
+      Did you forget to enable BangPatterns?
+      If you mean to bind (!) then perhaps you want
+      to add a space after the bang for clarity.
+
+T13600b.hs:4:3: warning: [-Wmissing-space-after-bang (in -Wdefault)]
+      Did you forget to enable BangPatterns?
+      If you mean to bind (!) then perhaps you want
+      to add a space after the bang for clarity.
+
+T13600b.hs:8:7: warning: [-Wmissing-space-after-bang (in -Wdefault)]
+      Did you forget to enable BangPatterns?
+      If you mean to bind (!) then perhaps you want
+      to add a space after the bang for clarity.
+
+T13600b.hs:9:7: warning: [-Wmissing-space-after-bang (in -Wdefault)]
+      Did you forget to enable BangPatterns?
+      If you mean to bind (!) then perhaps you want
+      to add a space after the bang for clarity.
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index a22d5d0e62..842bef0ebb 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -117,6 +117,8 @@ test('T13747', normal, compile, [''])
 test('T14189',     normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])
 test('T13986', normal, compile, [''])
 test('T10855', normal, compile, [''])
+test('T13600a', normal, compile, [''])
+test('T13600b', normal, compile, ['-Wno-missing-signatures -Wno-unused-matches'])
 test('T15139', normal, compile, ['-Wincomplete-patterns -fdiagnostics-show-caret'])
 test('T15323', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast'])
 test('KindSigs', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast'])
diff --git a/testsuite/tests/parser/should_compile/read029.hs b/testsuite/tests/parser/should_compile/read029.hs
index 191ef05877..863b906946 100644
--- a/testsuite/tests/parser/should_compile/read029.hs
+++ b/testsuite/tests/parser/should_compile/read029.hs
@@ -10,5 +10,5 @@ import Prelude hiding ( (-) )
 as        = ShouldCompile.as
 hiding    = ShouldCompile.hiding
 qualified = ShouldCompile.qualified
-x!y       = x ShouldCompile.! y
-x-y       = x ShouldCompile.- y
+x ! y     = x ShouldCompile.! y
+x - y     = x ShouldCompile.- y