255 lines
11 KiB
Haskell
255 lines
11 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
module Language.Haskell.Brittany.Internal.StepOrchestrate
|
|
( processModule
|
|
)
|
|
where
|
|
|
|
import Language.Haskell.Brittany.Internal.Prelude
|
|
|
|
import qualified Control.Monad.Trans.MultiRWS.Strict
|
|
as MultiRWSS
|
|
import Data.CZipWith
|
|
import qualified Data.Map.Strict as Map
|
|
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
|
|
( EpaBlockComment
|
|
, EpaEofComment
|
|
, EpaLineComment
|
|
)
|
|
, GenLocated(L)
|
|
, HsModule(HsModule)
|
|
, LHsDecl
|
|
, SrcSpanAnn'(SrcSpanAnn)
|
|
)
|
|
import qualified GHC.Types.SrcLoc as GHC
|
|
import qualified GHC.OldList as List
|
|
import GHC.Types.SrcLoc ( srcSpanFileName_maybe )
|
|
import qualified Language.Haskell.GHC.ExactPrint
|
|
as ExactPrint
|
|
|
|
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
|
import Language.Haskell.Brittany.Internal.Config.Types
|
|
import Language.Haskell.Brittany.Internal.Config.Types.Instances2
|
|
( )
|
|
import Language.Haskell.Brittany.Internal.S2_SplitModule
|
|
( splitModule )
|
|
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
|
import Language.Haskell.Brittany.Internal.S4_WriteBriDoc
|
|
( ppBriDoc )
|
|
import Language.Haskell.Brittany.Internal.ToBriDoc.Decl
|
|
import Language.Haskell.Brittany.Internal.ToBriDoc.Import
|
|
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)
|
|
|
|
|
|
|
|
-- BrittanyErrors can be non-fatal warnings, thus both are returned instead
|
|
-- of an Either.
|
|
-- This should be cleaned up once it is clear what kinds of errors really
|
|
-- can occur.
|
|
processModule
|
|
:: TraceFunc
|
|
-> Config
|
|
-> PerItemConfig
|
|
-> GHC.ParsedSource
|
|
-> 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
|
|
-- mTell $ TextL.Builder.fromString "\n"
|
|
pure x
|
|
)
|
|
-- _tracer =
|
|
-- -- if Seq.null debugStrings
|
|
-- -- then id
|
|
-- -- else
|
|
-- trace ("---- DEBUGMESSAGES ---- ")
|
|
-- . foldr (seq . join trace) id debugStrings
|
|
debugStrings `forM_` \s -> useTraceFunc traceFunc s
|
|
-- moduleElementsStream
|
|
-- (\el rest -> do
|
|
-- case el of
|
|
-- 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 ++ " _")
|
|
-- MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp)
|
|
-- rest
|
|
-- )
|
|
-- (\_ -> pure ())
|
|
pure (errs, TextL.Builder.toLazyText out)
|
|
|
|
commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered
|
|
commentToDoc (indent, c) = case c of
|
|
GHC.EpaDocCommentNext str -> docLitS (replicate indent ' ' ++ str)
|
|
GHC.EpaDocCommentPrev str -> docLitS (replicate indent ' ' ++ str)
|
|
GHC.EpaDocCommentNamed str -> docLitS (replicate indent ' ' ++ str)
|
|
GHC.EpaDocSection _ str -> docLitS (replicate indent ' ' ++ str)
|
|
GHC.EpaDocOptions str -> docLitS (replicate indent ' ' ++ str)
|
|
GHC.EpaLineComment str -> docLitS (replicate indent ' ' ++ str)
|
|
GHC.EpaBlockComment str -> docLitS (replicate indent ' ' ++ str)
|
|
GHC.EpaEofComment -> docEmpty
|
|
|
|
|
|
-- Prints the information associated with the module annotation
|
|
-- This includes the imports
|
|
-- This returns a `Maybe` because it only produces a BriDocNumbered if
|
|
-- re-formatting the module head is enabled. We maybe should change that
|
|
-- for consistency.
|
|
ppModuleHead :: GHC.ParsedSource -> PPMLocal (Maybe BriDocNumbered)
|
|
ppModuleHead lmod = do
|
|
processDefault lmod $> Nothing
|
|
|
|
processDefault
|
|
:: (ExactPrint.ExactPrint ast, MonadMultiWriter Text.Builder.Builder m)
|
|
-- , MonadMultiReader ExactPrint.Types.Anns m
|
|
=> GHC.Located ast
|
|
-> m ()
|
|
processDefault x = do
|
|
let str = ExactPrint.exactPrint x
|
|
-- this hack is here so our print-empty-module trick does not add
|
|
-- a newline at the start if there actually is no module header / imports
|
|
-- / anything.
|
|
-- TODO: instead the appropriate annotation could be removed when "cleaning"
|
|
-- the module (header). This would remove the need for this hack!
|
|
case str of
|
|
"\n" -> return ()
|
|
_ -> mTell $ Text.Builder.fromString $ List.dropWhileEnd ((==) '\n') str
|
|
|
|
|
|
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
|
|
mDeclConf = case GHC.locA $ GHC.getLoc decl of
|
|
GHC.RealSrcSpan x _ -> Map.lookup x $ _icd_perAnchor inlineConf
|
|
GHC.UnhelpfulSpan{} -> Nothing
|
|
|
|
ppToplevelDecl :: LHsDecl GhcPs -> [(Int, EpaCommentTok)] -> PPMLocal ()
|
|
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)
|
|
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)
|
|
if errorCount == 0
|
|
then pure (r, 0)
|
|
else briDocMToPPM layouters $ briDocByExactNoComment decl
|
|
ppBriDoc bd False
|
|
let commCntIn = connectedCommentCount decl
|
|
commCntOut <- mGet
|
|
when (commCntIn /= commCntOut) $ if commCntOut < commCntIn
|
|
then mTell
|
|
[ ErrorUnusedComments decl
|
|
(unCommentCounter commCntIn)
|
|
(unCommentCounter commCntOut)
|
|
]
|
|
else mTell
|
|
[ ErrorUnusedComments decl
|
|
(unCommentCounter commCntIn)
|
|
(unCommentCounter commCntOut)
|
|
]
|
|
-- error
|
|
-- $ "internal brittany error: inconsistent comment count ("
|
|
-- ++ show commCntOut
|
|
-- ++ ">"
|
|
-- ++ show commCntIn
|
|
-- ++ ")!"
|
|
|