Refactoring -- get rid of Haddock.Packages

2 files changed, 38 insertions, 160 deletions

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)