diff options
| -rw-r--r-- | src/Haddock/InterfaceFile.hs | 102 |
1 files changed, 60 insertions, 42 deletions
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 6d96ffa5..226d3acc 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -8,7 +8,7 @@ module Haddock.InterfaceFile ( InterfaceFile(..), - readInterfaceFile, + readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile ) where @@ -37,6 +37,7 @@ import FastMutInt import HsDoc import FastString import Unique +import MonadUtils ( MonadIO(..) ) data InterfaceFile = InterfaceFile { @@ -142,16 +143,42 @@ writeInterfaceFile filename iface = do writeBinMem bh filename return () +type NameCacheAccessor m = (m NameCache, NameCache -> m ()) + +nameCacheFromGhc :: NameCacheAccessor Ghc +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 []) -- | Read a Haddock (@.haddock@) interface file. Return either an --- 'InterfaceFile' or an error message. If given a GHC 'Session', the function --- registers all read names in the name cache of the session. -readInterfaceFile :: Maybe Session -> FilePath -> IO (Either String InterfaceFile) -readInterfaceFile mbSession filename = do - bh0 <- readBinMem filename +-- '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 :: MonadIO m => + NameCacheAccessor m + -> FilePath -> m (Either String InterfaceFile) +readInterfaceFile (get_name_cache, set_name_cache) filename = do + bh0 <- liftIO $ readBinMem filename - magic <- get bh0 - version <- get bh0 + magic <- liftIO $ get bh0 + version <- liftIO $ get bh0 case () of _ | magic /= binaryInterfaceMagic -> return . Left $ @@ -160,49 +187,40 @@ readInterfaceFile mbSession filename = do "Interface file is of wrong version: " ++ filename | otherwise -> do - -- get the dictionary - dict_p <- get bh0 - data_p <- tellBin bh0 - seekBin bh0 dict_p - dict <- getDictionary bh0 - seekBin bh0 data_p + dict <- get_dictionary bh0 + bh1 <- init_handle_user_data bh0 dict - -- initialise the user-data field of bh0 - ud <- newReadState dict - bh1 <- return (setUserData bh0 ud) - - -- get the name cache from ghc if we have a ghc session, - -- otherwise create a new one - (theNC, mbRef) <- case mbSession of - Just session -> do - ref <- withSession session (return . hsc_NC) - nc <- readIORef ref - return (nc, Just ref) - Nothing -> do - -- construct an empty name cache - u <- mkSplitUniqSupply 'a' -- ?? - return (initNameCache u [], Nothing) - - -- get the symbol table - symtab_p <- get bh1 - data_p' <- tellBin bh1 - seekBin bh1 symtab_p - (nc', symtab) <- getSymbolTable bh1 theNC - seekBin bh1 data_p' - - -- write back the new name cache if we have a ghc session - case mbRef of - Just ref -> writeIORef ref nc' - Nothing -> return () + theNC <- get_name_cache + (nc', symtab) <- get_symbol_table bh1 theNC + set_name_cache nc' -- set the symbol table let ud' = getUserData bh1 bh2 <- return $! setUserData bh1 ud'{ud_symtab = symtab} -- load the actual data - iface <- get bh2 + iface <- liftIO $ get bh2 return (Right iface) + where + 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 + + init_handle_user_data bin_handle dict = liftIO $ do + ud <- newReadState dict + return (setUserData bin_handle ud) + 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) ------------------------------------------------------------------------------- -- Symbol table |