diff options
25 files changed, 190 insertions, 209 deletions
diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index c327ff1fd4..eb66dc0f28 100644 --- a/compiler/GHC/Hs.hs +++ b/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 diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index cebeba3809..a64ee3f07e 100644 --- a/compiler/GHC/Parser.y +++ b/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 diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index dfccebce86..0f0f37075f 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/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) -> diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs index e783e90dd1..30ff00deed 100644 --- a/compiler/GHC/Types/SrcLoc.hs +++ b/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, diff --git a/testsuite/tests/ghc-api/exactprint/LocalDecls2.expected.hs b/testsuite/tests/ghc-api/exactprint/LocalDecls2.expected.hs index d2353e94c5..f015e958e9 100644 --- a/testsuite/tests/ghc-api/exactprint/LocalDecls2.expected.hs +++ b/testsuite/tests/ghc-api/exactprint/LocalDecls2.expected.hs @@ -4,5 +4,3 @@ foo a = bar a where nn :: Int nn = 2 - - diff --git a/testsuite/tests/ghc-api/exactprint/Test20239.stderr b/testsuite/tests/ghc-api/exactprint/Test20239.stderr index bcbb818b05..8bfb5085ce 100644 --- a/testsuite/tests/ghc-api/exactprint/Test20239.stderr +++ b/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) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr index 212f3f9bec..484a56ecc0 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr +++ b/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) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr index 28f3f4ef63..1efed5e02e 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr +++ b/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) diff --git a/testsuite/tests/module/mod185.stderr b/testsuite/tests/module/mod185.stderr index f5dbe2fa70..b9e5ee7849 100644 --- a/testsuite/tests/module/mod185.stderr +++ b/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) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index fdea6a5bce..1e48180185 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/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) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr index 0f451eeb14..6050639d73 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr +++ b/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) diff --git a/testsuite/tests/parser/should_compile/DumpSemis.stderr b/testsuite/tests/parser/should_compile/DumpSemis.stderr index faa926b6c4..4e283a73fe 100644 --- a/testsuite/tests/parser/should_compile/DumpSemis.stderr +++ b/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) diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index f9b9a986e4..df228cb912 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/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) diff --git a/testsuite/tests/parser/should_compile/T15323.stderr b/testsuite/tests/parser/should_compile/T15323.stderr index 36768671e4..a3bc49d34f 100644 --- a/testsuite/tests/parser/should_compile/T15323.stderr +++ b/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) diff --git a/testsuite/tests/parser/should_compile/T20452.stderr b/testsuite/tests/parser/should_compile/T20452.stderr index 0c2982dd9c..f05cef65b8 100644 --- a/testsuite/tests/parser/should_compile/T20452.stderr +++ b/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) diff --git a/testsuite/tests/parser/should_compile/T20718.stderr b/testsuite/tests/parser/should_compile/T20718.stderr index ab90eb29bc..bd071a0227 100644 --- a/testsuite/tests/parser/should_compile/T20718.stderr +++ b/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) diff --git a/testsuite/tests/parser/should_compile/T20718b.stderr b/testsuite/tests/parser/should_compile/T20718b.stderr index 79b5d67bb3..6370f1cbcc 100644 --- a/testsuite/tests/parser/should_compile/T20718b.stderr +++ b/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) diff --git a/testsuite/tests/parser/should_compile/T20846.stderr b/testsuite/tests/parser/should_compile/T20846.stderr index edacbd9ff6..7cb906a78a 100644 --- a/testsuite/tests/parser/should_compile/T20846.stderr +++ b/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) diff --git a/testsuite/tests/printer/T18791.stderr b/testsuite/tests/printer/T18791.stderr index 52c97faba4..28727aabf6 100644 --- a/testsuite/tests/printer/T18791.stderr +++ b/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) diff --git a/testsuite/tests/printer/Test20297.stdout b/testsuite/tests/printer/Test20297.stdout index 9a220e21db..df6f3347f9 100644 --- a/testsuite/tests/printer/Test20297.stdout +++ b/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) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 52fb4136ec..57389565b4 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/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 diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index 87921ac3e8..f286355cc1 100644 --- a/utils/check-exact/Main.hs +++ b/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 diff --git a/utils/check-exact/Orphans.hs b/utils/check-exact/Orphans.hs index 1403324861..f6000288b0 100644 --- a/utils/check-exact/Orphans.hs +++ b/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 diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs index 13c089eb71..3e3ebdcb39 100644 --- a/utils/check-exact/Transform.hs +++ b/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 diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs index 91d9cd5827..b60c989bcf 100644 --- a/utils/check-exact/Utils.hs +++ b/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)] |