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

4 files changed, 232 insertions, 38 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