Add support for --read-interface again

3 files changed, 49 insertions, 10 deletions

diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 6441c503..7f2fd6f4 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -45,15 +45,19 @@ data InterfaceMod = InterfaceMod {
 }
 
 data InterfaceFile = InterfaceFile {
-  ifLinkEnv  :: LinkEnv
---  ifModules :: [InterfaceMod]  
+  ifLinkEnv :: LinkEnv,
+  ifModules :: [Module]  
 } 
 
 instance Binary InterfaceFile where
-  put_ bh (InterfaceFile x) = put_ bh (Map.toList x)
-  get  bh = do
-    env <- get bh
-    return (InterfaceFile (Map.fromList env))
+  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,
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 89850f9c..152b30d4 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -9,7 +9,8 @@ module Haddock.Options (
   parseHaddockOpts,
   Flag(..),
   getUsage,
-  makeGhcFlags
+  getGhcFlags,
+  getIfacePairs
 ) where
 
 
@@ -36,14 +37,26 @@ parseHaddockOpts words =
       throwE (concat errors ++ usage)
 
 
-makeGhcFlags :: [Flag] -> [String]
-makeGhcFlags flags = [ option | Flag_OptGhc option <- flags ]
+getGhcFlags :: [Flag] -> [String]
+getGhcFlags flags = [ option | Flag_OptGhc option <- flags ]
+
+
+getIfacePairs :: [Flag] -> [(FilePath, FilePath)]
+getIfacePairs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
+
+
+parseIfaceOption :: String -> (FilePath, FilePath)
+parseIfaceOption s = 
+  case break (==',') s of
+	(fpath,',':file) -> (fpath, file)
+	(file, _)        -> ("", file)
 
 
 data Flag
   = Flag_CSS String
   | Flag_Debug
 --  | Flag_DocBook
+  | Flag_ReadInterface String
   | Flag_DumpInterface String
   | Flag_Heading String
   | Flag_Html
@@ -83,6 +96,8 @@ options backwardsCompat =
 	"directory in which to put the output files",
    Option ['l']  ["lib"]         (ReqArg Flag_Lib "DIR") 
 	"location of Haddock's auxiliary files",
+   Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE")
+	"read an interface from FILE",
    Option ['D']  ["dump-interface"] (ReqArg Flag_DumpInterface "FILE") 
   "interface file name",
 --    Option ['S']  ["docbook"]  (NoArg Flag_DocBook)
diff --git a/src/Haddock/Packages.hs b/src/Haddock/Packages.hs
index d722bdfe..ba3ee841 100644
--- a/src/Haddock/Packages.hs
+++ b/src/Haddock/Packages.hs
@@ -8,6 +8,7 @@
 module Haddock.Packages (
   HaddockPackage(..),
   getHaddockPackages,
+  getHaddockPackages',
   combineLinkEnvs
 ) where
 
@@ -15,6 +16,7 @@ module Haddock.Packages (
 import Haddock.Types
 import Haddock.Exception
 import Haddock.InterfaceFile
+import qualified Distribution.Haddock as D
 
 import Data.Maybe
 import qualified Data.Map as Map
@@ -38,6 +40,24 @@ data HaddockPackage = HaddockPackage {
 }
 
 
+getHaddockPackages' :: [(FilePath, FilePath)] -> IO [HaddockPackage]
+getHaddockPackages' pairs = do
+  mbPackages <- mapM tryReadIface pairs
+  return (catMaybes mbPackages)
+  where
+    -- try to get a HaddockPackage, warn if we can't
+    tryReadIface (html, iface) = do
+      eIface <- D.readInterfaceFile iface
+      case eIface of
+        Left err -> do
+          putStrLn ("Warning: Cannot read " ++ iface ++ ":")
+          putStrLn ("   " ++ show err)
+          putStrLn "Skipping this interface."
+          return Nothing
+        Right iface -> return $ Just $
+                       HaddockPackage (ifModules iface) (ifLinkEnv iface) html
+
+
 -- | Try to read the installed Haddock information for the given packages, 
 -- if it exists. Print a warning on stdout if it couldn't be found for a 
 -- package.
@@ -65,7 +85,7 @@ getPackage pkgInfo = do
   iface     <- readInterfaceFile ifacePath
   
   return $ HaddockPackage {
-    pdModules  = packageModules pkgInfo,
+    pdModules  = ifModules iface,
     pdLinkEnv  = ifLinkEnv iface,
     pdHtmlPath = html
   }