Commit e396f67f authored by John Ericson's avatar John Ericson

Merge branch 'cg-je-match-result-refactor' into HEAD

parents 6191c6b1 333a855f
......@@ -998,23 +998,23 @@ dsDo stmts
dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> Maybe (SyntaxExpr 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
| matchCanFail match = 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]
extractMatchResult match fail_expr
| otherwise =
extractMatchResult match (error "It can't fail")
dsHandleMonadicFailure pat match m_fail_op =
case shareFailureHandler match of
MatchResult_Unfailable body -> body
MatchResult_Failable 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 " ++
......
......@@ -6,10 +6,14 @@
@DsMonad@: monadery used in desugaring
-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
module DsMonad (
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
......@@ -42,8 +46,7 @@ module DsMonad (
-- Data types
DsMatchContext(..),
EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
CanItFail(..), orFail,
EquationInfo(..), MatchResult'(..), MatchResult, runMatchResult, DsWrapper, idDsWrapper,
-- Levity polymorphism
dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
......@@ -134,21 +137,28 @@ idDsWrapper e = e
-- \fail. wrap (case vs of { pats -> rhs fail })
-- where vs are not bound by wrap
-- A MatchResult is an expression with a hole in it
data MatchResult
= MatchResult
CanItFail -- Tells whether the failure expression is used
(CoreExpr -> DsM CoreExpr)
-- Takes a expression to plug in at the
-- failure point(s). The expression should
-- be duplicatable!
data CanItFail = CanFail | CantFail
orFail :: CanItFail -> CanItFail -> CanItFail
orFail CantFail CantFail = CantFail
orFail _ _ = CanFail
-- This is a value of type a with potentially a CoreExpr-shaped hole in it. We explicitly represent
-- the case where there is no hole. This is used to deal with cases where we are potentially handling
-- pattern match failure, and want to later specify how failure is handled.
data MatchResult' a
= MatchResult_Unfailable (DsM a)
| MatchResult_Failable (CoreExpr -> DsM a)
deriving (Functor)
instance Applicative MatchResult' where
pure v = MatchResult_Unfailable (pure v)
MatchResult_Unfailable f <*> MatchResult_Unfailable x = MatchResult_Unfailable (f <*> x)
f <*> x = MatchResult_Failable $ \fail -> runMatchResult fail f <*> runMatchResult fail x
-- This is a CoreExpr with potentially a CoreExpr hole in it, which is the most common case.
type MatchResult = MatchResult' CoreExpr
-- Given a fail expression to use, and a MatchResult, compute the filled CoreExpr whether
-- the MatchResult was failable or not.
runMatchResult :: CoreExpr -> MatchResult' a -> DsM a
runMatchResult fail = \case
MatchResult_Unfailable body -> body
MatchResult_Failable body_fn -> body_fn fail
{-
************************************************************************
......
This diff is collapsed.
......@@ -234,7 +234,7 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty
matchEmpty :: MatchId -> Type -> DsM [MatchResult]
-- See Note [Empty case expressions]
matchEmpty var res_ty
= return [MatchResult CanFail mk_seq]
= return [MatchResult_Failable mk_seq]
where
mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
[(DEFAULT, [], fail)]
......
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