Commit 301bdd23 authored by John Ericson's avatar John Ericson Committed by Jonathan DK Gibbons

Deduplicate copied monad failure handler code

(cherry picked from commit 63053481)
parent 51eb739f
......@@ -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"
......@@ -916,7 +917,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
......@@ -938,7 +939,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)
}
......@@ -988,10 +989,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)
......
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
......@@ -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 :: HasSrcSpan e => DynFlags -> 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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment