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)
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 :: Word32
binaryInterfaceMagic = 0xD0Cface
binaryInterfaceVersion :: Word16
binaryInterfaceVersion = 1
initBinMemSize :: Int
initBinMemSize = 1024*1024
writeInterfaceFile :: FilePath -> InterfaceFile -> IO ()
writeInterfaceFile filename iface = do
bh <- openBinMem initBinMemSize
put_ bh binaryInterfaceMagic
put_ bh binaryInterfaceVersion
dict_p_p <- tellBin bh
put_ bh dict_p_p
symtab_p_p <- tellBin bh
put_ bh symtab_p_p
ud <- newWriteState
bh <- return $ setUserData bh ud
put_ bh iface
symtab_p <- tellBin bh
putAt bh symtab_p_p symtab_p
seekBin bh symtab_p
symtab_next <- readFastMutInt (ud_symtab_next ud)
symtab_map <- readIORef (ud_symtab_map ud)
putSymbolTable bh symtab_next symtab_map
dict_p <- tellBin bh
putAt bh dict_p_p dict_p
seekBin bh dict_p
dict_next <- readFastMutInt (ud_dict_next ud)
dict_map <- readIORef (ud_dict_map ud)
putDictionary bh dict_next dict_map
writeBinMem bh filename
return ()
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
dict_p <- get bh
data_p <- tellBin bh
seekBin bh dict_p
dict <- getDictionary bh
seekBin bh data_p
ud <- newReadState dict
bh <- return (setUserData bh ud)
(theNC, mbRef) <- case mbSession of
Just session -> do
ref <- withSession session (return . hsc_NC)
nc <- readIORef ref
return (nc, Just ref)
Nothing -> do
u <- mkSplitUniqSupply 'a'
return (initNameCache u [], Nothing)
symtab_p <- get bh
data_p <- tellBin bh
seekBin bh symtab_p
(nc', symtab) <- getSymbolTable bh theNC
seekBin bh data_p
case mbRef of
Just ref -> writeIORef ref nc'
Nothing -> return ()
let ud = getUserData bh
bh <- return $! setUserData bh ud{ud_symtab = symtab}
iface <- get bh
return (Right iface)
putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
putSymbolTable bh next_off symtab = do
put_ bh next_off
let names = elems (array (0,next_off1) (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,sz1) 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)
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"
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)