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