[Git][ghc/ghc][wip/az/locateda-epa-improve] EPA: Explicitly capture EOF Location in AnnsModule
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Mon Nov 28 23:29:57 UTC 2022
Alan Zimmerman pushed to branch wip/az/locateda-epa-improve at Glasgow Haskell Compiler / GHC
Commits:
b6d8b5cd by Alan Zimmerman at 2022-11-28T23:29:14+00:00
EPA: Explicitly capture EOF Location in AnnsModule
And also get rid of EpaEofComment.
- - - - -
9 changed files:
- compiler/GHC/Hs.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- testsuite/tests/ghc-api/exactprint/AddDecl2.expected.hs
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Orphans.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
compiler/GHC/Hs.hs
=====================================
@@ -101,7 +101,8 @@ deriving instance Data (HsModule GhcPs)
data AnnsModule
= AnnsModule {
am_main :: [AddEpAnn],
- am_decls :: AnnList
+ am_decls :: AnnList,
+ am_eof :: Maybe (RealSrcSpan, RealSrcSpan) -- End of file and end of prior token
} deriving (Data, Eq)
instance Outputable (HsModule GhcPs) where
=====================================
compiler/GHC/Parser.y
=====================================
@@ -885,8 +885,8 @@ unitdecl :: { LHsUnitDecl PackageName }
signature :: { Located (HsModule GhcPs) }
: 'signature' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- acs (\cs-> (L loc (HsModule (XModulePs
- (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6)) cs)
+ acs (\cs -> (L loc (HsModule (XModulePs
+ (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6) Nothing) cs)
(thdOf3 $6) $3 Nothing)
(Just $2) $4 (fst $ sndOf3 $6)
(snd $ sndOf3 $6)))
@@ -895,16 +895,16 @@ signature :: { Located (HsModule GhcPs) }
module :: { Located (HsModule GhcPs) }
: 'module' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- acsFinal (\cs -> (L loc (HsModule (XModulePs
- (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs)
+ acsFinal (\cs eof -> (L loc (HsModule (XModulePs
+ (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6) eof) cs)
(thdOf3 $6) $3 Nothing)
(Just $2) $4 (fst $ sndOf3 $6)
(snd $ sndOf3 $6))
)) }
| body2
{% fileSrcSpan >>= \ loc ->
- acsFinal (\cs -> (L loc (HsModule (XModulePs
- (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1)) cs)
+ acsFinal (\cs eof -> (L loc (HsModule (XModulePs
+ (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1) eof) cs)
(thdOf3 $1) Nothing Nothing)
Nothing Nothing
(fst $ sndOf3 $1) (snd $ sndOf3 $1)))) }
@@ -956,14 +956,14 @@ header :: { Located (HsModule GhcPs) }
: 'module' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
acs (\cs -> (L loc (HsModule (XModulePs
- (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)
+ (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] []) Nothing) cs)
NoLayoutInfo $3 Nothing)
(Just $2) $4 $6 []
))) }
| 'signature' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
acs (\cs -> (L loc (HsModule (XModulePs
- (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)
+ (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] []) Nothing) cs)
NoLayoutInfo $3 Nothing)
(Just $2) $4 $6 []
))) }
@@ -4309,17 +4309,16 @@ acs a = do
return (a cs)
-- Called at the very end to pick up the EOF position, as well as any comments not allocated yet.
-acsFinal :: (EpAnnComments -> Located a) -> P (Located a)
+acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a)
acsFinal a = do
- let (L l _) = a emptyComments
+ let (L l _) = a emptyComments Nothing
cs <- getCommentsFor l
csf <- getFinalCommentsFor l
meof <- getEofPos
let ce = case meof of
- Strict.Nothing -> EpaComments []
- Strict.Just (pos `Strict.And` gap) ->
- EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)]
- return (a (cs Semi.<> csf Semi.<> ce))
+ Strict.Nothing -> Nothing
+ Strict.Just (pos `Strict.And` gap) -> Just (pos,gap)
+ return (a (cs Semi.<> csf) ce)
-- acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a)
acsa :: (Monoid t, MonadP m) => (EpAnnComments -> LocatedAnS t a) -> m (LocatedAnS t a)
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -381,12 +381,6 @@ data EpaCommentTok =
| EpaDocOptions String -- ^ doc options (prune, ignore-exports, etc)
| EpaLineComment String -- ^ comment starting by "--"
| EpaBlockComment String -- ^ comment in {- -}
- | EpaEofComment -- ^ empty comment, capturing
- -- location of EOF
-
- -- See #19697 for a discussion of EpaEofComment's use and how it
- -- should be removed in favour of capturing it in the location for
- -- 'Located HsModule' in the parser.
deriving (Eq, Data, Show)
-- Note: these are based on the Token versions, but the Token type is
=====================================
testsuite/tests/ghc-api/exactprint/AddDecl2.expected.hs
=====================================
@@ -8,6 +8,6 @@ foo a b = a + b
-- | Do bar
bar x y = {- baz -} foo (x+y) x
-nn = n2
-
-- end of file
+
+nn = n2
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -247,11 +247,7 @@ instance HasEntry (EpAnnS a) where
fromAnn' :: (HasEntry a) => a -> Entry
fromAnn' an = case fromAnn an of
NoEntryVal -> NoEntryVal
- Entry a c _ u -> Entry a c' FlushComments u
- where
- c' = case c of
- EpaComments cs -> EpaCommentsBalanced (filterEofComment False cs) (filterEofComment True cs)
- EpaCommentsBalanced cp ct -> EpaCommentsBalanced cp ct
+ Entry a c _ u -> Entry a c FlushComments u
-- ---------------------------------------------------------------------
@@ -377,7 +373,8 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
let mflush = when (flush == FlushComments) $ do
debugM $ "flushing comments in enterAnn:" ++ showAst cs
- flushComments (getFollowingComments cs ++ filterEofComment True (priorComments cs))
+ -- flushComments (getFollowingComments cs ++ priorComments cs)
+ flushComments (getFollowingComments cs)
advance edp
a' <- exact a
@@ -436,23 +433,14 @@ addComments csNew = do
-- ones in the state.
flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m ()
flushComments trailing = do
- addCommentsA (filterEofComment False trailing)
+ addCommentsA trailing
cs <- getUnallocatedComments
debugM $ "flushing comments starting"
mapM_ printOneComment (sortComments cs)
debugM $ "flushing comments:EOF:trailing:" ++ showAst (trailing)
- debugM $ "flushing comments:EOF:" ++ showAst (filterEofComment True trailing)
- mapM_ printOneComment (map tokComment (filterEofComment True trailing))
+ -- mapM_ printOneComment (map tokComment (filterEofComment True trailing))
debugM $ "flushing comments done"
-filterEofComment :: Bool -> [LEpaComment] -> [LEpaComment]
-filterEofComment keep cs = fixCs cs
- where
- notEof com = case com of
- L _ (GHC.EpaComment (EpaEofComment) _) -> keep
- _ -> not keep
- fixCs c = filter notEof c
-
-- ---------------------------------------------------------------------
-- |In order to interleave annotations into the stream, we turn them into
@@ -1444,6 +1432,13 @@ instance ExactPrint (HsModule GhcPs) where
EpAnnNotUsed -> (am_decls $ anns an0)
EpAnn _ r _ -> r
+ -- Print EOF
+ case am_eof $ anns an of
+ Nothing -> return ()
+ Just (pos, prior) -> do
+ let dp = origDelta pos prior
+ printStringAtLsDelta dp ""
+
let anf = an0 { anns = (anns an0) { am_decls = am_decls' }}
debugM $ "HsModule, anf=" ++ showAst anf
=====================================
utils/check-exact/Main.hs
=====================================
@@ -55,13 +55,13 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/ghc-api/exactprint/LetIn1.hs" (Just changeLetIn1)
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn4.hs" (Just changeWhereIn4)
-- "../../testsuite/tests/ghc-api/exactprint/AddDecl1.hs" (Just changeAddDecl1)
- "../../testsuite/tests/ghc-api/exactprint/AddDecl2.hs" (Just changeAddDecl2)
+ -- "../../testsuite/tests/ghc-api/exactprint/AddDecl2.hs" (Just changeAddDecl2)
-- "../../testsuite/tests/ghc-api/exactprint/AddDecl3.hs" (Just changeAddDecl3)
-- "../../testsuite/tests/ghc-api/exactprint/LocalDecls.hs" (Just changeLocalDecls)
-- "../../testsuite/tests/ghc-api/exactprint/LocalDecls2.hs" (Just changeLocalDecls2)
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn3a.hs" (Just changeWhereIn3a)
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn3b.hs" (Just changeWhereIn3b)
- -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl1.hs" (Just addLocaLDecl1)
+ "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl1.hs" (Just addLocaLDecl1)
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl2.hs" (Just addLocaLDecl2)
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl3.hs" (Just addLocaLDecl3)
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl4.hs" (Just addLocaLDecl4)
@@ -596,12 +596,14 @@ addLocaLDecl1 libdir top = do
Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
let decl' = setEntryDP (L ld decl) (DifferentLine 1 5)
doAddLocal = do
- let lp = makeDeltaAst top
+ -- let lp = makeDeltaAst top
+ let lp = top
(de1:d2:d3:_) <- hsDecls lp
(de1'',d2') <- balanceComments de1 d2
(de1',_) <- modifyValD (getLocA de1'') de1'' $ \_m d -> do
return ((wrapDecl decl' : d),Nothing)
replaceDecls lp [de1', d2', d3]
+ -- `debug` ("addLocaLDecl1: (de1'', de1):" ++ showAst (de1'', de1))
(lp',_,w) <- runTransformT doAddLocal
debugM $ "addLocaLDecl1:" ++ intercalate "\n" w
@@ -635,7 +637,8 @@ addLocaLDecl3 libdir top = do
Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
let
doAddLocal = do
- let lp = makeDeltaAst top
+ -- let lp = makeDeltaAst top
+ let lp = top
(de1:d2:_) <- hsDecls lp
(de1'',d2') <- balanceComments de1 d2
@@ -720,7 +723,8 @@ addLocaLDecl6 libdir lp = do
rmDecl1 :: Changer
rmDecl1 _libdir top = do
let doRmDecl = do
- let lp = makeDeltaAst top
+ -- let lp = makeDeltaAst top
+ let lp = top
tlDecs0 <- hsDecls lp
tlDecs <- balanceCommentsList $ captureLineSpacing tlDecs0
let (de1:_s1:_d2:d3:ds) = tlDecs
@@ -839,7 +843,8 @@ rmDecl7 :: Changer
rmDecl7 _libdir top = do
let
doRmDecl = do
- let lp = makeDeltaAst top
+ -- let lp = makeDeltaAst top
+ let lp = top
tlDecs <- hsDecls lp
[s1,de1,d2,d3] <- balanceCommentsList tlDecs
@@ -919,7 +924,8 @@ addHiding1 _libdir (L l p) = do
addHiding2 :: Changer
addHiding2 _libdir top = do
let doTransform = do
- let (L l p) = makeDeltaAst top
+ -- let (L l p) = makeDeltaAst top
+ let (L l p) = top
l1 <- uniqueSrcSpanT
l2 <- uniqueSrcSpanT
let
=====================================
utils/check-exact/Orphans.hs
=====================================
@@ -89,4 +89,4 @@ instance Default EpAnnSumPat where
def = EpAnnSumPat def def def
instance Default AnnsModule where
- def = AnnsModule [] mempty
+ def = AnnsModule [] mempty Nothing
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -342,7 +342,7 @@ setEntryDP (L (EpAnnS (EpaSpan r) an cs) a) dp
-- delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r
delta = case getLoc lc of
EpaSpan rr -> tweakDelta $ ss2delta (ss2pos rr) r
- EpaDelta dp _ -> tweakDelta dp
+ EpaDelta _dp _ -> DifferentLine 1 0
line = getDeltaLine delta
col = deltaColumn delta
edp' = if line == 0 then SameLine col
@@ -688,7 +688,7 @@ trailingCommentsDeltas :: RealSrcSpan -> [LEpaComment]
-> [(Int, LEpaComment)]
trailingCommentsDeltas _ [] = []
trailingCommentsDeltas rs (la@(L (EpaDelta dp _) _):las)
- = (deltaLine dp, la): trailingCommentsDeltas rs las
+ = (getDeltaLine dp, la): trailingCommentsDeltas rs las
trailingCommentsDeltas rs (la@(L l _):las)
= deltaComment rs la : trailingCommentsDeltas (anchor l) las
where
@@ -801,29 +801,11 @@ anchorFromLocatedA (L (EpAnnS anc _ _) _) = anchor anc
commentOrigDelta :: LEpaComment -> LEpaComment
commentOrigDelta (L (EpaSpan la) (GHC.EpaComment t pp))
= (L op (GHC.EpaComment t pp))
- `debug` ("commentOrigDelta: (la, pp, r,c, op)=" ++ showAst (la, pp, r,c, op))
where
- (r,c) = ss2posEnd pp
-
- op' = if r == 0
- then EpaDelta (ss2delta (r,c+1) la) []
- else EpaDelta (tweakDelta $ ss2delta (r,c) la) []
- op = if t == EpaEofComment && op' == EpaDelta (SameLine 0) []
- then EpaDelta (DifferentLine 1 0) []
- else op'
+ op = EpaDelta (origDelta la pp) []
commentOrigDelta (L anc (GHC.EpaComment t pp))
= (L anc (GHC.EpaComment t pp))
-
--- ---------------------------------------------------------------------
-
-
--- | For comment-related deltas starting on a new line we have an
--- off-by-one problem. Adjust
-tweakDelta :: DeltaPos -> DeltaPos
-tweakDelta (SameLine d) = SameLine d
-tweakDelta (DifferentLine l d) = DifferentLine l (d-1)
-
-- ---------------------------------------------------------------------
balanceSameLineComments :: (Monad m)
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -172,6 +172,25 @@ isPointSrcSpan ss = spanLength ss == 0
-- ---------------------------------------------------------------------
+origDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos
+origDelta pos pp = op
+ where
+ (r,c) = ss2posEnd pp
+
+ op = if r == 0
+ then ( ss2delta (r,c+1) pos)
+ else (tweakDelta $ ss2delta (r,c ) pos)
+
+-- ---------------------------------------------------------------------
+
+-- | For comment-related deltas starting on a new line we have an
+-- off-by-one problem. Adjust
+tweakDelta :: DeltaPos -> DeltaPos
+tweakDelta (SameLine d) = SameLine d
+tweakDelta (DifferentLine l d) = DifferentLine l (d-1)
+
+-- ---------------------------------------------------------------------
+
-- |Given a list of items and a list of keys, returns a list of items
-- ordered by their position in the list of keys.
orderByKey :: [(RealSrcSpan,a)] -> [RealSrcSpan] -> [(RealSrcSpan,a)]
@@ -214,7 +233,6 @@ ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDoc
ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaLineComment s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s
-ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _)) = ""
tokComment :: LEpaComment -> Comment
tokComment t@(L lt c) = mkComment (normaliseCommentText $ ghcCommentText t) lt (ac_prior_tok c)
@@ -229,7 +247,6 @@ comment2LEpaComment :: Comment -> LEpaComment
comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r
mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment
-mkLEpaComment "" anc r = (L anc (GHC.EpaComment (EpaEofComment) r))
mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r))
mkComment :: String -> Anchor -> RealSrcSpan -> Comment
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b6d8b5cda6cc5dcf4720a130293e09c58671473e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b6d8b5cda6cc5dcf4720a130293e09c58671473e
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/20221128/1437e1a0/attachment-0001.html>
More information about the ghc-commits
mailing list