[Git][ghc/ghc][wip/or-pats] 2 commits: Use ';;' for or patterns
David (@knothed)
gitlab at gitlab.haskell.org
Fri Oct 28 15:10:22 UTC 2022
David pushed to branch wip/or-pats at Glasgow Haskell Compiler / GHC
Commits:
625c6688 by David Knothe at 2022-10-28T15:49:25+02:00
Use ';;' for or patterns
- - - - -
a2cc55f1 by David Knothe at 2022-10-28T17:10:14+02:00
Remove old parsing of '||'
- - - - -
7 changed files:
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/Types.hs
- 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) = brackets (interppDvBar (toList pats))
+pprPat (OrPat _ pats) = pprWithSemis 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/Parser.y
=====================================
@@ -3043,12 +3043,47 @@ texp :: { ECP }
$1 >>= \ $1 ->
pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 }
+ | exp ';' ';' texp { ECP $
+ unECP $1 >>= \ $1 ->
+ unECP $4 >>= \ $4 ->
+ mkHsOrPatPV (comb2 (reLoc $1) (reLoc $>)) $1 $4 [mu AnnDsemi (merge_ts $2 $3)] }
+
-- View patterns get parenthesized above
- | exp '->' texp { ECP $
+ | exp '->' texp1 { ECP $
unECP $1 >>= \ $1 ->
unECP $3 >>= \ $3 ->
mkHsViewPatPV (comb2 (reLoc $1) (reLoc $>)) $1 $3 [mu AnnRarrow $2] }
+ -- View patterns get parenthesized above
+ | exp '->' texp1 ';' ';' texp
+ { ECP $
+ unECP $1 >>= \ $1 ->
+ unECP $3 >>= \ $3 ->
+ unECP $6 >>= \ $6 ->
+ (mkHsViewPatPV (comb2 (reLoc $1) (reLoc $3)) $1 $3 [mu AnnRarrow $2]) >>= \v ->
+ mkHsOrPatPV (comb2 (reLoc $1) (reLoc $6)) v $6 [mu AnnDsemi (merge_ts $4 $5)] }
+
+texp1 :: { ECP }
+ : exp { $1 }
+
+ | infixexp qop
+ {% runPV (unECP $1) >>= \ $1 ->
+ runPV (rejectPragmaPV $1) >>
+ runPV $2 >>= \ $2 ->
+ return $ ecpFromExp $
+ reLocA $ sLL (reLoc $1) (reLocN $>) $ SectionL noAnn $1 (n2l $2) }
+
+ | qopm infixexp { ECP $
+ superInfixOp $
+ unECP $2 >>= \ $2 ->
+ $1 >>= \ $1 ->
+ pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 }
+
+ | exp '->' texp1 { ECP $
+ unECP $1 >>= \ $1 ->
+ unECP $3 >>= \ $3 ->
+ mkHsViewPatPV (comb2 (reLoc $1) (reLoc $>)) $1 $3 [mu AnnRarrow $2] }
+
-- Always at least one comma or bar.
-- Though this can parse just commas (without any expressions), it won't
-- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple]
@@ -4232,6 +4267,10 @@ msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (EpaSpan $ rs $ gl l
mu :: AnnKeywordId -> Located Token -> AddEpAnn
mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (EpaSpan $ rs l)
+-- Merge the source spans of the tokens into the first one.
+merge_ts :: Located Token -> Located Token -> Located Token
+merge_ts (L l1 t) (L l2 _) = L (combineSrcSpans l1 l2) t
+
-- | If the 'Token' is using its unicode variant return the unicode variant of
-- the annotation
toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -285,6 +285,7 @@ data AnnKeywordId
| AnnRole
| AnnSafe
| AnnSemi -- ^ ';'
+ | AnnDsemi -- ^ ';;'
| AnnSimpleQuote -- ^ '''
| AnnSignature
| AnnStatic -- ^ 'static'
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1192,7 +1192,6 @@ checkFPat loc e _ _ = do
checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat loc e0 = do
nPlusKPatterns <- getBit NPlusKPatternsBit
- e0 <- rebalance e0
case e0 of
PatBuilderPat p -> return p
PatBuilderVar _ -> unLoc <$> checkLPat (L loc e0)
@@ -1217,12 +1216,6 @@ checkAPat loc e0 = do
addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos
return (WildPat noExtField)
- pat@(PatBuilderOpApp _ op _ _) | opIsDvbar (unLoc op) -> do
- let (pats', anns) = unzip . NE.toList $ flatten pat loc
- pats <- zipWithM checkAPat anns pats'
- let lpats = zipWith L anns pats
- return (OrPat EpAnnNotUsed (NE.fromList lpats))
-
PatBuilderOpApp l (L cl c) r anns
| isRdrDataCon c -> do
l <- checkLPat l
@@ -1249,43 +1242,13 @@ checkAPat loc e0 = do
details <- fromParseContext <$> askParseContext
patFail (locA loc) (PsErrInPat e0 details)
-flatten :: PatBuilder GhcPs -> SrcSpanAnnA -> NonEmpty (PatBuilder GhcPs, SrcSpanAnnA) -- flatten the or-hierarchy
-flatten x l = case x of
- PatBuilderOpApp (L l1 p1) op (L l2 p2) _ | unLoc op == dvbar_RDR -> flatten p1 l1 `NE.append` flatten p2 l2
- PatBuilderPar _ (L l p) _ -> flatten p l
- _ -> (x,l) :| []
-
--- Rebalance the PatBuilder tree to give '||' a lower precedence than '+', to make stuff like (n+3 || n+4) possible
-rebalance :: PatBuilder GhcPs -> PV (PatBuilder GhcPs)
-rebalance e = case e of
- -- a || b ~> a || b
- PatBuilderOpApp (L l1 pat1) op (L l2 pat2) ann | unLoc op == dvbar_RDR -> do
- p1 <- rebalance pat1
- p2 <- rebalance pat2
- return $ PatBuilderOpApp (L l1 p1) op (L l2 p2) ann
-
- -- (a || b) + c ~> a || (b + c)
- PatBuilderOpApp (L _ (PatBuilderOpApp (L l1 pat1) iop (L l2 pat2) _))
- oop
- (L l3 pat3)
- oann
- | unLoc iop == dvbar_RDR && unLoc oop == plus_RDR -> do
- cs <- getCommentsFor (locA innpat_l)
- new1 <- rebalance pat1
- innpat <- rebalance $ PatBuilderOpApp (L l2 pat2) oop (L l3 pat3) (EpAnn (spanAsAnchor (locA innpat_l)) [] cs)
- return $ PatBuilderOpApp (L l1 new1) iop (L innpat_l innpat) oann where
- innpat_l = SrcSpanAnn EpAnnNotUsed $ combineSrcSpans (locA l2) (locA l3)
-
- x -> pure x
-
placeHolderPunRhs :: DisambECP b => PV (LocatedA b)
-- The RHS of a punned record field will be filled in by the renamer
-- It's better not to make it an error, in case we want to print it when
-- debugging
placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR)
-dvbar_RDR, plus_RDR, pun_RDR :: RdrName
-dvbar_RDR = mkUnqual varName (fsLit "||") -- Hack
+plus_RDR, pun_RDR :: RdrName
plus_RDR = mkUnqual varName (fsLit "+") -- Hack
pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
@@ -1632,6 +1595,9 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
mkHsViewPatPV
:: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)
-- | Disambiguate "a at b" (as-pattern)
+ mkHsOrPatPV
+ :: SrcSpan -> LocatedA b -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)
+ -- | Disambiguate "a at b" (as-pattern)
mkHsAsPatPV
:: SrcSpan -> LocatedN RdrName -> LHsToken "@" GhcPs -> LocatedA b -> PV (LocatedA b)
-- | Disambiguate "~a" (lazy pattern)
@@ -1753,6 +1719,8 @@ instance DisambECP (HsCmd GhcPs) where
in pp_op <> ppr c
mkHsViewPatPV l a b _ = cmdFail l $
ppr a <+> text "->" <+> ppr b
+ mkHsOrPatPV l a b _ = cmdFail l $
+ ppr a <+> text "->" <+> ppr b
mkHsAsPatPV l v _ c = cmdFail l $
pprPrefixOcc (unLoc v) <> text "@" <> ppr c
mkHsLazyPatPV l c _ = cmdFail l $
@@ -1849,6 +1817,8 @@ instance DisambECP (HsExpr GhcPs) where
return $ L l (SectionR (comment (realSrcSpan l) cs) op e)
mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b)
>> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
+ mkHsOrPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b) -- todo OR
+ >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
mkHsAsPatPV l v _ e = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e)
>> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
mkHsLazyPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e)
@@ -1932,6 +1902,15 @@ instance DisambECP (PatBuilder GhcPs) where
p <- checkLPat b
cs <- getCommentsFor l
return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (EpAnn (spanAsAnchor l) anns cs) a p))
+ mkHsOrPatPV l a b anns = do
+ p <- flatten <$> checkLPat a
+ q <- flatten <$> checkLPat b
+ cs <- getCommentsFor l
+ return $ L (noAnnSrcSpan l) (PatBuilderPat (OrPat (EpAnn (spanAsAnchor l) anns cs) (NE.append p q)))
+ where
+ flatten :: LPat GhcPs -> NE.NonEmpty (LPat GhcPs)
+ flatten (L _ (OrPat _ xs)) = join (NE.map flatten xs)
+ flatten x = NE.singleton x
mkHsAsPatPV l v at e = do
p <- checkLPat e
cs <- getCommentsFor l
@@ -3129,9 +3108,6 @@ mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do
mkSumOrTupleExpr l Boxed a at Sum{} _ =
addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a
--- Or
-mkSumOrTupleExpr l _ (OrPat' _) _ = pprPanic "mkSumOrTupleExpr" (ppr l)
-
mkSumOrTuplePat
:: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn]
-> PV (LocatedA (PatBuilder GhcPs))
@@ -3160,12 +3136,6 @@ mkSumOrTuplePat l Boxed a at Sum{} _ =
addFatalError $
mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a
--- Or
-mkSumOrTuplePat l _ (OrPat' ps) anns = do
- ps' <- traverse checkLPat ps
- cs <- getCommentsFor (locA l)
- return $ L l (PatBuilderPat (OrPat (EpAnn (spanAsAnchor $ locA l) anns cs) ps'))
-
mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy prom x op y =
let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y
=====================================
compiler/GHC/Parser/Types.hs
=====================================
@@ -25,13 +25,11 @@ import GHC.Data.OrdList
import Data.Foldable
import GHC.Parser.Annotation
import Language.Haskell.Syntax
-import qualified Data.List.NonEmpty as NEL
data SumOrTuple b
= Sum ConTag Arity (LocatedA b) [EpaLocation] [EpaLocation]
-- ^ Last two are the locations of the '|' before and after the payload
| Tuple [Either (EpAnn EpaLocation) (LocatedA b)]
- | OrPat' (NEL.NonEmpty (LocatedA b))
pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc
pprSumOrTuple boxity = \case
@@ -41,9 +39,6 @@ pprSumOrTuple boxity = \case
Tuple xs ->
parOpen <> (fcat . punctuate comma $ map ppr_tup xs)
<> parClose
- OrPat' xs ->
- parOpen <> (fcat . punctuate (text " || ") . toList $ NEL.map ppr xs)
- <> parClose
where
ppr_tup (Left _) = empty
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -24,9 +24,9 @@ module GHC.Utils.Outputable (
-- * Pretty printing combinators
SDoc, runSDoc, PDoc(..),
docToSDoc,
- interppDvBar, interppSP, interpp'SP, interpp'SP',
+ interppSP, interpp'SP, interpp'SP',
pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,
- pprWithBars,
+ pprWithBars, pprWithSemis,
empty, isEmpty, nest,
char,
text, ftext, ptext, ztext,
@@ -1341,15 +1341,16 @@ 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))
+pprWithSemis :: (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.
+pprWithSemis pp xs = fsep (intersperse semi (map pp xs))
+
-- | Returns the separated concatenation of the pretty printed things.
interppSP :: Outputable a => [a] -> SDoc
interppSP xs = sep (map ppr xs)
--- | Returns the double-bar-separated concatenation of the pretty printed things.
-interppDvBar :: Outputable a => [a] -> SDoc
-interppDvBar xs = sep (punctuate dvbar (map ppr xs)) where
- dvbar = docToSDoc $ Pretty.text "||"
-
-- | Returns the comma-separated concatenation of the pretty printed things.
interpp'SP :: Outputable a => [a] -> SDoc
interpp'SP xs = interpp'SP' ppr xs
=====================================
utils/check-exact/Lookup.hs
=====================================
@@ -55,6 +55,7 @@ keywordToString kw =
AnnDo -> "do"
AnnDot -> "."
AnnDotdot -> ".."
+ AnnDsemi -> ";;"
AnnElse -> "else"
AnnEqual -> "="
AnnExport -> "export"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b16c8171965344d410486778481a346fe974e86f...a2cc55f10182950a9acbf5fa9568f35fe02603ff
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b16c8171965344d410486778481a346fe974e86f...a2cc55f10182950a9acbf5fa9568f35fe02603ff
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/20221028/e4386220/attachment-0001.html>
More information about the ghc-commits
mailing list