{-# 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 -- ++ ")!"