diff options
| -rw-r--r-- | src/Haddock/InterfaceFile.hs | 20 | ||||
| -rw-r--r-- | 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 ++ ":") |