Refactoring -- get rid of Haddock.Packages

4 files changed, 66 insertions, 187 deletions

diff --git a/src/Distribution/Haddock.hs b/src/Distribution/Haddock.hs
index b43c4f6b..2d0f3dc7 100644
--- a/src/Distribution/Haddock.hs
+++ b/src/Distribution/Haddock.hs
@@ -7,19 +7,7 @@
 
 module Distribution.Haddock (
   readInterfaceFile,
-  H.InterfaceFile(..)
 ) where
 
 
-import Haddock.Exception
-import qualified Haddock.InterfaceFile as H
-
-import Control.Exception
-import Control.Monad
-
-
-readInterfaceFile :: FilePath -> IO (Either String H.InterfaceFile)
-readInterfaceFile f = 
-  liftM Right (H.readInterfaceFile f)
-  `catchDyn` 
-  (\(e::HaddockException) -> return $ Left $ show e)
+import Haddock.InterfaceFile
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 7f2fd6f4..93d6fe4c 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -114,47 +114,51 @@ writeInterfaceFile filename iface = do
 	-- snd send the result to the file
   writeBinMem bh filename
   return ()
+
     
-readInterfaceFile :: FilePath -> IO InterfaceFile
+readInterfaceFile :: FilePath -> IO (Either String InterfaceFile)
 readInterfaceFile filename = do
   bh <- readBinMem filename
 
-  magic <- get bh
-  when (magic /= binaryInterfaceMagic) $ throwE $
-    "Magic number mismatch: couldn't load interface file: " ++ filename
-
+  magic   <- get bh
   version <- get bh
-  when (version /= binaryInterfaceVersion) $ throwE $
-    "Interface file is of wrong version: " ++ filename
 
-  -- get the dictionary
-  dict_p <- get bh
-  data_p <- tellBin bh		
-  seekBin bh dict_p
-  dict <- getDictionary bh
-  seekBin bh data_p		
-
-  -- initialise the user-data field of bh
-  ud <- newReadState dict
-  bh <- return (setUserData bh ud)
+  case () of
+    _ | magic /= binaryInterfaceMagic -> return . Left $
+      "Magic number mismatch: couldn't load interface file: " ++ filename
+      | version /= binaryInterfaceVersion -> return . Left $
+      "Interface file is of wrong version: " ++ filename
+      | otherwise -> do
+
+      -- get the dictionary
+      dict_p <- get bh
+      data_p <- tellBin bh		
+      seekBin bh dict_p
+      dict <- getDictionary bh
+      seekBin bh data_p		
+
+      -- initialise the user-data field of bh
+      ud <- newReadState dict
+      bh <- return (setUserData bh ud)
 	
-  -- get the symbol table
-  symtab_p <- get bh
-  data_p   <- tellBin bh
-  seekBin bh symtab_p
-  -- (construct an empty name cache)
-  u  <- mkSplitUniqSupply 'a' -- ??
-  let nc = initNameCache u []
-  (_, symtab) <- getSymbolTable bh nc
-  seekBin bh data_p
-
-  -- set the symbol table
-  let ud = getUserData bh
-  bh <- return $! setUserData bh ud{ud_symtab = symtab}
-
-  -- load the actual data
-  iface <- get bh
-  return iface
+      -- get the symbol table
+      symtab_p <- get bh
+      data_p   <- tellBin bh
+      seekBin bh symtab_p
+      -- (construct an empty name cache)
+      u  <- mkSplitUniqSupply 'a' -- ??
+      let nc = initNameCache u []
+      (_, symtab) <- getSymbolTable bh nc
+      seekBin bh data_p
+
+      -- set the symbol table
+      let ud = getUserData bh
+      bh <- return $! setUserData bh ud{ud_symtab = symtab}
+
+      -- load the actual data
+      iface <- get bh
+      return (Right iface)
+
 
 -------------------------------------------------------------------------------
 -- Symbol table
diff --git a/src/Haddock/Packages.hs b/src/Haddock/Packages.hs
deleted file mode 100644
index ba3ee841..00000000
--- a/src/Haddock/Packages.hs
+++ /dev/null
@@ -1,126 +0,0 @@
---
--- Haddock - A Haskell Documentation Tool
---
--- (c) Simon Marlow 2003
---
-
-
-module Haddock.Packages (
-  HaddockPackage(..),
-  getHaddockPackages,
-  getHaddockPackages',
-  combineLinkEnvs
-) where
-
-
-import Haddock.Types
-import Haddock.Exception
-import Haddock.InterfaceFile
-import qualified Distribution.Haddock as D
-
-import Data.Maybe
-import qualified Data.Map as Map
-import Control.Monad
-import Control.Exception
-import System.Directory
-
-import GHC
-import DynFlags
-import Module
-import Packages
-
-
--- | This structure represents the installed Haddock information for a 
--- package. This is basically the contents of the .haddock file, the path
--- to the html files and the list of modules in the package
-data HaddockPackage = HaddockPackage {
-  pdModules  :: [Module],
-  pdLinkEnv  :: LinkEnv,
-  pdHtmlPath :: FilePath
-}
-
-
-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.
-getHaddockPackages :: [InstalledPackageInfo] -> IO [HaddockPackage]
-getHaddockPackages pkgInfos = liftM catMaybes $ mapM tryGetPackage pkgInfos
-  where
-    -- try to get a HaddockPackage, warn if we can't
-    tryGetPackage pkgInfo = 
-        (getPackage pkgInfo >>= return . Just)
-      `catchDyn`
-        (\(e::HaddockException) -> do
-          let pkgName = showPackageId (package pkgInfo)
-          putStrLn ("Warning: Cannot use package " ++ pkgName ++ ":")
-          putStrLn ("   " ++ show e)
-          return Nothing
-        )
-
-
--- | Try to read a HaddockPackage structure for a package
-getPackage :: InstalledPackageInfo -> IO HaddockPackage
-getPackage pkgInfo = do
-
-  html      <- getHtml pkgInfo
-  ifacePath <- getIface pkgInfo
-  iface     <- readInterfaceFile ifacePath
-  
-  return $ HaddockPackage {
-    pdModules  = ifModules iface,
-    pdLinkEnv  = ifLinkEnv iface,
-    pdHtmlPath = html
-  } 
-
-
--- | Recreate exposed modules from an InstalledPackageInfo
-packageModules :: InstalledPackageInfo -> [Module]
-packageModules pkgInfo = map (mkModule (pkgId pkgInfo)) moduleNames
-  where 
-    moduleNames = map mkModuleName (exposedModules pkgInfo)
-    pkgId = mkPackageId . package 
-
-
--- | Get the Haddock HTML directory path for a package
-getHtml :: InstalledPackageInfo -> IO FilePath
-getHtml pkgInfo = case haddockHTMLs pkgInfo of 
-  (path:_) | not (null path) -> do
-    dirExists <- doesDirectoryExist path
-    if dirExists then return path else throwE $
-       "HTML directory " ++ path ++ " does not exist."
-  _ -> throwE "No Haddock documentation installed."
-
-
--- | Get the Haddock interface path for a package
-getIface :: InstalledPackageInfo -> IO FilePath
-getIface pkgInfo = case haddockInterfaces pkgInfo of
-  (file:_) | not (null file) -> do
-    fileExists <- doesFileExist file
-    if fileExists then return file else throwE $
-       "Interface file " ++ file ++ " does not exist."
-  _ -> throwE "No Haddock interface installed."
-
-
--- | Build one big link env out of a list of packages. If multiple packages 
--- export the same (original) name, we just pick one of the packages as the 
--- documentation site.
-combineLinkEnvs :: [HaddockPackage] -> LinkEnv
-combineLinkEnvs packages = Map.unions (map pdLinkEnv packages)
diff --git a/src/Main.hs b/src/Main.hs
index 8ddea3e9..779da8f2 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -10,7 +10,6 @@
 module Main (main) where
 
 
-import Haddock.Packages
 import Haddock.Backends.Html
 import Haddock.Backends.Hoogle
 import Haddock.Interface
@@ -108,21 +107,14 @@ main = handleTopExceptions $ do
   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
-
   -- get packages via --read-interface
-  packages' <- getHaddockPackages' (getIfacePairs flags)
-  let packages = packages'' ++ packages'
+  packages <- readInterfaceFiles (getIfacePairs flags)
 
   -- typecheck argument modules using GHC
   modules <- typecheckFiles session fileArgs
 
   -- combine the link envs of the external packages into one
-  let extLinks = combineLinkEnvs packages
+  let extLinks = Map.unions (map (ifLinkEnv . fst) packages)
 
   -- create the interfaces -- this is the core part of Haddock
   let (interfaces, homeLinks, messages) = createInterfaces modules extLinks flags
@@ -217,10 +209,27 @@ render flags interfaces = do
 
 
 -------------------------------------------------------------------------------
--- Misc
+-- Reading and dumping interface files
 -------------------------------------------------------------------------------
 
 
+readInterfaceFiles :: [(FilePath, FilePath)] -> IO [(InterfaceFile, FilePath)]
+readInterfaceFiles pairs = do
+  mbPackages <- mapM tryReadIface pairs
+  return (catMaybes mbPackages)
+  where
+    -- try to read an interface, warn if we can't
+    tryReadIface (html, iface) = do
+      eIface <- 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 (iface, html)
+
+
 dumpInterfaceFile :: [Module] -> LinkEnv -> [Flag] -> IO ()
 dumpInterfaceFile modules homeLinks flags = 
   case [str | Flag_DumpInterface str <- flags] of
@@ -233,6 +242,11 @@ dumpInterfaceFile modules homeLinks flags =
       }
 
 
+-------------------------------------------------------------------------------
+-- Misc
+-------------------------------------------------------------------------------
+
+
 handleEasyFlags flags fileArgs = do
   usage <- getUsage
 
@@ -255,12 +269,11 @@ handleEasyFlags flags fileArgs = do
       ", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n"
 
 
-updateHTMLXRefs :: [HaddockPackage] -> IO ()
+updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO ()
 updateHTMLXRefs packages = do
   writeIORef html_xrefs_ref (Map.fromList mapping)
   where
-    mapping = [ (mod, html) | 
-                (HaddockPackage mods _ html) <- packages, mod <- mods ] 
+    mapping = [(mod, html) | (iface, html) <- packages, mod <- ifModules iface] 
 
 
 getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName))