From 6b31cd2c50be41cb3b7e3f85f6b0485dcbcae9f3 Mon Sep 17 00:00:00 2001
From: David Waern <davve@dtek.chalmers.se>
Date: Thu, 8 Nov 2007 01:45:13 +0000
Subject: Synch loading of names from .haddock files with GHC's name cache

---
 src/Haddock/InterfaceFile.hs | 20 ++++++++++++--------
 src/Main.hs                  |  8 ++++----
 2 files changed, 16 insertions(+), 12 deletions(-)

diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 93d6fe4c..92dc371b 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -115,9 +115,9 @@ writeInterfaceFile filename iface = do
   writeBinMem bh filename
   return ()
 
-    
-readInterfaceFile :: FilePath -> IO (Either String InterfaceFile)
-readInterfaceFile filename = do
+
+readInterfaceFile :: Session -> FilePath -> IO (Either String InterfaceFile)
+readInterfaceFile session filename = do
   bh <- readBinMem filename
 
   magic   <- get bh
@@ -140,17 +140,21 @@ readInterfaceFile filename = do
       -- initialise the user-data field of bh
       ud <- newReadState dict
       bh <- return (setUserData bh ud)
-	
+
+      -- get the name cache from the ghc session
+      ncRef <- withSession session (return . hsc_NC)
+      nc <- readIORef ncRef
+
       -- get the symbol table
       symtab_p <- get bh
       data_p   <- tellBin bh
       seekBin bh symtab_p
-      -- (construct an empty name cache)
-      u  <- mkSplitUniqSupply 'a' -- ??
-      let nc = initNameCache u []
-      (_, symtab) <- getSymbolTable bh nc
+      (nc', symtab) <- getSymbolTable bh nc
       seekBin bh data_p
 
+      -- write back the new name cache
+      writeIORef ncRef nc'
+
       -- set the symbol table
       let ud = getUserData bh
       bh <- return $! setUserData bh ud{ud_symtab = symtab}
diff --git a/src/Main.hs b/src/Main.hs
index 18001c85..e89f41ed 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -107,7 +107,7 @@ main = handleTopExceptions $ do
   (session, dynflags) <- startGhc libDir (ghcFlags flags)
 
   -- get packages via --read-interface
-  packages <- readInterfaceFiles (ifacePairs flags)
+  packages <- readInterfaceFiles session (ifacePairs flags)
 
   -- typecheck argument modules using GHC
   modules <- typecheckFiles session fileArgs
@@ -212,14 +212,14 @@ render flags interfaces = do
 -------------------------------------------------------------------------------
 
 
-readInterfaceFiles :: [(FilePath, FilePath)] -> IO [(InterfaceFile, FilePath)]
-readInterfaceFiles pairs = do
+readInterfaceFiles :: Session -> [(FilePath, FilePath)] -> IO [(InterfaceFile, FilePath)]
+readInterfaceFiles session pairs = do
   mbPackages <- mapM tryReadIface pairs
   return (catMaybes mbPackages)
   where
     -- try to read an interface, warn if we can't
     tryReadIface (html, iface) = do
-      eIface <- readInterfaceFile iface
+      eIface <- readInterfaceFile session iface
       case eIface of
         Left err -> do
           putStrLn ("Warning: Cannot read " ++ iface ++ ":")
-- 
cgit v1.2.3