[Git][ghc/ghc][wip/az/epa-eof-annsmodule] 4 commits: Correct `exitWith` Haddocks
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Mon Dec 19 16:47:18 UTC 2022
Alan Zimmerman pushed to branch wip/az/epa-eof-annsmodule at Glasgow Haskell Compiler / GHC
Commits:
6fe2d778 by amesgen at 2022-12-18T19:33:49-05:00
Correct `exitWith` Haddocks
The `IOError`-specific `catch` in the Prelude is long gone.
- - - - -
b3eacd64 by Ben Gamari at 2022-12-18T19:34:24-05:00
rts: Drop racy assertion
0e274c39bf836d5bb846f5fa08649c75f85326ac added an assertion in
`dirty_MUT_VAR` checking that the MUT_VAR being dirtied was clean.
However, this isn't necessarily the case since another thread may have
raced us to dirty the object.
- - - - -
761c1f49 by Ben Gamari at 2022-12-18T19:35:00-05:00
rts/libdw: Silence uninitialized usage warnings
As noted in #22538, previously some GCC versions warned that various
locals in Libdw.c may be used uninitialized. Although this wasn't
strictly true (since they were initialized in an inline assembler block)
we fix this by providing explicit empty initializers.
Fixes #22538
- - - - -
80890099 by Alan Zimmerman at 2022-12-19T12:06:06+00:00
EPA: Make EOF position part of AnnsModule
Closes #20951
Closes #19697
- - - - -
28 changed files:
- compiler/GHC/Hs.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Types/SrcLoc.hs
- libraries/base/System/Exit.hs
- rts/Libdw.c
- rts/sm/Storage.c
- 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,
=====================================
libraries/base/System/Exit.hs
=====================================
@@ -45,16 +45,14 @@ import GHC.IO.Exception
-- A program that terminates successfully without calling 'exitWith'
-- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'.
--
--- As an 'ExitCode' is not an 'IOError', 'exitWith' bypasses
--- the error handling in the 'IO' monad and cannot be intercepted by
--- 'catch' from the "Prelude". However it is a 'Control.Exception.SomeException', and can
--- be caught using the functions of "Control.Exception". This means
--- that cleanup computations added with 'Control.Exception.bracket'
--- (from "Control.Exception") are also executed properly on 'exitWith'.
+-- As an 'ExitCode' is an 'Control.Exception.Exception', it can be
+-- caught using the functions of "Control.Exception". This means that
+-- cleanup computations added with 'Control.Exception.bracket' (from
+-- "Control.Exception") are also executed properly on 'exitWith'.
--
-- Note: in GHC, 'exitWith' should be called from the main program
-- thread in order to exit the process. When called from another
--- thread, 'exitWith' will throw an 'ExitException' as normal, but the
+-- thread, 'exitWith' will throw an 'ExitCode' as normal, but the
-- exception will not cause the process itself to exit.
--
exitWith :: ExitCode -> IO a
=====================================
rts/Libdw.c
=====================================
@@ -290,7 +290,7 @@ static bool set_initial_registers(Dwfl_Thread *thread, void *arg);
#if defined(x86_64_HOST_ARCH)
static bool set_initial_registers(Dwfl_Thread *thread,
void *arg STG_UNUSED) {
- Dwarf_Word regs[17];
+ Dwarf_Word regs[17] = {};
__asm__ ("movq %%rax, 0x00(%0)\n\t"
"movq %%rdx, 0x08(%0)\n\t"
"movq %%rcx, 0x10(%0)\n\t"
@@ -318,7 +318,7 @@ static bool set_initial_registers(Dwfl_Thread *thread,
#elif defined(i386_HOST_ARCH)
static bool set_initial_registers(Dwfl_Thread *thread,
void *arg STG_UNUSED) {
- Dwarf_Word regs[9];
+ Dwarf_Word regs[9] = {};
__asm__ ("movl %%eax, 0x00(%0)\n\t"
"movl %%ecx, 0x04(%0)\n\t"
"movl %%edx, 0x08(%0)\n\t"
@@ -339,7 +339,7 @@ static bool set_initial_registers(Dwfl_Thread *thread,
#elif defined(s390x_HOST_ARCH)
static bool set_initial_registers(Dwfl_Thread *thread,
void *arg STG_UNUSED) {
- Dwarf_Word regs[32];
+ Dwarf_Word regs[32] = {};
__asm__ ("stmg %%r0,%%r15,0(%0)\n\t"
"std %%f0, 128(0,%0)\n\t"
"std %%f2, 136(0,%0)\n\t"
=====================================
rts/sm/Storage.c
=====================================
@@ -1404,7 +1404,10 @@ allocatePinned (Capability *cap, W_ n /*words*/, W_ alignment /*bytes*/, W_ alig
void
dirty_MUT_VAR(StgRegTable *reg, StgMutVar *mvar, StgClosure *old)
{
+#if defined(THREADED_RTS)
+ // This doesn't hold in the threaded RTS as we may race with another thread.
ASSERT(RELAXED_LOAD(&mvar->header.info) == &stg_MUT_VAR_CLEAN_info);
+#endif
Capability *cap = regTableToCapability(reg);
// No barrier required here as no other heap object fields are read. See
=====================================
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/-/compare/cc3ac0133babf3c5c67b24ac6380b29fb79f2840...808900997f0c99c387a8d61cf3d9a1f3ebc6da3a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cc3ac0133babf3c5c67b24ac6380b29fb79f2840...808900997f0c99c387a8d61cf3d9a1f3ebc6da3a
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/20221219/e6ec8e7a/attachment-0001.html>
More information about the ghc-commits
mailing list