From 3907ee01e68b383fa30386d163decf203acedb19 Mon Sep 17 00:00:00 2001 From: Cale Gibbard Date: Tue, 16 Jun 2020 14:50:02 -0400 Subject: A fix to an error message in monad comprehensions, and a move of dsHandleMonadicFailure as suggested by comments on !2330. --- compiler/GHC/HsToCore/Expr.hs | 30 ++---------------------------- 1 file changed, 2 insertions(+), 28 deletions(-) (limited to 'compiler/GHC/HsToCore/Expr.hs') 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) - {- ************************************************************************ * * -- cgit v1.2.1