diff options
author | Jakob Bruenker <jakob.bruenker@gmail.com> | 2022-03-21 00:14:25 +0100 |
---|---|---|
committer | Jakob Bruenker <jakob.bruenker@gmail.com> | 2022-04-01 20:31:08 +0200 |
commit | 32070e6c2e1b4b7c32530a9566fe14543791f9a6 (patch) | |
tree | f0913ef2a69fd660542723ec07240167dbd37961 /compiler/GHC/Parser.y | |
parent | d85c7dcb7c457efc23b20ac8f4e4ae88bae5b050 (diff) | |
download | haskell-32070e6c2e1b4b7c32530a9566fe14543791f9a6.tar.gz |
Implement \cases (Proposal 302)
This commit implements proposal 302: \cases - Multi-way lambda
expressions.
This adds a new expression heralded by \cases, which works exactly like
\case, but can match multiple apats instead of a single pat.
Updates submodule haddock to support the ITlcases token.
Closes #20768
Diffstat (limited to 'compiler/GHC/Parser.y')
-rw-r--r-- | compiler/GHC/Parser.y | 104 |
1 files changed, 59 insertions, 45 deletions
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 55052f0df6..381af647ba 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -648,6 +648,7 @@ are the most common patterns, rewritten as regular expressions for clarity: '=' { L _ ITequal } '\\' { L _ ITlam } 'lcase' { L _ ITlcase } + 'lcases' { L _ ITlcases } '|' { L _ ITvbar } '<-' { L _ (ITlarrow _) } '->' { L _ (ITrarrow _) } @@ -2808,9 +2809,12 @@ aexp :: { ECP } | 'let' binds 'in' exp { ECP $ unECP $4 >>= \ $4 -> mkHsLetPV (comb2A $1 $>) (hsTok $1) (unLoc $2) (hsTok $3) $4 } - | '\\' 'lcase' altslist + | '\\' 'lcase' altslist(pats1) { ECP $ $3 >>= \ $3 -> - mkHsLamCasePV (comb2 $1 (reLoc $>)) $3 [mj AnnLam $1,mj AnnCase $2] } + mkHsLamCasePV (comb2 $1 (reLoc $>)) LamCase $3 [mj AnnLam $1,mj AnnCase $2] } + | '\\' 'lcases' altslist(apats) + { ECP $ $3 >>= \ $3 -> + mkHsLamCasePV (comb2 $1 (reLoc $>)) LamCases $3 [mj AnnLam $1,mj AnnCases $2] } | 'if' exp optSemi 'then' exp optSemi 'else' exp {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) -> return $ ECP $ @@ -2828,11 +2832,11 @@ aexp :: { ECP } fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsMultiIf (EpAnn (glR $1) (mj AnnIf $1:(fst $ unLoc $2)) cs) (reverse $ snd $ unLoc $2)) } - | 'case' exp 'of' altslist {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) -> - return $ ECP $ - $4 >>= \ $4 -> - mkHsCasePV (comb3 $1 $3 (reLoc $4)) $2 $4 - (EpAnnHsCase (glAA $1) (glAA $3) []) } + | 'case' exp 'of' altslist(pats1) {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) -> + return $ ECP $ + $4 >>= \ $4 -> + mkHsCasePV (comb3 $1 $3 (reLoc $4)) $2 $4 + (EpAnnHsCase (glAA $1) (glAA $3) []) } -- QualifiedDo. | DO stmtlist {% do hintQualifiedDo $1 @@ -3212,48 +3216,48 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } ----------------------------------------------------------------------------- -- Case alternatives -altslist :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) } - : '{' alts '}' { $2 >>= \ $2 -> amsrl - (sLL $1 $> (reverse (snd $ unLoc $2))) - (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) } - | vocurly alts close { $2 >>= \ $2 -> amsrl - (L (getLoc $2) (reverse (snd $ unLoc $2))) - (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) } - | '{' '}' { amsrl (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) } - | vocurly close { return $ noLocA [] } - -alts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) } - : alts1 { $1 >>= \ $1 -> return $ +altslist(PATS) :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) } + : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsrl + (sLL $1 $> (reverse (snd $ unLoc $2))) + (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) } + | vocurly alts(PATS) close { $2 >>= \ $2 -> amsrl + (L (getLoc $2) (reverse (snd $ unLoc $2))) + (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) } + | '{' '}' { amsrl (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) } + | vocurly close { return $ noLocA [] } + +alts(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) } + : alts1(PATS) { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { $2 >>= \ $2 -> return $ + | ';' alts(PATS) { $2 >>= \ $2 -> return $ sLL $1 $> (((mz AnnSemi $1) ++ (fst $ unLoc $2) ) ,snd $ unLoc $2) } -alts1 :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) } - : alts1 ';' alt { $1 >>= \ $1 -> - $3 >>= \ $3 -> - case snd $ unLoc $1 of - [] -> return (sLL $1 (reLoc $>) ((fst $ unLoc $1) ++ (mz AnnSemi $2) - ,[$3])) - (h:t) -> do - h' <- addTrailingSemiA h (gl $2) - return (sLL $1 (reLoc $>) (fst $ unLoc $1,$3 : h' : t)) } - | alts1 ';' { $1 >>= \ $1 -> - case snd $ unLoc $1 of - [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2) - ,[])) - (h:t) -> do - h' <- addTrailingSemiA h (gl $2) - return (sLL $1 $> (fst $ unLoc $1, h' : t)) } - | alt { $1 >>= \ $1 -> return $ sL1 (reLoc $1) ([],[$1]) } - -alt :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) } - : pat alt_rhs { $2 >>= \ $2 -> - acsA (\cs -> sLL (reLoc $1) $> - (Match { m_ext = (EpAnn (glAR $1) [] cs) - , m_ctxt = CaseAlt - , m_pats = [$1] - , m_grhss = unLoc $2 }))} +alts1(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) } + : alts1(PATS) ';' alt(PATS) { $1 >>= \ $1 -> + $3 >>= \ $3 -> + case snd $ unLoc $1 of + [] -> return (sLL $1 (reLoc $>) ((fst $ unLoc $1) ++ (mz AnnSemi $2) + ,[$3])) + (h:t) -> do + h' <- addTrailingSemiA h (gl $2) + return (sLL $1 (reLoc $>) (fst $ unLoc $1,$3 : h' : t)) } + | alts1(PATS) ';' { $1 >>= \ $1 -> + case snd $ unLoc $1 of + [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2) + ,[])) + (h:t) -> do + h' <- addTrailingSemiA h (gl $2) + return (sLL $1 $> (fst $ unLoc $1, h' : t)) } + | alt(PATS) { $1 >>= \ $1 -> return $ sL1 (reLoc $1) ([],[$1]) } + +alt(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) } + : PATS alt_rhs { $2 >>= \ $2 -> + acsA (\cs -> sLLAsl $1 $> + (Match { m_ext = EpAnn (listAsAnchor $1) [] cs + , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing + , m_pats = $1 + , m_grhss = unLoc $2 }))} alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) } : ralt wherebinds { $1 >>= \alt -> @@ -3293,6 +3297,11 @@ gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) } pat :: { LPat GhcPs } pat : exp {% (checkPattern <=< runPV) (unECP $1) } +-- 'pats1' does the same thing as 'pat', but returns it as a singleton +-- list so that it can be used with a parameterized production rule +pats1 :: { [LPat GhcPs] } +pats1 : pat { [ $1 ] } + bindpat :: { LPat GhcPs } bindpat : exp {% -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess checkPattern_details incompleteDoBlock @@ -4061,6 +4070,11 @@ sLLlA x y = sL (comb2A x y) -- #define LL sL (comb2 $1 $>) sLLAl :: LocatedAn t a -> Located b -> c -> Located c sLLAl x y = sL (comb2A y x) -- #define LL sL (comb2 $1 $>) +{-# INLINE sLLAsl #-} +sLLAsl :: [LocatedAn t a] -> Located b -> c -> Located c +sLLAsl [] = sL1 +sLLAsl (x:_) = sLLAl x + {-# INLINE sLLAA #-} sLLAA :: LocatedAn t a -> LocatedAn u b -> c -> Located c sLLAA x y = sL (comb2 (reLoc y) (reLoc x)) -- #define LL sL (comb2 $1 $>) |