Adapt Haddock to Logger and Parser changes (#1399)

1 files changed, 10 insertions, 7 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index d955ae4f..9158d83c 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -69,8 +69,10 @@ import Text.ParserCombinators.ReadP (readP_to_S)
 import GHC hiding (verbosity)
 import GHC.Settings.Config
 import GHC.Driver.Session hiding (projectVersion, verbosity)
+import GHC.Driver.Config.Logger (initLogFlags)
 import GHC.Driver.Env
 import GHC.Utils.Error
+import GHC.Utils.Logger
 import GHC.Types.Name.Cache
 import GHC.Unit
 import GHC.Utils.Panic (handleGhcException)
@@ -192,7 +194,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
       name_cache <- freshNameCache
       mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), path)] noChecks
       forM_ mIfaceFile $ \(_, ifaceFile) -> do
-        putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile)
+        putMsg logger $ renderJson (jsonInterfaceFile ifaceFile)
 
     if not (null files) then do
       (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
@@ -282,7 +284,7 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d
 -- | Render the interfaces with whatever backend is specified in the flags.
 render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
        -> [InstalledInterface] -> Map Module FilePath -> IO ()
-render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
+render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
 
   let
     title                = fromMaybe "" (optTitle flags)
@@ -298,6 +300,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
     dflags'
       | unicode          = gopt_set dflags Opt_PrintUnicodeSyntax
       | otherwise        = dflags
+    logger               = setLogFlags log' (initLogFlags dflags')
 
     visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
 
@@ -372,7 +375,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
   let withQuickjump = Flag_QuickJumpIndex `elem` flags
 
   when (Flag_GenIndex `elem` flags) $ do
-    withTiming logger dflags' "ppHtmlIndex" (const ()) $ do
+    withTiming logger "ppHtmlIndex" (const ()) $ do
       _ <- {-# SCC ppHtmlIndex #-}
            ppHtmlIndex odir title pkgStr
                   themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
@@ -382,7 +385,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
     copyHtmlBits odir libDir themes withQuickjump
 
   when (Flag_GenContents `elem` flags) $ do
-    withTiming logger dflags' "ppHtmlContents" (const ()) $ do
+    withTiming logger "ppHtmlContents" (const ()) $ do
       _ <- {-# SCC ppHtmlContents #-}
            ppHtmlContents unit_state odir title pkgStr
                      themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
@@ -392,7 +395,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
     copyHtmlBits odir libDir themes withQuickjump
 
   when (Flag_Html `elem` flags) $ do
-    withTiming logger dflags' "ppHtml" (const ()) $ do
+    withTiming logger "ppHtml" (const ()) $ do
       _ <- {-# SCC ppHtml #-}
            ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir
                   prologue
@@ -427,14 +430,14 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
           ]
 
   when (Flag_LaTeX `elem` flags) $ do
-    withTiming logger dflags' "ppLatex" (const ()) $ do
+    withTiming logger "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 logger dflags' "ppHyperlinkedSource" (const ()) $ do
+    withTiming logger "ppHyperlinkedSource" (const ()) $ do
       _ <- {-# SCC ppHyperlinkedSource #-}
            ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces
       return ()