Fix top-level comment position+whitespace bug

ghc92
Lennart Spitzner 2023-05-12 20:43:05 +00:00
parent 860c8771ae
commit e38836fdab
3 changed files with 42 additions and 16 deletions

View File

@ -993,3 +993,8 @@ func = do
doeeRbaviceQzymin a b = olivhuwqbaq doeeRbaviceQzymin a b = olivhuwqbaq
iqnz biwomeJhhujy _ _ | biwomeJhhujy < volpoqAsizmHdwpl = pure 0 iqnz biwomeJhhujy _ _ | biwomeJhhujy < volpoqAsizmHdwpl = pure 0
pure True pure True
#test comment-inside-decl
func False = 0
-- comment
func True = 1

View File

@ -56,7 +56,9 @@ import GHC.Parser.Annotation ( DeltaPos
) )
, EpaCommentTok(EpaEofComment) , EpaCommentTok(EpaEofComment)
) )
import GHC.Types.SrcLoc ( realSrcSpanEnd ) import GHC.Types.SrcLoc ( realSrcSpanEnd
, realSrcSpanStart
)
import qualified Language.Haskell.GHC.ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types
as ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Utils import qualified Language.Haskell.GHC.ExactPrint.Utils
@ -161,12 +163,23 @@ enrichDecls
:: ExactPrint.Pos -> [LHsDecl GhcPs] -> FinalList ModuleElement ExactPrint.Pos :: ExactPrint.Pos -> [LHsDecl GhcPs] -> FinalList ModuleElement ExactPrint.Pos
enrichDecls lastSpanEnd = \case enrichDecls lastSpanEnd = \case
[] -> finalPure $ lastSpanEnd [] -> finalPure $ lastSpanEnd
(L (SrcSpanAnn dAnn rlspan@(GHC.RealSrcSpan span _)) decl : declRest) -> L (SrcSpanAnn dAnn rlspan@(GHC.RealSrcSpan span _)) decl : declRest ->
case dAnn of case dAnn of
EpAnn dAnchor items (EpaComments dComments) -> do EpAnn dAnchor items (EpaComments dComments) -> do
let let
withoutComments = (innerComments, outerComments) =
(L (SrcSpanAnn (EpAnn dAnchor items (EpaComments [])) rlspan) decl) partition
(\(L (Anchor anch _) _) ->
realSrcSpanStart anch < realSrcSpanEnd span
)
dComments
withoutOuterComments =
(L
(SrcSpanAnn (EpAnn dAnchor items (EpaComments innerComments))
rlspan
)
decl
)
commentExtract = \case commentExtract = \case
L (GHC.Anchor anch _) EpaComment{} -> ExactPrint.ss2posEnd anch L (GHC.Anchor anch _) EpaComment{} -> ExactPrint.ss2posEnd anch
-- It would be really nice if `ExactPrint.ss2posEnd span` was -- It would be really nice if `ExactPrint.ss2posEnd span` was
@ -180,7 +193,8 @@ enrichDecls lastSpanEnd = \case
-- throughout the code now. But optimizing it is not easy, and -- throughout the code now. But optimizing it is not easy, and
-- at worst it is larger constant factor on the size of the -- at worst it is larger constant factor on the size of the
-- input, so it isn't _that_ bad. -- input, so it isn't _that_ bad.
fixedSpanEnd = SYB.everything fixedSpanEnd =
SYB.everything
max max
(SYB.mkQ (ExactPrint.ss2posEnd span) commentExtract) (SYB.mkQ (ExactPrint.ss2posEnd span) commentExtract)
decl decl
@ -188,12 +202,18 @@ enrichDecls lastSpanEnd = \case
SameLine{} -> pure () SameLine{} -> pure ()
DifferentLine n _ -> DifferentLine n _ ->
finalYield $ MEWhitespace $ DifferentLine (n - 1) 1 finalYield $ MEWhitespace $ DifferentLine (n - 1) 1
let (afterComms, span2) = finalToList $ enrichComms fixedSpanEnd (reverse dComments) let (afterComms, span2) = finalToList
let (immediate, later) = List.span (\case $ enrichComms fixedSpanEnd (reverse outerComments)
let (immediate, later) =
List.span
(\case
MEComment{} -> True MEComment{} -> True
_ -> False _ -> False
) afterComms )
finalYield $ MEDecl withoutComments [ comm | MEComment comm <- immediate ] afterComms
finalYield
$ MEDecl withoutOuterComments [ comm | MEComment comm <- immediate ]
-- $ MEDecl ldecl []
later `forM_` finalYield later `forM_` finalYield
enrichDecls span2 declRest enrichDecls span2 declRest
EpAnn _anchor _items (EpaCommentsBalanced{}) -> EpAnn _anchor _items (EpaCommentsBalanced{}) ->

View File

@ -151,8 +151,9 @@ processModule traceFunc conf inlineConf parsedModule = do
-- MEExactModuleHead{} -> useTraceFunc traceFunc "MEExactModuleHead" -- MEExactModuleHead{} -> useTraceFunc traceFunc "MEExactModuleHead"
-- MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead" -- MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead"
-- MEImportDecl{} -> useTraceFunc traceFunc "MEImportDecl" -- MEImportDecl{} -> useTraceFunc traceFunc "MEImportDecl"
-- MEDecl{} -> useTraceFunc traceFunc "MEDecl" -- MEDecl decl _ -> useTraceFunc traceFunc ("MEDecl " ++ intercalate "," (getDeclBindingNames decl))
-- MEComment{} -> useTraceFunc traceFunc "MEComment" -- MEComment (y, EpaLineComment str) -> useTraceFunc traceFunc ("MEComment " ++ show y ++ " " ++ str)
-- MEComment (y, _) -> useTraceFunc traceFunc ("MEComment " ++ show y ++ " _")
-- MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp) -- MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp)
-- rest -- rest
-- ) -- )