[commit: ghc] master: Fix #14588 by checking for more bang patterns (9caf40e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/9caf40e9d7233a2a6e78a0c4f2d2f13acbf804dd/ghc

>---------------------------------------------------------------

commit 9caf40e9d7233a2a6e78a0c4f2d2f13acbf804dd
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Wed Dec 20 19:25:30 2017 -0500

    Fix #14588 by checking for more bang patterns
    
    Summary:
    Commit 372995364c52eef15066132d7d1ea8b6760034e6
    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


>---------------------------------------------------------------

9caf40e9d7233a2a6e78a0c4f2d2f13acbf804dd
 compiler/parser/Parser.y                         |  3 +--
 compiler/parser/RdrHsSyn.hs                      | 19 +++++++++++++------
 testsuite/tests/parser/should_fail/T14588.hs     |  3 +++
 testsuite/tests/parser/should_fail/T14588.stderr |  4 ++++
 testsuite/tests/parser/should_fail/all.T         |  1 +
 5 files changed, 22 insertions(+), 8 deletions(-)

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 7ae653f..1b59390 100644
--- a/compiler/parser/Parser.y
+++ b/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]
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 0c2b204..0f8e503 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/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]
diff --git a/testsuite/tests/parser/should_fail/T14588.hs b/testsuite/tests/parser/should_fail/T14588.hs
new file mode 100644
index 0000000..8a0bcec
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T14588.hs
@@ -0,0 +1,3 @@
+module T14588 where
+
+main = print (let !x = 1 + 2 in x)
diff --git a/testsuite/tests/parser/should_fail/T14588.stderr b/testsuite/tests/parser/should_fail/T14588.stderr
new file mode 100644
index 0000000..cb64103
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T14588.stderr
@@ -0,0 +1,4 @@
+
+T14588.hs:3:19: error:
+    Illegal bang-pattern (use BangPatterns):
+    ! x
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index abe3da9..483e5fe 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/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, [''])