{-# 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.Sequence as Seq
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 @Bool
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
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
HsModule _ _layoutInfo Nothing Just{} _ _ _ _ -> error
"brittany internal error: exports without module name"
HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do
let startDelta = obtainAnnDeltaPos epAnn GHC.AnnModule
tellDebugMess (show startDelta)
case startDelta of
Nothing -> pure ()
Just GHC.SameLine{} -> pure ()
Just (GHC.DifferentLine r _) ->
mTell $ TextL.Builder.fromString $ replicate (r - 1) '\n'
(bd, _) <-
briDocMToPPM
$ maybe id
docFlushRemaining
(srcSpanFileName_maybe loc)
$ moduleNameExportBridoc epAnn n les
ppBriDoc bd
MEImportDecl importDecl immediateAfterComms ->
wrapNonDeclToBriDoc $ do
(bd, _) <-
briDocMToPPM
$ docSeq
( layoutImport importDecl
: map commentToDoc immediateAfterComms
)
ppBriDoc bd
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 @Bool
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
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
-- ++ ")!"