Deduplicate copied monad failure handler code

3 files changed, 12 insertions, 26 deletions

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index e58bb341aa..d79caead00 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -11,7 +11,8 @@ Desugaring expressions.
 {-# LANGUAGE ViewPatterns #-}
 
 module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
-              , dsValBinds, dsLit, dsSyntaxExpr ) where
+              , dsValBinds, dsLit, dsSyntaxExpr
+              , dsHandleMonadicFailure ) where
 
 #include "HsVersions.h"
 
@@ -918,7 +919,7 @@ dsDo stmts
             ; var   <- selectSimpleMatchVarL pat
             ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
                                       res1_ty (cantFailMatchResult body)
-            ; match_code <- handle_failure pat match fail_op
+            ; match_code <- dsHandleMonadicFailure pat match fail_op
             ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
 
     go _ (ApplicativeStmt body_ty args mb_join) stmts
@@ -940,7 +941,7 @@ dsDo stmts
                    = do { var   <- selectSimpleMatchVarL pat
                         ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
                                    body_ty (cantFailMatchResult body)
-                        ; match_code <- handle_failure pat match fail_op
+                        ; match_code <- dsHandleMonadicFailure pat match fail_op
                         ; return (var:vs, match_code)
                         }
 
@@ -990,10 +991,10 @@ dsDo stmts
     go _ (TransStmt {}) _ = panic "dsDo TransStmt"
     go _ (XStmtLR nec)  _ = noExtCon nec
 
-handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
     -- In a do expression, pattern-match failure just calls
     -- the monadic 'fail' rather than throwing an exception
-handle_failure pat match fail_op
+dsHandleMonadicFailure pat match fail_op
   | matchCanFail match
   = do { dflags <- getDynFlags
        ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
diff --git a/compiler/deSugar/DsExpr.hs-boot b/compiler/deSugar/DsExpr.hs-boot
index 54864d5835..e3eed65538 100644
--- a/compiler/deSugar/DsExpr.hs-boot
+++ b/compiler/deSugar/DsExpr.hs-boot
@@ -1,6 +1,6 @@
 module DsExpr where
-import GHC.Hs      ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )
-import DsMonad     ( DsM )
+import GHC.Hs      ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )
+import DsMonad     ( DsM, MatchResult )
 import CoreSyn     ( CoreExpr )
 import GHC.Hs.Extension ( GhcTc)
 
@@ -8,3 +8,5 @@ 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 -> SyntaxExpr GhcTc -> DsM CoreExpr
diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs
index 084a9dabff..74fffacc73 100644
--- a/compiler/deSugar/DsListComp.hs
+++ b/compiler/deSugar/DsListComp.hs
@@ -16,7 +16,7 @@ module DsListComp ( dsListComp, dsMonadComp ) where
 
 import GhcPrelude
 
-import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
+import {-# SOURCE #-} DsExpr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
 
 import GHC.Hs
 import TcHsSyn
@@ -624,26 +624,9 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
         ; var      <- selectSimpleMatchVarL pat
         ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
                                   res1_ty (cantFailMatchResult body)
-        ; match_code <- handle_failure pat match fail_op
+        ; match_code <- dsHandleMonadicFailure pat match fail_op
         ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
 
-  where
-    -- In a monad comprehension expression, pattern-match failure just calls
-    -- the monadic `fail` rather than throwing an exception
-    handle_failure pat match fail_op
-      | matchCanFail match
-        = do { dflags <- getDynFlags
-             ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
-             ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
-             ; extractMatchResult match fail_expr }
-      | otherwise
-        = extractMatchResult match (error "It can't fail")
-
-    mk_fail_msg :: DynFlags -> Located e -> String
-    mk_fail_msg dflags pat
-        = "Pattern match failure in monad comprehension at " ++
-          showPpr dflags (getLoc pat)
-
 -- Desugar nested monad comprehensions, for example in `then..` constructs
 --    dsInnerMonadComp quals [a,b,c] ret_op
 -- returns the desugaring of