aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/InterfaceFile.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/InterfaceFile.hs')
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs636
1 files changed, 636 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
new file mode 100644
index 00000000..bb997b9a
--- /dev/null
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -0,0 +1,636 @@
+{-# 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"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 07:04:03 +0000