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).

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))