From 08b75f838779c59083e4f693ed2b002d5ac2c49f Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 10 Nov 2007 17:01:43 +0000 Subject: Introduce InstalledInterface structure and add more stuff to the .haddock files We introduce InstalledInterface capturing the part of Interface that is stored in the interface files. We change the ppHtmlContents and ppHtmllIndex to take this structure instead of a partial Interface. We add stuff like the doc map and exported names to the .haddock file (via InstalledInterface). --- src/Haddock/Backends/Html.hs | 19 ++-- src/Haddock/InterfaceFile.hs | 216 +++++++++++++++++++++++++++++++++++++------ src/Haddock/Types.hs | 27 +++++- src/Haddock/Utils.hs | 8 +- 4 files changed, 232 insertions(+), 38 deletions(-) (limited to 'src/Haddock') diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs index c4c769a2..acd3dd93 100644 --- a/src/Haddock/Backends/Html.hs +++ b/src/Haddock/Backends/Html.hs @@ -75,13 +75,14 @@ ppHtml doctitle maybe_package ifaces odir prologue maybe_html_help_format when (not (isJust maybe_contents_url)) $ ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url maybe_source_url maybe_wiki_url - visible_ifaces + (map toInstalledInterface visible_ifaces) False -- we don't want to display the packages in a single-package contents prologue when (not (isJust maybe_index_url)) $ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format - maybe_contents_url maybe_source_url maybe_wiki_url visible_ifaces + maybe_contents_url maybe_source_url maybe_wiki_url + (map toInstalledInterface visible_ifaces) when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format [] @@ -291,13 +292,13 @@ ppHtmlContents -> Maybe String -> SourceURLs -> WikiURLs - -> [Interface] -> Bool -> Maybe (GHC.HsDoc GHC.RdrName) + -> [InstalledInterface] -> Bool -> Maybe (GHC.HsDoc GHC.RdrName) -> IO () ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url - maybe_source_url maybe_wiki_url modules showPkgs prologue = do + maybe_source_url maybe_wiki_url ifaces showPkgs prologue = do let tree = mkModuleTree showPkgs - [(ifaceMod mod, toDescription mod) | mod <- modules] + [(instMod mod, toInstalledDescription mod) | mod <- ifaces] html = header (documentCharacterEncoding +++ @@ -405,7 +406,7 @@ ppHtmlIndex :: FilePath -> Maybe String -> SourceURLs -> WikiURLs - -> [Interface] + -> [InstalledInterface] -> IO () ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_url maybe_source_url maybe_wiki_url modules = do @@ -483,9 +484,9 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format getHModIndex iface = [ (getOccString name, - Map.fromList [(name, [(mdl, name `elem` ifaceVisibleExports iface)])]) - | name <- ifaceExports iface ] - where mdl = ifaceMod iface + Map.fromList [(name, [(mdl, name `elem` instVisibleExports iface)])]) + | name <- instExports iface ] + where mdl = instMod iface indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable indexElt (str, entities) = diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 92dc371b..e822cdda 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -7,9 +7,8 @@ module Haddock.InterfaceFile ( InterfaceFile(..), - writeInterfaceFile, readInterfaceFile, - iface2interface + writeInterfaceFile ) where @@ -24,8 +23,8 @@ import qualified Data.Map as Map import System.IO import Control.Monad -import GHC -import SrcLoc ( noSrcSpan ) -- tmp, GHC now exports this +import GHC hiding (NoLink) +import SrcLoc (noSrcSpan) -- tmp, GHC now exports this import Binary import Name import UniqSupply @@ -38,38 +37,20 @@ import FastMutInt import InstEnv import HsDoc -data InterfaceMod = InterfaceMod { - imModule :: Module, - imFilename :: FilePath, - imExportItems :: [ExportItem DocName] -} data InterfaceFile = InterfaceFile { - ifLinkEnv :: LinkEnv, - ifModules :: [Module] + ifLinkEnv :: LinkEnv, + ifInstalledIfaces :: [InstalledInterface] } -instance Binary InterfaceFile where - put_ bh (InterfaceFile env mods) = do - put_ bh (Map.toList env) - put_ bh mods - get bh = do - env <- get bh - mods <- get bh - return (InterfaceFile (Map.fromList env) mods) - -iface2interface iface = InterfaceMod { - imModule = ifaceMod iface, - imFilename = ifaceOrigFilename iface, - imExportItems = ifaceRnExportItems iface -} - binaryInterfaceMagic = 0xD0Cface :: Word32 binaryInterfaceVersion = 0 :: Word16 + initBinMemSize = (1024*1024) :: Int + writeInterfaceFile :: FilePath -> InterfaceFile -> IO () writeInterfaceFile filename iface = do bh <- openBinMem initBinMemSize @@ -214,3 +195,186 @@ 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) + + +{-* Generated by DrIFT : Look, but Don't Touch. *-} +instance Binary DocName where + put_ bh (Link aa) = do + putByte bh 0 + put_ bh aa + put_ bh (NoLink ab) = do + putByte bh 1 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do + aa <- get bh + return (Link aa) + 1 -> do + ab <- get bh + return (NoLink ab) + _ -> fail "invalid binary data found" + + +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) diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index e704ae4d..e1fd5b4a 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -8,7 +8,8 @@ module Haddock.Types where -import Data.Map +import Data.Map (Map) +import qualified Data.Map as Map import Control.Monad.Writer import GHC hiding (NoLink) @@ -110,7 +111,7 @@ data GhcModule = GhcModule { -- data needed during its creation. data Interface = Interface { - -- | A value to identify the module + -- | The documented module ifaceMod :: Module, -- | The original filename for this module @@ -157,6 +158,28 @@ data Interface = Interface { } +-- | A smaller version of 'Interface' that we can get from the Haddock +-- interface files. +data InstalledInterface = InstalledInterface { + instMod :: Module, + instInfo :: HaddockModInfo Name, + instDocMap :: Map Name (HsDoc DocName), + instExports :: [Name], + instVisibleExports :: [Name] +} + + +-- | Convert an 'Interface' to an 'InstalledInterface' +toInstalledInterface :: Interface -> InstalledInterface +toInstalledInterface interface = InstalledInterface { + instMod = ifaceMod interface, + instInfo = ifaceInfo interface, + instDocMap = ifaceRnDocMap interface, + instExports = ifaceExports interface, + instVisibleExports = ifaceVisibleExports interface +} + + data DocMarkup id a = Markup { markupEmpty :: a, markupString :: String -> a, diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index fd19de9f..6f2c32fc 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -9,7 +9,7 @@ module Haddock.Utils ( -- * Misc utilities restrictTo, - toDescription, + toDescription, toInstalledDescription, -- * Filename utilities basename, dirname, splitFilename3, @@ -63,10 +63,16 @@ import System.IO.Unsafe ( unsafePerformIO ) -- ----------------------------------------------------------------------------- -- Some Utilities + -- | extract a module's short description. toDescription :: Interface -> Maybe (HsDoc Name) toDescription = hmi_description . ifaceInfo +-- | extract a module's short description. +toInstalledDescription :: InstalledInterface -> Maybe (HsDoc Name) +toInstalledDescription = hmi_description . instInfo + + -- --------------------------------------------------------------------------- -- Making abstract declarations -- cgit v1.2.3