[Git][ghc/ghc][wip/az/epa-remove-addepann-3] Remove [AddEpAnn] from PatBuilderOpApp
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Sun Oct 13 13:17:55 UTC 2024
Alan Zimmerman pushed to branch wip/az/epa-remove-addepann-3 at Glasgow Haskell Compiler / GHC
Commits:
b8244ff9 by Alan Zimmerman at 2024-10-13T11:22:29+01:00
Remove [AddEpAnn] from PatBuilderOpApp
- - - - -
3 changed files:
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/Types.hs
Changes:
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -72,6 +72,7 @@ module GHC.Parser.Lexer (
disableHaddock,
lexTokenStream,
mkParensEpAnn,
+ mkParensEpToks,
mkParensLocs,
getCommentsFor, getPriorCommentsFor, getFinalCommentsFor,
getEofPos,
@@ -3628,6 +3629,7 @@ warn_unknown_prag prags span buf len buf2 = do
%************************************************************************
-}
+-- TODO:AZ: we should have only mkParensEpToks. Delee mkParensEpAnn, mkParensLocs
-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
-- 'AddEpAnn' values for the opening and closing bordering on the start
@@ -3644,6 +3646,22 @@ mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan (RealSrcSpan lo Strict.Nothing)),
lo = mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1))
lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)
+-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
+-- 'AddEpAnn' values for the opening and closing bordering on the start
+-- and end of the span
+mkParensEpToks :: RealSrcSpan -> (EpToken "(", EpToken ")")
+mkParensEpToks ss = (EpTok (EpaSpan (RealSrcSpan lo Strict.Nothing)),
+ EpTok (EpaSpan (RealSrcSpan lc Strict.Nothing)))
+ where
+ f = srcSpanFile ss
+ sl = srcSpanStartLine ss
+ sc = srcSpanStartCol ss
+ el = srcSpanEndLine ss
+ ec = srcSpanEndCol ss
+ lo = mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1))
+ lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)
+
+
-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
-- 'EpaLocation' values for the opening and closing bordering on the start
-- and end of the span
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -161,7 +161,7 @@ import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Monad (unlessM)
import Data.Either
-import Data.List ( findIndex, partition )
+import Data.List ( findIndex )
import Data.Foldable
import qualified Data.Semigroup as Semi
import GHC.Unit.Module.Warnings
@@ -738,8 +738,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =
do { unless (name == patsyn_name) $
wrongNameBindingErr (locA loc) decl
-- conAnn should only be AnnOpenP, AnnCloseP, so the rest should be empty
- ; let (ann_fun, rest) = mk_ann_funrhs []
- ; unless (null rest) $ return $ panic "mkPatSynMatchGroup: unexpected anns"
+ ; let ann_fun = mk_ann_funrhs [] []
; match <- case details of
PrefixCon _ pats -> return $ Match { m_ext = noExtField
, m_ctxt = ctxt, m_pats = L l pats
@@ -1332,12 +1331,12 @@ checkAPat loc e0 = do
addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos
return (WildPat noExtField)
- PatBuilderOpApp l (L cl c) r anns
+ PatBuilderOpApp l (L cl c) r (_os,_cs)
| isRdrDataCon c || isRdrTc c -> do
l <- checkLPat l
r <- checkLPat r
return $ ConPat
- { pat_con_ext = mk_ann_conpat anns
+ { pat_con_ext = noAnn
, pat_con = L cl c
, pat_args = InfixCon l r
}
@@ -1390,9 +1389,8 @@ checkValDef loc lhs (mult_ann, Nothing) grhss
| HsNoMultAnn{} <- mult_ann
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
- Just (fun, is_infix, pats, ann) -> do
- let (ann_fun, ann_rest) = mk_ann_funrhs ann
- unless (null ann_rest) $ panic "checkValDef: unexpected anns"
+ Just (fun, is_infix, pats, ops, cps) -> do
+ let ann_fun = mk_ann_funrhs ops cps
let l = listLocation pats
checkFunBind loc ann_fun
fun is_infix (L l pats) grhss
@@ -1405,29 +1403,8 @@ checkValDef loc lhs (mult_ann, Nothing) ghrss
= do lhs' <- checkPattern lhs
checkPatBind loc lhs' ghrss mult_ann
-mk_ann_funrhs :: [AddEpAnn] -> (AnnFunRhs, [AddEpAnn])
-mk_ann_funrhs ann = (AnnFunRhs strict (map to_tok opens) (map to_tok closes), rest)
- where
- (opens, ra0) = partition (\(AddEpAnn kw _) -> kw == AnnOpenP) ann
- (closes, ra1) = partition (\(AddEpAnn kw _) -> kw == AnnCloseP) ra0
- (bangs, rest) = partition (\(AddEpAnn kw _) -> kw == AnnBang) ra1
- strict = case bangs of
- (AddEpAnn _ s:_) -> EpTok s
- _ -> NoEpTok
- to_tok (AddEpAnn _ s) = EpTok s
-
-mk_ann_conpat :: [AddEpAnn] -> (Maybe (EpToken "{"), Maybe (EpToken "}"))
-mk_ann_conpat ann = (open, close)
- where
- (opens, ra0) = partition (\(AddEpAnn kw _) -> kw == AnnOpenC) ann
- (closes, _ra1) = partition (\(AddEpAnn kw _) -> kw == AnnCloseC) ra0
- open = case opens of
- (o:_) -> Just (to_tok o)
- _ -> Nothing
- close = case closes of
- (o:_) -> Just (to_tok o)
- _ -> Nothing
- to_tok (AddEpAnn _ s) = EpTok s
+mk_ann_funrhs :: [EpToken "("] -> [EpToken ")"] -> AnnFunRhs
+mk_ann_funrhs ops cps = AnnFunRhs NoEpTok ops cps
checkFunBind :: SrcSpan
-> AnnFunRhs
@@ -1469,10 +1446,10 @@ checkPatBind :: SrcSpan
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> HsMultAnn GhcPs
-> P (HsBind GhcPs)
-checkPatBind loc (L _ (BangPat ans (L _ (VarPat _ v))))
+checkPatBind loc (L _ (BangPat an (L _ (VarPat _ v))))
(L _match_span grhss) (HsNoMultAnn _)
= return (makeFunBind v (L (noAnnSrcSpan loc)
- [L (noAnnSrcSpan loc) (m ans v)]))
+ [L (noAnnSrcSpan loc) (m an v)]))
where
m a v = Match { m_ext = noExtField
, m_ctxt = FunRhs { mc_fun = v
@@ -1518,7 +1495,7 @@ checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr
isFunLhs :: LocatedA (PatBuilder GhcPs)
-> P (Maybe (LocatedN RdrName, LexicalFixity,
- [LocatedA (ArgPatBuilder GhcPs)],[AddEpAnn]))
+ [LocatedA (ArgPatBuilder GhcPs)],[EpToken "("],[EpToken ")"]))
-- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS
isFunLhs e = go e [] [] []
@@ -1528,7 +1505,7 @@ isFunLhs e = go e [] [] []
go (L l (PatBuilderVar (L loc f))) es ops cps
| not (isRdrDataCon f) = do
let (_l, loc') = transferCommentsOnlyA l loc
- return (Just (L loc' f, Prefix, es, (reverse ops) ++ cps))
+ return (Just (L loc' f, Prefix, es, (reverse ops), cps))
go (L l (PatBuilderApp (L lf f) e)) es ops cps = do
let (_l, lf') = transferCommentsOnlyA l lf
go (L lf' f) (mk e:es) ops cps
@@ -1538,21 +1515,21 @@ isFunLhs e = go e [] [] []
-- of funlhs.
where
(_l, le') = transferCommentsOnlyA l le
- (o,c) = mkParensEpAnn (realSrcSpan $ locA l)
- go (L loc (PatBuilderOpApp (L ll l) (L loc' op) r anns)) es ops cps
+ (o,c) = mkParensEpToks (realSrcSpan $ locA l)
+ go (L loc (PatBuilderOpApp (L ll l) (L loc' op) r (os,cs))) es ops cps
| not (isRdrDataCon op) -- We have found the function!
= do { let (_l, ll') = transferCommentsOnlyA loc ll
- ; return (Just (L loc' op, Infix, (mk (L ll' l):mk r:es), (anns ++ reverse ops ++ cps))) }
+ ; return (Just (L loc' op, Infix, (mk (L ll' l):mk r:es), (os ++ reverse ops), (cs ++ cps))) }
| otherwise -- Infix data con; keep going
= do { let (_l, ll') = transferCommentsOnlyA loc ll
; mb_l <- go (L ll' l) es ops cps
; return (reassociate =<< mb_l) }
where
- reassociate (op', Infix, j : L k_loc (ArgPatBuilderVisPat k) : es', anns')
- = Just (op', Infix, j : op_app : es', anns')
+ reassociate (op', Infix, j : L k_loc (ArgPatBuilderVisPat k) : es', ops', cps')
+ = Just (op', Infix, j : op_app : es', ops', cps')
where
op_app = mk $ L loc (PatBuilderOpApp (L k_loc k)
- (L loc' op) r (reverse ops ++ cps))
+ (L loc' op) r (reverse ops, cps))
reassociate _other = Nothing
go (L l (PatBuilderAppType (L lp pat) tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps
= go (L lp' pat) (L (EpAnn anc' ann cs) (ArgPatBuilderArgPat invis_pat) : es) ops cps
@@ -2052,7 +2029,7 @@ instance DisambECP (PatBuilder GhcPs) where
superInfixOp m = m
mkHsOpAppPV l p1 op p2 = do
!cs <- getCommentsFor l
- return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 []
+ return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 ([],[])
mkHsLamPV l lam_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaInPat lam_variant)
=====================================
compiler/GHC/Parser/Types.hs
=====================================
@@ -57,7 +57,7 @@ data PatBuilder p
| PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))
| PatBuilderAppType (LocatedA (PatBuilder p)) (EpToken "@") (HsTyPat GhcPs)
| PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName)
- (LocatedA (PatBuilder p)) [AddEpAnn]
+ (LocatedA (PatBuilder p)) ([EpToken "("], [EpToken ")"])
| PatBuilderVar (LocatedN RdrName)
| PatBuilderOverLit (HsOverLit GhcPs)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8244ff93f30c9eaafed22cc4e6f6e706547d42e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8244ff93f30c9eaafed22cc4e6f6e706547d42e
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/20241013/74634b97/attachment-0001.html>
More information about the ghc-commits
mailing list