Skip to content
Snippets Groups Projects
Commit 15be7e06 authored by David Waern's avatar David Waern
Browse files

Synch loading of names from .haddock files with GHC's name cache

parent c2170cdb
No related branches found
No related tags found
No related merge requests found
...@@ -115,9 +115,9 @@ writeInterfaceFile filename iface = do ...@@ -115,9 +115,9 @@ writeInterfaceFile filename iface = do
writeBinMem bh filename writeBinMem bh filename
return () return ()
readInterfaceFile :: FilePath -> IO (Either String InterfaceFile) readInterfaceFile :: Session -> FilePath -> IO (Either String InterfaceFile)
readInterfaceFile filename = do readInterfaceFile session filename = do
bh <- readBinMem filename bh <- readBinMem filename
magic <- get bh magic <- get bh
...@@ -140,17 +140,21 @@ readInterfaceFile filename = do ...@@ -140,17 +140,21 @@ readInterfaceFile filename = do
-- initialise the user-data field of bh -- initialise the user-data field of bh
ud <- newReadState dict ud <- newReadState dict
bh <- return (setUserData bh ud) 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 -- get the symbol table
symtab_p <- get bh symtab_p <- get bh
data_p <- tellBin bh data_p <- tellBin bh
seekBin bh symtab_p seekBin bh symtab_p
-- (construct an empty name cache) (nc', symtab) <- getSymbolTable bh nc
u <- mkSplitUniqSupply 'a' -- ??
let nc = initNameCache u []
(_, symtab) <- getSymbolTable bh nc
seekBin bh data_p seekBin bh data_p
-- write back the new name cache
writeIORef ncRef nc'
-- set the symbol table -- set the symbol table
let ud = getUserData bh let ud = getUserData bh
bh <- return $! setUserData bh ud{ud_symtab = symtab} bh <- return $! setUserData bh ud{ud_symtab = symtab}
......
...@@ -107,7 +107,7 @@ main = handleTopExceptions $ do ...@@ -107,7 +107,7 @@ main = handleTopExceptions $ do
(session, dynflags) <- startGhc libDir (ghcFlags flags) (session, dynflags) <- startGhc libDir (ghcFlags flags)
-- get packages via --read-interface -- get packages via --read-interface
packages <- readInterfaceFiles (ifacePairs flags) packages <- readInterfaceFiles session (ifacePairs flags)
-- typecheck argument modules using GHC -- typecheck argument modules using GHC
modules <- typecheckFiles session fileArgs modules <- typecheckFiles session fileArgs
...@@ -212,14 +212,14 @@ render flags interfaces = do ...@@ -212,14 +212,14 @@ render flags interfaces = do
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
readInterfaceFiles :: [(FilePath, FilePath)] -> IO [(InterfaceFile, FilePath)] readInterfaceFiles :: Session -> [(FilePath, FilePath)] -> IO [(InterfaceFile, FilePath)]
readInterfaceFiles pairs = do readInterfaceFiles session pairs = do
mbPackages <- mapM tryReadIface pairs mbPackages <- mapM tryReadIface pairs
return (catMaybes mbPackages) return (catMaybes mbPackages)
where where
-- try to read an interface, warn if we can't -- try to read an interface, warn if we can't
tryReadIface (html, iface) = do tryReadIface (html, iface) = do
eIface <- readInterfaceFile iface eIface <- readInterfaceFile session iface
case eIface of case eIface of
Left err -> do Left err -> do
putStrLn ("Warning: Cannot read " ++ iface ++ ":") putStrLn ("Warning: Cannot read " ++ iface ++ ":")
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment