Add some tests for fail messages in do-expressions and monad-comprehensions.

8 files changed, 15 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)
 
 {- *********************************************************************
diff --git a/testsuite/tests/deSugar/should_run/DsDoExprFailMsg.hs b/testsuite/tests/deSugar/should_run/DsDoExprFailMsg.hs
new file mode 100644
index 0000000000..126308b66d
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsDoExprFailMsg.hs
@@ -0,0 +1,3 @@
+main = do
+  (x:xs) <- return []
+  return ()
diff --git a/testsuite/tests/deSugar/should_run/DsDoExprFailMsg.stderr b/testsuite/tests/deSugar/should_run/DsDoExprFailMsg.stderr
new file mode 100644
index 0000000000..6a0c0b97dc
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsDoExprFailMsg.stderr
@@ -0,0 +1 @@
+DsDoExprFailMsg: user error (Pattern match failure in 'do' block at DsDoExprFailMsg.hs:2:3-8)
diff --git a/testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.hs b/testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.hs
new file mode 100644
index 0000000000..869c475e8e
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.hs
@@ -0,0 +1,2 @@
+{-# LANGUAGE MonadComprehensions #-}
+main = [() | (x:xs) <- return []]
diff --git a/testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.stderr b/testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.stderr
new file mode 100644
index 0000000000..d5b72f848c
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.stderr
@@ -0,0 +1 @@
+DsMonadCompFailMsg: user error (Pattern match failure in monad comprehension at DsMonadCompFailMsg.hs:2:14-19)
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index 6245f9caf5..2df9586b7d 100644
--- a/testsuite/tests/deSugar/should_run/all.T
+++ b/testsuite/tests/deSugar/should_run/all.T
@@ -66,3 +66,6 @@ test('T12595', normal, compile_and_run, [''])
 test('T13285', normal, compile_and_run, [''])
 test('T18151', normal, compile_and_run, [''])
 test('T18172', [], ghci_script, ['T18172.script'])
+
+test('DsDoExprFailMsg', exit_code(1), compile_and_run, [''])
+test('DsMonadCompFailMsg', exit_code(1), compile_and_run, [''])