diff options
| author | Cale Gibbard <cgibbard@gmail.com> | 2020-06-30 10:46:49 -0400 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-08-07 08:34:46 -0400 |
| commit | fa9bb70a3fefef681cb0e80cc78977386c1dcf0a (patch) | |
| tree | 09c9f9f42540f75b5098ed47a28a09bb07ee19a2 /compiler | |
| parent | 3907ee01e68b383fa30386d163decf203acedb19 (diff) | |
| download | haskell-fa9bb70a3fefef681cb0e80cc78977386c1dcf0a.tar.gz | |
Add some tests for fail messages in do-expressions and monad-comprehensions.
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/ListComp.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Utils.hs | 4 |
3 files changed, 5 insertions, 5 deletions
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 2987e3e9f3..ffa4e9323f 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -988,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 DoExpr pat match (xbstc_failOp xbs) + ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs) ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] } go _ (ApplicativeStmt body_ty args mb_join) stmts @@ -1009,7 +1009,7 @@ dsDo ctx stmts = do { var <- selectSimpleMatchVarL Many pat ; match <- matchSinglePatVar var (StmtCtxt ctx) pat body_ty (cantFailMatchResult body) - ; match_code <- dsHandleMonadicFailure DoExpr pat match fail_op + ; match_code <- dsHandleMonadicFailure ctx pat match fail_op ; return (var:vs, match_code) } diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index ee1fcaa206..174d0a27af 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -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 MonadComp pat match fail_op + ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } -- Desugar nested monad comprehensions, for example in `then..` constructs diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index b9644e4444..1b0face052 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -898,7 +898,7 @@ 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 +dsHandleMonadicFailure :: Outputable (IdP p) => HsStmtContext p -> 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 = @@ -919,7 +919,7 @@ dsHandleMonadicFailure ctx pat match m_fail_op = fail_expr <- dsSyntaxExpr fail_op [fail_msg] body fail_expr -mk_fail_msg :: DynFlags -> HsStmtContext GhcTc -> Located e -> String +mk_fail_msg :: Outputable (IdP p) => DynFlags -> HsStmtContext p -> Located e -> String mk_fail_msg dflags ctx pat = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx <+> text "at" <+> ppr (getLoc pat) {- ********************************************************************* |