Fix #14588 by checking for more bang patterns
authorRyan Scott <ryan.gl.scott@gmail.com>
Thu, 21 Dec 2017 00:25:30 +0000 (19:25 -0500)
committerRyan Scott <ryan.gl.scott@gmail.com>
Thu, 21 Dec 2017 00:25:31 +0000 (19:25 -0500)
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

compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
testsuite/tests/parser/should_fail/T14588.hs [new file with mode: 0644]
testsuite/tests/parser/should_fail/T14588.stderr [new file with mode: 0644]
testsuite/tests/parser/should_fail/all.T

index 7ae653f..1b59390 100644 (file)
@@ -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]
index 0c2b204..0f8e503 100644 (file)
@@ -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 (file)
index 0000000..8a0bcec
--- /dev/null
@@ -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 (file)
index 0000000..cb64103
--- /dev/null
@@ -0,0 +1,4 @@
+
+T14588.hs:3:19: error:
+    Illegal bang-pattern (use BangPatterns):
+    ! x
index abe3da9..483e5fe 100644 (file)
@@ -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, [''])