aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs9
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs161
2 files changed, 24 insertions, 146 deletions
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
-------------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 16:45:11 +0000