summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohn Ericson <John.Ericson@Obsidian.Systems>2019-12-16 18:06:11 -0500
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-12-20 10:50:22 -0500
commit1a0d1a6583cc39a31d6947eda1d4998c4fb53c4f (patch)
tree7639a0c41a1d611d658da9f6c0eda61d314003ed
parent0c114c6599c1df93b208c5f2b1754523858d80ee (diff)
downloadhaskell-1a0d1a6583cc39a31d6947eda1d4998c4fb53c4f.tar.gz
Deduplicate copied monad failure handler code
-rw-r--r--compiler/deSugar/DsExpr.hs11
-rw-r--r--compiler/deSugar/DsExpr.hs-boot6
-rw-r--r--compiler/deSugar/DsListComp.hs21
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