Merge pull request #1310 from hsyl20/wip/hsyl20/logger2

Logger refactoring

3 files changed, 31 insertions, 26 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 2b6e2d57..49a63604 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -185,12 +185,13 @@ haddockWithGhc ghc args = handleTopExceptions $ do
 
   ghc flags' $ withDir $ do
     dflags <- getDynFlags
+    logger <- getLogger
     unit_state <- hsc_units <$> getSession
 
     forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
       mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
       forM_ mIfaceFile $ \(_, ifaceFile) -> do
-        logOutput dflags $ withPprStyle defaultUserStyle (renderJson (jsonInterfaceFile ifaceFile))
+        putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile)
 
     if not (null files) then do
       (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
@@ -203,7 +204,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
           }
 
       -- Render the interfaces.
-      liftIO $ renderStep dflags unit_state flags sinceQual qual packages ifaces
+      liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces
 
     else do
       when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
@@ -213,7 +214,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
       packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
 
       -- Render even though there are no input files (usually contents/index).
-      liftIO $ renderStep dflags unit_state flags sinceQual qual packages []
+      liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages []
 
 -- | Run the GHC action using a temporary output directory
 withTempOutputDir :: Ghc a -> Ghc a
@@ -262,9 +263,9 @@ readPackagesAndProcessModules flags files = do
     return (packages, ifaces, homeLinks)
 
 
-renderStep :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption
+renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption
            -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
-renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do
+renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do
   updateHTMLXRefs pkgs
   let
     ifaceFiles = map snd pkgs
@@ -273,12 +274,12 @@ renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do
       ((_, Just path), ifile) <- pkgs
       iface <- ifInstalledIfaces ifile
       return (instMod iface, path)
-  render dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
+  render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
 
 -- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
+render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
        -> [InstalledInterface] -> Map Module FilePath -> IO ()
-render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
+render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
 
   let
     title                = fromMaybe "" (optTitle flags)
@@ -368,7 +369,7 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap =
   let withQuickjump = Flag_QuickJumpIndex `elem` flags
 
   when (Flag_GenIndex `elem` flags) $ do
-    withTiming dflags' "ppHtmlIndex" (const ()) $ do
+    withTiming logger dflags' "ppHtmlIndex" (const ()) $ do
       _ <- {-# SCC ppHtmlIndex #-}
            ppHtmlIndex odir title pkgStr
                   themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
@@ -378,7 +379,7 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap =
     copyHtmlBits odir libDir themes withQuickjump
 
   when (Flag_GenContents `elem` flags) $ do
-    withTiming dflags' "ppHtmlContents" (const ()) $ do
+    withTiming logger dflags' "ppHtmlContents" (const ()) $ do
       _ <- {-# SCC ppHtmlContents #-}
            ppHtmlContents unit_state odir title pkgStr
                      themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
@@ -388,7 +389,7 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap =
     copyHtmlBits odir libDir themes withQuickjump
 
   when (Flag_Html `elem` flags) $ do
-    withTiming dflags' "ppHtml" (const ()) $ do
+    withTiming logger dflags' "ppHtml" (const ()) $ do
       _ <- {-# SCC ppHtml #-}
            ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir
                   prologue
@@ -423,14 +424,14 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap =
           ]
 
   when (Flag_LaTeX `elem` flags) $ do
-    withTiming dflags' "ppLatex" (const ()) $ do
+    withTiming logger dflags' "ppLatex" (const ()) $ do
       _ <- {-# SCC ppLatex #-}
            ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
                    libDir
       return ()
 
   when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do
-    withTiming dflags' "ppHyperlinkedSource" (const ()) $ do
+    withTiming logger dflags' "ppHyperlinkedSource" (const ()) $ do
       _ <- {-# SCC ppHyperlinkedSource #-}
            ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces
       return ()
@@ -469,7 +470,8 @@ readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
 -- compilation and linking. Then run the given 'Ghc' action.
 withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a
 withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
-  dynflags' <- parseGhcFlags =<< getSessionDynFlags
+  logger <- getLogger
+  dynflags' <- parseGhcFlags logger =<< getSessionDynFlags
 
   -- We disable pattern match warnings because than can be very
   -- expensive to check
@@ -493,8 +495,8 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
             go arg    func True = arg : func True
 
 
-    parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags
-    parseGhcFlags dynflags = do
+    parseGhcFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
+    parseGhcFlags logger dynflags = do
       -- TODO: handle warnings?
 
       let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock]
@@ -506,7 +508,7 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
                         }
           flags' = filterRtsFlags flags
 
-      (dynflags'', rest, _) <- parseDynamicFlags dynflags' (map noLoc flags')
+      (dynflags'', rest, _) <- parseDynamicFlags logger dynflags' (map noLoc flags')
       if not (null rest)
         then throwE ("Couldn't parse GHC options: " ++ unwords flags')
         else return dynflags''
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index f1403def..b4c20b99 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -59,15 +59,15 @@ import GHC.Data.Graph.Directed
 import GHC.Driver.Session hiding (verbosity)
 import GHC hiding (verbosity)
 import GHC.Driver.Env
-import GHC.Driver.Monad (Session(..), modifySession, reflectGhc)
+import GHC.Driver.Monad
 import GHC.Data.FastString (unpackFS)
+import GHC.Utils.Error
 import GHC.Tc.Types (TcM, TcGblEnv(..))
 import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv)
 import GHC.Tc.Utils.Env (tcLookupGlobal)
 import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
 import GHC.Types.Name.Occurrence (isTcOcc)
 import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts)
-import GHC.Utils.Error (withTimingD)
 import GHC.HsToCore.Docs
 import GHC.Runtime.Loader (initializePlugins)
 import GHC.Plugins (Outputable, StaticPlugin(..), Plugin(..), PluginWithArgs(..),
@@ -113,7 +113,7 @@ processModules verbosity modules flags extIfaces = do
       mods = Set.fromList $ map ifaceMod interfaces
   out verbosity verbose "Attaching instances..."
   interfaces' <- {-# SCC attachInstances #-}
-                 withTimingD "attachInstances" (const ()) $ do
+                 withTimingM "attachInstances" (const ()) $ do
                    attachInstances (exportedNames, mods) interfaces instIfaceMap ms
 
   out verbosity verbose "Building cross-linking environment..."
@@ -161,7 +161,7 @@ createIfaces verbosity modules flags instIfaceMap = do
   targets <- mapM (\filePath -> guessTarget filePath Nothing) modules
   setTargets targets
 
-  loadOk <- withTimingD "load" (const ()) $
+  loadOk <- withTimingM "load" (const ()) $
     {-# SCC load #-} GHC.load LoadAllTargets
 
   case loadOk of
@@ -212,7 +212,8 @@ plugin verbosity flags instIfaceMap = liftIO $ do
       | otherwise = do
           hsc_env <- getTopEnv
           ifaces <- liftIO $ readIORef ifaceMapRef
-          (iface, modules) <- withTimingD "processModule" (const ()) $
+          (iface, modules) <- withTiming (hsc_logger hsc_env) (hsc_dflags hsc_env)
+                                "processModule" (const ()) $
             processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env
 
           liftIO $ do
@@ -263,8 +264,11 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
 
     unit_state = hsc_units hsc_env
 
-  (!interface, messages) <- {-# SCC createInterface #-}
-    withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
+  (!interface, messages) <- do
+    logger <- getLogger
+    dflags <- getDynFlags
+    {-# SCC createInterface #-}
+     withTiming logger dflags "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
       createInterface1 flags unit_state mod_summary tc_gbl_env
         ifaces inst_ifaces
 
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 6ef0ed19..317258eb 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -127,9 +127,8 @@ attachToExportItem index expInfo getInstDoc getFixity export =
             cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]
             famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ]
         in do
-          dfs <- getDynFlags
           let mkBug = (text "haddock-bug:" <+>) . text
-          liftIO $ putMsg dfs (sep $ map mkBug famInstErrs)
+          putMsgM (sep $ map mkBug famInstErrs)
           return $ cls_insts ++ cleanFamInsts
       return $ e { expItemInstances = insts }
     e -> return e