From a20b326ff0a7e4ce913af90f5cf968e312891643 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Thu, 4 Feb 2021 22:33:32 +0100
Subject: Fix after NameCache changes

---
 haddock-api/src/Haddock.hs | 21 ++++++++++++---------
 1 file changed, 12 insertions(+), 9 deletions(-)

(limited to 'haddock-api/src/Haddock.hs')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 8182707d..d955ae4f 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -71,6 +71,7 @@ import GHC.Settings.Config
 import GHC.Driver.Session hiding (projectVersion, verbosity)
 import GHC.Driver.Env
 import GHC.Utils.Error
+import GHC.Types.Name.Cache
 import GHC.Unit
 import GHC.Utils.Panic (handleGhcException)
 import GHC.Data.FastString
@@ -188,7 +189,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do
     unit_state <- hsc_units <$> getSession
 
     forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
-      mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
+      name_cache <- freshNameCache
+      mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), path)] noChecks
       forM_ mIfaceFile $ \(_, ifaceFile) -> do
         putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile)
 
@@ -210,7 +212,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do
         throwE "No input file(s)."
 
       -- Get packages supplied with --read-interface.
-      packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
+      name_cache <- liftIO $ freshNameCache
+      packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
 
       -- Render even though there are no input files (usually contents/index).
       liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages []
@@ -253,7 +256,8 @@ readPackagesAndProcessModules :: [Flag] -> [String]
 readPackagesAndProcessModules flags files = do
     -- Get packages supplied with --read-interface.
     let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
-    packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks
+    name_cache <- hsc_NC <$> getSession
+    packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
 
     -- Create the interfaces -- this is the core part of Haddock.
     let ifaceFiles = map snd packages
@@ -441,18 +445,17 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
 -------------------------------------------------------------------------------
 
 
-readInterfaceFiles :: MonadIO m
-                   => NameCacheAccessor m
+readInterfaceFiles :: NameCache
                    -> [(DocPaths, FilePath)]
                    -> Bool
-                   -> m [(DocPaths, InterfaceFile)]
-readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
+                   -> IO [(DocPaths, InterfaceFile)]
+readInterfaceFiles name_cache pairs bypass_version_check = do
   catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
   where
     -- try to read an interface, warn if we can't
     tryReadIface (paths, file) =
-      readInterfaceFile name_cache_accessor file bypass_version_check >>= \case
-        Left err -> liftIO $ do
+      readInterfaceFile name_cache file bypass_version_check >>= \case
+        Left err -> do
           putStrLn ("Warning: Cannot read " ++ file ++ ":")
           putStrLn ("   " ++ err)
           putStrLn "Skipping this interface."
-- 
cgit v1.2.3