Fix after NameCache changes

4 files changed, 36 insertions, 157 deletions

diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs
index 10d6849a..e5d84796 100644
--- a/haddock-api/src/Documentation/Haddock.hs
+++ b/haddock-api/src/Documentation/Haddock.hs
@@ -52,9 +52,7 @@ module Documentation.Haddock (
   -- * Interface files
   InterfaceFile(..),
   readInterfaceFile,
-  nameCacheFromGhc,
   freshNameCache,
-  NameCacheAccessor,
 
   -- * Flags and options
   Flag(..),
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."
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index d16aa24e..39be6762 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -9,6 +9,7 @@ module Haddock.Backends.Hyperlinker
 
 import Haddock.Types
 import Haddock.Utils (writeUtf8File, out, verbose, Verbosity)
+import Haddock.InterfaceFile
 import Haddock.Backends.Hyperlinker.Renderer
 import Haddock.Backends.Hyperlinker.Parser
 import Haddock.Backends.Hyperlinker.Types
@@ -20,7 +21,7 @@ import System.Directory
 import System.FilePath
 
 import GHC.Iface.Ext.Types  ( pattern HiePath, HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) )
-import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..))
+import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result )
 import GHC.Types.SrcLoc     ( realSrcLocSpan, mkRealSrcLoc )
 import Data.Map as M
 import GHC.Data.FastString     ( mkFastString )
@@ -58,15 +59,13 @@ ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interfa
 ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of
     Just hfp -> do
         -- Parse the GHC-produced HIE file
-        u <- mkSplitUniqSupply 'a'
-        let nc = (initNameCache u [])
-            ncu = NCU $ \f -> pure $ snd $ f nc
+        nc <- freshNameCache
         HieFile { hie_hs_file = file
                 , hie_asts = HieASTs asts
                 , hie_types = types
                 , hie_hs_src = rawSrc
                 } <- hie_file_result
-                 <$> (readHieFile ncu hfp)
+                 <$> (readHieFile nc hfp)
 
         -- Get the AST and tokens corresponding to the source file we want
         let fileFs = mkFastString file
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 211c7d55..7147dc9d 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -16,7 +16,7 @@
 -----------------------------------------------------------------------------
 module Haddock.InterfaceFile (
   InterfaceFile(..), ifUnitId, ifModule,
-  readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
+  readInterfaceFile, freshNameCache,
   writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
 ) where
 
@@ -32,7 +32,7 @@ import qualified Data.Map as Map
 import Data.Map (Map)
 import Data.Word
 
-import GHC.Iface.Binary (getSymtabName, getDictFastString)
+import GHC.Iface.Binary (getWithUserData, putSymbolTable)
 import GHC.Utils.Binary
 import GHC.Data.FastMutInt
 import GHC.Data.FastString
@@ -165,103 +165,32 @@ writeInterfaceFile filename iface = do
   return ()
 
 
-type NameCacheAccessor m = (m NameCache, NameCache -> m ())
-
-
-nameCacheFromGhc :: forall m. GhcMonad m => NameCacheAccessor m
-nameCacheFromGhc = ( read_from_session , write_to_session )
-  where
-    read_from_session = do
-       ref <- withSession (return . hsc_NC)
-       liftIO $ readIORef ref
-    write_to_session nc' = do
-       ref <- withSession (return . hsc_NC)
-       liftIO $ writeIORef ref nc'
-
-
-freshNameCache :: NameCacheAccessor IO
-freshNameCache = ( create_fresh_nc , \_ -> return () )
-  where
-    create_fresh_nc = do
-       u  <- mkSplitUniqSupply 'a' -- ??
-       return (initNameCache u [])
-
+freshNameCache :: IO NameCache
+freshNameCache = do
+  u  <- mkSplitUniqSupply 'a' -- ??
+  initNameCache u []
 
 -- | Read a Haddock (@.haddock@) interface file. Return either an
 -- 'InterfaceFile' or an error message.
 --
 -- This function can be called in two ways.  Within a GHC session it will
 -- update the use and update the session's name cache.  Outside a GHC session
--- a new empty name cache is used.  The function is therefore generic in the
--- monad being used.  The exact monad is whichever monad the first
--- argument, the getter and setter of the name cache, requires.
---
-readInterfaceFile :: forall m.
-                     MonadIO m
-                  => NameCacheAccessor m
+-- a new empty name cache is used.
+readInterfaceFile :: NameCache
                   -> FilePath
                   -> Bool  -- ^ Disable version check. Can cause runtime crash.
-                  -> m (Either String InterfaceFile)
-readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do
-  bh0 <- liftIO $ readBinMem filename
-
-  magic   <- liftIO $ get bh0
-  version <- liftIO $ get bh0
-
-  case () of
-    _ | magic /= binaryInterfaceMagic -> return . Left $
-      "Magic number mismatch: couldn't load interface file: " ++ filename
-      | not bypass_checks
-      , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $
-      "Interface file is of wrong version: " ++ filename
-      | otherwise -> with_name_cache $ \update_nc -> do
-
-      dict  <- get_dictionary bh0
-
-      -- read the symbol table so we are capable of reading the actual data
-      bh1 <- do
-          let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
-                                                   (getDictFastString dict)
-          symtab <- update_nc (get_symbol_table bh1)
-          return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab)
-                                                  (getDictFastString dict)
-
-      -- load the actual data
-      iface <- liftIO $ get bh1
-      return (Right iface)
- where
-   with_name_cache :: forall a.
-                      ((forall n b. MonadIO n
-                                => (NameCache -> n (NameCache, b))
-                                -> n b)
-                       -> m a)
-                   -> m a
-   with_name_cache act = do
-      nc_var <-  get_name_cache >>= (liftIO . newIORef)
-      x <- act $ \f -> do
-              nc <- liftIO $ readIORef nc_var
-              (nc', x) <- f nc
-              liftIO $ writeIORef nc_var nc'
-              return x
-      liftIO (readIORef nc_var) >>= set_name_cache
-      return x
-
-   get_dictionary bin_handle = liftIO $ do
-      dict_p <- get bin_handle
-      data_p <- tellBin bin_handle
-      seekBin bin_handle dict_p
-      dict <- getDictionary bin_handle
-      seekBin bin_handle data_p
-      return dict
-
-   get_symbol_table bh1 theNC = liftIO $ do
-      symtab_p <- get bh1
-      data_p'  <- tellBin bh1
-      seekBin bh1 symtab_p
-      (nc', symtab) <- getSymbolTable bh1 theNC
-      seekBin bh1 data_p'
-      return (nc', symtab)
-
+                  -> IO (Either String InterfaceFile)
+readInterfaceFile name_cache filename bypass_checks = do
+  bh <- readBinMem filename
+
+  magic   <- get bh
+  if magic /= binaryInterfaceMagic
+    then return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename
+    else do
+      version <- get bh
+      if not bypass_checks && (version `notElem` binaryInterfaceVersionCompatibility)
+        then return . Left $ "Interface file is of wrong version: " ++ filename
+        else Right <$> getWithUserData name_cache bh
 
 -------------------------------------------------------------------------------
 -- * Symbol table
@@ -312,56 +241,6 @@ data BinDictionary = BinDictionary {
                                 -- indexed by FastString
   }
 
-
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
-putSymbolTable bh next_off symtab = do
-  put_ bh next_off
-  let names = elems (array (0,next_off-1) (eltsUFM symtab))
-  mapM_ (\n -> serialiseName bh n symtab) names
-
-
-getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
-getSymbolTable bh namecache = do
-  sz <- get bh
-  od_names <- replicateM sz (get bh)
-  let arr = listArray (0,sz-1) names
-      (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names
-  return (namecache', arr)
-
-
-type OnDiskName = (Unit, ModuleName, OccName)
-
-
-fromOnDiskName
-   :: Array Int Name
-   -> NameCache
-   -> OnDiskName
-   -> (NameCache, Name)
-fromOnDiskName _ nc (pid, mod_name, occ) =
-  let
-        modu  = mkModule pid mod_name
-        cache = nsNames nc
-  in
-  case lookupOrigNameCache cache modu occ of
-     Just name -> (nc, name)
-     Nothing   ->
-        let
-                us        = nsUniqs nc
-                u         = uniqFromSupply us
-                name      = mkExternalName u modu occ noSrcSpan
-                new_cache = extendNameCache cache modu occ name
-        in
-        case splitUniqSupply us of { (us',_) ->
-        ( nc{ nsUniqs = us', nsNames = new_cache }, name )
-        }
-
-
-serialiseName :: BinHandle -> Name -> UniqFM Name (Int,Name) -> IO ()
-serialiseName bh name _ = do
-  let modu = nameModule name
-  put_ bh (moduleUnit modu, moduleName modu, nameOccName name)
-
-
 -------------------------------------------------------------------------------
 -- * GhcBinary instances
 -------------------------------------------------------------------------------