diff options
| -rw-r--r-- | haddock-ghc.cabal | 1 | ||||
| -rw-r--r-- | src/Haddock/InterfaceFile.hs | 189 | ||||
| -rw-r--r-- | src/Main.hs | 14 |
3 files changed, 178 insertions, 26 deletions
diff --git a/haddock-ghc.cabal b/haddock-ghc.cabal index c21e0f2d..97a78a54 100644 --- a/haddock-ghc.cabal +++ b/haddock-ghc.cabal @@ -9,6 +9,7 @@ stability: stable homepage: http://www.haskell.org/haddock/ synopsis: Haddock is a documentation-generation tool for Haskell libraries build-depends: base>=1.0, haskell98>=1.0, mtl>=1.0, ghc, network>=1.0, Cabal, FilePath>=0.11 +extensions: CPP, PatternGuards ghc-options: -fglasgow-exts hs-source-dirs: src exposed-modules: 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) diff --git a/src/Main.hs b/src/Main.hs index 264c1ec3..28723e71 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -308,6 +308,7 @@ startGHC libDir = do let flags'' = dopt_set flags' Opt_Haddock return (session, flags'') +-- TODO: clean up, restructure and make sure it handles cleanup sortAndCheckModules :: Session -> [FilePath] -> IO [CheckedMod] sortAndCheckModules session files = do parseStaticFlags [] -- to avoid a GHC bug @@ -428,10 +429,15 @@ run flags modules extEnv = do maybe_contents_url maybe_index_url copyHtmlBits odir libdir css_file + let iface = InterfaceFile { + ifDocEnv = homeEnv +-- ifModules = map hmod2interface visibleMods + } + case [str | Flag_DumpInterface str <- flags] of [] -> return () fs -> let filename = (last fs) in - writeInterfaceFile filename (InterfaceFile homeEnv) + writeInterfaceFile filename iface type CheckedMod = (Module, FilePath, FullyCheckedMod) @@ -1226,8 +1232,8 @@ getPackage :: Session -> InstalledPackageInfo -> IO PackageData getPackage session pkgInfo = do html <- getHtml pkgInfo iface <- getIface pkgInfo - InterfaceFile docEnv <- readInterfaceFile iface - + iface <- readInterfaceFile iface + let modules = packageModules pkgInfo -- try to get a ModuleInfo struct for each module @@ -1240,7 +1246,7 @@ getPackage session pkgInfo = do return $ PackageData { pdModules = modules, - pdDocEnv = docEnv, + pdDocEnv = ifDocEnv iface, pdHtmlPath = html } |