[Git][ghc/ghc][master] EPA: Make EOF position part of AnnsModule
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Dec 23 04:39:03 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
3699a554 by Alan Zimmerman at 2022-12-22T23:38:35-05:00
EPA: Make EOF position part of AnnsModule
Closes #20951
Closes #19697
- - - - -
25 changed files:
- compiler/GHC/Hs.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Types/SrcLoc.hs
- testsuite/tests/ghc-api/exactprint/LocalDecls2.expected.hs
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/parser/should_compile/T20718.stderr
- testsuite/tests/parser/should_compile/T20718b.stderr
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/Test20297.stdout
- 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
=====================================
@@ -886,7 +886,7 @@ 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)
+ (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 []
))) }
@@ -4277,17 +4277,17 @@ 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 a = do
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -916,18 +916,11 @@ instance Outputable Token where
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When using the Api Annotations to exact print a modified AST, managing
the space before a comment is important. The PsSpan in the comment
-token allows this to happen.
-
-We also need to track the space before the end of file. The normal
-mechanism of using the previous token does not work, as the ITeof is
-synthesised to come at the same location of the last token, and the
-normal previous token updating has by then updated the required
-location.
-
-We track this using a 2-back location, prev_loc2. This adds extra
-processing to every single token, which is a performance hit for
-something needed only at the end of the file. This needs
-improving. Perhaps a backward scan on eof?
+token allows this to happen, and this location is tracked in prev_loc
+in PState. This only tracks physical tokens, so is not updated for
+zero-width ones.
+
+We also use this to track the space before the end-of-file marker.
-}
{- Note [Minus tokens]
@@ -1363,7 +1356,7 @@ lineCommentToken :: Action
lineCommentToken span buf len buf2 = do
b <- getBit RawTokenStreamBit
if b then do
- lt <- getLastLocComment
+ lt <- getLastLocIncludingComments
strtoken (\s -> ITlineComment s lt) span buf len buf2
else lexToken
@@ -1374,7 +1367,7 @@ lineCommentToken span buf len buf2 = do
-}
nested_comment :: Action
nested_comment span buf len _buf2 = {-# SCC "nested_comment" #-} do
- l <- getLastLocComment
+ l <- getLastLocIncludingComments
let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span
input <- getInput
-- Include decorator in comment
@@ -1478,7 +1471,7 @@ withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (Hdk
-> P (PsLocated Token)
withLexedDocType lexDocComment = do
input@(AI _ buf) <- getInput
- l <- getLastLocComment
+ l <- getLastLocIncludingComments
case prevChar buf ' ' of
-- The `Bool` argument to lexDocComment signals whether or not the next
-- line of input might also belong to this doc comment.
@@ -2001,7 +1994,7 @@ lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action
lex_string_prag_comment mkTok span _buf _len _buf2
= do input <- getInput
start <- getParsedLoc
- l <- getLastLocComment
+ l <- getLastLocIncludingComments
tok <- go l [] input
end <- getParsedLoc
return (L (mkPsSpan start end) tok)
@@ -2494,9 +2487,7 @@ data PState = PState {
tab_first :: Strict.Maybe RealSrcSpan, -- pos of first tab warning in the file
tab_count :: !Word, -- number of tab warnings in the file
last_tk :: Strict.Maybe (PsLocated Token), -- last non-comment token
- prev_loc :: PsSpan, -- pos of previous token, including comments,
- prev_loc2 :: PsSpan, -- pos of two back token, including comments,
- -- see Note [PsSpan in Comments]
+ prev_loc :: PsSpan, -- pos of previous non-virtual token, including comments,
last_loc :: PsSpan, -- pos of current token
last_len :: !Int, -- len of current token
loc :: PsLoc, -- current loc (end of prev token + 1)
@@ -2624,24 +2615,21 @@ setLastToken loc len = P $ \s -> POk s {
} ()
setLastTk :: PsLocated Token -> P ()
-setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Strict.Just tk
- , prev_loc = l
- , prev_loc2 = prev_loc s} ()
+setLastTk tk@(L l _) = P $ \s ->
+ if isPointRealSpan (psRealSpan l)
+ then POk s { last_tk = Strict.Just tk } ()
+ else POk s { last_tk = Strict.Just tk
+ , prev_loc = l } ()
setLastComment :: PsLocated Token -> P ()
-setLastComment (L l _) = P $ \s -> POk s { prev_loc = l
- , prev_loc2 = prev_loc s} ()
+setLastComment (L l _) = P $ \s -> POk s { prev_loc = l } ()
getLastTk :: P (Strict.Maybe (PsLocated Token))
getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
-- see Note [PsSpan in Comments]
-getLastLocComment :: P PsSpan
-getLastLocComment = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc
-
--- see Note [PsSpan in Comments]
-getLastLocEof :: P PsSpan
-getLastLocEof = P $ \s@(PState { prev_loc2 = prev_loc2 }) -> POk s prev_loc2
+getLastLocIncludingComments :: P PsSpan
+getLastLocIncludingComments = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc
getLastLoc :: P PsSpan
getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc
@@ -3024,7 +3012,6 @@ initParserState options buf loc =
tab_count = 0,
last_tk = Strict.Nothing,
prev_loc = mkPsSpan init_loc init_loc,
- prev_loc2 = mkPsSpan init_loc init_loc,
last_loc = mkPsSpan init_loc init_loc,
last_len = 0,
loc = init_loc,
@@ -3498,8 +3485,8 @@ lexToken = do
case alexScanUser exts inp sc of
AlexEOF -> do
let span = mkPsSpan loc1 loc1
- lt <- getLastLocEof
- setEofPos (psRealSpan span) (psRealSpan lt)
+ lc <- getLastLocIncludingComments
+ setEofPos (psRealSpan span) (psRealSpan lc)
setLastToken span 0
return (L span ITeof)
AlexError (AI loc2 buf) ->
=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -64,6 +64,9 @@ module GHC.Types.SrcLoc (
isGoodSrcSpan, isOneLineSpan, isZeroWidthSpan,
containsSpan, isNoSrcSpan,
+ -- ** Predicates on RealSrcSpan
+ isPointRealSpan,
+
-- * StringBuffer locations
BufPos(..),
getBufPos,
=====================================
testsuite/tests/ghc-api/exactprint/LocalDecls2.expected.hs
=====================================
@@ -4,5 +4,3 @@ foo a = bar a
where
nn :: Int
nn = 2
-
-
=====================================
testsuite/tests/ghc-api/exactprint/Test20239.stderr
=====================================
@@ -17,16 +17,14 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { Test20239.hs:8:1 }
+ { Test20239.hs:7:34-63 })))
(EpaCommentsBalanced
[]
- [(L
- (Anchor
- { Test20239.hs:8:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { Test20239.hs:7:34-63 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
=====================================
@@ -17,16 +17,14 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { T17544.hs:57:1 }
+ { T17544.hs:55:18-20 })))
(EpaCommentsBalanced
[]
- [(L
- (Anchor
- { T17544.hs:57:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { T17544.hs:57:1 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
=====================================
@@ -17,16 +17,14 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { T17544_kw.hs:25:1 }
+ { T17544_kw.hs:24:18 })))
(EpaCommentsBalanced
[]
- [(L
- (Anchor
- { T17544_kw.hs:25:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { T17544_kw.hs:25:1 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/module/mod185.stderr
=====================================
@@ -16,16 +16,14 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { mod185.hs:6:1 }
+ { mod185.hs:5:8-24 })))
(EpaCommentsBalanced
[]
- [(L
- (Anchor
- { mod185.hs:6:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { mod185.hs:6:1 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
=====================================
@@ -17,16 +17,14 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { DumpParsedAst.hs:25:1 }
+ { DumpParsedAst.hs:24:17-23 })))
(EpaCommentsBalanced
[]
- [(L
- (Anchor
- { DumpParsedAst.hs:25:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { DumpParsedAst.hs:25:1 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
=====================================
@@ -18,7 +18,11 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { DumpParsedAstComments.hs:17:1 }
+ { DumpParsedAstComments.hs:16:17-23 })))
(EpaCommentsBalanced
[(L
(Anchor
@@ -44,13 +48,7 @@
(EpaLineComment
"-- Other comment")
{ DumpParsedAstComments.hs:5:30-34 }))]
- [(L
- (Anchor
- { DumpParsedAstComments.hs:17:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { DumpParsedAstComments.hs:17:1 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -28,16 +28,14 @@
,(AddSemiAnn
(EpaSpan { DumpSemis.hs:4:7 }))
,(AddSemiAnn
- (EpaSpan { DumpSemis.hs:4:8 }))]))
+ (EpaSpan { DumpSemis.hs:4:8 }))])
+ (Just
+ ((,)
+ { DumpSemis.hs:46:1 }
+ { DumpSemis.hs:45:1 })))
(EpaCommentsBalanced
[]
- [(L
- (Anchor
- { DumpSemis.hs:46:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { DumpSemis.hs:46:1 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/parser/should_compile/KindSigs.stderr
=====================================
@@ -17,16 +17,14 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { KindSigs.hs:36:1 }
+ { KindSigs.hs:35:8-11 })))
(EpaCommentsBalanced
[]
- [(L
- (Anchor
- { KindSigs.hs:36:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { KindSigs.hs:36:1 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/parser/should_compile/T15323.stderr
=====================================
@@ -17,16 +17,14 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { T15323.hs:7:1 }
+ { T15323.hs:6:54 })))
(EpaCommentsBalanced
[]
- [(L
- (Anchor
- { T15323.hs:7:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { T15323.hs:7:1 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/parser/should_compile/T20452.stderr
=====================================
@@ -17,16 +17,14 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { T20452.hs:10:1 }
+ { T20452.hs:9:85 })))
(EpaCommentsBalanced
[]
- [(L
- (Anchor
- { T20452.hs:10:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { T20452.hs:10:1 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/parser/should_compile/T20718.stderr
=====================================
@@ -17,7 +17,11 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { T20718.hs:12:1 }
+ { T20718.hs:11:1-8 })))
(EpaCommentsBalanced
[(L
(Anchor
@@ -51,13 +55,7 @@
(EpaLineComment
"-- before 2")
{ T20718.hs:5:1-11 }))]
- [(L
- (Anchor
- { T20718.hs:12:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { T20718.hs:11:1-8 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/parser/should_compile/T20718b.stderr
=====================================
@@ -17,7 +17,11 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { T20718b.hs:8:1 }
+ { T20718b.hs:7:1-21 })))
(EpaCommentsBalanced
[(L
(Anchor
@@ -51,13 +55,7 @@
(EpaLineComment
"-- trailing comment 2")
{ T20718b.hs:6:1-21 }))]
- [(L
- (Anchor
- { T20718b.hs:8:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { T20718b.hs:7:1-21 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/parser/should_compile/T20846.stderr
=====================================
@@ -17,16 +17,14 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { T20846.hs:5:1 }
+ { T20846.hs:4:10-18 })))
(EpaCommentsBalanced
[]
- [(L
- (Anchor
- { T20846.hs:5:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { T20846.hs:5:1 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/printer/T18791.stderr
=====================================
@@ -17,16 +17,14 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { T18791.hs:6:1 }
+ { T18791.hs:5:17 })))
(EpaCommentsBalanced
[]
- [(L
- (Anchor
- { T18791.hs:6:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { T18791.hs:6:1 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
testsuite/tests/printer/Test20297.stdout
=====================================
@@ -17,7 +17,11 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { Test20297.hs:12:1 }
+ { Test20297.hs:11:22-26 })))
(EpaCommentsBalanced
[(L
(Anchor
@@ -27,13 +31,7 @@
(EpaBlockComment
"{-# OPTIONS -ddump-parsed-ast #-}")
{ Test20297.hs:1:1 }))]
- [(L
- (Anchor
- { Test20297.hs:12:1 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { Test20297.hs:12:1 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
@@ -364,7 +362,11 @@
(Nothing)
(Nothing)
[]
- []))
+ [])
+ (Just
+ ((,)
+ { Test20297.ppr.hs:9:25 }
+ { Test20297.ppr.hs:9:20-24 })))
(EpaCommentsBalanced
[(L
(Anchor
@@ -374,13 +376,7 @@
(EpaBlockComment
"{-# OPTIONS -ddump-parsed-ast #-}")
{ Test20297.ppr.hs:1:1 }))]
- [(L
- (Anchor
- { Test20297.ppr.hs:9:25 }
- (UnchangedAnchor))
- (EpaComment
- (EpaEofComment)
- { Test20297.ppr.hs:9:20 }))]))
+ []))
(VirtualBraces
(1))
(Nothing)
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -114,6 +114,7 @@ defaultEPState = EPState
, uExtraDP = Nothing
, epComments = []
, epCommentsApplied = []
+ , epEof = Nothing
}
@@ -188,6 +189,7 @@ data EPState = EPState
-- Shared
, epComments :: ![Comment]
, epCommentsApplied :: ![[Comment]]
+ , epEof :: !(Maybe (RealSrcSpan, RealSrcSpan))
}
-- ---------------------------------------------------------------------
@@ -238,11 +240,7 @@ instance HasEntry (EpAnn 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
-- ---------------------------------------------------------------------
@@ -355,7 +353,7 @@ 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)
advance edp
a' <- exact a
@@ -369,6 +367,17 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
mapM_ printOneComment (map tokComment $ getFollowingComments cs)
debugM $ "ending trailing comments"
+ eof <- getEofPos
+ case eof of
+ Nothing -> return ()
+ Just (pos, prior) -> do
+ let dp = if pos == prior
+ then (DifferentLine 1 0)
+ else origDelta pos prior
+ debugM $ "EOF:(pos,prior,dp) =" ++ showGhc (ss2pos pos, ss2pos prior, dp)
+ printStringAtLsDelta dp ""
+ setEofPos Nothing -- Only do this once
+
let newAchor = anchor' { anchor_op = MovedAnchor edp }
let r = case canUpdateAnchor of
CanUpdateAnchor -> setAnnotationAnchor a' newAchor (mkEpaComments (priorCs++ postCs) [])
@@ -413,23 +422,12 @@ 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))
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
@@ -1397,6 +1395,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
+ debugM $ "am_eof:" ++ showGhc (pos, prior)
+ setEofPos (Just (pos, prior))
+
let anf = an0 { anns = (anns an0) { am_decls = am_decls' }}
debugM $ "HsModule, anf=" ++ showAst anf
@@ -4761,7 +4766,7 @@ printStringAtLsDelta cl s = do
-- `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s))
p' <- getPosP
d <- getPriorEndD
- debugM $ "printStringAtLsDelta:(pos,p',d,s):" ++ show (undelta p cl colOffset,p',d,s)
+ debugM $ "printStringAtLsDelta:(pos,p,p',d,s):" ++ show (undelta p cl colOffset,p,p',d,s)
else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s))
-- ---------------------------------------------------------------------
@@ -4873,6 +4878,14 @@ setAnchorU rss = do
debugM $ "setAnchorU:" ++ show (rs2range rss)
modify (\s -> s { uAnchorSpan = rss })
+getEofPos :: (Monad m, Monoid w) => EP w m (Maybe (RealSrcSpan, RealSrcSpan))
+getEofPos = gets epEof
+
+setEofPos :: (Monad m, Monoid w) => Maybe (RealSrcSpan, RealSrcSpan) -> EP w m ()
+setEofPos l = modify (\s -> s {epEof = l})
+
+-- ---------------------------------------------------------------------
+
getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment]
getUnallocatedComments = gets epComments
=====================================
utils/check-exact/Main.hs
=====================================
@@ -36,7 +36,8 @@ import GHC.Data.FastString
-- ---------------------------------------------------------------------
_tt :: IO ()
-_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib/"
+_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib/"
+-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
@@ -58,7 +59,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../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/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)
@@ -194,7 +195,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Test19834.hs" Nothing
-- "../../testsuite/tests/printer/Test19840.hs" Nothing
-- "../../testsuite/tests/printer/Test19850.hs" Nothing
- "../../testsuite/tests/printer/Test20258.hs" Nothing
+ -- "../../testsuite/tests/printer/Test20258.hs" Nothing
-- "../../testsuite/tests/printer/PprLinearArrow.hs" Nothing
-- "../../testsuite/tests/printer/PprSemis.hs" Nothing
-- "../../testsuite/tests/printer/PprEmptyMostly.hs" Nothing
=====================================
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
=====================================
@@ -709,15 +709,6 @@ commentOrigDelta (L (GHC.Anchor la _) (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)
=> LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))
balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do
=====================================
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)]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3699a5542caa88a8718588e68549b6291bcb5bfc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3699a5542caa88a8718588e68549b6291bcb5bfc
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/20221222/ed5131c8/attachment-0001.html>
More information about the ghc-commits
mailing list