From 34c8fd93d73dbf4a11f3dffbf314501bb5eb5393 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 18 May 2023 17:05:41 +0200 Subject: [PATCH] Respect inline configs that happen to appear deep in AST comments between top-level decls should be considered for inline-config. But despite being placed between top-level decls, occasionally they get connected somewhere nested inside the AST of the first decl. We fix this by extracting such comments in a pre-processing step. The control flow was significantly altered to allow for this; before: parsing -> extract inline configs -> compute final config(s) -> split module into head/decls/comments/whitespace -> ... bridoc -> transformations -> printing after: parsing -> split module into head/decl/comments/whitespace -> extract inline configs respecting comments that got extracted from decls in the previous step -> compute final config(s) -> ... bridoc -> transformations -> printing --- .../Language/Haskell/Brittany/Internal.hs | 32 +- .../Brittany/Internal/Config/InlineParsing.hs | 52 +--- .../Brittany/Internal/S2_SplitModule.hs | 279 +++++++++--------- .../Brittany/Internal/StepOrchestrate.hs | 213 +++++++------ .../Haskell/Brittany/Internal/Types.hs | 5 +- .../library/Language/Haskell/Brittany/Main.hs | 12 +- 6 files changed, 308 insertions(+), 285 deletions(-) diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index bf201ca..fb460f3 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -10,6 +10,8 @@ module Language.Haskell.Brittany.Internal -- re-export from utils: , extractCommentConfigs , TraceFunc(TraceFunc) + , Splitting.splitModuleDecls + , Splitting.extractDeclMap ) where @@ -17,7 +19,6 @@ import Control.Monad.Trans.Except import Data.CZipWith import qualified Data.Text as Text import qualified Data.Text.Lazy as TextL -import qualified GHC hiding ( parseModule ) import qualified GHC.Driver.Session as GHC import GHC.Hs import qualified GHC.LanguageExtensions.Type as GHC @@ -29,6 +30,8 @@ import Language.Haskell.Brittany.Internal.S3_ToBriDocTools import Language.Haskell.Brittany.Internal.Prelude import qualified Language.Haskell.Brittany.Internal.S1_Parsing as Parsing +import qualified Language.Haskell.Brittany.Internal.S2_SplitModule + as Splitting import Language.Haskell.Brittany.Internal.StepOrchestrate ( processModule ) import Language.Haskell.Brittany.Internal.Types @@ -79,9 +82,13 @@ parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do case parseResult of Left err -> throwE [ErrorInput err] Right x -> pure x + let moduleElementList = Splitting.splitModuleDecls parsedSource (inlineConf, perItemConf) <- mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id) - $ extractCommentConfigs (useTraceFunc traceFunc) parsedSource + $ extractCommentConfigs + (useTraceFunc traceFunc) + (Splitting.extractDeclMap parsedSource) + moduleElementList let moduleConfig = cZipWith fromOptionIdentity config inlineConf let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack @@ -96,11 +103,12 @@ parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do & _econf_omit_output_valid_check & confUnpack (ews, outRaw) <- if hasCPP || omitCheck - then lift $ processModule traceFunc moduleConfig perItemConf parsedSource + then lift + $ processModule traceFunc moduleConfig perItemConf moduleElementList else lift $ pPrintModuleAndCheck traceFunc moduleConfig perItemConf - parsedSource + moduleElementList let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes @@ -134,11 +142,11 @@ pPrintModuleAndCheck :: TraceFunc -> Config -> PerItemConfig - -> GHC.ParsedSource + -> FinalList ModuleElement p -> IO ([BrittanyError], TextL.Text) -pPrintModuleAndCheck traceFunc conf inlineConf parsedModule = do +pPrintModuleAndCheck traceFunc conf inlineConf moduleElementList = do let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity - (errs, output) <- processModule traceFunc conf inlineConf parsedModule + (errs, output) <- processModule traceFunc conf inlineConf moduleElementList parseResult <- Parsing.parseModuleFromString ghcOptions "output" (\_ -> return $ Right ()) @@ -162,10 +170,14 @@ parsePrintModuleTests conf filename input = do case parseResult of Left err -> return $ Left err Right (parsedModule, _) -> runExceptT $ do + let moduleElementList = Splitting.splitModuleDecls parsedModule (inlineConf, perItemConf) <- mapExceptT (fmap (bimap (\(a, _) -> "when parsing inline config: " ++ a) id)) - $ extractCommentConfigs (\_ -> pure ()) parsedModule + $ extractCommentConfigs + (\_ -> pure ()) + (Splitting.extractDeclMap parsedModule) + moduleElementList let moduleConf = cZipWith fromOptionIdentity conf inlineConf let omitCheck = conf @@ -176,11 +188,11 @@ parsePrintModuleTests conf filename input = do then lift $ processModule (TraceFunc $ \_ -> pure ()) moduleConf perItemConf - parsedModule + moduleElementList else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ()) moduleConf perItemConf - parsedModule + moduleElementList if null errs then pure $ TextL.toStrict $ ltext else throwE diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/InlineParsing.hs b/source/library/Language/Haskell/Brittany/Internal/Config/InlineParsing.hs index 3138748..dd488ac 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/InlineParsing.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/InlineParsing.hs @@ -26,7 +26,7 @@ import Control.Monad.Trans.Except import Language.Haskell.Brittany.Internal.Config.Config import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Util.AST +import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Config.Types.Instances1 () import Language.Haskell.Brittany.Internal.Config.Types.Instances2 () -- import Language.Haskell.Brittany.Internal.Utils @@ -44,46 +44,26 @@ data InlineConfigTarget extractCommentConfigs :: (String -> IO ()) - -> GHC.ParsedSource + -> Map GHC.RealSrcSpan [String] + -> FinalList ModuleElement a -> ExceptT (String, String) IO (CConfig Maybe, PerItemConfig) -extractCommentConfigs _putErrorLn modul = do - let (L _ (GHC.HsModule modAnn _ _ _ _ decls _ _)) = modul - let declMap :: Map GHC.RealSrcSpan [String] - declMap = Map.fromList - [ ( case span of - GHC.RealSrcSpan s _ -> s - GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan" - , getDeclBindingNames decl - ) - | decl <- decls - , let (L (GHC.SrcSpanAnn _ span) _) = decl - ] - let epAnnComms = \case - GHC.EpAnn _ _ (GHC.EpaComments prior) -> prior - GHC.EpAnn _ _ (GHC.EpaCommentsBalanced prior following) -> - prior ++ following - GHC.EpAnnNotUsed -> [] - let gatheredComments = - join - $ epAnnComms modAnn - : [ epAnnComms epAnn | L (GHC.SrcSpanAnn epAnn _) _x <- decls ] - -- gatheredComments `forM_` \comm@(L anchor _) -> do - -- liftIO $ putErrorLn $ showOutputable comm - -- case Map.lookupLE (GHC.anchor anchor) declMap of - -- Nothing -> pure () - -- Just (pos, le) -> do - -- liftIO $ putErrorLn $ " le = " ++ show (toConstr le) ++ " at " ++ show - -- (ExactPrint.Utils.ss2deltaEnd pos (GHC.anchor anchor)) - -- case Map.lookupGE (GHC.anchor anchor) declMap of - -- Nothing -> pure () - -- Just (pos, ge) -> do - -- liftIO $ putErrorLn $ " ge = " ++ show (toConstr ge) ++ " at " ++ show - -- (ExactPrint.Utils.ss2deltaStart (GHC.anchor anchor) pos) +extractCommentConfigs _putErrorLn declMap moduleElementList = do + let comments = concatMapFinal (void moduleElementList) $ \case + MEExactModuleHead modul -> case GHC.hsmodAnn $ GHC.unLoc modul of + GHC.EpAnn _ _ (GHC.EpaComments prior) -> prior + GHC.EpAnn _ _ (GHC.EpaCommentsBalanced prior following) -> + prior ++ following + GHC.EpAnnNotUsed -> [] + MEPrettyModuleHead{} -> [] + MEImportDecl{} -> [] + MEDecl{} -> [] + MEComment (_, comment) -> [comment] + MEWhitespace{} -> [] lineConfigs <- sequence [ case Butcher.runCmdParserSimpleString line2 parser of Left err -> throwE (err, line2) Right (target, conf) -> pure $ (GHC.anchor anchr, target, conf) - | L anchr (EpaComment comm _) <- gatheredComments + | L anchr (EpaComment comm _) <- comments , Just line1 <- case comm of EpaLineComment l -> [ List.stripPrefix "-- BRITTANY" l diff --git a/source/library/Language/Haskell/Brittany/Internal/S2_SplitModule.hs b/source/library/Language/Haskell/Brittany/Internal/S2_SplitModule.hs index 7dc1deb..ba87065 100644 --- a/source/library/Language/Haskell/Brittany/Internal/S2_SplitModule.hs +++ b/source/library/Language/Haskell/Brittany/Internal/S2_SplitModule.hs @@ -3,15 +3,17 @@ -- TODO92 module Language.Haskell.Brittany.Internal.S2_SplitModule - ( splitModule - ) -where + ( extractDeclMap + , splitModuleDecls + , splitModuleStart + ) where import Language.Haskell.Brittany.Internal.Prelude import qualified Data.Generics as SYB +import qualified Data.Map as Map import qualified GHC import GHC ( AddEpAnn(AddEpAnn) , Anchor(Anchor) @@ -64,82 +66,96 @@ import qualified Language.Haskell.GHC.ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint import Safe ( maximumMay ) +import qualified Control.Monad.Trans.Writer.Strict + as WriterS import Language.Haskell.Brittany.Internal.Components.BriDoc import Language.Haskell.Brittany.Internal.ToBriDoc.Module import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Util.AST -splitModule - :: Bool - -> GHC.ParsedSource - -> Maybe GHC.RealSrcLoc - -> FinalList ModuleElement ExactPrint.Pos -splitModule shouldReformatHead lmod posWhere = do +extractDeclMap :: GHC.ParsedSource -> Map GHC.RealSrcSpan [String] +extractDeclMap modul = + Map.fromList + [ ( case span of + GHC.RealSrcSpan s _ -> s + GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan" + , getDeclBindingNames decl + ) + | decl <- decls + , let (L (GHC.SrcSpanAnn _ span) _) = decl + ] + where (L _ (GHC.HsModule _ _ _ _ _ decls _ _)) = modul + +splitModuleDecls :: GHC.ParsedSource -> FinalList ModuleElement ExactPrint.Pos +splitModuleDecls lmod = do let L moduleSpan modl = lmod - HsModule _ _layout _name _exports imports decls _ _ = modl + HsModule _ _layout _name _exports _imports decls _ _ = modl (hsModAnn', finalComments) = case GHC.hsmodAnn modl of EpAnn a modAnns (EpaCommentsBalanced prior post) -> (EpAnn a modAnns (EpaCommentsBalanced prior []), post) _ -> (GHC.hsmodAnn modl, []) - moduleWithoutComments = - L moduleSpan modl { GHC.hsmodAnn = hsModAnn', GHC.hsmodDecls = [] } - lastSpan <- if shouldReformatHead - then do - finalYield $ MEPrettyModuleHead moduleWithoutComments - let locBeforeImports = - maximumMay - $ [ realSrcSpanEnd $ anchor a - | L a _ <- case hsModAnn' of - EpAnn _ _ (EpaComments cs ) -> cs - EpAnn _ _ (EpaCommentsBalanced cs1 cs2) -> cs1 ++ cs2 - EpAnnNotUsed -> error "unexpected EpAnnNotUsed" - ] - ++ [ pos | Just pos <- [posWhere] ] - let (importLines, lastSpan) = finalToList $ transformToImportLine - ( maybe 0 srcLocLine locBeforeImports - , maybe 1 srcLocCol locBeforeImports - ) - imports - let commentedImports = groupifyImportLines importLines - sortCommentedImports commentedImports `forM_` \case - EmptyLines n -> - finalYield $ MEWhitespace $ DifferentLine n 1 - SamelineComment{} -> - error "brittany internal error: splitModule SamelineComment" - NewlineComment comm -> finalYield $ MEComment comm - ImportStatement record -> do - forM_ (commentsBefore record) $ finalYield . MEComment - finalYield - $ MEImportDecl (importStatement record) (commentsSameline record) - forM_ (commentsAfter record) $ finalYield . MEComment - pure $ lastSpan - else do - finalYield $ MEExactModuleHead moduleWithoutComments - pure - $ maybe (1, 1) (ExactPrint.ss2posEnd) - $ maximumMay - $ [ GHC.anchor a - | L a _ <- GHC.priorComments $ case hsModAnn' of - EpAnn _ _ cs -> cs - EpAnnNotUsed -> error "unexpected EpAnnNotUsed" - ] - ++ [ s | AddEpAnn _ (EpaSpan s) <- GHC.am_main $ GHC.anns hsModAnn' ] - ++ [ GHC.anchor a - | L da _ <- GHC.hsmodImports modl - , L a _ <- case GHC.ann da of - EpAnn _ _ (EpaComments l ) -> l - EpAnn _ _ (EpaCommentsBalanced _ l) -> l - EpAnnNotUsed -> [] - ] - ++ [ span - | L (SrcSpanAnn _ (GHC.RealSrcSpan span _)) _ <- GHC.hsmodImports - modl - ] + moduleWithoutComments = L moduleSpan modl { GHC.hsmodAnn = hsModAnn' + , GHC.hsmodDecls = [] + } + lastSpan <- do + finalYield $ MEExactModuleHead moduleWithoutComments + pure + $ maybe (1, 1) (ExactPrint.ss2posEnd) + $ maximumMay + $ [ GHC.anchor a + | L a _ <- GHC.priorComments $ case hsModAnn' of + EpAnn _ _ cs -> cs + EpAnnNotUsed -> error "unexpected EpAnnNotUsed" + ] + ++ [ s | AddEpAnn _ (EpaSpan s) <- GHC.am_main $ GHC.anns hsModAnn' ] + ++ [ GHC.anchor a + | L da _ <- GHC.hsmodImports modl + , L a _ <- case GHC.ann da of + EpAnn _ _ (EpaComments l ) -> l + EpAnn _ _ (EpaCommentsBalanced _ l) -> l + EpAnnNotUsed -> [] + ] + ++ [ span + | L (SrcSpanAnn _ (GHC.RealSrcSpan span _)) _ <- GHC.hsmodImports modl + ] spanAfterDecls <- enrichDecls lastSpan decls enrichComms spanAfterDecls finalComments +splitModuleStart + :: GHC.ParsedSource + -> Maybe GHC.RealSrcLoc + -> FinalList ModuleElement ExactPrint.Pos +splitModuleStart modul posWhere = do + finalYield $ MEPrettyModuleHead modul + let locBeforeImports = + maximumMay + $ [ realSrcSpanEnd $ anchor a + | L a _ <- case GHC.hsmodAnn $ unLoc modul of + EpAnn _ _ (EpaComments cs ) -> cs + EpAnn _ _ (EpaCommentsBalanced cs1 cs2) -> cs1 ++ cs2 + EpAnnNotUsed -> error "unexpected EpAnnNotUsed" + ] + ++ [ pos | Just pos <- [posWhere] ] + let (importLines, lastSpan) = finalToList $ transformToImportLine + ( maybe 0 srcLocLine locBeforeImports + , maybe 1 srcLocCol locBeforeImports + ) + (GHC.hsmodImports $ unLoc modul) + let commentedImports = groupifyImportLines importLines + sortCommentedImports commentedImports `forM_` \case + EmptyLines n -> finalYield $ MEWhitespace $ DifferentLine n 1 + SamelineComment{} -> + error "brittany internal error: splitModuleStart SamelineComment" + NewlineComment comm -> finalYield $ MEComment comm + ImportStatement record -> do + forM_ (commentsBefore record) $ finalYield . MEComment + finalYield $ MEImportDecl (importStatement record) + (commentsSameline record) + forM_ (commentsAfter record) $ finalYield . MEComment + pure $ lastSpan enrichComms :: ExactPrint.Pos -> [LEpaComment] -> FinalList ModuleElement ExactPrint.Pos @@ -150,60 +166,46 @@ enrichComms lastSpanEnd = \case SameLine i -> SameLine i DifferentLine l c -> DifferentLine (l - 1) c enrichComms (ExactPrint.ss2posEnd span) commRest - (L (Anchor span _) (EpaComment comm _) : commRest) -> do + lcomm@(L (Anchor span _) _) : commRest -> do case ExactPrint.ss2delta lastSpanEnd span of SameLine i -> do - finalYield $ MEComment (i, comm) + finalYield $ MEComment (i, lcomm) DifferentLine l c -> do finalYield $ MEWhitespace $ DifferentLine (l - 1) c - finalYield $ MEComment (0, comm) + finalYield $ MEComment (0, lcomm) enrichComms (ExactPrint.ss2posEnd span) commRest enrichDecls :: ExactPrint.Pos -> [LHsDecl GhcPs] -> FinalList ModuleElement ExactPrint.Pos enrichDecls lastSpanEnd = \case [] -> finalPure $ lastSpanEnd - L (SrcSpanAnn dAnn rlspan@(GHC.RealSrcSpan span _)) decl : declRest -> + ldecl@(L (SrcSpanAnn dAnn (GHC.RealSrcSpan span _)) _) : declRest -> case dAnn of - EpAnn dAnchor items (EpaComments dComments) -> do + EpAnn _dAnchor _items (EpaComments _dComments) -> do let - (innerComments, outerComments) = - partition - (\(L (Anchor anch _) _) -> - realSrcSpanStart anch < realSrcSpanEnd span - ) - dComments - withoutOuterComments = - (L - (SrcSpanAnn (EpAnn dAnchor items (EpaComments innerComments)) - rlspan - ) - decl - ) - commentExtract = \case - L (GHC.Anchor anch _) EpaComment{} -> ExactPrint.ss2posEnd anch - -- It would be really nice if `ExactPrint.ss2posEnd span` was - -- sufficient. But for some reason the comments are not - -- (consistently) included in the length of the anchor. I.e. - -- there are cases where a syntax tree node has an anchor from - -- pos A -> pos B. But then somewhere _below_ that node is a - -- comment that has an anchor pos B -> pos C. - -- We simply detect this here. - -- We probably do some redundant `SYB.everything` lookups - -- throughout the code now. But optimizing it is not easy, and - -- at worst it is larger constant factor on the size of the - -- input, so it isn't _that_ bad. - fixedSpanEnd = - SYB.everything - max - (SYB.mkQ (ExactPrint.ss2posEnd span) commentExtract) - decl + commentExtract + :: [LEpaComment] -> WriterS.Writer [LEpaComment] [LEpaComment] + commentExtract comms = do + let (innerComments, outerComments) = + partition + (\(L (Anchor anch _) _) -> + ( realSrcSpanStart anch < realSrcSpanEnd span + && realSrcSpanEnd anch > realSrcSpanStart span + ) + ) + comms + WriterS.tell outerComments + pure innerComments + (ldecl', extractedComments) = WriterS.runWriter + $ SYB.everywhereM (SYB.mkM commentExtract) ldecl case ExactPrint.ss2delta lastSpanEnd span of SameLine{} -> pure () DifferentLine n _ -> finalYield $ MEWhitespace $ DifferentLine (n - 1) 1 + let fixedSpanEnd = ExactPrint.ss2posEnd span let (afterComms, span2) = finalToList - $ enrichComms fixedSpanEnd (reverse outerComments) + $ enrichComms fixedSpanEnd + (List.sortOn (\(L l _) -> l) extractedComments) let (immediate, later) = List.span (\case @@ -212,8 +214,9 @@ enrichDecls lastSpanEnd = \case ) afterComms finalYield - $ MEDecl withoutOuterComments [ comm | MEComment comm <- immediate ] - -- $ MEDecl ldecl [] + $ MEDecl + ldecl' + [ (ind, GHC.ac_tok comm) | MEComment (ind, L _ comm) <- immediate ] later `forM_` finalYield enrichDecls span2 declRest EpAnn _anchor _items (EpaCommentsBalanced{}) -> @@ -227,8 +230,8 @@ enrichDecls lastSpanEnd = \case data ImportLine = EmptyLines Int - | SamelineComment (Int, EpaCommentTok) - | NewlineComment (Int, EpaCommentTok) -- indentation and comment + | SamelineComment (Int, LEpaComment) + | NewlineComment (Int, LEpaComment) -- indentation and comment | ImportStatement ImportStatementRecord instance Show ImportLine where @@ -241,10 +244,10 @@ instance Show ImportLine where (length $ commentsAfter r) data ImportStatementRecord = ImportStatementRecord - { commentsBefore :: [(Int, EpaCommentTok)] + { commentsBefore :: [(Int, LEpaComment)] , importStatement :: LImportDecl GhcPs , commentsSameline :: [(Int, EpaCommentTok)] - , commentsAfter :: [(Int, EpaCommentTok)] + , commentsAfter :: [(Int, LEpaComment)] } instance Show ImportStatementRecord where @@ -263,13 +266,13 @@ transformToImportLine startPos is = :: [LEpaComment] -> ExactPrint.Pos -> FinalList ImportLine ExactPrint.Pos flattenComms = \case [] -> finalPure - (L (Anchor span _) (EpaComment comm _) : commRest) -> \lastSpanEnd -> do + lcomm@(L (Anchor span _) _) : commRest -> \lastSpanEnd -> do case ExactPrint.ss2delta lastSpanEnd span of SameLine i -> do - finalYield $ SamelineComment (i, comm) + finalYield $ SamelineComment (i, lcomm) DifferentLine l c -> do finalYield $ EmptyLines (l - 1) - finalYield $ NewlineComment (c - 1, comm) + finalYield $ NewlineComment (c - 1, lcomm) flattenComms commRest (ExactPrint.ss2posEnd span) flattenDecls :: [LImportDecl GhcPs] @@ -278,43 +281,41 @@ transformToImportLine startPos is = flattenDecls = \case [] -> finalPure (L (SrcSpanAnn epAnn srcSpan@(RealSrcSpan declSpan _)) decl : declRest) - -> \lastSpanEnd -> + -> \lastSpanEnd -> let (commsBefore, commsAfter, cleanEpAnn) = case epAnn of EpAnn anch s (EpaComments cs) -> ([], reverse cs, EpAnn anch s (EpaComments [])) EpAnn anch s (EpaCommentsBalanced cs1 cs2) -> (reverse cs1, reverse cs2, EpAnn anch s (EpaComments [])) EpAnnNotUsed -> ([], [], EpAnnNotUsed) - in - do - span1 <- flattenComms commsBefore lastSpanEnd - let newlines = case ExactPrint.ss2delta span1 declSpan of - SameLine _ -> 0 - DifferentLine i _ -> i - 1 - finalYield - $ EmptyLines newlines - finalYield $ ImportStatement ImportStatementRecord - { commentsBefore = [] - , importStatement = L (SrcSpanAnn cleanEpAnn srcSpan) decl - , commentsSameline = [] - , commentsAfter = [] - } - span2 <- flattenComms commsAfter (ExactPrint.ss2posEnd declSpan) - flattenDecls declRest span2 + in do + span1 <- flattenComms commsBefore lastSpanEnd + let newlines = case ExactPrint.ss2delta span1 declSpan of + SameLine _ -> 0 + DifferentLine i _ -> i - 1 + finalYield $ EmptyLines newlines + finalYield $ ImportStatement ImportStatementRecord + { commentsBefore = [] + , importStatement = L (SrcSpanAnn cleanEpAnn srcSpan) decl + , commentsSameline = [] + , commentsAfter = [] + } + span2 <- flattenComms commsAfter (ExactPrint.ss2posEnd declSpan) + flattenDecls declRest span2 (L (SrcSpanAnn _epAnn UnhelpfulSpan{}) _decl : _declRest) -> error "UnhelpfulSpan" in flattenDecls is startPos -data Partial = PartialCommsOnly [(Int, EpaCommentTok)] +data Partial = PartialCommsOnly [(Int, LEpaComment)] | PartialImport ImportStatementRecord groupifyImportLines :: [ImportLine] -> [ImportLine] groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls where go acc [] = case acc of - PartialCommsOnly comms -> - reverse comms `forM_` \comm -> finalYield $ NewlineComment comm + PartialCommsOnly comms -> reverse comms `forM_` \comm -> + finalYield $ NewlineComment comm PartialImport partialRecord -> finalYield $ ImportStatement $ unpartial partialRecord go acc (line1 : lineR) = do @@ -326,9 +327,10 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls pure $ PartialCommsOnly [] SamelineComment comm -> do pure $ PartialCommsOnly (comm : comms) - NewlineComment comm -> pure $ PartialCommsOnly (comm : comms) - ImportStatement record -> - pure $ PartialImport $ record { commentsBefore = comms } + NewlineComment comm -> pure $ PartialCommsOnly (comm : comms) + ImportStatement record -> pure $ PartialImport $ record + { commentsBefore = comms + } PartialImport partialRecord -> case line1 of e@EmptyLines{} -> do finalYield $ ImportStatement $ unpartial partialRecord @@ -337,7 +339,8 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls SamelineComment comm -> do if (null $ commentsAfter partialRecord) then pure $ PartialImport partialRecord - { commentsSameline = comm : commentsSameline partialRecord + { commentsSameline = tokenOnly comm + : commentsSameline partialRecord } else pure $ PartialImport partialRecord { commentsAfter = comm : commentsAfter partialRecord @@ -353,6 +356,8 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls pure $ PartialImport $ record { commentsBefore = contestedComments } -- comments in between will stay connected to the following decl go newAcc lineR + tokenOnly :: (Int, LEpaComment) -> (Int, EpaCommentTok) + tokenOnly (ind, L _ (EpaComment tok _)) = (ind, tok) unpartial :: ImportStatementRecord -> ImportStatementRecord unpartial partialRecord = ImportStatementRecord { commentsBefore = reverse (commentsBefore partialRecord) @@ -365,7 +370,7 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls sortCommentedImports :: [ImportLine] -> [ImportLine] sortCommentedImports = -- TODO92 we don't need this unpackImports, it is implied later in the process - mergeGroups . map (fmap (sortGroups)) . groupify + mergeGroups . map (fmap (sortGroups)) . groupify where -- unpackImports :: [ImportLine] -> [ImportLine] -- unpackImports xs = xs >>= \case @@ -381,8 +386,8 @@ sortCommentedImports = Left x -> [x] Right y -> ImportStatement <$> y sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] - sortGroups = - List.sortOn (moduleNameString . unLoc . ideclName . unLoc . importStatement) + sortGroups = List.sortOn + (moduleNameString . unLoc . ideclName . unLoc . importStatement) groupify :: [ImportLine] -> [Either ImportLine [ImportStatementRecord]] groupify cs = go [] cs where diff --git a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs index 8ce57a3..ebc3fef 100644 --- a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs +++ b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs @@ -1,9 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany.Internal.StepOrchestrate ( processModule - ) -where + ) where import Language.Haskell.Brittany.Internal.Prelude @@ -15,7 +15,8 @@ import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy.Builder as TextL.Builder import qualified Data.Text.Lazy.Builder as Text.Builder import qualified GHC -import GHC ( EpaCommentTok +import GHC ( EpaComment(EpaComment) + , EpaCommentTok ( EpaBlockComment , EpaEofComment , EpaLineComment @@ -36,7 +37,7 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types.Instances2 ( ) import Language.Haskell.Brittany.Internal.S2_SplitModule - ( splitModule ) + ( splitModuleStart ) import Language.Haskell.Brittany.Internal.S3_ToBriDocTools import Language.Haskell.Brittany.Internal.S4_WriteBriDoc ( ppBriDoc ) @@ -46,7 +47,8 @@ import Language.Haskell.Brittany.Internal.ToBriDoc.Module import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Util.AST import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.ToBriDoc (layouters) +import Language.Haskell.Brittany.Internal.ToBriDoc + ( layouters ) @@ -58,86 +60,26 @@ processModule :: TraceFunc -> Config -> PerItemConfig - -> GHC.ParsedSource + -> FinalList ModuleElement p -> IO ([BrittanyError], TextL.Text) -processModule traceFunc conf inlineConf parsedModule = do - let shouldReformatHead = - conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack - let - wrapNonDeclToBriDoc = MultiRWSS.withMultiReader conf - . MultiRWSS.withMultiState_ (CommentCounter 0) - FinalList moduleElementsStream = splitModule - shouldReformatHead - parsedModule - (fmap GHC.realSrcSpanStart $ obtainAnnPos (GHC.hsmodAnn $ GHC.unLoc parsedModule) GHC.AnnWhere) - ((out, errs), debugStrings) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterW - $ MultiRWSS.withMultiReader traceFunc - $ moduleElementsStream - (\modElem cont -> do - case modElem of - MEExactModuleHead modHead -> wrapNonDeclToBriDoc $ do - bdMay <- ppModuleHead modHead - case bdMay of - Nothing -> pure () - Just bd -> ppBriDoc bd True - MEPrettyModuleHead (L loc modHead) -> wrapNonDeclToBriDoc $ do - case modHead of - HsModule epAnn _layoutInfo Nothing Nothing _ _ _ _ -> do - (bd, _) <- - briDocMToPPM layouters - $ maybe id - docFlushRemaining - (srcSpanFileName_maybe loc) - $ docHandleComms epAnn docSeparator - ppBriDoc bd True - HsModule _ _layoutInfo Nothing Just{} _ _ _ _ -> error - "brittany internal error: exports without module name" - HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do - (bd, _) <- - briDocMToPPM layouters - $ maybe id - docFlushRemaining - (srcSpanFileName_maybe loc) - $ moduleNameExportBridoc epAnn n les - ppBriDoc bd True - MEImportDecl importDecl immediateAfterComms -> - wrapNonDeclToBriDoc $ do - (bd, _) <- - briDocMToPPM layouters - $ docSeq - ( layoutImport importDecl - : map commentToDoc immediateAfterComms - ) - ppBriDoc bd False - MEDecl decl immediateAfterComms -> do - let declConfig = getDeclConfig conf inlineConf decl - MultiRWSS.withMultiReader declConfig - $ MultiRWSS.withMultiState_ (CommentCounter 0) - $ ppToplevelDecl decl immediateAfterComms - MEComment (ind, EpaLineComment str) -> do - mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str) - mTell $ TextL.Builder.fromString "\n" - MEComment (ind, EpaBlockComment str) -> do - mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str) - mTell $ TextL.Builder.fromString "\n" - MEComment (_, EpaEofComment) -> pure () - MEComment _ -> - mTell $ TextL.Builder.fromString "some other comment" - MEWhitespace dp -> do - -- mTell $ TextL.Builder.fromString "B" - -- mTell $ TextL.Builder.fromString ("whitespace " ++ show dp) - ppmMoveToExactLoc dp - cont - ) - (\x -> do +processModule traceFunc conf inlineConf moduleElems = do + let FinalList moduleElementsStream = moduleElems + ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader traceFunc + $ moduleElementsStream + (\modElem cont -> do + processModuleElement modElem + cont + ) + (\x -> do -- mTell $ TextL.Builder.fromString "\n" - pure x - ) + pure x + ) -- _tracer = -- -- if Seq.null debugStrings -- -- then id @@ -151,14 +93,94 @@ processModule traceFunc conf inlineConf parsedModule = do -- MEExactModuleHead{} -> useTraceFunc traceFunc "MEExactModuleHead" -- MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead" -- MEImportDecl{} -> useTraceFunc traceFunc "MEImportDecl" - -- MEDecl decl _ -> useTraceFunc traceFunc ("MEDecl " ++ intercalate "," (getDeclBindingNames decl)) - -- MEComment (y, EpaLineComment str) -> useTraceFunc traceFunc ("MEComment " ++ show y ++ " " ++ str) - -- MEComment (y, _) -> useTraceFunc traceFunc ("MEComment " ++ show y ++ " _") + -- MEDecl decl _ -> + -- useTraceFunc + -- traceFunc + -- ("MEDecl " ++ intercalate "," (getDeclBindingNames decl)) + -- MEComment (y, L _ (EpaComment (EpaLineComment str) _)) -> + -- useTraceFunc traceFunc ("MEComment " ++ show y ++ " " ++ str) + -- MEComment (y, L _ (EpaComment (EpaBlockComment str) _)) -> + -- useTraceFunc traceFunc ("MEComment " ++ show y ++ " " ++ take 5 str) + -- MEComment (y, _) -> + -- useTraceFunc traceFunc ("MEComment " ++ show y ++ " _") -- MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp) -- rest -- ) -- (\_ -> pure ()) pure (errs, TextL.Builder.toLazyText out) + where + shouldReformatHead = + conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack + wrapNonDeclToBriDoc = + MultiRWSS.withMultiReader conf . MultiRWSS.withMultiState_ + (CommentCounter 0) + processModuleElement + :: ModuleElement + -> MultiRWSS.MultiRWST + '[TraceFunc] + '[Text.Builder.Builder , [BrittanyError] , Seq String] + '[] + Identity + () + processModuleElement = \case + MEExactModuleHead modHead -> if shouldReformatHead + then do + let FinalList startElems = + splitModuleStart + modHead + ( fmap GHC.realSrcSpanStart + $ obtainAnnPos (GHC.hsmodAnn $ GHC.unLoc modHead) GHC.AnnWhere + ) + startElems + (\modElem cont -> do + processModuleElement modElem + cont + ) + (\_ -> pure ()) + else wrapNonDeclToBriDoc $ do + bdMay <- ppModuleHead modHead + case bdMay of + Nothing -> pure () + Just bd -> do + ppBriDoc bd True + mTell $ Text.Builder.fromString "\n" + MEPrettyModuleHead (L loc modHead) -> wrapNonDeclToBriDoc $ do + case modHead of + HsModule epAnn _layoutInfo Nothing Nothing _ _ _ _ -> do + (bd, _) <- + briDocMToPPM layouters + $ maybe id docFlushRemaining (srcSpanFileName_maybe loc) + $ docHandleComms epAnn docSeparator + ppBriDoc bd True + HsModule _ _layoutInfo Nothing Just{} _ _ _ _ -> + error "brittany internal error: exports without module name" + HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do + (bd, _) <- + briDocMToPPM layouters + $ maybe id docFlushRemaining (srcSpanFileName_maybe loc) + $ moduleNameExportBridoc epAnn n les + ppBriDoc bd True + MEImportDecl importDecl immediateAfterComms -> wrapNonDeclToBriDoc $ do + (bd, _) <- briDocMToPPM layouters $ docSeq + (layoutImport importDecl : map commentToDoc immediateAfterComms) + ppBriDoc bd False + MEDecl decl immediateAfterComms -> do + let declConfig = getDeclConfig conf inlineConf decl + MultiRWSS.withMultiReader declConfig + $ MultiRWSS.withMultiState_ (CommentCounter 0) + $ ppToplevelDecl decl immediateAfterComms + MEComment (ind, L _ (EpaComment (EpaLineComment str) _)) -> do + mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str) + mTell $ TextL.Builder.fromString "\n" + MEComment (ind, L _ (EpaComment (EpaBlockComment str) _)) -> do + mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str) + mTell $ TextL.Builder.fromString "\n" + MEComment (_, L _ (EpaComment EpaEofComment _)) -> pure () + MEComment _ -> mTell $ TextL.Builder.fromString "some other comment" + MEWhitespace dp -> do + -- mTell $ TextL.Builder.fromString "B" + -- mTell $ TextL.Builder.fromString ("whitespace " ++ show dp) + ppmMoveToExactLoc dp commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered commentToDoc (indent, c) = case c of @@ -198,17 +220,13 @@ processDefault x = do _ -> mTell $ Text.Builder.fromString $ List.dropWhileEnd ((==) '\n') str -getDeclConfig - :: Config - -> PerItemConfig - -> GHC.LHsDecl GhcPs - -> Config +getDeclConfig :: Config -> PerItemConfig -> GHC.LHsDecl GhcPs -> Config getDeclConfig config inlineConf decl = cZipWith fromOptionIdentity config $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) where declBindingNames = getDeclBindingNames decl - mBindingConfs = - declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf + mBindingConfs = declBindingNames <&> \n -> + Map.lookup n $ _icd_perBinding inlineConf mDeclConf = case GHC.locA $ GHC.getLoc decl of GHC.RealSrcSpan x _ -> Map.lookup x $ _icd_perAnchor inlineConf GHC.UnhelpfulSpan{} -> Nothing @@ -218,16 +236,15 @@ ppToplevelDecl decl immediateAfterComms = do exactprintOnly <- mAsk <&> \declConfig -> declConfig & _conf_roundtrip_exactprint_only & confUnpack bd <- fmap fst $ if exactprintOnly - then briDocMToPPM layouters - $ docSeq - (briDocByExactNoComment decl : map commentToDoc immediateAfterComms) + then briDocMToPPM layouters $ docSeq + (briDocByExactNoComment decl : map commentToDoc immediateAfterComms) else do let innerDoc = case decl of L (SrcSpanAnn _ (GHC.RealSrcSpan s _)) _ -> docFlushRemaining (GHC.srcSpanFile s) $ layoutDecl decl _ -> layoutDecl decl - (r, errorCount) <- briDocMToPPM layouters - $ docSeq (innerDoc : map commentToDoc immediateAfterComms) + (r, errorCount) <- briDocMToPPM layouters $ docSeq + (innerDoc : map commentToDoc immediateAfterComms) if errorCount == 0 then pure (r, 0) else briDocMToPPM layouters $ briDocByExactNoComment decl diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs index 83888b0..3f4ed1c 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs @@ -24,6 +24,7 @@ import GHC ( Anno , ParsedSource , XRec , LImportDecl + , LEpaComment ) import GHC.Utils.Outputable(Outputable) import Language.Haskell.Brittany.Internal.Config.Types @@ -89,6 +90,8 @@ finalToList_ :: FinalList a () -> [a] finalToList_ (FinalList l) = l (:) (\() -> []) finalToList :: FinalList a b -> ([a], b) finalToList (FinalList l) = l (\x (a, b) -> (x:a, b)) (\b -> ([], b)) +concatMapFinal :: FinalList a () -> (a -> [b]) -> [b] +concatMapFinal (FinalList l) f = l (\x rest -> f x ++ rest) (\() -> []) instance Functor (FinalList a) where fmap = _finalRMap @@ -119,7 +122,7 @@ data ModuleElement -- ^ an import decl, only occurs if pretty-printing the module head. | MEDecl (LHsDecl GhcPs) [(Int, EpaCommentTok)] -- ^ a top-level declaration - | MEComment (Int, EpaCommentTok) + | MEComment (Int, LEpaComment) -- ^ a top-level comment, i.e. a comment located between top-level elements -- (and not associated to some nested node, which might in theory happen). -- The Int carries the indentation of the comment. diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs index 466ede4..b8d8498 100644 --- a/source/library/Language/Haskell/Brittany/Main.hs +++ b/source/library/Language/Haskell/Brittany/Main.hs @@ -381,9 +381,15 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = putErrorLn left ExceptT.throwE 60 Right (parsedSource, hasCPP) -> do + let moduleElementList = splitModuleDecls parsedSource (inlineConf, perItemConf) <- do resE <- - liftIO $ ExceptT.runExceptT $ extractCommentConfigs putErrorLnIO parsedSource + liftIO + $ ExceptT.runExceptT + $ extractCommentConfigs + putErrorLnIO + (extractDeclMap parsedSource) + moduleElementList case resE of Left (err, input) -> do putErrorLn $ "Error: parse error in inline configuration:" @@ -414,9 +420,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = .> _econf_omit_output_valid_check .> confUnpack (ews, outRaw) <- if hasCPP || omitCheck - then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource + then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf moduleElementList else liftIO - $ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource + $ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf moduleElementList let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ")