Add missing case to HsExpr.isMonadFailStmtContext

This fixes Trac #14591

I took the opportunity to delete the dead code isMonadCompExpr

4 files changed, 25 insertions, 13 deletions

diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index fedaa4491a..de0e473ba4 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/rename/should_fail/T14591.hs b/testsuite/tests/rename/should_fail/T14591.hs
new file mode 100644
index 0000000000..44313427fb
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T14591.hs
@@ -0,0 +1,12 @@
+-- Checks that the ordering constraint on the groupWith function is respected
+{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}
+
+module T14591 where
+
+import GHC.Exts (groupWith)
+
+data Unorderable = Gnorf | Pinky | Brain
+foo = [ ()
+      | 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 0000000000..47e4df0d55
--- /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 2a85d89401..fb53d3306a 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, [''])