[commit: ghc] master: Add missing case to HsExpr.isMonadFailStmtContext (23b5b80)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/23b5b80418e219f0c0c27f0e37a08ccdc0045e87/ghc

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

commit 23b5b80418e219f0c0c27f0e37a08ccdc0045e87
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Dec 18 11:55:16 2017 +0000

    Add missing case to HsExpr.isMonadFailStmtContext
    
    This fixes Trac #14591
    
    I took the opportunity to delete the dead code isMonadCompExpr


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

23b5b80418e219f0c0c27f0e37a08ccdc0045e87
 compiler/hsSyn/HsExpr.hs                           | 23 ++++++++++------------
 .../mc20.hs => rename/should_fail/T14591.hs}       |  7 ++-----
 testsuite/tests/rename/should_fail/T14591.stderr   |  2 ++
 testsuite/tests/rename/should_fail/all.T           |  1 +
 4 files changed, 15 insertions(+), 18 deletions(-)

diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index fedaa44..de0e473 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1978,7 +1978,8 @@ pprStmt (LetStmt (L _ binds))     = hsep [text "let", pprBinds binds]
 pprStmt (BodyStmt expr _ _ _)     = ppr expr
 pprStmt (ParStmt stmtss _ _ _)    = sep (punctuate (text " | ") (map ppr stmtss))
 
-pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form })
+pprStmt (TransStmt { trS_stmts = stmts, trS_by = by
+                   , trS_using = using, trS_form = form })
   = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])
 
 pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
@@ -2464,22 +2465,18 @@ isListCompExpr PArrComp          = True
 isListCompExpr MonadComp         = True
 isListCompExpr (ParStmtCtxt c)   = isListCompExpr c
 isListCompExpr (TransStmtCtxt c) = isListCompExpr c
-isListCompExpr _                 = False
-
-isMonadCompExpr :: HsStmtContext id -> Bool
-isMonadCompExpr MonadComp            = True
-isMonadCompExpr (ParStmtCtxt ctxt)   = isMonadCompExpr ctxt
-isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt
-isMonadCompExpr _                    = False
+isListCompExpr _ = False
 
 -- | Should pattern match failure in a 'HsStmtContext' be desugared using
 -- 'MonadFail'?
 isMonadFailStmtContext :: HsStmtContext id -> Bool
-isMonadFailStmtContext MonadComp    = True
-isMonadFailStmtContext DoExpr       = True
-isMonadFailStmtContext MDoExpr      = True
-isMonadFailStmtContext GhciStmtCtxt = True
-isMonadFailStmtContext _            = False
+isMonadFailStmtContext MonadComp            = True
+isMonadFailStmtContext DoExpr               = True
+isMonadFailStmtContext MDoExpr              = True
+isMonadFailStmtContext GhciStmtCtxt         = True
+isMonadFailStmtContext (ParStmtCtxt ctxt)   = isMonadFailStmtContext ctxt
+isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt
+isMonadFailStmtContext _ = False -- ListComp, PArrComp, PatGuard, ArrowExpr
 
 matchSeparator :: HsMatchContext id -> SDoc
 matchSeparator (FunRhs {})  = text "="
diff --git a/testsuite/tests/typecheck/should_fail/mc20.hs b/testsuite/tests/rename/should_fail/T14591.hs
similarity index 83%
copy from testsuite/tests/typecheck/should_fail/mc20.hs
copy to testsuite/tests/rename/should_fail/T14591.hs
index efdfd5b..4431342 100644
--- a/testsuite/tests/typecheck/should_fail/mc20.hs
+++ b/testsuite/tests/rename/should_fail/T14591.hs
@@ -1,15 +1,12 @@
-
 -- Checks that the ordering constraint on the groupWith function is respected
-
 {-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}
 
-module ShouldFail where
+module T14591 where
 
 import GHC.Exts (groupWith)
 
 data Unorderable = Gnorf | Pinky | Brain
-
 foo = [ ()
-      | x <- [Gnorf, Brain]
+      | Gnorf <- [Gnorf, Brain]
       , then group by x using groupWith
       ]
diff --git a/testsuite/tests/rename/should_fail/T14591.stderr b/testsuite/tests/rename/should_fail/T14591.stderr
new file mode 100644
index 0000000..47e4df0
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T14591.stderr
@@ -0,0 +1,2 @@
+
+T14591.hs:11:23: error: Variable not in scope: x
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index 2a85d89..fb53d33 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -129,3 +129,4 @@ test('T13568', normal, multimod_compile_fail, ['T13568','-v0'])
 test('T13947', normal, compile_fail, [''])
 test('T13847', normal, multimod_compile_fail, ['T13847','-v0'])
 test('T14307', normal, compile_fail, [''])
+test('T14591', normal, compile_fail, [''])