{-# 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.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
-- 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
(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
$ 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
$ maybe id
docFlushRemaining
(srcSpanFileName_maybe loc)
$ moduleNameExportBridoc epAnn n les
ppBriDoc bd True
MEImportDecl importDecl immediateAfterComms ->
wrapNonDeclToBriDoc $ do
(bd, _) <-
briDocMToPPM
$ 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{} -> useTraceFunc traceFunc "MEDecl"
-- MEComment{} -> useTraceFunc traceFunc "MEComment"
-- 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
$ docSeq (briDocByExact 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
$ docSeq (innerDoc : map commentToDoc immediateAfterComms)
if errorCount == 0 then pure (r, 0) else briDocMToPPM $ briDocByExact 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
-- ++ ")!"