[Git][ghc/ghc][master] 2 commits: A fix to an error message in monad comprehensions, and a move of dsHandleMonadicFailure
Marge Bot
gitlab at gitlab.haskell.org
Fri Aug 7 12:34:51 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
3907ee01 by Cale Gibbard at 2020-08-07T08:34:46-04:00
A fix to an error message in monad comprehensions, and a move of dsHandleMonadicFailure
as suggested by comments on !2330.
- - - - -
fa9bb70a by Cale Gibbard at 2020-08-07T08:34:46-04:00
Add some tests for fail messages in do-expressions and monad-comprehensions.
- - - - -
9 changed files:
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Expr.hs-boot
- compiler/GHC/HsToCore/ListComp.hs
- compiler/GHC/HsToCore/Utils.hs
- + testsuite/tests/deSugar/should_run/DsDoExprFailMsg.hs
- + testsuite/tests/deSugar/should_run/DsDoExprFailMsg.stderr
- + testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.hs
- + testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.stderr
- testsuite/tests/deSugar/should_run/all.T
Changes:
=====================================
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 ctx 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 ctx 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)
-
{-
************************************************************************
* *
=====================================
compiler/GHC/HsToCore/Expr.hs-boot
=====================================
@@ -1,6 +1,6 @@
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
=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -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 :: HsStmtContext GhcRn) pat match fail_op
; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
-- Desugar nested monad comprehensions, for example in `then..` constructs
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -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 :: 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 =
+ 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 :: 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)
-************************************************************************
+{- *********************************************************************
* *
Ticks
* *
=====================================
testsuite/tests/deSugar/should_run/DsDoExprFailMsg.hs
=====================================
@@ -0,0 +1,3 @@
+main = do
+ (x:xs) <- return []
+ return ()
=====================================
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)
=====================================
testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.hs
=====================================
@@ -0,0 +1,2 @@
+{-# LANGUAGE MonadComprehensions #-}
+main = [() | (x:xs) <- return []]
=====================================
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)
=====================================
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, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9570c21295a2b4a1d1e40939869124f0b9b9bf91...fa9bb70a3fefef681cb0e80cc78977386c1dcf0a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9570c21295a2b4a1d1e40939869124f0b9b9bf91...fa9bb70a3fefef681cb0e80cc78977386c1dcf0a
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200807/9382c87f/attachment-0001.html>
More information about the ghc-commits
mailing list