compiler/GHC/HsToCore/Expr.hs

@@ -16,7 +16,6 @@ Desugaring expressions.
 module GHC.HsToCore.Expr
    ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
    , dsValBinds, dsLit, dsSyntaxExpr
-   , dsHandleMonadicFailure
    )
 where
 
@@ -989,7 +988,7 @@ dsDo ctx stmts
             ; var   <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat
             ; match <- matchSinglePatVar var (StmtCtxt ctx) pat
                          (xbstc_boundResultType xbs) (cantFailMatchResult body)
-            ; match_code <- dsHandleMonadicFailure pat match (xbstc_failOp xbs)
+            ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)
             ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
 
     go _ (ApplicativeStmt body_ty args mb_join) stmts
@@ -1010,7 +1009,7 @@ dsDo ctx stmts
                    = do { var   <- selectSimpleMatchVarL Many pat
                         ; match <- matchSinglePatVar var (StmtCtxt ctx) pat
                                    body_ty (cantFailMatchResult body)
-                        ; match_code <- dsHandleMonadicFailure pat match fail_op
+                        ; match_code <- dsHandleMonadicFailure ctx pat match fail_op
                         ; return (var:vs, match_code)
                         }
 
@@ -1065,31 +1064,6 @@ dsDo ctx stmts
     go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
     go _ (TransStmt {}) _ = panic "dsDo TransStmt"
 
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
-    -- In a do expression, pattern-match failure just calls
-    -- the monadic 'fail' rather than throwing an exception
-dsHandleMonadicFailure pat match m_fail_op =
-  case shareFailureHandler match of
-    MR_Infallible body -> body
-    MR_Fallible body -> do
-      fail_op <- case m_fail_op of
-        -- Note that (non-monadic) list comprehension, pattern guards, etc could
-        -- have fallible bindings without an explicit failure op, but this is
-        -- handled elsewhere. See Note [Failing pattern matches in Stmts] the
-        -- breakdown of regular and special binds.
-        Nothing -> pprPanic "missing fail op" $
-          text "Pattern match:" <+> ppr pat <+>
-          text "is failable, and fail_expr was left unset"
-        Just fail_op -> pure fail_op
-      dflags <- getDynFlags
-      fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
-      fail_expr <- dsSyntaxExpr fail_op [fail_msg]
-      body fail_expr
-
-mk_fail_msg :: DynFlags -> Located e -> String
-mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
-                         showPpr dflags (getLoc pat)
-
 {-
 ************************************************************************
 *                                                                      *

compiler/GHC/HsToCore/Expr.hs-boot

 module GHC.HsToCore.Expr where
-import GHC.Hs             ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr, FailOperator )
-import GHC.HsToCore.Monad ( DsM, MatchResult )
+import GHC.Hs             ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )
+import GHC.HsToCore.Monad ( DsM )
 import GHC.Core           ( CoreExpr )
 import GHC.Hs.Extension   ( GhcTc)
 
@@ -8,5 +8,3 @@ dsExpr  :: HsExpr GhcTc -> DsM CoreExpr
 dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
 dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
 dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
-
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr

compiler/GHC/HsToCore/ListComp.hs

@@ -16,7 +16,7 @@ module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where
 
 import GHC.Prelude
 
-import {-# SOURCE #-} GHC.HsToCore.Expr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
+import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
 
 import GHC.Hs
 import GHC.Tc.Utils.Zonk
@@ -618,7 +618,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
         ; var      <- selectSimpleMatchVarL Many pat
         ; match <- matchSinglePatVar var (StmtCtxt (DoExpr Nothing)) pat
                                   res1_ty (cantFailMatchResult body)
-        ; match_code <- dsHandleMonadicFailure pat match fail_op
+        ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op
         ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
 
 -- Desugar nested monad comprehensions, for example in `then..` constructs

compiler/GHC/HsToCore/Utils.hs

@@ -24,6 +24,7 @@ module GHC.HsToCore.Utils (
         extractMatchResult, combineMatchResults,
         adjustMatchResultDs,
         shareFailureHandler,
+        dsHandleMonadicFailure,
         mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
         matchCanFail, mkEvalMatchResult,
         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
@@ -49,7 +50,7 @@ module GHC.HsToCore.Utils (
 import GHC.Prelude
 
 import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply )
-import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr )
+import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr, dsSyntaxExpr )
 
 import GHC.Hs
 import GHC.Tc.Utils.Zonk
@@ -895,9 +896,33 @@ entered at most once.  Adding a dummy 'realWorld' token argument makes
 it clear that sharing is not an issue.  And that in turn makes it more
 CPR-friendly.  This matters a lot: if you don't get it right, you lose
 the tail call property.  For example, see #3403.
+-}
 
+dsHandleMonadicFailure :: Outputable (IdP p) => HsStmtContext p -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
+    -- In a do expression, pattern-match failure just calls
+    -- the monadic 'fail' rather than throwing an exception
+dsHandleMonadicFailure ctx pat match m_fail_op =
+  case shareFailureHandler match of
+    MR_Infallible body -> body
+    MR_Fallible body -> do
+      fail_op <- case m_fail_op of
+        -- Note that (non-monadic) list comprehension, pattern guards, etc could
+        -- have fallible bindings without an explicit failure op, but this is
+        -- handled elsewhere. See Note [Failing pattern matches in Stmts] the
+        -- breakdown of regular and special binds.
+        Nothing -> pprPanic "missing fail op" $
+          text "Pattern match:" <+> ppr pat <+>
+          text "is failable, and fail_expr was left unset"
+        Just fail_op -> pure fail_op
+      dflags <- getDynFlags
+      fail_msg <- mkStringExpr (mk_fail_msg dflags ctx pat)
+      fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+      body fail_expr
+
+mk_fail_msg :: Outputable (IdP p) => DynFlags -> HsStmtContext p -> Located e -> String
+mk_fail_msg dflags ctx pat = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx <+> text "at" <+> ppr (getLoc pat)
 
-************************************************************************
+{- *********************************************************************
 *                                                                      *
               Ticks
 *                                                                      *

testsuite/tests/deSugar/should_run/DsDoExprFailMsg.hs

+main = do
+  (x:xs) <- return []
+  return ()

testsuite/tests/deSugar/should_run/DsDoExprFailMsg.stderr

+DsDoExprFailMsg: user error (Pattern match failure in 'do' block at DsDoExprFailMsg.hs:2:3-8)

testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.hs

+{-# LANGUAGE MonadComprehensions #-}
+main = [() | (x:xs) <- return []]

testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.stderr

+DsMonadCompFailMsg: user error (Pattern match failure in monad comprehension at DsMonadCompFailMsg.hs:2:14-19)

testsuite/tests/deSugar/should_run/all.T

@@ -66,3 +66,6 @@ test('T12595', normal, compile_and_run, [''])
 test('T13285', normal, compile_and_run, [''])
 test('T18151', normal, compile_and_run, [''])
 test('T18172', [], ghci_script, ['T18172.script'])
+
+test('DsDoExprFailMsg', exit_code(1), compile_and_run, [''])
+test('DsMonadCompFailMsg', exit_code(1), compile_and_run, [''])