Fix #14588 by checking for more bang patterns

Summary:
Commit 37299536
inadvertently removed a check in the parser which rejected
let-bindings with bang patterns, leading to #14588. This fixes it by
creating a `hintBangPat` function to perform this check, and
sprinkling it in the right places.

Test Plan: make test TEST=T14588

Reviewers: bgamari, alanz, simonpj

Reviewed By: bgamari, simonpj

Subscribers: rwbarton, thomie, mpickering, carter

GHC Trac Issues: #14588

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

compiler/parser/Parser.y

@@ -2204,10 +2204,9 @@ decl_no_th :: { LHsDecl GhcPs }
         : sigdecl               { $1 }
 
         | '!' aexp rhs          {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)
-                                              -- Turn it all into an expression so that
-                                              -- checkPattern can check that bangs are enabled
                                             ; l = comb2 $1 $> };
                                         (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
+                                        hintBangPat (comb2 $1 $2) (unLoc e) ;
                                         -- Depending upon what the pattern looks like we might get either
                                         -- a FunBind or PatBind back from checkValDef. See Note
                                         -- [FunBind vs PatBind]

compiler/parser/RdrHsSyn.hs

@@ -53,7 +53,7 @@ module   RdrHsSyn (
         checkValSigLhs,
         checkDoAndIfThenElse,
         checkRecordSyntax,
-        parseErrorSDoc,
+        parseErrorSDoc, hintBangPat,
         splitTilde, splitTildeApps,
 
         -- Help with processing exports
@@ -855,11 +855,10 @@ checkAPat msg loc e0 = do
 
    SectionR (L lb (HsVar (L _ bang))) e    -- (! x)
         | bang == bang_RDR
-        -> do { bang_on <- extension bangPatEnabled
-              ; if bang_on then do { e' <- checkLPat msg e
-                                   ; addAnnotation loc AnnBang lb
-                                   ; return  (BangPat e') }
-                else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }
+        -> do { hintBangPat loc e0
+              ; e' <- checkLPat msg e
+              ; addAnnotation loc AnnBang lb
+              ; return  (BangPat e') }
 
    ELazyPat e         -> checkLPat msg e >>= (return . LazyPat)
    EAsPat n e         -> checkLPat msg e >>= (return . AsPat n)
@@ -1556,6 +1555,14 @@ isImpExpQcWildcard _                = False
 parseErrorSDoc :: SrcSpan -> SDoc -> P a
 parseErrorSDoc span s = failSpanMsgP span s
 
+-- | Hint about bang patterns, assuming @BangPatterns@ is off.
+hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
+hintBangPat span e = do
+    bang_on <- extension bangPatEnabled
+    unless bang_on $
+      parseErrorSDoc span
+        (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
+
 data SumOrTuple
   = Sum ConTag Arity (LHsExpr GhcPs)
   | Tuple [LHsTupArg GhcPs]

testsuite/tests/parser/should_fail/T14588.hs

+module T14588 where
+
+main = print (let !x = 1 + 2 in x)

testsuite/tests/parser/should_fail/T14588.stderr

+
+T14588.hs:3:19: error:
+    Illegal bang-pattern (use BangPatterns):
+    ! x

testsuite/tests/parser/should_fail/all.T

@@ -102,3 +102,4 @@ test('T8501a', normal, compile_fail, [''])
 test('T8501b', normal, compile_fail, [''])
 test('T8501c', normal, compile_fail, [''])
 test('T12610', normal, compile_fail, [''])
+test('T14588', normal, compile_fail, [''])