rename: Don't require 'fail' in non-monadic contexts

Fixes #11216.

4 files changed, 32 insertions, 4 deletions

diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index d695d8e651..1b6ccdc1d8 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -2338,6 +2338,15 @@ isMonadCompExpr (ParStmtCtxt ctxt)   = isMonadCompExpr ctxt
 isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt
 isMonadCompExpr _                    = 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
+
 matchSeparator :: HsMatchContext id -> SDoc
 matchSeparator (FunRhs {})  = text "="
 matchSeparator CaseAlt      = text "->"
@@ -2414,6 +2423,9 @@ pprStmtContext (TransStmtCtxt c)
  | opt_PprStyle_Debug = sep [text "transformed branch of", pprAStmtContext c]
  | otherwise          = pprStmtContext c
 
+instance (Outputable id, Outputable (NameOrRdrName id))
+      => Outputable (HsStmtContext id) where
+    ppr = pprStmtContext
 
 -- Used to generate the string for a *runtime* error message
 matchContextErrString :: Outputable id
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 7cafc2b22f..5427579793 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -803,9 +803,16 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
         ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
 
         ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
-        ; let failFunction | xMonadFailEnabled = failMName
-                           | otherwise         = failMName_preMFP
-        ; (fail_op, fvs2) <- lookupSyntaxName failFunction
+        ; let getFailFunction
+                -- For non-monadic contexts (e.g. guard patterns, list
+                -- comprehensions, etc.) we should not need to fail
+                | not (isMonadFailStmtContext ctxt)
+                                    = return (err, emptyFVs)
+                | xMonadFailEnabled = lookupSyntaxName failMName
+                | otherwise         = lookupSyntaxName failMName_preMFP
+                where err = pprPanic "rnStmt: fail function forced"
+                                     (text "context:" <+> ppr ctxt)
+        ; (fail_op, fvs2) <- getFailFunction
 
         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
diff --git a/testsuite/tests/rebindable/T11216A.hs b/testsuite/tests/rebindable/T11216A.hs
new file mode 100644
index 0000000000..4bc06f6da9
--- /dev/null
+++ b/testsuite/tests/rebindable/T11216A.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE RebindableSyntax #-}
+
+module Bug where
+
+data Maybe a = Just a | Nothing
+
+foo :: [Maybe a] -> [a]
+foo xs = [ x | Just x <- xs ]
diff --git a/testsuite/tests/rebindable/all.T b/testsuite/tests/rebindable/all.T
index f1737e9603..dd51e2b1cf 100644
--- a/testsuite/tests/rebindable/all.T
+++ b/testsuite/tests/rebindable/all.T
@@ -31,5 +31,6 @@ test('T4851', normal, compile, [''])
 
 test('T5908', normal, compile, [''])
 test('T10112', normal, compile, [''])
-test('T11216', [expect_broken(11216)], compile, [''])
+test('T11216', normal, compile, [''])
+test('T11216A', normal, compile, [''])
 test('T12080', normal, compile, [''])