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