aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Html.hs19
-rw-r--r--src/Haddock/InterfaceFile.hs216
-rw-r--r--src/Haddock/Types.hs27
-rw-r--r--src/Haddock/Utils.hs8
-rw-r--r--src/Main.hs24
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))
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 09:39:19 +0000