[Git][ghc/ghc][wip/or-pats] Add group PgOr for matching
David (@knothed)
gitlab at gitlab.haskell.org
Wed Nov 30 10:25:06 UTC 2022
David pushed to branch wip/or-pats at Glasgow Haskell Compiler / GHC
Commits:
11db9682 by David Knothe at 2022-11-30T10:55:06+01:00
Add group PgOr for matching
- - - - -
6 changed files:
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Parser.y
- compiler/GHC/Utils/Outputable.hs
- utils/check-exact/Lookup.hs
Changes:
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -353,7 +353,7 @@ pprPat (SplicePat ext splice) =
GhcTc -> dataConCantHappen ext
pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (ListPat _ pats) = brackets (interpp'SP pats)
-pprPat (OrPat _ pats) = pprWithDSemis ppr (toList pats)
+pprPat (OrPat _ pats) = text "one of" <+> pprWithCommas ppr (toList pats)
pprPat (TuplePat _ pats bx)
-- Special-case unary boxed tuples so that they are pretty-printed as
-- `Solo x`, not `(x)`
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -7,6 +7,8 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use camelCase" #-}
{-
(c) The University of Glasgow 2006
@@ -201,7 +203,7 @@ match (v:vs) ty eqns -- Eqns *can* be empty
; let platform = targetPlatform dflags
-- Tidy the first pattern, generating
-- auxiliary bindings if necessary
- ; (aux_binds, tidy_eqns) <- biconcat <$> mapAndUnzipM (tidyEqnInfo v) eqns
+ ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
-- Group the equations and match each group in turn
; let grouped = groupEquations platform tidy_eqns
@@ -213,7 +215,6 @@ match (v:vs) ty eqns -- Eqns *can* be empty
foldr1 combineMatchResults match_results
}
where
- biconcat (a, b) = (concat a, concat b)
vars = v :| vs
dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
@@ -225,7 +226,7 @@ match (v:vs) ty eqns -- Eqns *can* be empty
match_groups (g:gs) = mapM match_group $ g :| gs
match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr)
- match_group eqns@((group,_) :| _)
+ match_group eqns@((group,eq) :| _)
= case group of
PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
PgSyn {} -> matchPatSyn vars ty (dropGroup eqns)
@@ -237,6 +238,7 @@ match (v:vs) ty eqns -- Eqns *can* be empty
PgBang -> matchBangs vars ty (dropGroup eqns)
PgCo {} -> matchCoercion vars ty (dropGroup eqns)
PgView {} -> matchView vars ty (dropGroup eqns)
+ PgOr -> matchOr vars ty eq -- every or-pattern makes up a single PgOr group
where eqns' = NEL.toList eqns
ne l = case NEL.nonEmpty l of
Just nel -> nel
@@ -305,6 +307,18 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
(mkCoreAppDs (text "matchView") viewExpr' (Var var))
match_result) }
+matchOr :: NonEmpty MatchId -> Type -> EquationInfo -> DsM (MatchResult CoreExpr)
+matchOr (var :| vars) ty eqn = do {
+ let OrPat _ pats = firstPat eqn
+ -- what to do *after* the OrPat matches
+ ; match_result <- match vars ty [eqn { eqn_pats = tail (eqn_pats eqn) }]
+ -- share match_result across the different cases of the OrPat match
+ ; shareSuccessHandler match_result ty (\expr -> do {
+ let or_eqns = map (singleEqn expr) (NEL.toList pats) in match [var] ty or_eqns
+ })
+ } where
+ singleEqn expr (L _ pat) = EqnInfo { eqn_pats = [pat], eqn_orig = FromSource, eqn_rhs = pure expr }
+
-- decompose the first pattern and leave the rest alone
decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
@@ -393,7 +407,7 @@ only these which can be assigned a PatternGroup (see patGroup).
-}
tidyEqnInfo :: Id -> EquationInfo
- -> DsM ([DsWrapper], [EquationInfo])
+ -> DsM (DsWrapper, EquationInfo)
-- DsM'd because of internal call to dsLHsBinds
-- and mkSelectorBinds.
-- "tidy1" does the interesting stuff, looking at
@@ -406,14 +420,14 @@ tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
= panic "tidyEqnInfo"
tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
- = do { (wraps, pats') <- tidy1 v orig pat
- ; return $ (wraps, map (\p -> eqn { eqn_pats = p : pats }) pats') }
+ = do { (wrap, pat') <- tidy1 v orig pat
+ ; return $ (wrap, eqn { eqn_pats = pat' : pats }) }
tidy1 :: Id -- The Id being scrutinised
-> Origin -- Was this a pattern the user wrote?
-> Pat GhcTc -- The pattern against which it is to be matched
- -> DsM ([DsWrapper], -- Extra bindings to do before the match
- [Pat GhcTc]) -- Equivalent pattern(s)
+ -> DsM (DsWrapper, -- Extra bindings to do before the match
+ Pat GhcTc) -- Equivalent pattern(s)
-------------------------------------------------------
-- (pat', mr') = tidy1 v pat mr
@@ -423,23 +437,24 @@ tidy1 :: Id -- The Id being scrutinised
tidy1 v o (ParPat _ _ pat _) = tidy1 v o (unLoc pat)
tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat)
-tidy1 _ _ (WildPat ty) = return ([idDsWrapper], [WildPat ty])
+tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty)
tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
-tidy1 v o (OrPat _ pats) = do { r <- mapM (tidy1 v o . unLoc) (NEL.toList pats); return $ concatUnzip r } where
- concatUnzip :: [([a], [b])] -> ([a], [b])
- concatUnzip xs = let (as,bs) = unzip xs in (concat as, concat bs)
+tidy1 v o (OrPat x pats) = do
+ (wraps, pats) <- mapAndUnzipM (tidy1 v o . unLoc) (NEL.toList pats)
+ let wrap = foldr (.) id wraps in
+ return $ (wrap, OrPat x (NEL.fromList $ map (L noSrcSpanA) pats))
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
tidy1 v _ (VarPat _ (L _ var))
- = return ([wrapBind var v], [WildPat (idType var)])
+ = return (wrapBind var v, WildPat (idType 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)
- ; return (map (wrapBind var v .) wrap, pat') }
+ ; return (wrapBind var v . wrap, pat') }
{- now, here we handle lazy patterns:
tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
@@ -464,17 +479,17 @@ tidy1 v _ (LazyPat _ pat)
; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
- ; return ([mkCoreLets sel_binds], [WildPat (idType v)]) }
+ ; return (mkCoreLets sel_binds, WildPat (idType v)) }
tidy1 _ _ (ListPat ty pats)
- = return ([idDsWrapper], [unLoc list_ConPat])
+ = return (idDsWrapper, unLoc list_ConPat)
where
list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
(mkNilPat ty)
pats
tidy1 _ _ (TuplePat tys pats boxity)
- = return ([idDsWrapper], [unLoc tuple_ConPat])
+ = return (idDsWrapper, unLoc tuple_ConPat)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys'
@@ -484,7 +499,7 @@ tidy1 _ _ (TuplePat tys pats boxity)
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
tidy1 _ _ (SumPat tys pat alt arity)
- = return ([idDsWrapper], [unLoc sum_ConPat])
+ = return (idDsWrapper, unLoc sum_ConPat)
where
sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys)
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
@@ -493,7 +508,7 @@ tidy1 _ _ (SumPat tys pat alt arity)
tidy1 _ o (LitPat _ lit)
= do { unless (isGenerated o) $
warnAboutOverflowedLit lit
- ; return ([idDsWrapper], [tidyLitPat 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)
@@ -501,22 +516,22 @@ tidy1 _ o (NPat ty (L _ lit at OverLit { ol_val = v }) mb_neg eq)
let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
| otherwise = lit
in warnAboutOverflowedOverLit lit'
- ; return ([idDsWrapper], [tidyNPat lit mb_neg eq ty]) }
+ ; 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
warnAboutOverflowedOverLit lit1
warnAboutOverflowedOverLit lit2
- ; return ([idDsWrapper], [n]) }
+ ; return (idDsWrapper, n) }
-- Everything else goes through unchanged...
tidy1 _ _ non_interesting_pat
- = return ([idDsWrapper], [non_interesting_pat])
+ = return (idDsWrapper, non_interesting_pat)
--------------------
tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc
- -> DsM ([DsWrapper], [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
@@ -565,7 +580,7 @@ tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
--
-- NB: SigPatIn, ConPatIn should not happen
-tidy_bang_pat _ _ l p = return ([idDsWrapper], [BangPat noExtField (L l p)])
+tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p))
-------------------
push_bang_into_newtype_arg :: SrcSpanAnnA
@@ -929,6 +944,7 @@ data PatGroup
| PgView (LHsExpr GhcTc) -- view pattern (e -> p):
-- the LHsExpr is the expression e
Type -- the Type is the type of p (equivalently, the result type of e)
+ | PgOr -- Or pattern
{- Note [Don't use Literal for PgN]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1199,6 +1215,7 @@ patGroup platform (LitPat _ lit) = PgLit (hsLitKey platform lit)
patGroup platform (XPat ext) = case ext of
CoPat _ p _ -> PgCo (hsPatType p) -- Type of innelexp pattern
ExpansionPat _ p -> patGroup platform p
+patGroup _ (OrPat _ (p :| _)) = PgOr
patGroup _ pat = pprPanic "patGroup" (ppr pat)
{-
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.HsToCore.Utils (
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
adjustMatchResultDs,
- shareFailureHandler,
+ shareFailureHandler, shareSuccessHandler,
dsHandleMonadicFailure,
mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
matchCanFail, mkEvalMatchResult,
@@ -907,31 +907,46 @@ carefully), but we certainly don't support it now.
anyway, and the Void# doesn't do much harm.
-}
-mkFailurePair :: CoreExpr -- Result type of the whole case expression
- -> DsM (CoreBind, -- Binds the newly-created fail variable
- -- to \ _ -> expression
- CoreExpr) -- Fail variable applied to realWorld#
+mkSharedPair :: FastString -- Name of the newly created variable
+ -> Type -- Type of the expression to share
+ -> DsM (CoreExpr -> (CoreExpr -> CoreExpr),
+ -- Given the expression to share, returns a float that
+ -- wraps a NonRec let around the expression for the shared
+ -- binding
+ CoreExpr)
+ -- Fail variable applied to (# #)
+mkSharedPair fun_name ty
+ = do { fun_var <- mkSysLocalM fun_name Many (unboxedUnitTy `mkVisFunTyMany` ty)
+ ; fun_arg <- newSysLocalDs Many unboxedUnitTy
+ ; let real_arg = setOneShotLambda fun_arg
+ ; return (Let . NonRec fun_var . Lam real_arg,
+ App (Var fun_var) unboxedUnitExpr) }
+
+mkFailurePair :: Type -> DsM (CoreExpr -> (CoreExpr -> CoreExpr), CoreExpr)
-- See Note [Failure thunks and CPR]
-mkFailurePair expr
- = do { fail_fun_var <- newFailLocalDs Many (unboxedUnitTy `mkVisFunTyMany` ty)
- ; fail_fun_arg <- newSysLocalDs Many unboxedUnitTy
- ; let real_arg = setOneShotLambda fail_fun_arg
- ; return (NonRec fail_fun_var (Lam real_arg expr),
- App (Var fail_fun_var) unboxedUnitExpr) }
- where
- ty = exprType expr
+mkFailurePair = mkSharedPair (fsLit "fail")
+
+mkSuccessPair :: Type -> DsM (CoreExpr -> (CoreExpr -> CoreExpr), CoreExpr)
+mkSuccessPair = mkSharedPair (fsLit "success")
--- Uses '@mkFailurePair@' to bind the failure case. Infallible matches have
--- neither a failure arg or failure "hole", so nothing is let-bound, and no
+-- Uses '@mkSharedPair@' to bind the failure case. Infallible matches have
+-- neither a failure arg nor failure "hole", so nothing is let-bound, and no
-- extraneous Core is produced.
shareFailureHandler :: MatchResult CoreExpr -> MatchResult CoreExpr
shareFailureHandler = \case
mr@(MR_Infallible _) -> mr
MR_Fallible match_fn -> MR_Fallible $ \fail_expr -> do
- (fail_bind, shared_failure_handler) <- mkFailurePair fail_expr
- body <- match_fn shared_failure_handler
+ (mk_fail_bind, shared_failure_handler) <- mkFailurePair (exprType fail_expr)
-- Never unboxed, per the above, so always OK for `let` not `case`.
- return $ Let fail_bind body
+ mk_fail_bind fail_expr <$> match_fn shared_failure_handler
+
+-- Uses '@mkSharedPair@' to bind the success case
+shareSuccessHandler :: MatchResult CoreExpr -> Type -> (CoreExpr -> DsM (MatchResult CoreExpr)) -> DsM (MatchResult CoreExpr)
+shareSuccessHandler success_result ty match_body = do
+ (mk_success_bind, shared_success_handler) <- mkSuccessPair ty
+ -- Never unboxed, per the above, so always OK for `let` not `case`.
+ body_result <- match_body shared_success_handler
+ pure (mk_success_bind <$> success_result <*> body_result)
{-
Note [Failure thunks and CPR]
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3060,7 +3060,7 @@ texp :: { ECP }
$1 >>= \ $1 ->
pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 }
- | 'one' 'of' vocurly orpats close { ecpFromPat (L noSrcSpanA (mkorpat $4)) }
+ | 'one' 'of' vocurly orpats close { ecpFromPat (sLLa ($1) (reLoc (last $4)) (mkorpat $4)) }
-- View patterns get parenthesized above
| exp '->' texp { ECP $
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -26,14 +26,14 @@ module GHC.Utils.Outputable (
docToSDoc,
interppSP, interpp'SP, interpp'SP',
pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,
- pprWithBars, pprWithDSemis,
+ pprWithBars,
empty, isEmpty, nest,
char,
text, ftext, ptext, ztext,
int, intWithCommas, integer, word, float, double, rational, doublePrec,
parens, cparen, brackets, braces, quotes, quote,
doubleQuotes, angleBrackets,
- semi, dsemi, comma, colon, dcolon, space, equals, dot, vbar,
+ semi, comma, colon, dcolon, space, equals, dot, vbar,
arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,
lambda,
lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
@@ -707,7 +707,7 @@ quotes d = sdocOption sdocCanUseUnicode $ \case
_ | Just '\'' <- lastMaybe str -> pp_d
| otherwise -> Pretty.quotes pp_d
-semi, dsemi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
+semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc
lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
@@ -723,7 +723,6 @@ arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-")
larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<")
lambda = unicodeSyntax (char 'λ') (char '\\')
semi = docToSDoc $ Pretty.semi
-dsemi = docToSDoc $ Pretty.text ";;"
comma = docToSDoc $ Pretty.comma
colon = docToSDoc $ Pretty.colon
equals = docToSDoc $ Pretty.equals
@@ -1329,12 +1328,6 @@ pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use
-- bar-separated and finally packed into a paragraph.
pprWithBars pp xs = fsep (intersperse vbar (map pp xs))
-pprWithDSemis :: (a -> SDoc) -- ^ The pretty printing function to use
- -> [a] -- ^ The things to be pretty printed
- -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
- -- bar-separated and finally packed into a paragraph.
-pprWithDSemis pp xs = fsep (intersperse dsemi (map pp xs))
-
-- | Returns the separated concatenation of the pretty printed things.
interppSP :: Outputable a => [a] -> SDoc
interppSP xs = sep (map ppr xs)
=====================================
utils/check-exact/Lookup.hs
=====================================
@@ -55,7 +55,6 @@ keywordToString kw =
AnnDo -> "do"
AnnDot -> "."
AnnDotdot -> ".."
- AnnDsemi -> ";;"
AnnElse -> "else"
AnnEqual -> "="
AnnExport -> "export"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/11db9682ea9c6feb0907d3dce41be2284acf0946
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/11db9682ea9c6feb0907d3dce41be2284acf0946
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/20221130/8c21d3ba/attachment-0001.html>
More information about the ghc-commits
mailing list