diff options
Diffstat (limited to 'src/Haddock/InterfaceFile.hs')
| -rw-r--r-- | src/Haddock/InterfaceFile.hs | 636 |
1 files changed, 0 insertions, 636 deletions
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs deleted file mode 100644 index bb997b9a..00000000 --- a/src/Haddock/InterfaceFile.hs +++ /dev/null @@ -1,636 +0,0 @@ -{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.InterfaceFile --- Copyright : (c) David Waern 2006-2009, --- Mateusz Kowalczyk 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable --- --- Reading and writing the .haddock interface file ------------------------------------------------------------------------------ -module Haddock.InterfaceFile ( - InterfaceFile(..), ifPackageId, - readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, - writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility -) where - - -import Haddock.Types -import Haddock.Utils hiding (out) - -import Control.Monad -import Data.Array -import Data.Functor ((<$>)) -import Data.IORef -import Data.List -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Word - -import BinIface (getSymtabName, getDictFastString) -import Binary -import FastMutInt -import FastString -import GHC hiding (NoLink) -import GhcMonad (withSession) -import HscTypes -import IfaceEnv -import Name -import UniqFM -import UniqSupply -import Unique - - -data InterfaceFile = InterfaceFile { - ifLinkEnv :: LinkEnv, - ifInstalledIfaces :: [InstalledInterface] -} - - -ifPackageId :: InterfaceFile -> PackageId -ifPackageId if_ = - case ifInstalledIfaces if_ of - [] -> error "empty InterfaceFile" - iface:_ -> modulePackageId $ instMod iface - - -binaryInterfaceMagic :: Word32 -binaryInterfaceMagic = 0xD0Cface - - --- IMPORTANT: Since datatypes in the GHC API might change between major --- versions, and because we store GHC datatypes in our interface files, we need --- to make sure we version our interface files accordingly. --- --- If you change the interface file format or adapt Haddock to work with a new --- major version of GHC (so that the format changes indirectly) *you* need to --- follow these steps: --- --- (1) increase `binaryInterfaceVersion` --- --- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] --- -binaryInterfaceVersion :: Word16 -#if __GLASGOW_HASKELL__ == 708 -binaryInterfaceVersion = 25 - -binaryInterfaceVersionCompatibility :: [Word16] -binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] -#else -#error Unsupported GHC version -#endif - - -initBinMemSize :: Int -initBinMemSize = 1024*1024 - - -writeInterfaceFile :: FilePath -> InterfaceFile -> IO () -writeInterfaceFile filename iface = do - bh0 <- openBinMem initBinMemSize - put_ bh0 binaryInterfaceMagic - put_ bh0 binaryInterfaceVersion - - -- remember where the dictionary pointer will go - dict_p_p <- tellBin bh0 - put_ bh0 dict_p_p - - -- remember where the symbol table pointer will go - symtab_p_p <- tellBin bh0 - put_ bh0 symtab_p_p - - -- Make some intial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 - symtab_map <- newIORef emptyUFM - let bin_symtab = BinSymbolTable { - bin_symtab_next = symtab_next, - bin_symtab_map = symtab_map } - dict_next_ref <- newFastMutInt - writeFastMutInt dict_next_ref 0 - dict_map_ref <- newIORef emptyUFM - let bin_dict = BinDictionary { - bin_dict_next = dict_next_ref, - bin_dict_map = dict_map_ref } - - -- put the main thing - let bh = setUserData bh0 $ newWriteState (putName bin_symtab) - (putFastString bin_dict) - put_ bh iface - - -- write the symtab pointer at the front 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 symtab_next - symtab_map' <- readIORef symtab_map - 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 dict_next_ref - dict_map <- readIORef dict_map_ref - putDictionary bh dict_next dict_map - - -- and send the result to the file - writeBinMem bh filename - return () - - -type NameCacheAccessor m = (m NameCache, NameCache -> m ()) - - -nameCacheFromGhc :: NameCacheAccessor Ghc -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 []) - - --- | 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 - -> FilePath - -> m (Either String InterfaceFile) -readInterfaceFile (get_name_cache, set_name_cache) filename = 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 - | 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) - - -------------------------------------------------------------------------------- --- * Symbol table -------------------------------------------------------------------------------- - - -putName :: BinSymbolTable -> BinHandle -> Name -> IO () -putName BinSymbolTable{ - bin_symtab_map = symtab_map_ref, - bin_symtab_next = symtab_next } bh name - = do - symtab_map <- readIORef symtab_map_ref - case lookupUFM symtab_map name of - Just (off,_) -> put_ bh (fromIntegral off :: Word32) - Nothing -> do - off <- readFastMutInt symtab_next - writeFastMutInt symtab_next (off+1) - writeIORef symtab_map_ref - $! addToUFM symtab_map name (off,name) - put_ bh (fromIntegral off :: Word32) - - -data BinSymbolTable = BinSymbolTable { - bin_symtab_next :: !FastMutInt, -- The next index to use - bin_symtab_map :: !(IORef (UniqFM (Int,Name))) - -- indexed by Name - } - - -putFastString :: BinDictionary -> BinHandle -> FastString -> IO () -putFastString BinDictionary { bin_dict_next = j_r, - bin_dict_map = out_r} bh f - = do - out <- readIORef out_r - let unique = getUnique f - case lookupUFM out unique of - Just (j, _) -> put_ bh (fromIntegral j :: Word32) - Nothing -> do - j <- readFastMutInt j_r - put_ bh (fromIntegral j :: Word32) - writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM out unique (j, f) - - -data BinDictionary = BinDictionary { - bin_dict_next :: !FastMutInt, -- The next index to use - bin_dict_map :: !(IORef (UniqFM (Int,FastString))) - -- indexed by FastString - } - - -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 <- replicateM 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 _ 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 (Int,Name) -> IO () -serialiseName bh name _ = do - let modu = nameModule name - put_ bh (modulePackageId modu, moduleName modu, nameOccName name) - - -------------------------------------------------------------------------------- --- * GhcBinary instances -------------------------------------------------------------------------------- - - -instance (Ord k, Binary k, Binary v) => Binary (Map k v) where - put_ bh m = put_ bh (Map.toList m) - get bh = fmap (Map.fromList) (get bh) - - -instance Binary InterfaceFile where - put_ bh (InterfaceFile env ifaces) = do - put_ bh env - put_ bh ifaces - - get bh = do - env <- get bh - ifaces <- get bh - return (InterfaceFile env ifaces) - - -instance Binary InstalledInterface where - put_ bh (InstalledInterface modu info docMap argMap - exps visExps opts subMap fixMap) = do - put_ bh modu - put_ bh info - put_ bh docMap - put_ bh argMap - put_ bh exps - put_ bh visExps - put_ bh opts - put_ bh subMap - put_ bh fixMap - - get bh = do - modu <- get bh - info <- get bh - docMap <- get bh - argMap <- get bh - exps <- get bh - visExps <- get bh - opts <- get bh - subMap <- get bh - fixMap <- get bh - - return (InstalledInterface modu info docMap argMap - exps visExps opts subMap fixMap) - - -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 - put_ bh OptShowExtensions = do - putByte bh 4 - 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 - 4 -> do - return OptShowExtensions - _ -> fail "invalid binary data found" - - -instance Binary Example where - put_ bh (Example expression result) = do - put_ bh expression - put_ bh result - get bh = do - expression <- get bh - result <- get bh - return (Example expression result) - -instance Binary Hyperlink where - put_ bh (Hyperlink url label) = do - put_ bh url - put_ bh label - get bh = do - url <- get bh - label <- get bh - return (Hyperlink url label) - -instance Binary Picture where - put_ bh (Picture uri title) = do - put_ bh uri - put_ bh title - get bh = do - uri <- get bh - title <- get bh - return (Picture uri title) - -instance Binary a => Binary (Header a) where - put_ bh (Header l t) = do - put_ bh l - put_ bh t - get bh = do - l <- get bh - t <- get bh - return (Header l t) - -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance (Binary mod, Binary id) => Binary (DocH mod 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 (DocHyperlink am) = do - putByte bh 12 - put_ bh am - put_ bh (DocPic x) = do - putByte bh 13 - put_ bh x - put_ bh (DocAName an) = do - putByte bh 14 - put_ bh an - put_ bh (DocExamples ao) = do - putByte bh 15 - put_ bh ao - put_ bh (DocIdentifierUnchecked x) = do - putByte bh 16 - put_ bh x - put_ bh (DocWarning ag) = do - putByte bh 17 - put_ bh ag - put_ bh (DocProperty x) = do - putByte bh 18 - put_ bh x - put_ bh (DocBold x) = do - putByte bh 19 - put_ bh x - put_ bh (DocHeader aa) = do - putByte bh 20 - put_ bh aa - - 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 (DocHyperlink am) - 13 -> do - x <- get bh - return (DocPic x) - 14 -> do - an <- get bh - return (DocAName an) - 15 -> do - ao <- get bh - return (DocExamples ao) - 16 -> do - x <- get bh - return (DocIdentifierUnchecked x) - 17 -> do - ag <- get bh - return (DocWarning ag) - 18 -> do - x <- get bh - return (DocProperty x) - 19 -> do - x <- get bh - return (DocBold x) - 20 -> do - aa <- get bh - return (DocHeader aa) - _ -> error "invalid binary data found in the interface file" - - -instance Binary name => Binary (HaddockModInfo name) where - put_ bh hmi = do - put_ bh (hmi_description hmi) - put_ bh (hmi_copyright hmi) - put_ bh (hmi_license hmi) - put_ bh (hmi_maintainer hmi) - put_ bh (hmi_stability hmi) - put_ bh (hmi_portability hmi) - put_ bh (hmi_safety hmi) - put_ bh (fromEnum <$> hmi_language hmi) - put_ bh (map fromEnum $ hmi_extensions hmi) - - get bh = do - descr <- get bh - copyr <- get bh - licen <- get bh - maint <- get bh - stabi <- get bh - porta <- get bh - safet <- get bh - langu <- fmap toEnum <$> get bh - exten <- map toEnum <$> get bh - return (HaddockModInfo descr copyr licen maint stabi porta safet langu exten) - -instance Binary DocName where - put_ bh (Documented name modu) = do - putByte bh 0 - put_ bh name - put_ bh modu - put_ bh (Undocumented name) = do - putByte bh 1 - put_ bh name - - get bh = do - h <- getByte bh - case h of - 0 -> do - name <- get bh - modu <- get bh - return (Documented name modu) - 1 -> do - name <- get bh - return (Undocumented name) - _ -> error "get DocName: Bad h" |