[Git][ghc/ghc][wip/match-datatype] Update Match Datatype
David (@knothed)
gitlab at gitlab.haskell.org
Wed Jul 5 18:00:38 UTC 2023
David pushed to branch wip/match-datatype at Glasgow Haskell Compiler / GHC
Commits:
44733ad1 by David Knothe at 2023-07-05T20:00:23+02:00
Update Match Datatype
EquationInfo currently contains a list of the equation's patterns together with a CoreExpr that is to be evaluated after a successful match on this equation.
All the match-functions only operate on the first pattern of an equation - after successfully matching it, match is called recursively on the tail of the pattern list.
We can express this more clearly and make the code a little more elegant by updating the datatype of EquationInfo as follows:
data EquationInfo
= EqnMatch { eqn_pat = Pat GhcTc, eqn_rest = EquationInfo }
| EqnDone { eqn_rhs = MatchResult CoreExpr }
An EquationInfo now explicitly exposes its first pattern which most functions operate on, and exposes the equation that remains after processing the first pattern. An EqnDone signifies an empty equation where the CoreExpr can now be evaluated.
- - - - -
6 changed files:
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Utils.hs
Changes:
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -203,11 +203,8 @@ dsUnliftedBind (PatBind { pat_lhs = pat, pat_rhs = grhss
-- ==> case rhs of C x# y# -> body
do { match_nablas <- pmcGRHSs PatBindGuards grhss
; rhs <- dsGuarded grhss ty match_nablas
- ; let upat = unLoc pat
- eqn = EqnInfo { eqn_pats = [upat],
- eqn_orig = FromSource,
- eqn_rhs = cantFailMatchResult body }
- ; var <- selectMatchVar ManyTy upat
+ ; let eqn = EqnMatch { eqn_pat = pat, eqn_rest = EqnDone (cantFailMatchResult body) }
+ ; var <- selectMatchVar ManyTy (unLoc pat)
-- `var` will end up in a let binder, so the multiplicity
-- doesn't matter.
; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -27,7 +27,6 @@ import GHC.Platform
import Language.Haskell.Syntax.Basic (Boxity(..))
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
-
import GHC.Types.Basic ( Origin(..), isGenerated )
import GHC.Types.SourceText
import GHC.Driver.DynFlags
@@ -192,11 +191,7 @@ match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with
match [] ty eqns
= assertPpr (not (null eqns)) (ppr ty) $
- return (foldr1 combineMatchResults match_results)
- where
- match_results = [ assert (null (eqn_pats eqn)) $
- eqn_rhs eqn
- | eqn <- eqns ]
+ combineEqnRhss (NEL.fromList eqns)
match (v:vs) ty eqns -- Eqns *can* be empty
= assertPpr (all (isInternalName . idName) vars) (ppr vars) $
@@ -279,7 +274,7 @@ matchBangs (var :| vars) ty eqns
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 :| _))
+matchCoercion (var :| vars) ty eqns@(eqn1 :| _)
= do { let XPat (CoPat co pat _) = firstPat eqn1
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var (idMult var) pat_ty'
@@ -291,7 +286,7 @@ matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
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 :| _))
+matchView (var :| vars) ty eqns@(eqn1 :| _)
= do { -- we could pass in the expr from the PgView,
-- but this needs to extract the pat anyway
-- to figure out the type of the fresh variable
@@ -309,8 +304,7 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
-- decompose the first pattern and leave the rest alone
decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
-decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
- = eqn { eqn_pats = extractpat pat : pats}
+decomposeFirstPat extract eqn@(EqnMatch { eqn_pat = pat }) = eqn{eqn_pat = fmap extract pat}
decomposeFirstPat _ _ = panic "decomposeFirstPat"
getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
@@ -404,15 +398,14 @@ tidyEqnInfo :: Id -> EquationInfo
-- POST CONDITION: head pattern in the EqnInfo is
-- one of these for which patGroup is defined.
-tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
- = panic "tidyEqnInfo"
+tidyEqnInfo _ eqn@(EqnDone {}) = return (idDsWrapper, eqn)
-tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
- = do { (wrap, pat') <- tidy1 v orig pat
- ; return (wrap, eqn { eqn_pats = pat' : pats }) }
+tidyEqnInfo v eqn@(EqnMatch { eqn_pat = (L loc pat) }) = do
+ (wrap, pat') <- tidy1 v (isGeneratedSrcSpan (locA loc)) pat
+ return (wrap, eqn{eqn_pat = L loc pat' })
tidy1 :: Id -- The Id being scrutinised
- -> Origin -- Was this a pattern the user wrote?
+ -> Bool -- `True` if the pattern was generated, `False` if it was user-written
-> Pat GhcTc -- The pattern against which it is to be matched
-> DsM (DsWrapper, -- Extra bindings to do before the match
Pat GhcTc) -- Equivalent pattern
@@ -423,10 +416,10 @@ tidy1 :: Id -- The Id being scrutinised
-- It eliminates many pattern forms (as-patterns, variable patterns,
-- list patterns, etc) and returns any created bindings in the wrapper.
-tidy1 v o (ParPat _ _ pat _) = tidy1 v o (unLoc pat)
-tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat)
+tidy1 v g (ParPat _ _ pat _) = tidy1 v g (unLoc pat)
+tidy1 v g (SigPat _ pat _) = tidy1 v g (unLoc pat)
tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty)
-tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
+tidy1 v g (BangPat _ (L l p)) = tidy_bang_pat v g l p
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
@@ -435,8 +428,8 @@ tidy1 v _ (VarPat _ (L _ var))
-- case v of { x at p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
-tidy1 v o (AsPat _ (L _ var) _ pat)
- = do { (wrap, pat') <- tidy1 v o (unLoc pat)
+tidy1 v g (AsPat _ (L _ var) _ pat)
+ = do { (wrap, pat') <- tidy1 v g (unLoc pat)
; return (wrapBind var v . wrap, pat') }
{- now, here we handle lazy patterns:
@@ -488,22 +481,22 @@ tidy1 _ _ (SumPat tys pat alt arity)
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (LitPat _ lit)
- = do { unless (isGenerated o) $
+tidy1 _ g (LitPat _ lit)
+ = do { unless g $
warnAboutOverflowedLit lit
; return (idDsWrapper, tidyLitPat lit) }
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (NPat ty (L _ lit at OverLit { ol_val = v }) mb_neg eq)
- = do { unless (isGenerated o) $
+tidy1 _ g (NPat ty (L _ lit at OverLit { ol_val = v }) mb_neg eq)
+ = do { unless g $
let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
| otherwise = lit
in warnAboutOverflowedOverLit lit'
; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
-- NPlusKPat: we may want to warn about the literals
-tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
- = do { unless (isGenerated o) $ do
+tidy1 _ g n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
+ = do { unless g $ do
warnAboutOverflowedOverLit lit1
warnAboutOverflowedOverLit lit2
; return (idDsWrapper, n) }
@@ -513,28 +506,28 @@ tidy1 _ _ non_interesting_pat
= return (idDsWrapper, non_interesting_pat)
--------------------
-tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc
+tidy_bang_pat :: Id -> Bool -> SrcSpanAnnA -> Pat GhcTc
-> DsM (DsWrapper, Pat GhcTc)
-- Discard par/sig under a bang
-tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p
-tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p
+tidy_bang_pat v g _ (ParPat _ _ (L l p) _) = tidy_bang_pat v g l p
+tidy_bang_pat v g _ (SigPat _ (L l p) _) = tidy_bang_pat v g l p
-- Push the bang-pattern inwards, in the hope that
-- it may disappear next time
-tidy_bang_pat v o l (AsPat x v' at p)
- = tidy1 v o (AsPat x v' at (L l (BangPat noExtField p)))
-tidy_bang_pat v o l (XPat (CoPat w p t))
- = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t)
+tidy_bang_pat v g l (AsPat x v' at p)
+ = tidy1 v g (AsPat x v' at (L l (BangPat noExtField p)))
+tidy_bang_pat v g l (XPat (CoPat w p t))
+ = tidy1 v g (XPat $ CoPat w (BangPat noExtField (L l p)) t)
-- Discard bang around strict pattern
-tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p
-tidy_bang_pat v o _ p@(ListPat {}) = tidy1 v o p
-tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p
-tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p
+tidy_bang_pat v g _ p@(LitPat {}) = tidy1 v g p
+tidy_bang_pat v g _ p@(ListPat {}) = tidy1 v g p
+tidy_bang_pat v g _ p@(TuplePat {}) = tidy1 v g p
+tidy_bang_pat v g _ p@(SumPat {}) = tidy1 v g p
-- Data/newtype constructors
-tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
+tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc)
, pat_args = args
, pat_con_ext = ConPatTc
{ cpt_arg_tys = arg_tys
@@ -543,8 +536,8 @@ tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
-- Newtypes: push bang inwards (#9844)
=
if isNewTyCon (dataConTyCon dc)
- then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
- else tidy1 v o p -- Data types: discard the bang
+ then tidy1 v g (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
+ else tidy1 v g p -- Data types: discard the bang
where
(ty:_) = dataConInstArgTys dc arg_tys
@@ -807,16 +800,14 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo
mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)
= do { dflags <- getDynFlags
- ; let upats = map (unLoc . decideBangHood dflags) pats
+ ; let upats = map (decideBangHood dflags) pats
-- pat_nablas is the covered set *after* matching the pattern, but
-- before any of the GRHSs. We extend the environment with pat_nablas
-- (via updPmNablas) so that the where-clause of 'grhss' can profit
-- from that knowledge (#18533)
; match_result <- updPmNablas pat_nablas $
dsGRHSs ctxt grhss rhs_ty rhss_nablas
- ; return EqnInfo { eqn_pats = upats
- , eqn_orig = FromSource
- , eqn_rhs = match_result } }
+ ; return $ mkEqnInfo upats match_result }
discard_warnings_if_generated orig =
if isGenerated orig
@@ -953,9 +944,8 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result
addCoreScrutTmCs (maybeToList mb_scrut) [var] $
pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
- ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
- , eqn_orig = FromSource
- , eqn_rhs = match_result }
+ ; let eqn_info = EqnMatch { eqn_pat = decideBangHood dflags pat
+ , eqn_rest = EqnDone match_result }
; match [var] ty [eqn_info] }
@@ -984,6 +974,13 @@ data PatGroup
-- the LHsExpr is the expression e
Type -- the Type is the type of p (equivalently, the result type of e)
+instance Show PatGroup where
+ show PgAny = "PgAny"
+ show (PgCon _) = "PgCon"
+ show (PgLit _) = "PgLit"
+ show (PgView _ _) = "PgView"
+ show _ = "PgOther"
+
{- Note [Don't use Literal for PgN]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Previously we had, as PatGroup constructors
@@ -1148,8 +1145,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
-- the fixities have been straightened out by now, so it's safe
-- to ignore them?
- exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
- lexp l l' && lexp o o' && lexp ri ri'
+ exp (OpApp _ l g ri) (OpApp _ l' o' ri') =
+ lexp l l' && lexp g o' && lexp ri ri'
exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
lexp e1 e1' && lexp e2 e2'
@@ -1230,8 +1227,8 @@ patGroup :: Platform -> Pat GhcTc -> PatGroup
patGroup _ (ConPat { pat_con = L _ con
, pat_con_ext = ConPatTc { cpt_arg_tys = tys }
})
- | RealDataCon dcon <- con = PgCon dcon
- | PatSynCon psyn <- con = PgSyn psyn tys
+ | RealDataCon dcon <- con = PgCon dcon
+ | PatSynCon psyn <- con = PgSyn psyn tys
patGroup _ (WildPat {}) = PgAny
patGroup _ (BangPat {}) = PgBang
patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) =
=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -20,7 +20,6 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( match )
import GHC.Hs
import GHC.HsToCore.Binds
import GHC.Core.ConLike
-import GHC.Types.Basic ( Origin(..) )
import GHC.Tc.Utils.TcType
import GHC.Core.Multiplicity
import GHC.HsToCore.Monad
@@ -153,24 +152,21 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
; return $ foldr1 (.) wraps <$> match_result
}
- shift (_, eqn@(EqnInfo
- { eqn_pats = ConPat
- { pat_args = args
- , pat_con_ext = ConPatTc
- { cpt_tvs = tvs
- , cpt_dicts = ds
- , cpt_binds = bind
- }
- } : pats
- }))
+ shift (_, EqnMatch {
+ eqn_pat = L _ (ConPat
+ { pat_args = args
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = tvs
+ , cpt_dicts = ds
+ , cpt_binds = bind }})
+ , eqn_rest = rest })
= do dsTcEvBinds bind $ \ds_bind ->
return ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets ds_bind
- , eqn { eqn_orig = Generated
- , eqn_pats = conArgPats val_arg_tys args ++ pats }
+ , prependEqn (map (L (SrcSpanAnn EpAnnNotUsed generatedSrcSpan)) $ conArgPats val_arg_tys args) rest
)
- shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
+ shift (_, eqn) = pprPanic "matchOneCon/shift" (ppr eqn)
; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys
-- The 'val_arg_tys' are taken from the data type definition, they
-- do not take into account the context multiplicity, therefore we
@@ -208,6 +204,10 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
ex_tvs = conLikeExTyCoVars con1
+ prependEqn :: [LPat GhcTc] -> EquationInfo -> EquationInfo
+ prependEqn [] eqn = eqn
+ prependEqn (pat:pats) eqn = EqnMatch { eqn_pat = pat, eqn_rest = prependEqn pats eqn }
+
-- Choose the right arg_vars in the right order for this group
-- Note [Record patterns]
select_arg_vars :: [Id] -> NonEmpty (ConArgPats, EquationInfo) -> [Id]
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -625,10 +625,10 @@ matchLiterals (var :| vars) ty sub_groups
}
where
match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
- match_group eqns@(firstEqn :| _)
+ match_group eqns
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
- ; let LitPat _ hs_lit = firstPat firstEqn
+ ; let EqnMatch { eqn_pat = L _ (LitPat _ hs_lit) } = NEL.head eqns
; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
; return (hsLitKey platform hs_lit, match_result) }
@@ -726,7 +726,7 @@ matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
fmap (foldr1 (.) wraps) $
match_result) }
where
- shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
- = (wrapBind n n1, eqn { eqn_pats = pats })
+ shift n1 (EqnMatch { eqn_pat = L _ (NPlusKPat _ (L _ n) _ _ _ _), eqn_rest = rest })
+ = (wrapBind n n1, rest)
-- The wrapBind is a no-op for the first equation
shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -48,7 +48,8 @@ module GHC.HsToCore.Monad (
-- Data types
DsMatchContext(..),
- EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
+ EquationInfo(..), mkEqnInfo, eqnMatchResult,
+ MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
-- Trace injection
pprRuntimeTrace
@@ -91,7 +92,6 @@ import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
import GHC.Types.Name.Reader
-import GHC.Types.Basic ( Origin )
import GHC.Types.SourceFile
import GHC.Types.Id
import GHC.Types.Var (EvId)
@@ -131,27 +131,35 @@ instance Outputable DsMatchContext where
ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
data EquationInfo
- = EqnInfo { eqn_pats :: [Pat GhcTc]
- -- ^ The patterns for an equation
- --
- -- NB: We have /already/ applied 'decideBangHood' to
- -- these patterns. See Note [decideBangHood] in "GHC.HsToCore.Utils"
-
- , eqn_orig :: Origin
- -- ^ Was this equation present in the user source?
- --
- -- This helps us avoid warnings on patterns that GHC elaborated.
- --
- -- For instance, the pattern @-1 :: Word@ gets desugared into
- -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
- -- literal for /both/ of these cases.
-
- , eqn_rhs :: MatchResult CoreExpr
- -- ^ What to do after match
- }
+ = EqnMatch { eqn_pat :: LPat GhcTc
+ -- ^ The first pattern of the equation
+ --
+ -- NB: The location info is used to determine whether the
+ -- pattern is generated or not.
+ -- This helps us avoid warnings on patterns that GHC elaborated.
+ --
+ -- NB: We have /already/ applied 'decideBangHood' to this
+ -- pattern. See Note [decideBangHood] in "GHC.HsToCore.Utils"
+
+ , eqn_rest :: EquationInfo }
+ -- ^ The rest of the equation after its first pattern
+
+ -- The empty tail of an equation having no more patterns
+ | EqnDone (MatchResult CoreExpr)
+ -- ^ What to do after match
+
+mkEqnInfo :: [LPat GhcTc] -> MatchResult CoreExpr -> EquationInfo
+mkEqnInfo [] rhs = EqnDone rhs
+mkEqnInfo (pat:pats) rhs = EqnMatch { eqn_pat = pat, eqn_rest = mkEqnInfo pats rhs }
+
+eqnMatchResult :: EquationInfo -> MatchResult CoreExpr
+eqnMatchResult (EqnDone rhs) = rhs
+eqnMatchResult (EqnMatch { eqn_rest = eq }) = eqnMatchResult eq
instance Outputable EquationInfo where
- ppr (EqnInfo pats _ _) = ppr pats
+ ppr = ppr . allEqnPats where
+ allEqnPats (EqnDone {}) = []
+ allEqnPats (EqnMatch { eqn_pat = pat, eqn_rest = eq }) = unLoc pat : allEqnPats eq
type DsWrapper = CoreExpr -> CoreExpr
idDsWrapper :: DsWrapper
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -15,7 +15,7 @@ This module exports some utility functions of no great interest.
-- | Utility functions for constructing Core syntax, principally for desugaring
module GHC.HsToCore.Utils (
EquationInfo(..),
- firstPat, shiftEqns,
+ firstPat, maybeFirstPat, shiftEqns, combineEqnRhss,
MatchResult (..), CaseAlt(..),
cantFailMatchResult, alwaysFailMatchResult,
@@ -87,7 +87,7 @@ import GHC.Tc.Types.Evidence
import Control.Monad ( zipWithM )
import Data.List.NonEmpty (NonEmpty(..))
-import Data.Maybe (maybeToList)
+import Data.Maybe (maybeToList, fromMaybe)
import qualified Data.List.NonEmpty as NEL
{-
@@ -195,11 +195,18 @@ worthy of a type synonym and a few handy functions.
-}
firstPat :: EquationInfo -> Pat GhcTc
-firstPat eqn = assert (notNull (eqn_pats eqn)) $ head (eqn_pats eqn)
+firstPat = fromMaybe (error "firstPat: no patterns") . maybeFirstPat
+
+maybeFirstPat :: EquationInfo -> Maybe (Pat GhcTc)
+maybeFirstPat (EqnMatch { eqn_pat = pat }) = Just (unLoc pat)
+maybeFirstPat (EqnDone {}) = Nothing
shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
-- Drop the first pattern in each equation
-shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }
+shiftEqns = fmap eqn_rest
+
+combineEqnRhss :: NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+combineEqnRhss eqns = return $ foldr1 combineMatchResults $ map eqnMatchResult (NEL.toList eqns)
-- Functions on MatchResult CoreExprs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44733ad12fe2b0097dacda72a298d9f5289e59dc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44733ad12fe2b0097dacda72a298d9f5289e59dc
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/20230705/95824691/attachment-0001.html>
More information about the ghc-commits
mailing list