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

1 files changed, 190 insertions, 26 deletions

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)