hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

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
ghc92
Lennart Spitzner 2023-05-18 17:05:41 +02:00
parent 91a8c23989
commit a90550f62d
6 changed files with 308 additions and 285 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
source/library/Language/Haskell/Brittany/Internal.hs
View File

@ -10,6 +10,8 @@ module Language.Haskell.Brittany.Internal
-- re-export from utils: -- re-export from utils:
, extractCommentConfigs , extractCommentConfigs
, TraceFunc(TraceFunc) , TraceFunc(TraceFunc)
, Splitting.splitModuleDecls
, Splitting.extractDeclMap
) )
where where
@ -17,7 +19,6 @@ import Control.Monad.Trans.Except
import Data.CZipWith import Data.CZipWith
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy as TextL
import qualified GHC hiding ( parseModule )
import qualified GHC.Driver.Session as GHC import qualified GHC.Driver.Session as GHC
import GHC.Hs import GHC.Hs
import qualified GHC.LanguageExtensions.Type as GHC 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 Language.Haskell.Brittany.Internal.Prelude
import qualified Language.Haskell.Brittany.Internal.S1_Parsing import qualified Language.Haskell.Brittany.Internal.S1_Parsing
as Parsing as Parsing
import qualified Language.Haskell.Brittany.Internal.S2_SplitModule
as Splitting
import Language.Haskell.Brittany.Internal.StepOrchestrate import Language.Haskell.Brittany.Internal.StepOrchestrate
( processModule ) ( processModule )
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
@ -79,9 +82,13 @@ parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
case parseResult of case parseResult of
Left err -> throwE [ErrorInput err] Left err -> throwE [ErrorInput err]
Right x -> pure x Right x -> pure x
let moduleElementList = Splitting.splitModuleDecls parsedSource
(inlineConf, perItemConf) <- (inlineConf, perItemConf) <-
mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id) 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 moduleConfig = cZipWith fromOptionIdentity config inlineConf
let disableFormatting = let disableFormatting =
moduleConfig & _conf_disable_formatting & confUnpack moduleConfig & _conf_disable_formatting & confUnpack
@ -96,11 +103,12 @@ parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
& _econf_omit_output_valid_check & _econf_omit_output_valid_check
& confUnpack & confUnpack
(ews, outRaw) <- if hasCPP || omitCheck (ews, outRaw) <- if hasCPP || omitCheck
then lift $ processModule traceFunc moduleConfig perItemConf parsedSource then lift
$ processModule traceFunc moduleConfig perItemConf moduleElementList
else lift $ pPrintModuleAndCheck traceFunc else lift $ pPrintModuleAndCheck traceFunc
moduleConfig moduleConfig
perItemConf perItemConf
parsedSource moduleElementList
let hackF s = fromMaybe s let hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes pure $ if hackAroundIncludes
@ -134,11 +142,11 @@ pPrintModuleAndCheck
:: TraceFunc :: TraceFunc
-> Config -> Config
-> PerItemConfig -> PerItemConfig
-> GHC.ParsedSource -> FinalList ModuleElement p
-> IO ([BrittanyError], TextL.Text) -> IO ([BrittanyError], TextL.Text)
pPrintModuleAndCheck traceFunc conf inlineConf parsedModule = do pPrintModuleAndCheck traceFunc conf inlineConf moduleElementList = do
let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity 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 parseResult <- Parsing.parseModuleFromString ghcOptions
"output" "output"
(\_ -> return $ Right ()) (\_ -> return $ Right ())
@ -162,10 +170,14 @@ parsePrintModuleTests conf filename input = do
case parseResult of case parseResult of
Left err -> return $ Left err Left err -> return $ Left err
Right (parsedModule, _) -> runExceptT $ do Right (parsedModule, _) -> runExceptT $ do
let moduleElementList = Splitting.splitModuleDecls parsedModule
(inlineConf, perItemConf) <- (inlineConf, perItemConf) <-
mapExceptT mapExceptT
(fmap (bimap (\(a, _) -> "when parsing inline config: " ++ a) id)) (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 moduleConf = cZipWith fromOptionIdentity conf inlineConf
let omitCheck = let omitCheck =
conf conf
@ -176,11 +188,11 @@ parsePrintModuleTests conf filename input = do
then lift $ processModule (TraceFunc $ \_ -> pure ()) then lift $ processModule (TraceFunc $ \_ -> pure ())
moduleConf moduleConf
perItemConf perItemConf
parsedModule moduleElementList
else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ()) else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ())
moduleConf moduleConf
perItemConf perItemConf
parsedModule moduleElementList
if null errs if null errs
then pure $ TextL.toStrict $ ltext then pure $ TextL.toStrict $ ltext
else throwE else throwE

52
source/library/Language/Haskell/Brittany/Internal/Config/InlineParsing.hs
View File

@ -26,7 +26,7 @@ import Control.Monad.Trans.Except
import Language.Haskell.Brittany.Internal.Config.Config import Language.Haskell.Brittany.Internal.Config.Config
import Language.Haskell.Brittany.Internal.Config.Types 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.Instances1 ()
import Language.Haskell.Brittany.Internal.Config.Types.Instances2 () import Language.Haskell.Brittany.Internal.Config.Types.Instances2 ()
-- import Language.Haskell.Brittany.Internal.Utils -- import Language.Haskell.Brittany.Internal.Utils
@ -44,46 +44,26 @@ data InlineConfigTarget
extractCommentConfigs extractCommentConfigs
:: (String -> IO ()) :: (String -> IO ())
-> GHC.ParsedSource -> Map GHC.RealSrcSpan [String]
-> FinalList ModuleElement a
-> ExceptT (String, String) IO (CConfig Maybe, PerItemConfig) -> ExceptT (String, String) IO (CConfig Maybe, PerItemConfig)
extractCommentConfigs _putErrorLn modul = do extractCommentConfigs _putErrorLn declMap moduleElementList = do
let (L _ (GHC.HsModule modAnn _ _ _ _ decls _ _)) = modul let comments = concatMapFinal (void moduleElementList) $ \case
let declMap :: Map GHC.RealSrcSpan [String] MEExactModuleHead modul -> case GHC.hsmodAnn $ GHC.unLoc modul of
declMap = Map.fromList GHC.EpAnn _ _ (GHC.EpaComments prior) -> prior
[ ( case span of GHC.EpAnn _ _ (GHC.EpaCommentsBalanced prior following) ->
GHC.RealSrcSpan s _ -> s prior ++ following
GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan" GHC.EpAnnNotUsed -> []
, getDeclBindingNames decl MEPrettyModuleHead{} -> []
) MEImportDecl{} -> []
| decl <- decls MEDecl{} -> []
, let (L (GHC.SrcSpanAnn _ span) _) = decl MEComment (_, comment) -> [comment]
] MEWhitespace{} -> []
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)
lineConfigs <- sequence lineConfigs <- sequence
[ case Butcher.runCmdParserSimpleString line2 parser of [ case Butcher.runCmdParserSimpleString line2 parser of
Left err -> throwE (err, line2) Left err -> throwE (err, line2)
Right (target, conf) -> pure $ (GHC.anchor anchr, target, conf) Right (target, conf) -> pure $ (GHC.anchor anchr, target, conf)
| L anchr (EpaComment comm _) <- gatheredComments | L anchr (EpaComment comm _) <- comments
, Just line1 <- case comm of , Just line1 <- case comm of
EpaLineComment l -> EpaLineComment l ->
[ List.stripPrefix "-- BRITTANY" l [ List.stripPrefix "-- BRITTANY" l

279
source/library/Language/Haskell/Brittany/Internal/S2_SplitModule.hs
View File

@ -3,15 +3,17 @@
-- TODO92 -- TODO92
module Language.Haskell.Brittany.Internal.S2_SplitModule module Language.Haskell.Brittany.Internal.S2_SplitModule
( splitModule ( extractDeclMap
) , splitModuleDecls
where , splitModuleStart
) where
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import qualified Data.Generics as SYB import qualified Data.Generics as SYB
import qualified Data.Map as Map
import qualified GHC import qualified GHC
import GHC ( AddEpAnn(AddEpAnn) import GHC ( AddEpAnn(AddEpAnn)
, Anchor(Anchor) , Anchor(Anchor)
@ -64,82 +66,96 @@ import qualified Language.Haskell.GHC.ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Utils import qualified Language.Haskell.GHC.ExactPrint.Utils
as ExactPrint as ExactPrint
import Safe ( maximumMay ) import Safe ( maximumMay )
import qualified Control.Monad.Trans.Writer.Strict
as WriterS
import Language.Haskell.Brittany.Internal.Components.BriDoc import Language.Haskell.Brittany.Internal.Components.BriDoc
import Language.Haskell.Brittany.Internal.ToBriDoc.Module import Language.Haskell.Brittany.Internal.ToBriDoc.Module
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Util.AST
splitModule extractDeclMap :: GHC.ParsedSource -> Map GHC.RealSrcSpan [String]
:: Bool extractDeclMap modul =
-> GHC.ParsedSource Map.fromList
-> Maybe GHC.RealSrcLoc [ ( case span of
-> FinalList ModuleElement ExactPrint.Pos GHC.RealSrcSpan s _ -> s
splitModule shouldReformatHead lmod posWhere = do 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 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 (hsModAnn', finalComments) = case GHC.hsmodAnn modl of
EpAnn a modAnns (EpaCommentsBalanced prior post) -> EpAnn a modAnns (EpaCommentsBalanced prior post) ->
(EpAnn a modAnns (EpaCommentsBalanced prior []), post) (EpAnn a modAnns (EpaCommentsBalanced prior []), post)
_ -> (GHC.hsmodAnn modl, []) _ -> (GHC.hsmodAnn modl, [])
moduleWithoutComments = moduleWithoutComments = L moduleSpan modl { GHC.hsmodAnn = hsModAnn'
L moduleSpan modl { GHC.hsmodAnn = hsModAnn', GHC.hsmodDecls = [] } , GHC.hsmodDecls = []
lastSpan <- if shouldReformatHead }
then do lastSpan <- do
finalYield $ MEPrettyModuleHead moduleWithoutComments finalYield $ MEExactModuleHead moduleWithoutComments
let locBeforeImports = pure
maximumMay $ maybe (1, 1) (ExactPrint.ss2posEnd)
$ [ realSrcSpanEnd $ anchor a $ maximumMay
| L a _ <- case hsModAnn' of $ [ GHC.anchor a
EpAnn _ _ (EpaComments cs ) -> cs | L a _ <- GHC.priorComments $ case hsModAnn' of
EpAnn _ _ (EpaCommentsBalanced cs1 cs2) -> cs1 ++ cs2 EpAnn _ _ cs -> cs
EpAnnNotUsed -> error "unexpected EpAnnNotUsed" EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
] ]
++ [ pos | Just pos <- [posWhere] ] ++ [ s | AddEpAnn _ (EpaSpan s) <- GHC.am_main $ GHC.anns hsModAnn' ]
let (importLines, lastSpan) = finalToList $ transformToImportLine ++ [ GHC.anchor a
( maybe 0 srcLocLine locBeforeImports | L da _ <- GHC.hsmodImports modl
, maybe 1 srcLocCol locBeforeImports , L a _ <- case GHC.ann da of
) EpAnn _ _ (EpaComments l ) -> l
imports EpAnn _ _ (EpaCommentsBalanced _ l) -> l
let commentedImports = groupifyImportLines importLines EpAnnNotUsed -> []
sortCommentedImports commentedImports `forM_` \case ]
EmptyLines n -> ++ [ span
finalYield $ MEWhitespace $ DifferentLine n 1 | L (SrcSpanAnn _ (GHC.RealSrcSpan span _)) _ <- GHC.hsmodImports modl
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
]
spanAfterDecls <- enrichDecls lastSpan decls spanAfterDecls <- enrichDecls lastSpan decls
enrichComms spanAfterDecls finalComments 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 enrichComms
:: ExactPrint.Pos -> [LEpaComment] -> FinalList ModuleElement ExactPrint.Pos :: ExactPrint.Pos -> [LEpaComment] -> FinalList ModuleElement ExactPrint.Pos
@ -150,60 +166,46 @@ enrichComms lastSpanEnd = \case
SameLine i -> SameLine i SameLine i -> SameLine i
DifferentLine l c -> DifferentLine (l - 1) c DifferentLine l c -> DifferentLine (l - 1) c
enrichComms (ExactPrint.ss2posEnd span) commRest enrichComms (ExactPrint.ss2posEnd span) commRest
(L (Anchor span _) (EpaComment comm _) : commRest) -> do lcomm@(L (Anchor span _) _) : commRest -> do
case ExactPrint.ss2delta lastSpanEnd span of case ExactPrint.ss2delta lastSpanEnd span of
SameLine i -> do SameLine i -> do
finalYield $ MEComment (i, comm) finalYield $ MEComment (i, lcomm)
DifferentLine l c -> do DifferentLine l c -> do
finalYield $ MEWhitespace $ DifferentLine (l - 1) c finalYield $ MEWhitespace $ DifferentLine (l - 1) c
finalYield $ MEComment (0, comm) finalYield $ MEComment (0, lcomm)
enrichComms (ExactPrint.ss2posEnd span) commRest enrichComms (ExactPrint.ss2posEnd span) commRest
enrichDecls 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 -> ldecl@(L (SrcSpanAnn dAnn (GHC.RealSrcSpan span _)) _) : declRest ->
case dAnn of case dAnn of
EpAnn dAnchor items (EpaComments dComments) -> do EpAnn _dAnchor _items (EpaComments _dComments) -> do
let let
(innerComments, outerComments) = commentExtract
partition :: [LEpaComment] -> WriterS.Writer [LEpaComment] [LEpaComment]
(\(L (Anchor anch _) _) -> commentExtract comms = do
realSrcSpanStart anch < realSrcSpanEnd span let (innerComments, outerComments) =
) partition
dComments (\(L (Anchor anch _) _) ->
withoutOuterComments = ( realSrcSpanStart anch < realSrcSpanEnd span
(L && realSrcSpanEnd anch > realSrcSpanStart span
(SrcSpanAnn (EpAnn dAnchor items (EpaComments innerComments)) )
rlspan )
) comms
decl WriterS.tell outerComments
) pure innerComments
commentExtract = \case (ldecl', extractedComments) = WriterS.runWriter
L (GHC.Anchor anch _) EpaComment{} -> ExactPrint.ss2posEnd anch $ SYB.everywhereM (SYB.mkM commentExtract) ldecl
-- 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
case ExactPrint.ss2delta lastSpanEnd span of case ExactPrint.ss2delta lastSpanEnd span of
SameLine{} -> pure () SameLine{} -> pure ()
DifferentLine n _ -> DifferentLine n _ ->
finalYield $ MEWhitespace $ DifferentLine (n - 1) 1 finalYield $ MEWhitespace $ DifferentLine (n - 1) 1
let fixedSpanEnd = ExactPrint.ss2posEnd span
let (afterComms, span2) = finalToList let (afterComms, span2) = finalToList
$ enrichComms fixedSpanEnd (reverse outerComments) $ enrichComms fixedSpanEnd
(List.sortOn (\(L l _) -> l) extractedComments)
let (immediate, later) = let (immediate, later) =
List.span List.span
(\case (\case
@ -212,8 +214,9 @@ enrichDecls lastSpanEnd = \case
) )
afterComms afterComms
finalYield finalYield
$ MEDecl withoutOuterComments [ comm | MEComment comm <- immediate ] $ MEDecl
-- $ MEDecl ldecl [] ldecl'
[ (ind, GHC.ac_tok comm) | MEComment (ind, L _ comm) <- immediate ]
later `forM_` finalYield later `forM_` finalYield
enrichDecls span2 declRest enrichDecls span2 declRest
EpAnn _anchor _items (EpaCommentsBalanced{}) -> EpAnn _anchor _items (EpaCommentsBalanced{}) ->
@ -227,8 +230,8 @@ enrichDecls lastSpanEnd = \case
data ImportLine data ImportLine
= EmptyLines Int = EmptyLines Int
| SamelineComment (Int, EpaCommentTok) | SamelineComment (Int, LEpaComment)
| NewlineComment (Int, EpaCommentTok) -- indentation and comment | NewlineComment (Int, LEpaComment) -- indentation and comment
| ImportStatement ImportStatementRecord | ImportStatement ImportStatementRecord
instance Show ImportLine where instance Show ImportLine where
@ -241,10 +244,10 @@ instance Show ImportLine where
(length $ commentsAfter r) (length $ commentsAfter r)
data ImportStatementRecord = ImportStatementRecord data ImportStatementRecord = ImportStatementRecord
{ commentsBefore :: [(Int, EpaCommentTok)] { commentsBefore :: [(Int, LEpaComment)]
, importStatement :: LImportDecl GhcPs , importStatement :: LImportDecl GhcPs
, commentsSameline :: [(Int, EpaCommentTok)] , commentsSameline :: [(Int, EpaCommentTok)]
, commentsAfter :: [(Int, EpaCommentTok)] , commentsAfter :: [(Int, LEpaComment)]
} }
instance Show ImportStatementRecord where instance Show ImportStatementRecord where
@ -263,13 +266,13 @@ transformToImportLine startPos is =
:: [LEpaComment] -> ExactPrint.Pos -> FinalList ImportLine ExactPrint.Pos :: [LEpaComment] -> ExactPrint.Pos -> FinalList ImportLine ExactPrint.Pos
flattenComms = \case flattenComms = \case
[] -> finalPure [] -> finalPure
(L (Anchor span _) (EpaComment comm _) : commRest) -> \lastSpanEnd -> do lcomm@(L (Anchor span _) _) : commRest -> \lastSpanEnd -> do
case ExactPrint.ss2delta lastSpanEnd span of case ExactPrint.ss2delta lastSpanEnd span of
SameLine i -> do SameLine i -> do
finalYield $ SamelineComment (i, comm) finalYield $ SamelineComment (i, lcomm)
DifferentLine l c -> do DifferentLine l c -> do
finalYield $ EmptyLines (l - 1) finalYield $ EmptyLines (l - 1)
finalYield $ NewlineComment (c - 1, comm) finalYield $ NewlineComment (c - 1, lcomm)
flattenComms commRest (ExactPrint.ss2posEnd span) flattenComms commRest (ExactPrint.ss2posEnd span)
flattenDecls flattenDecls
:: [LImportDecl GhcPs] :: [LImportDecl GhcPs]
@ -278,43 +281,41 @@ transformToImportLine startPos is =
flattenDecls = \case flattenDecls = \case
[] -> finalPure [] -> finalPure
(L (SrcSpanAnn epAnn srcSpan@(RealSrcSpan declSpan _)) decl : declRest) (L (SrcSpanAnn epAnn srcSpan@(RealSrcSpan declSpan _)) decl : declRest)
-> \lastSpanEnd -> -> \lastSpanEnd ->
let (commsBefore, commsAfter, cleanEpAnn) = case epAnn of let (commsBefore, commsAfter, cleanEpAnn) = case epAnn of
EpAnn anch s (EpaComments cs) -> EpAnn anch s (EpaComments cs) ->
([], reverse cs, EpAnn anch s (EpaComments [])) ([], reverse cs, EpAnn anch s (EpaComments []))
EpAnn anch s (EpaCommentsBalanced cs1 cs2) -> EpAnn anch s (EpaCommentsBalanced cs1 cs2) ->
(reverse cs1, reverse cs2, EpAnn anch s (EpaComments [])) (reverse cs1, reverse cs2, EpAnn anch s (EpaComments []))
EpAnnNotUsed -> ([], [], EpAnnNotUsed) EpAnnNotUsed -> ([], [], EpAnnNotUsed)
in in do
do span1 <- flattenComms commsBefore lastSpanEnd
span1 <- flattenComms commsBefore lastSpanEnd let newlines = case ExactPrint.ss2delta span1 declSpan of
let newlines = case ExactPrint.ss2delta span1 declSpan of SameLine _ -> 0
SameLine _ -> 0 DifferentLine i _ -> i - 1
DifferentLine i _ -> i - 1 finalYield $ EmptyLines newlines
finalYield finalYield $ ImportStatement ImportStatementRecord
$ EmptyLines newlines { commentsBefore = []
finalYield $ ImportStatement ImportStatementRecord , importStatement = L (SrcSpanAnn cleanEpAnn srcSpan) decl
{ commentsBefore = [] , commentsSameline = []
, importStatement = L (SrcSpanAnn cleanEpAnn srcSpan) decl , commentsAfter = []
, commentsSameline = [] }
, commentsAfter = [] span2 <- flattenComms commsAfter (ExactPrint.ss2posEnd declSpan)
} flattenDecls declRest span2
span2 <- flattenComms commsAfter (ExactPrint.ss2posEnd declSpan)
flattenDecls declRest span2
(L (SrcSpanAnn _epAnn UnhelpfulSpan{}) _decl : _declRest) -> (L (SrcSpanAnn _epAnn UnhelpfulSpan{}) _decl : _declRest) ->
error "UnhelpfulSpan" error "UnhelpfulSpan"
in in
flattenDecls is startPos flattenDecls is startPos
data Partial = PartialCommsOnly [(Int, EpaCommentTok)] data Partial = PartialCommsOnly [(Int, LEpaComment)]
| PartialImport ImportStatementRecord | PartialImport ImportStatementRecord
groupifyImportLines :: [ImportLine] -> [ImportLine] groupifyImportLines :: [ImportLine] -> [ImportLine]
groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
where where
go acc [] = case acc of go acc [] = case acc of
PartialCommsOnly comms -> PartialCommsOnly comms -> reverse comms `forM_` \comm ->
reverse comms `forM_` \comm -> finalYield $ NewlineComment comm finalYield $ NewlineComment comm
PartialImport partialRecord -> PartialImport partialRecord ->
finalYield $ ImportStatement $ unpartial partialRecord finalYield $ ImportStatement $ unpartial partialRecord
go acc (line1 : lineR) = do go acc (line1 : lineR) = do
@ -326,9 +327,10 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
pure $ PartialCommsOnly [] pure $ PartialCommsOnly []
SamelineComment comm -> do SamelineComment comm -> do
pure $ PartialCommsOnly (comm : comms) pure $ PartialCommsOnly (comm : comms)
NewlineComment comm -> pure $ PartialCommsOnly (comm : comms) NewlineComment comm -> pure $ PartialCommsOnly (comm : comms)
ImportStatement record -> ImportStatement record -> pure $ PartialImport $ record
pure $ PartialImport $ record { commentsBefore = comms } { commentsBefore = comms
}
PartialImport partialRecord -> case line1 of PartialImport partialRecord -> case line1 of
e@EmptyLines{} -> do e@EmptyLines{} -> do
finalYield $ ImportStatement $ unpartial partialRecord finalYield $ ImportStatement $ unpartial partialRecord
@ -337,7 +339,8 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
SamelineComment comm -> do SamelineComment comm -> do
if (null $ commentsAfter partialRecord) if (null $ commentsAfter partialRecord)
then pure $ PartialImport partialRecord then pure $ PartialImport partialRecord
{ commentsSameline = comm : commentsSameline partialRecord { commentsSameline = tokenOnly comm
: commentsSameline partialRecord
} }
else pure $ PartialImport partialRecord else pure $ PartialImport partialRecord
{ commentsAfter = comm : commentsAfter partialRecord { commentsAfter = comm : commentsAfter partialRecord
@ -353,6 +356,8 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
pure $ PartialImport $ record { commentsBefore = contestedComments } pure $ PartialImport $ record { commentsBefore = contestedComments }
-- comments in between will stay connected to the following decl -- comments in between will stay connected to the following decl
go newAcc lineR go newAcc lineR
tokenOnly :: (Int, LEpaComment) -> (Int, EpaCommentTok)
tokenOnly (ind, L _ (EpaComment tok _)) = (ind, tok)
unpartial :: ImportStatementRecord -> ImportStatementRecord unpartial :: ImportStatementRecord -> ImportStatementRecord
unpartial partialRecord = ImportStatementRecord unpartial partialRecord = ImportStatementRecord
{ commentsBefore = reverse (commentsBefore partialRecord) { commentsBefore = reverse (commentsBefore partialRecord)
@ -365,7 +370,7 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
sortCommentedImports :: [ImportLine] -> [ImportLine] sortCommentedImports :: [ImportLine] -> [ImportLine]
sortCommentedImports = sortCommentedImports =
-- TODO92 we don't need this unpackImports, it is implied later in the process -- 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 where
-- unpackImports :: [ImportLine] -> [ImportLine] -- unpackImports :: [ImportLine] -> [ImportLine]
-- unpackImports xs = xs >>= \case -- unpackImports xs = xs >>= \case
@ -381,8 +386,8 @@ sortCommentedImports =
Left x -> [x] Left x -> [x]
Right y -> ImportStatement <$> y Right y -> ImportStatement <$> y
sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
sortGroups = sortGroups = List.sortOn
List.sortOn (moduleNameString . unLoc . ideclName . unLoc . importStatement) (moduleNameString . unLoc . ideclName . unLoc . importStatement)
groupify :: [ImportLine] -> [Either ImportLine [ImportStatementRecord]] groupify :: [ImportLine] -> [Either ImportLine [ImportStatementRecord]]
groupify cs = go [] cs groupify cs = go [] cs
where where

213
source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs
View File

@ -1,9 +1,9 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
module Language.Haskell.Brittany.Internal.StepOrchestrate module Language.Haskell.Brittany.Internal.StepOrchestrate
( processModule ( processModule
) ) where
where
import Language.Haskell.Brittany.Internal.Prelude 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 TextL.Builder
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified GHC import qualified GHC
import GHC ( EpaCommentTok import GHC ( EpaComment(EpaComment)
, EpaCommentTok
( EpaBlockComment ( EpaBlockComment
, EpaEofComment , EpaEofComment
, EpaLineComment , 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.Config.Types.Instances2
( ) ( )
import Language.Haskell.Brittany.Internal.S2_SplitModule import Language.Haskell.Brittany.Internal.S2_SplitModule
( splitModule ) ( splitModuleStart )
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
import Language.Haskell.Brittany.Internal.S4_WriteBriDoc import Language.Haskell.Brittany.Internal.S4_WriteBriDoc
( ppBriDoc ) ( ppBriDoc )
@ -46,7 +47,8 @@ import Language.Haskell.Brittany.Internal.ToBriDoc.Module
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Util.AST import Language.Haskell.Brittany.Internal.Util.AST
import Language.Haskell.Brittany.Internal.Utils 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 :: TraceFunc
-> Config -> Config
-> PerItemConfig -> PerItemConfig
-> GHC.ParsedSource -> FinalList ModuleElement p
-> IO ([BrittanyError], TextL.Text) -> IO ([BrittanyError], TextL.Text)
processModule traceFunc conf inlineConf parsedModule = do processModule traceFunc conf inlineConf moduleElems = do
let shouldReformatHead = let FinalList moduleElementsStream = moduleElems
conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack ((out, errs), debugStrings) =
let runIdentity
wrapNonDeclToBriDoc = MultiRWSS.withMultiReader conf $ MultiRWSS.runMultiRWSTNil
. MultiRWSS.withMultiState_ (CommentCounter 0) $ MultiRWSS.withMultiWriterAW
FinalList moduleElementsStream = splitModule $ MultiRWSS.withMultiWriterAW
shouldReformatHead $ MultiRWSS.withMultiWriterW
parsedModule $ MultiRWSS.withMultiReader traceFunc
(fmap GHC.realSrcSpanStart $ obtainAnnPos (GHC.hsmodAnn $ GHC.unLoc parsedModule) GHC.AnnWhere) $ moduleElementsStream
((out, errs), debugStrings) = (\modElem cont -> do
runIdentity processModuleElement modElem
$ MultiRWSS.runMultiRWSTNil cont
$ MultiRWSS.withMultiWriterAW )
$ MultiRWSS.withMultiWriterAW (\x -> do
$ 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
-- mTell $ TextL.Builder.fromString "\n" -- mTell $ TextL.Builder.fromString "\n"
pure x pure x
) )
-- _tracer = -- _tracer =
-- -- if Seq.null debugStrings -- -- if Seq.null debugStrings
-- -- then id -- -- then id
@ -151,14 +93,94 @@ 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 decl _ -> useTraceFunc traceFunc ("MEDecl " ++ intercalate "," (getDeclBindingNames decl)) -- MEDecl decl _ ->
-- MEComment (y, EpaLineComment str) -> useTraceFunc traceFunc ("MEComment " ++ show y ++ " " ++ str) -- useTraceFunc
-- MEComment (y, _) -> useTraceFunc traceFunc ("MEComment " ++ show y ++ " _") -- 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) -- MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp)
-- rest -- rest
-- ) -- )
-- (\_ -> pure ()) -- (\_ -> pure ())
pure (errs, TextL.Builder.toLazyText out) 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 :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered
commentToDoc (indent, c) = case c of commentToDoc (indent, c) = case c of
@ -198,17 +220,13 @@ processDefault x = do
_ -> mTell $ Text.Builder.fromString $ List.dropWhileEnd ((==) '\n') str _ -> mTell $ Text.Builder.fromString $ List.dropWhileEnd ((==) '\n') str
getDeclConfig getDeclConfig :: Config -> PerItemConfig -> GHC.LHsDecl GhcPs -> Config
:: Config
-> PerItemConfig
-> GHC.LHsDecl GhcPs
-> Config
getDeclConfig config inlineConf decl = cZipWith fromOptionIdentity config getDeclConfig config inlineConf decl = cZipWith fromOptionIdentity config
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
where where
declBindingNames = getDeclBindingNames decl declBindingNames = getDeclBindingNames decl
mBindingConfs = mBindingConfs = declBindingNames <&> \n ->
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf Map.lookup n $ _icd_perBinding inlineConf
mDeclConf = case GHC.locA $ GHC.getLoc decl of mDeclConf = case GHC.locA $ GHC.getLoc decl of
GHC.RealSrcSpan x _ -> Map.lookup x $ _icd_perAnchor inlineConf GHC.RealSrcSpan x _ -> Map.lookup x $ _icd_perAnchor inlineConf
GHC.UnhelpfulSpan{} -> Nothing GHC.UnhelpfulSpan{} -> Nothing
@ -218,16 +236,15 @@ ppToplevelDecl decl immediateAfterComms = do
exactprintOnly <- mAsk <&> \declConfig -> exactprintOnly <- mAsk <&> \declConfig ->
declConfig & _conf_roundtrip_exactprint_only & confUnpack declConfig & _conf_roundtrip_exactprint_only & confUnpack
bd <- fmap fst $ if exactprintOnly bd <- fmap fst $ if exactprintOnly
then briDocMToPPM layouters then briDocMToPPM layouters $ docSeq
$ docSeq (briDocByExactNoComment decl : map commentToDoc immediateAfterComms)
(briDocByExactNoComment decl : map commentToDoc immediateAfterComms)
else do else do
let innerDoc = case decl of let innerDoc = case decl of
L (SrcSpanAnn _ (GHC.RealSrcSpan s _)) _ -> L (SrcSpanAnn _ (GHC.RealSrcSpan s _)) _ ->
docFlushRemaining (GHC.srcSpanFile s) $ layoutDecl decl docFlushRemaining (GHC.srcSpanFile s) $ layoutDecl decl
_ -> layoutDecl decl _ -> layoutDecl decl
(r, errorCount) <- briDocMToPPM layouters (r, errorCount) <- briDocMToPPM layouters $ docSeq
$ docSeq (innerDoc : map commentToDoc immediateAfterComms) (innerDoc : map commentToDoc immediateAfterComms)
if errorCount == 0 if errorCount == 0
then pure (r, 0) then pure (r, 0)
else briDocMToPPM layouters $ briDocByExactNoComment decl else briDocMToPPM layouters $ briDocByExactNoComment decl

5
source/library/Language/Haskell/Brittany/Internal/Types.hs
View File

@ -24,6 +24,7 @@ import GHC ( Anno
, ParsedSource , ParsedSource
, XRec , XRec
, LImportDecl , LImportDecl
, LEpaComment
) )
import GHC.Utils.Outputable(Outputable) import GHC.Utils.Outputable(Outputable)
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
@ -89,6 +90,8 @@ finalToList_ :: FinalList a () -> [a]
finalToList_ (FinalList l) = l (:) (\() -> []) finalToList_ (FinalList l) = l (:) (\() -> [])
finalToList :: FinalList a b -> ([a], b) finalToList :: FinalList a b -> ([a], b)
finalToList (FinalList l) = l (\x (a, b) -> (x:a, b)) (\b -> ([], 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 instance Functor (FinalList a) where
fmap = _finalRMap fmap = _finalRMap
@ -119,7 +122,7 @@ data ModuleElement
-- ^ an import decl, only occurs if pretty-printing the module head. -- ^ an import decl, only occurs if pretty-printing the module head.
| MEDecl (LHsDecl GhcPs) [(Int, EpaCommentTok)] | MEDecl (LHsDecl GhcPs) [(Int, EpaCommentTok)]
-- ^ a top-level declaration -- ^ a top-level declaration
| MEComment (Int, EpaCommentTok) | MEComment (Int, LEpaComment)
-- ^ a top-level comment, i.e. a comment located between top-level elements -- ^ 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). -- (and not associated to some nested node, which might in theory happen).
-- The Int carries the indentation of the comment. -- The Int carries the indentation of the comment.

12
source/library/Language/Haskell/Brittany/Main.hs
View File

@ -381,9 +381,15 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
putErrorLn left putErrorLn left
ExceptT.throwE 60 ExceptT.throwE 60
Right (parsedSource, hasCPP) -> do Right (parsedSource, hasCPP) -> do
let moduleElementList = splitModuleDecls parsedSource
(inlineConf, perItemConf) <- do (inlineConf, perItemConf) <- do
resE <- resE <-
liftIO $ ExceptT.runExceptT $ extractCommentConfigs putErrorLnIO parsedSource liftIO
$ ExceptT.runExceptT
$ extractCommentConfigs
putErrorLnIO
(extractDeclMap parsedSource)
moduleElementList
case resE of case resE of
Left (err, input) -> do Left (err, input) -> do
putErrorLn $ "Error: parse error in inline configuration:" putErrorLn $ "Error: parse error in inline configuration:"
@ -414,9 +420,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
.> _econf_omit_output_valid_check .> _econf_omit_output_valid_check
.> confUnpack .> confUnpack
(ews, outRaw) <- if hasCPP || omitCheck (ews, outRaw) <- if hasCPP || omitCheck
then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf moduleElementList
else liftIO else liftIO
$ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource $ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf moduleElementList
let let
hackF s = fromMaybe s $ TextL.stripPrefix hackF s = fromMaybe s $ TextL.stripPrefix
(TextL.pack "-- BRITANY_INCLUDE_HACK ") (TextL.pack "-- BRITANY_INCLUDE_HACK ")