From 1ea1385dfe0b6024ac77a7af6e08474d289faa81 Mon Sep 17 00:00:00 2001
From: "davve@dtek.chalmers.se" <David Waern>
Date: Thu, 5 Apr 2007 17:19:56 +0000
Subject: Do save/read of interface files properly
---
src/Haddock/InterfaceFile.hs | 189 ++++++++++++++++++++++++++++++++++++++-----
1 file changed, 167 insertions(+), 22 deletions(-)
(limited to 'src/Haddock')
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 7964a3a5..c4f24bef 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -1,50 +1,195 @@
module Haddock.InterfaceFile (
InterfaceFile(..),
writeInterfaceFile,
- readInterfaceFile
+ readInterfaceFile,
+ hmod2interface
) where
import Haddock.Types
import Haddock.Exception
-import Binary
-import System.IO
+import Data.List
import Data.Word
+import Data.Array
+import Data.IORef
import qualified Data.Map as Map
+import System.IO
import Control.Monad
+import Binary
+import Name
+import UniqSupply
+import UniqFM
+import IfaceEnv
+import Module
+import Packages
+import SrcLoc
+import HscTypes
+import FastMutInt
+import InstEnv
+import HsDoc
+
+data InterfaceMod = InterfaceMod {
+ imModule :: Module,
+ imFilename :: FilePath,
+ imExportItems :: [ExportItem DocName]
+}
+
data InterfaceFile = InterfaceFile {
- ifDocEnv :: DocEnv
+ ifDocEnv :: DocEnv
+-- ifModules :: [InterfaceMod]
}
instance Binary InterfaceFile where
- put_ bh (InterfaceFile docEnv) = put_ bh (Map.toList docEnv)
- get bh = do
- envList <- get bh
- return (InterfaceFile (Map.fromList envList))
+ put_ bh (InterfaceFile x) = put_ bh (Map.toList x)
+ get bh = do
+ env <- get bh
+ return (InterfaceFile (Map.fromList env))
-packageFileMagic = 0xDA303001 :: Word32
-packageFileVersion = 0 :: Word16
+hmod2interface hmod = InterfaceMod {
+ imModule = hmod_mod hmod,
+ imFilename = hmod_orig_filename hmod,
+ imExportItems = hmod_rn_export_items hmod
+}
+
+binaryInterfaceMagic = 0xD0Cface :: Word32
+binaryInterfaceVersion = 0 :: Word16
+
+initBinMemSize = (1024*1024) :: Int
writeInterfaceFile :: FilePath -> InterfaceFile -> IO ()
writeInterfaceFile filename iface = do
- h <- openBinaryFile filename WriteMode
- bh <- openBinIO h
+ bh <- openBinMem initBinMemSize
+ put_ bh binaryInterfaceMagic
+ put_ bh binaryInterfaceVersion
+
+ -- remember where the dictionary pointer will go
+ dict_p_p <- tellBin bh
+ put_ bh dict_p_p
+
+ -- remember where the symbol table pointer will go
+ symtab_p_p <- tellBin bh
+ put_ bh symtab_p_p
+
+ -- Make some intial state
ud <- newWriteState
+
+ -- put the main thing
bh <- return $ setUserData bh ud
- put_ bh packageFileMagic
- put_ bh packageFileVersion
put_ bh iface
- hClose h
+
+ -- write the symtab pointer at the fornt of the file
+ symtab_p <- tellBin bh
+ putAt bh symtab_p_p symtab_p
+ seekBin bh symtab_p
+
+ -- write the symbol table itself
+ symtab_next <- readFastMutInt (ud_symtab_next ud)
+ symtab_map <- readIORef (ud_symtab_map ud)
+ putSymbolTable bh symtab_next symtab_map
+
+ -- write the dictionary pointer at the fornt of the file
+ dict_p <- tellBin bh
+ putAt bh dict_p_p dict_p
+ seekBin bh dict_p
+
+ -- write the dictionary itself
+ dict_next <- readFastMutInt (ud_dict_next ud)
+ dict_map <- readIORef (ud_dict_map ud)
+ putDictionary bh dict_next dict_map
+
+ -- snd send the result to the file
+ writeBinMem bh filename
+ return ()
readInterfaceFile :: FilePath -> IO InterfaceFile
readInterfaceFile filename = do
- h <- openBinaryFile filename ReadMode
- bh <- openBinIO h
- ud <- newReadState undefined
- bh <- return (setUserData bh ud)
+ bh <- readBinMem filename
+
magic <- get bh
- when (magic /= packageFileMagic) $ throwE $
+ when (magic /= binaryInterfaceMagic) $ throwE $
"Magic number mismatch: couldn't load interface file: " ++ filename
- (version :: Word16) <- get bh
- get bh
+
+ version <- get bh
+ when (version /= binaryInterfaceVersion) $ throwE $
+ "Interface file is of wrong version: " ++ filename
+
+ -- get the dictionary
+ dict_p <- get bh
+ data_p <- tellBin bh
+ seekBin bh dict_p
+ dict <- getDictionary bh
+ seekBin bh data_p
+
+ -- initialise the user-data field of bh
+ ud <- newReadState dict
+ bh <- return (setUserData bh ud)
+
+ -- 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
+ seekBin bh data_p
+
+ -- set the symbol table
+ let ud = getUserData bh
+ bh <- return $! setUserData bh ud{ud_symtab = symtab}
+
+ -- load the actual data
+ iface <- get bh
+ return iface
+
+-------------------------------------------------------------------------------
+-- Symbol table
+-------------------------------------------------------------------------------
+
+putSymbolTable :: BinHandle -> Int -> UniqFM (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 <- sequence (replicate sz (get bh))
+ let
+ arr = listArray (0,sz-1) names
+ (namecache', names) =
+ mapAccumR (fromOnDiskName arr) namecache od_names
+ --
+ return (namecache', arr)
+
+type OnDiskName = (PackageId, ModuleName, OccName)
+
+fromOnDiskName
+ :: Array Int Name
+ -> NameCache
+ -> OnDiskName
+ -> (NameCache, Name)
+fromOnDiskName arr nc (pid, mod_name, occ) =
+ let
+ mod = mkModule pid mod_name
+ cache = nsNames nc
+ in
+ case lookupOrigNameCache cache mod occ of
+ Just name -> (nc, name)
+ Nothing ->
+ let
+ us = nsUniqs nc
+ uniq = uniqFromSupply us
+ name = mkExternalName uniq mod occ noSrcLoc
+ new_cache = extendNameCache cache mod occ name
+ in
+ case splitUniqSupply us of { (us',_) ->
+ ( nc{ nsUniqs = us', nsNames = new_cache }, name )
+ }
+
+serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
+serialiseName bh name symtab = do
+ let mod = nameModule name
+ put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
--
cgit v1.2.3