summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohn Ericson <git@JohnEricson.me>2020-04-18 17:30:10 -0400
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-04-22 23:10:28 -0400
commitcde23cd47170cc33845b6859a47dd06ee85094d8 (patch)
treec8ecf86787942e27be27b27ff58c62835b286693
parentdcb7fe5aa2bc331fa71b537b042ec08a7c79b1ac (diff)
downloadhaskell-cde23cd47170cc33845b6859a47dd06ee85094d8.tar.gz
Inline `adjustMatchResult`
It is just `fmap`
-rw-r--r--compiler/GHC/HsToCore/GuardedRHSs.hs2
-rw-r--r--compiler/GHC/HsToCore/Match.hs8
-rw-r--r--compiler/GHC/HsToCore/Match/Constructor.hs3
-rw-r--r--compiler/GHC/HsToCore/Match/Literal.hs2
-rw-r--r--compiler/GHC/HsToCore/Utils.hs14
5 files changed, 14 insertions, 15 deletions
diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
index 24db0f0649..07f94906cd 100644
--- a/compiler/GHC/HsToCore/GuardedRHSs.hs
+++ b/compiler/GHC/HsToCore/GuardedRHSs.hs
@@ -130,7 +130,7 @@ matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do
core_rhs <- dsLExpr bind_rhs
match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
match_result
- pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
+ pure $ bindNonRec match_var core_rhs <$> match_result'
matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"
matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index dbdd24cbac..875542d4f8 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -198,8 +198,9 @@ match (v:vs) ty eqns -- Eqns *can* be empty
; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
; match_results <- match_groups grouped
- ; return (adjustMatchResult (foldr (.) id aux_binds) $
- foldr1 combineMatchResults match_results) }
+ ; return $ foldr (.) id aux_binds <$>
+ foldr1 combineMatchResults match_results
+ }
where
vars = v :| vs
@@ -844,7 +845,8 @@ matchSinglePat (Var var) ctx pat ty match_result
matchSinglePat scrut hs_ctx pat ty match_result
= do { var <- selectSimpleMatchVarL pat
; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result
- ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
+ ; return $ bindNonRec var scrut <$> match_result'
+ }
matchSinglePatVar :: Id -- See Note [Match Ids]
-> HsMatchContext GhcRn -> LPat GhcTc
diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs
index 779d893eaf..b3c639ca86 100644
--- a/compiler/GHC/HsToCore/Match/Constructor.hs
+++ b/compiler/GHC/HsToCore/Match/Constructor.hs
@@ -141,7 +141,8 @@ matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor
do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
; match_result <- match (group_arg_vars ++ vars) ty eqns'
- ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
+ ; return $ foldr1 (.) wraps <$> match_result
+ }
shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
pat_binds = bind, pat_args = args
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
index d835e62e42..acb5be40f4 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -515,7 +515,7 @@ matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
; match_result <- match vars ty eqns'
; return (mkGuardedMatchResult pred_expr $
mkCoLetMatchResult (NonRec n1 minusk_expr) $
- adjustMatchResult (foldr1 (.) wraps) $
+ fmap (foldr1 (.) wraps) $
match_result) }
where
shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 5982a07dde..308f0a14f5 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -22,7 +22,7 @@ module GHC.HsToCore.Utils (
MatchResult'(..), MatchResult, CaseAlt(..),
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
- adjustMatchResult, adjustMatchResultDs,
+ adjustMatchResultDs,
shareFailureHandler,
mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
matchCanFail, mkEvalMatchResult,
@@ -225,9 +225,6 @@ combineMatchResults match_result1 match_result2 =
-- Before actually failing, try the next match arm.
body_fn1 =<< runMatchResult fail_expr match_result2
-adjustMatchResult :: (a -> b) -> MatchResult' a -> MatchResult' b
-adjustMatchResult = fmap
-
adjustMatchResultDs :: (a -> DsM b) -> MatchResult' a -> MatchResult' b
adjustMatchResultDs encl_fn = \case
MR_Infallible body_fn -> MR_Infallible $
@@ -248,17 +245,16 @@ seqVar :: Var -> CoreExpr -> CoreExpr
seqVar var body = mkDefaultCase (Var var) var body
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
-mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
+mkCoLetMatchResult bind = fmap (mkCoreLet bind)
-- (mkViewMatchResult var' viewExpr mr) makes the expression
-- let var' = viewExpr in mr
mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
-mkViewMatchResult var' viewExpr =
- adjustMatchResult (mkCoreLet (NonRec var' viewExpr))
+mkViewMatchResult var' viewExpr = fmap $ mkCoreLet $ NonRec var' viewExpr
mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
-mkEvalMatchResult var ty
- = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
+mkEvalMatchResult var ty = fmap $ \e ->
+ Case (Var var) var ty [(DEFAULT, [], e)]
mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
mkGuardedMatchResult pred_expr mr = MR_Fallible $ \fail -> do