aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Documentation/Haddock.hs2
-rw-r--r--haddock-api/src/Haddock.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs9
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs161
4 files changed, 36 insertions, 157 deletions
diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs
index 10d6849a..e5d84796 100644
--- a/haddock-api/src/Documentation/Haddock.hs
+++ b/haddock-api/src/Documentation/Haddock.hs
@@ -52,9 +52,7 @@ module Documentation.Haddock (
-- * Interface files
InterfaceFile(..),
readInterfaceFile,
- nameCacheFromGhc,
freshNameCache,
- NameCacheAccessor,
-- * Flags and options
Flag(..),
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 8182707d..d955ae4f 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -71,6 +71,7 @@ import GHC.Settings.Config
import GHC.Driver.Session hiding (projectVersion, verbosity)
import GHC.Driver.Env
import GHC.Utils.Error
+import GHC.Types.Name.Cache
import GHC.Unit
import GHC.Utils.Panic (handleGhcException)
import GHC.Data.FastString
@@ -188,7 +189,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do
unit_state <- hsc_units <$> getSession
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
- mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
+ name_cache <- freshNameCache
+ mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), path)] noChecks
forM_ mIfaceFile $ \(_, ifaceFile) -> do
putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile)
@@ -210,7 +212,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do
throwE "No input file(s)."
-- Get packages supplied with --read-interface.
- packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
+ name_cache <- liftIO $ freshNameCache
+ packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
-- Render even though there are no input files (usually contents/index).
liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages []
@@ -253,7 +256,8 @@ readPackagesAndProcessModules :: [Flag] -> [String]
readPackagesAndProcessModules flags files = do
-- Get packages supplied with --read-interface.
let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
- packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks
+ name_cache <- hsc_NC <$> getSession
+ packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
-- Create the interfaces -- this is the core part of Haddock.
let ifaceFiles = map snd packages
@@ -441,18 +445,17 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
-------------------------------------------------------------------------------
-readInterfaceFiles :: MonadIO m
- => NameCacheAccessor m
+readInterfaceFiles :: NameCache
-> [(DocPaths, FilePath)]
-> Bool
- -> m [(DocPaths, InterfaceFile)]
-readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
+ -> IO [(DocPaths, InterfaceFile)]
+readInterfaceFiles name_cache pairs bypass_version_check = do
catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
where
-- try to read an interface, warn if we can't
tryReadIface (paths, file) =
- readInterfaceFile name_cache_accessor file bypass_version_check >>= \case
- Left err -> liftIO $ do
+ readInterfaceFile name_cache file bypass_version_check >>= \case
+ Left err -> do
putStrLn ("Warning: Cannot read " ++ file ++ ":")
putStrLn (" " ++ err)
putStrLn "Skipping this interface."
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-09-22 05:36:48 +0000