diff options
author | John Ericson <git@JohnEricson.me> | 2020-04-18 18:35:28 -0400 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-04-22 23:10:28 -0400 |
commit | 401f7bb312aa6c570287d313f8b587aaebca72b2 (patch) | |
tree | 8818dc1e4dddf6d8122becc9064b45491f1b8f7d | |
parent | 72cb6bcc23d2540274aac7d1b80682ef092f1615 (diff) | |
download | haskell-401f7bb312aa6c570287d313f8b587aaebca72b2.tar.gz |
`MatchResult'` -> `MatchResult`
Inline `MatchResult` alias accordingly.
-rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Expr.hs-boot | 2 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/GuardedRHSs.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Match.hs | 24 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Match.hs-boot | 6 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Match/Constructor.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Match/Literal.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Monad.hs | 19 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Utils.hs | 44 |
9 files changed, 61 insertions, 63 deletions
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 54f17b712e..eaae002ea2 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -1014,7 +1014,7 @@ dsDo stmts go _ (ParStmt {}) _ = panic "dsDo ParStmt" go _ (TransStmt {}) _ = panic "dsDo TransStmt" -dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> FailOperator GhcTc -> DsM CoreExpr +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 = diff --git a/compiler/GHC/HsToCore/Expr.hs-boot b/compiler/GHC/HsToCore/Expr.hs-boot index 505b062d26..794b18e617 100644 --- a/compiler/GHC/HsToCore/Expr.hs-boot +++ b/compiler/GHC/HsToCore/Expr.hs-boot @@ -9,4 +9,4 @@ dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> FailOperator GhcTc -> DsM CoreExpr +dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs index 07f94906cd..8ee3661da6 100644 --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -52,7 +52,7 @@ dsGuarded grhss rhs_ty mb_rhss_deltas = do error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty extractMatchResult match_result error_expr --- In contrast, @dsGRHSs@ produces a @MatchResult@. +-- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@. dsGRHSs :: HsMatchContext GhcRn -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs @@ -60,7 +60,7 @@ dsGRHSs :: HsMatchContext GhcRn -> Maybe (NonEmpty Deltas) -- ^ Refined pattern match checking -- models, one for each GRHS. Defaults -- to 'initDeltas' if 'Nothing'. - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty mb_rhss_deltas = ASSERT( notNull grhss ) do { match_results <- case toList <$> mb_rhss_deltas of @@ -73,14 +73,14 @@ dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty mb_rhss_deltas ; return match_result2 } dsGRHS :: HsMatchContext GhcRn -> Type -> Deltas -> LGRHS GhcTc (LHsExpr GhcTc) - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) dsGRHS hs_ctx rhs_ty rhs_deltas (L _ (GRHS _ guards rhs)) = updPmDeltas rhs_deltas (matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty) {- ************************************************************************ * * -* matchGuard : make a MatchResult from a guarded RHS * +* matchGuard : make a MatchResult CoreExpr CoreExpr from a guarded RHS * * * ************************************************************************ -} @@ -89,7 +89,7 @@ matchGuards :: [GuardStmt GhcTc] -- Guard -> HsStmtContext GhcRn -- Context -> LHsExpr GhcTc -- RHS -> Type -- Type of RHS of guard - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) -- See comments with HsExpr.Stmt re what a BodyStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 875542d4f8..2e62fa9856 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -174,7 +174,7 @@ type MatchId = Id -- See Note [Match Ids] match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with. See Note [Match Ids] -> Type -- ^ Type of the case expression -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below) - -> DsM MatchResult -- ^ Desugared result! + -> DsM (MatchResult CoreExpr) -- ^ Desugared result! match [] ty eqns = ASSERT2( not (null eqns), ppr ty ) @@ -207,12 +207,12 @@ match (v:vs) ty eqns -- Eqns *can* be empty dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo dropGroup = fmap snd - match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty MatchResult) - -- Result list of [MatchResult] is always non-empty + match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty (MatchResult CoreExpr)) + -- Result list of [MatchResult CoreExpr] is always non-empty match_groups [] = matchEmpty v ty match_groups (g:gs) = mapM match_group $ g :| gs - match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM MatchResult + match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr) match_group eqns@((group,_) :| _) = case group of PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns']) @@ -246,7 +246,7 @@ match (v:vs) ty eqns -- Eqns *can* be empty maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) (filter (not . null) gs)) -matchEmpty :: MatchId -> Type -> DsM (NonEmpty MatchResult) +matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr)) -- See Note [Empty case expressions] matchEmpty var res_ty = return [MR_Fallible mk_seq] @@ -254,18 +254,18 @@ matchEmpty var res_ty mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty [(DEFAULT, [], fail)] -matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- Real true variables, just like in matchVar, SLPJ p 94 -- No binding to do: they'll all be wildcards by now (done in tidy) matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns -matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) matchBangs (var :| vars) ty eqns = do { match_result <- match (var:vars) ty $ NEL.toList $ decomposeFirstPat getBangPat <$> eqns ; return (mkEvalMatchResult var ty match_result) } -matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- Apply the coercion to the match variable and then match that matchCoercion (var :| vars) ty (eqns@(eqn1 :| _)) = do { let CoPat _ co pat _ = firstPat eqn1 @@ -277,7 +277,7 @@ matchCoercion (var :| vars) ty (eqns@(eqn1 :| _)) ; let bind = NonRec var' (core_wrap (Var var)) ; return (mkCoLetMatchResult bind match_result) } -matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- Apply the view function to the match variable and then match that matchView (var :| vars) ty (eqns@(eqn1 :| _)) = do { -- we could pass in the expr from the PgView, @@ -295,7 +295,7 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _)) (mkCoreAppDs (text "matchView") viewExpr' (Var var)) match_result) } -matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _)) -- Since overloaded list patterns are treated as view patterns, -- the code is roughly the same as for matchView @@ -830,7 +830,7 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do extractMatchResult match_result' fail_expr matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc - -> Type -> MatchResult -> DsM MatchResult + -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) -- matchSinglePat ensures that the scrutinee is a variable -- and then calls matchSinglePatVar -- @@ -850,7 +850,7 @@ matchSinglePat scrut hs_ctx pat ty match_result matchSinglePatVar :: Id -- See Note [Match Ids] -> HsMatchContext GhcRn -> LPat GhcTc - -> Type -> MatchResult -> DsM MatchResult + -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) matchSinglePatVar var ctx pat ty match_result = ASSERT2( isInternalName (idName var), ppr var ) do { dflags <- getDynFlags diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot index a513a69f6d..9466cbdb17 100644 --- a/compiler/GHC/HsToCore/Match.hs-boot +++ b/compiler/GHC/HsToCore/Match.hs-boot @@ -11,7 +11,7 @@ import GHC.Hs.Extension ( GhcRn, GhcTc ) match :: [Id] -> Type -> [EquationInfo] - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) matchWrapper :: HsMatchContext GhcRn @@ -32,5 +32,5 @@ matchSinglePatVar -> HsMatchContext GhcRn -> LPat GhcTc -> Type - -> MatchResult - -> DsM MatchResult + -> MatchResult CoreExpr + -> DsM (MatchResult CoreExpr) diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs index b3c639ca86..f9c3e021d4 100644 --- a/compiler/GHC/HsToCore/Match/Constructor.hs +++ b/compiler/GHC/HsToCore/Match/Constructor.hs @@ -27,6 +27,7 @@ import GHC.Types.Basic ( Origin(..) ) import GHC.Tc.Utils.TcType import GHC.HsToCore.Monad import GHC.HsToCore.Utils +import GHC.Core ( CoreExpr ) import GHC.Core.Make ( mkCoreLets ) import Util import GHC.Types.Id @@ -94,7 +95,7 @@ have-we-used-all-the-constructors? question; the local function matchConFamily :: NonEmpty Id -> Type -> NonEmpty (NonEmpty EquationInfo) - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) -- Each group of eqns is for a single constructor matchConFamily (var :| vars) ty groups = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups @@ -107,7 +108,7 @@ matchConFamily (var :| vars) ty groups matchPatSyn :: NonEmpty Id -> Type -> NonEmpty EquationInfo - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) matchPatSyn (var :| vars) ty eqns = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns return (mkCoSynCaseMatchResult var ty alt) @@ -134,7 +135,7 @@ matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor -- and returns the types of the *value* args, which is what we want match_group :: [Id] - -> [(ConArgPats, EquationInfo)] -> DsM MatchResult + -> [(ConArgPats, EquationInfo)] -> DsM (MatchResult CoreExpr) -- All members of the group have compatible ConArgPats match_group arg_vars arg_eqn_prs = ASSERT( notNull arg_eqn_prs ) diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index acb5be40f4..93b042e033 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -407,7 +407,7 @@ tidyNPat over_lit mb_neg eq outer_ty matchLiterals :: NonEmpty Id -> Type -- ^ Type of the whole case expression -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits - -> DsM MatchResult + -> DsM (MatchResult CoreExpr) matchLiterals (var :| vars) ty sub_groups = do { -- Deal with each group @@ -424,7 +424,7 @@ matchLiterals (var :| vars) ty sub_groups return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts) } where - match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult) + match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr) match_group eqns@(firstEqn :| _) = do { dflags <- getDynFlags ; let platform = targetPlatform dflags @@ -432,7 +432,7 @@ matchLiterals (var :| vars) ty sub_groups ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns) ; return (hsLitKey platform hs_lit, match_result) } - wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult + wrap_str_guard :: Id -> (Literal,MatchResult CoreExpr) -> DsM (MatchResult CoreExpr) -- Equality check for string literals wrap_str_guard eq_str (LitString s, mr) = do { -- We now have to convert back to FastString. Perhaps there @@ -473,7 +473,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l) ************************************************************************ -} -matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 ; lit_expr <- dsOverLit lit @@ -502,7 +502,7 @@ We generate: \end{verbatim} -} -matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult +matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var :| vars) ty (eqn1 :| eqns) = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 25d1fcfeb4..f570330480 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -46,7 +46,7 @@ module GHC.HsToCore.Monad ( -- Data types DsMatchContext(..), - EquationInfo(..), MatchResult'(..), MatchResult, runMatchResult, DsWrapper, idDsWrapper, + EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, -- Levity polymorphism dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs, @@ -122,7 +122,7 @@ data EquationInfo -- @W# -1## :: Word@, but we shouldn't warn about an overflowed -- literal for /both/ of these cases. - , eqn_rhs :: MatchResult + , eqn_rhs :: MatchResult CoreExpr -- ^ What to do after match } @@ -133,14 +133,14 @@ type DsWrapper = CoreExpr -> CoreExpr idDsWrapper :: DsWrapper idDsWrapper e = e --- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult +-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult CoreExpr -- \fail. wrap (case vs of { pats -> rhs fail }) -- where vs are not bound by wrap -- | This is a value of type a with potentially a CoreExpr-shaped hole in it. -- 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 +data MatchResult a -- | We represent the case where there is no hole without a function from -- 'CoreExpr', like this, because sometimes we have nothing to put in the -- hole and so want to be sure there is in fact no hole. @@ -154,17 +154,14 @@ data MatchResult' a -- This is useful for combining a bunch of alternatives together and then -- getting the overall falliblity of the entire group. See 'mkDataConCase' for -- an example. -instance Applicative MatchResult' where +instance Applicative MatchResult where pure v = MR_Infallible (pure v) MR_Infallible f <*> MR_Infallible x = MR_Infallible (f <*> x) f <*> x = MR_Fallible $ \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 +-- Given a fail expression to use, and a MatchResult CoreExpr, compute the filled CoreExpr whether +-- the MatchResult CoreExpr was failable or not. +runMatchResult :: CoreExpr -> MatchResult a -> DsM a runMatchResult fail = \case MR_Infallible body -> body MR_Fallible body_fn -> body_fn fail diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index ade8f754a8..d208fb73da 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -19,7 +19,7 @@ module GHC.HsToCore.Utils ( EquationInfo(..), firstPat, shiftEqns, - MatchResult'(..), MatchResult, CaseAlt(..), + MatchResult (..), CaseAlt(..), cantFailMatchResult, alwaysFailMatchResult, extractMatchResult, combineMatchResults, adjustMatchResultDs, @@ -195,25 +195,25 @@ shiftEqns :: Functor f => f EquationInfo -> f EquationInfo -- Drop the first pattern in each equation shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) } --- Functions on MatchResults +-- Functions on MatchResult CoreExprs -matchCanFail :: MatchResult' a -> Bool +matchCanFail :: MatchResult a -> Bool matchCanFail (MR_Fallible {}) = True matchCanFail (MR_Infallible {}) = False -alwaysFailMatchResult :: MatchResult +alwaysFailMatchResult :: MatchResult CoreExpr alwaysFailMatchResult = MR_Fallible $ \fail -> return fail -cantFailMatchResult :: CoreExpr -> MatchResult +cantFailMatchResult :: CoreExpr -> MatchResult CoreExpr cantFailMatchResult expr = MR_Infallible $ return expr -extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr +extractMatchResult :: MatchResult CoreExpr -> CoreExpr -> DsM CoreExpr extractMatchResult match_result failure_expr = runMatchResult failure_expr (shareFailureHandler match_result) -combineMatchResults :: MatchResult -> MatchResult -> MatchResult +combineMatchResults :: MatchResult CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr combineMatchResults match_result1@(MR_Infallible _) _ = match_result1 combineMatchResults match_result1 match_result2 = @@ -225,7 +225,7 @@ combineMatchResults match_result1 match_result2 = -- Before actually failing, try the next match arm. body_fn1 =<< runMatchResult fail_expr match_result2 -adjustMatchResultDs :: (a -> DsM b) -> MatchResult' a -> MatchResult' b +adjustMatchResultDs :: (a -> DsM b) -> MatchResult a -> MatchResult b adjustMatchResultDs encl_fn = \case MR_Infallible body_fn -> MR_Infallible $ encl_fn =<< body_fn @@ -244,27 +244,27 @@ wrapBind new old body -- NB: this function must deal with term seqVar :: Var -> CoreExpr -> CoreExpr seqVar var body = mkDefaultCase (Var var) var body -mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult +mkCoLetMatchResult :: CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr mkCoLetMatchResult bind = fmap (mkCoreLet bind) -- (mkViewMatchResult var' viewExpr mr) makes the expression -- let var' = viewExpr in mr -mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult +mkViewMatchResult :: Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr mkViewMatchResult var' viewExpr = fmap $ mkCoreLet $ NonRec var' viewExpr -mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult +mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr mkEvalMatchResult var ty = fmap $ \e -> Case (Var var) var ty [(DEFAULT, [], e)] -mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult +mkGuardedMatchResult :: CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr mkGuardedMatchResult pred_expr mr = MR_Fallible $ \fail -> do body <- runMatchResult fail mr return (mkIfThenElse pred_expr body fail) mkCoPrimCaseMatchResult :: Id -- Scrutinee -> Type -- Type of the case - -> [(Literal, MatchResult)] -- Alternatives - -> MatchResult -- Literals are all unlifted + -> [(Literal, MatchResult CoreExpr)] -- Alternatives + -> MatchResult CoreExpr -- Literals are all unlifted mkCoPrimCaseMatchResult var ty match_alts = MR_Fallible mk_case where @@ -281,13 +281,13 @@ mkCoPrimCaseMatchResult var ty match_alts data CaseAlt a = MkCaseAlt{ alt_pat :: a, alt_bndrs :: [Var], alt_wrapper :: HsWrapper, - alt_result :: MatchResult } + alt_result :: MatchResult CoreExpr } mkCoAlgCaseMatchResult :: Id -- ^ Scrutinee -> Type -- ^ Type of exp -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts) - -> MatchResult + -> MatchResult CoreExpr mkCoAlgCaseMatchResult var ty match_alts | isNewtype -- Newtype case; use a let = ASSERT( null match_alts_tail && null (tail arg_ids1) ) @@ -310,7 +310,7 @@ mkCoAlgCaseMatchResult var ty match_alts -- (not that splitTyConApp does, these days) newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) -mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult +mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult CoreExpr mkCoSynCaseMatchResult var ty alt = MR_Fallible $ mkPatSynCase var ty alt mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr @@ -331,7 +331,7 @@ mkPatSynCase var ty alt fail = do ensure_unstrict cont | needs_void_lam = Lam voidArgId cont | otherwise = cont -mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult +mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult CoreExpr mkDataConCase var ty alts@(alt1 :| _) = liftA2 mk_case mk_default mk_alts -- The liftA2 combines the failability of all the alternatives and the default @@ -351,10 +351,10 @@ mkDataConCase var ty alts@(alt1 :| _) mk_case def alts = mkWildCase (Var var) (idType var) ty $ maybeToList def ++ alts - mk_alts :: MatchResult' [CoreAlt] + mk_alts :: MatchResult [CoreAlt] mk_alts = traverse mk_alt sorted_alts - mk_alt :: CaseAlt DataCon -> MatchResult' CoreAlt + mk_alt :: CaseAlt DataCon -> MatchResult CoreAlt mk_alt MkCaseAlt { alt_pat = con , alt_bndrs = args , alt_result = match_result } = @@ -366,7 +366,7 @@ mkDataConCase var ty alts@(alt1 :| _) let (rep_ids, binds) = initUs_ us (boxer ty_args args) return (DataAlt con, rep_ids, mkLets binds body) - mk_default :: MatchResult' (Maybe CoreAlt) + mk_default :: MatchResult (Maybe CoreAlt) mk_default | exhaustive_case = MR_Infallible $ return Nothing | otherwise = MR_Fallible $ \fail -> return $ Just (DEFAULT, [], fail) @@ -853,7 +853,7 @@ mkFailurePair expr -- Uses '@mkFailurePair@' to bind the failure case. Infallible matches have -- neither a failure arg or failure "hole", so nothing is let-bound, and no -- extraneous Core is produced. -shareFailureHandler :: MatchResult -> MatchResult +shareFailureHandler :: MatchResult CoreExpr -> MatchResult CoreExpr shareFailureHandler = \case mr@(MR_Infallible _) -> mr MR_Fallible match_fn -> MR_Fallible $ \fail_expr -> do |