-- -- Haddock - A Haskell Documentation Tool -- -- (c) Simon Marlow 2003 -- module Haddock.InterfaceFile ( InterfaceFile(..), readInterfaceFile, writeInterfaceFile ) where import Haddock.DocName import Haddock.Types import Haddock.Exception 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 GHC hiding (NoLink) import SrcLoc (noSrcSpan) -- tmp, GHC now exports this import Binary import Name import UniqSupply import UniqFM import IfaceEnv import Module import Packages import HscTypes import FastMutInt import InstEnv import HsDoc data InterfaceFile = InterfaceFile { ifLinkEnv :: LinkEnv, ifInstalledIfaces :: [InstalledInterface] } binaryInterfaceMagic = 0xD0Cface :: Word32 binaryInterfaceVersion = 1 :: Word16 initBinMemSize = (1024*1024) :: Int writeInterfaceFile :: FilePath -> InterfaceFile -> IO () writeInterfaceFile filename iface = do 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 iface -- 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 () -- | 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. -- The aim is to be compatible with interface files produced by any Haddock -- of version 2.0.0.0 or greater. readInterfaceFile :: Maybe Session -> FilePath -> IO (Either String InterfaceFile) readInterfaceFile mbSession filename = do bh <- readBinMem filename magic <- get bh version <- get bh case () of _ | magic /= binaryInterfaceMagic -> return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename | version /= binaryInterfaceVersion -> return . Left $ "Interface file is of wrong version: " ++ filename | otherwise -> do -- 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 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 bh data_p <- tellBin bh seekBin bh symtab_p (nc', symtab) <- getSymbolTable bh theNC seekBin bh data_p -- write back the new name cache if we have a ghc session case mbRef of Just ref -> writeIORef ref nc' Nothing -> return () -- set the symbol table let ud = getUserData bh bh <- return $! setUserData bh ud{ud_symtab = symtab} -- load the actual data iface <- get bh return (Right 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 noSrcSpan 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) ------------------------------------------------------------------------------- -- GhcBinary instances ------------------------------------------------------------------------------- instance Binary InterfaceFile where put_ bh (InterfaceFile env ifaces) = do put_ bh (Map.toList env) put_ bh ifaces get bh = do env <- get bh ifaces <- get bh return (InterfaceFile (Map.fromList env) ifaces) instance Binary InstalledInterface where put_ bh (InstalledInterface mod info docMap exps visExps) = do put_ bh mod put_ bh info put_ bh (Map.toList docMap) put_ bh exps put_ bh visExps get bh = do mod <- get bh info <- get bh docMap <- get bh exps <- get bh visExps <- get bh return (InstalledInterface mod info (Map.fromList docMap) exps visExps) instance Binary DocOption where put_ bh OptHide = do putByte bh 0 put_ bh OptPrune = do putByte bh 1 put_ bh OptIgnoreExports = do putByte bh 2 put_ bh OptNotHome = do putByte bh 3 get bh = do h <- getByte bh case h of 0 -> do return OptHide 1 -> do return OptPrune 2 -> do return OptIgnoreExports 3 -> do return OptNotHome _ -> fail "invalid binary data found" {-* Generated by DrIFT : Look, but Don't Touch. *-} instance (Binary id) => Binary (HsDoc id) where put_ bh DocEmpty = do putByte bh 0 put_ bh (DocAppend aa ab) = do putByte bh 1 put_ bh aa put_ bh ab put_ bh (DocString ac) = do putByte bh 2 put_ bh ac put_ bh (DocParagraph ad) = do putByte bh 3 put_ bh ad put_ bh (DocIdentifier ae) = do putByte bh 4 put_ bh ae put_ bh (DocModule af) = do putByte bh 5 put_ bh af put_ bh (DocEmphasis ag) = do putByte bh 6 put_ bh ag put_ bh (DocMonospaced ah) = do putByte bh 7 put_ bh ah put_ bh (DocUnorderedList ai) = do putByte bh 8 put_ bh ai put_ bh (DocOrderedList aj) = do putByte bh 9 put_ bh aj put_ bh (DocDefList ak) = do putByte bh 10 put_ bh ak put_ bh (DocCodeBlock al) = do putByte bh 11 put_ bh al put_ bh (DocURL am) = do putByte bh 12 put_ bh am put_ bh (DocAName an) = do putByte bh 13 put_ bh an get bh = do h <- getByte bh case h of 0 -> do return DocEmpty 1 -> do aa <- get bh ab <- get bh return (DocAppend aa ab) 2 -> do ac <- get bh return (DocString ac) 3 -> do ad <- get bh return (DocParagraph ad) 4 -> do ae <- get bh return (DocIdentifier ae) 5 -> do af <- get bh return (DocModule af) 6 -> do ag <- get bh return (DocEmphasis ag) 7 -> do ah <- get bh return (DocMonospaced ah) 8 -> do ai <- get bh return (DocUnorderedList ai) 9 -> do aj <- get bh return (DocOrderedList aj) 10 -> do ak <- get bh return (DocDefList ak) 11 -> do al <- get bh return (DocCodeBlock al) 12 -> do am <- get bh return (DocURL am) 13 -> do an <- get bh return (DocAName an) _ -> fail "invalid binary data found" instance Binary name => Binary (HaddockModInfo name) where put_ bh hmi = do put_ bh (hmi_description hmi) put_ bh (hmi_portability hmi) put_ bh (hmi_stability hmi) put_ bh (hmi_maintainer hmi) get bh = do descr <- get bh porta <- get bh stabi <- get bh maint <- get bh return (HaddockModInfo descr porta stabi maint)