A fix to an error message in monad comprehensions, and a move of dsHandleMonadicFailure

as suggested by comments on !2330.

1 files changed, 2 insertions, 28 deletions

diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 931527b57a..2987e3e9f3 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/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 DoExpr 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 DoExpr 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)
-
 {-
 ************************************************************************
 *                                                                      *