Add support for --read-interface again

4 files changed, 60 insertions, 16 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
   } 
diff --git a/src/Main.hs b/src/Main.hs
index c900529c..8ddea3e9 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -105,14 +105,18 @@ main = handleTopExceptions $ do
   libDir <- handleEasyFlags flags fileArgs
   
   -- initialize GHC
-  let ghcFlags = makeGhcFlags flags
+  let ghcFlags = getGhcFlags flags
   (session, dynflags) <- startGhc libDir ghcFlags
 
   -- get the -use-package packages, load them in GHC,
   -- and try to get the corresponding installed HaddockPackages
   let usePackages = [ pkg | Flag_UsePackage pkg <- flags ]
   pkgInfos <- loadPackages session usePackages
-  packages <- getHaddockPackages pkgInfos 
+  packages'' <- getHaddockPackages pkgInfos
+
+  -- get packages via --read-interface
+  packages' <- getHaddockPackages' (getIfacePairs flags)
+  let packages = packages'' ++ packages'
 
   -- typecheck argument modules using GHC
   modules <- typecheckFiles session fileArgs
@@ -129,7 +133,7 @@ main = handleTopExceptions $ do
   render flags interfaces
 
   -- last but not least, dump the interface file!
-  dumpInterfaceFile homeLinks flags
+  dumpInterfaceFile (map ghcModule modules) homeLinks flags
 
 
 -------------------------------------------------------------------------------
@@ -217,14 +221,15 @@ render flags interfaces = do
 -------------------------------------------------------------------------------
 
 
-dumpInterfaceFile :: LinkEnv -> [Flag] -> IO ()
-dumpInterfaceFile homeLinks flags = 
+dumpInterfaceFile :: [Module] -> LinkEnv -> [Flag] -> IO ()
+dumpInterfaceFile modules homeLinks flags = 
   case [str | Flag_DumpInterface str <- flags] of
     [] -> return ()
     fs -> let filename = last fs in writeInterfaceFile filename ifaceFile
   where 
     ifaceFile = InterfaceFile {
-        ifLinkEnv  = homeLinks
+        ifModules = modules,
+        ifLinkEnv = homeLinks
       }