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
parent
91a8c23989
commit
a90550f62d
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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 ")
|
||||
|
|
|
|||
Loading…
Reference in New Issue