diff options
| -rw-r--r-- | src/Haddock/Backends/Html.hs | 19 | ||||
| -rw-r--r-- | src/Haddock/InterfaceFile.hs | 216 | ||||
| -rw-r--r-- | src/Haddock/Types.hs | 27 | ||||
| -rw-r--r-- | src/Haddock/Utils.hs | 8 | ||||
| -rw-r--r-- | src/Main.hs | 24 |
5 files changed, 246 insertions, 48 deletions
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 diff --git a/src/Main.hs b/src/Main.hs index 90014d26..443466de 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -124,7 +124,7 @@ main = handleTopExceptions $ do render flags interfaces -- last but not least, dump the interface file! - dumpInterfaceFile (map ghcModule modules) homeLinks flags + dumpInterfaceFile (map toInstalledInterface interfaces) homeLinks flags ------------------------------------------------------------------------------- @@ -181,13 +181,14 @@ render flags interfaces = do prologue <- getPrologue flags let - visibleMods = [ m | m <- interfaces, OptHide `notElem` (ifaceOptions m) ] - packageName = (Just . modulePkgStr . ifaceMod . head) visibleMods + visibleMods = [ m | m <- interfaces, OptHide `notElem` (ifaceOptions m) ] + installedIfaces = map toInstalledInterface visibleMods + packageName = (Just . modulePkgStr . ifaceMod . head) visibleMods when (Flag_GenIndex `elem` flags) $ do ppHtmlIndex odir title packageName maybe_html_help_format maybe_contents_url maybe_source_urls maybe_wiki_urls - visibleMods + installedIfaces copyHtmlBits odir libdir css_file when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do @@ -196,7 +197,7 @@ render flags interfaces = do when (Flag_GenContents `elem` flags) $ do ppHtmlContents odir title packageName maybe_html_help_format maybe_index_url maybe_source_urls maybe_wiki_urls - visibleMods True prologue + installedIfaces True prologue copyHtmlBits odir libdir css_file when (Flag_Html `elem` flags) $ do @@ -229,18 +230,20 @@ readInterfaceFiles session pairs = do Right iface -> return $ Just (iface, html) -dumpInterfaceFile :: [Module] -> LinkEnv -> [Flag] -> IO () -dumpInterfaceFile modules homeLinks flags = +dumpInterfaceFile :: [InstalledInterface] -> LinkEnv -> [Flag] -> IO () +dumpInterfaceFile ifaces homeLinks flags = case [str | Flag_DumpInterface str <- flags] of [] -> return () fs -> let filename = last fs in writeInterfaceFile filename ifaceFile where ifaceFile = InterfaceFile { - ifModules = modules, - ifLinkEnv = homeLinks + ifInstalledIfaces = ifaces, + ifLinkEnv = homeLinks } + + ------------------------------------------------------------------------------- -- Misc ------------------------------------------------------------------------------- @@ -275,7 +278,8 @@ updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO () updateHTMLXRefs packages = do writeIORef html_xrefs_ref (Map.fromList mapping) where - mapping = [(mod, html) | (iface, html) <- packages, mod <- ifModules iface] + mapping = [ (instMod iface, html) | (ifaces, html) <- packages, + iface <- ifInstalledIfaces ifaces ] getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName)) |