Commit 3907ee01 authored by cgibbard's avatar cgibbard Committed by Marge Bot
Browse files

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

as suggested by comments on !2330.
parent 9570c212
......@@ -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)
{-
************************************************************************
* *
......
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
......@@ -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 pat match fail_op
; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
-- Desugar nested monad comprehensions, for example in `then..` constructs
......
......@@ -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 :: HsStmtContext GhcTc -> 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 :: DynFlags -> HsStmtContext GhcTc -> Located e -> String
mk_fail_msg dflags ctx pat = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx <+> text "at" <+> ppr (getLoc pat)
************************************************************************
{- *********************************************************************
* *
Ticks
* *
......
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