Factor out package code to Haddock.Packages

2 files changed, 164 insertions, 138 deletions

diff --git a/src/Haddock/Packages.hs b/src/Haddock/Packages.hs
new file mode 100644
index 00000000..18383c4c
--- /dev/null
+++ b/src/Haddock/Packages.hs
@@ -0,0 +1,155 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Packages (
+  HaddockPackage(..),
+  initAndReadPackages,
+  combineDocEnvs
+) where
+
+
+import Haddock.Types
+import Haddock.Exception
+import Haddock.InterfaceFile
+
+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
+
+
+-- | 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],
+  pdDocEnv   :: DocEnv,
+  pdHtmlPath :: FilePath
+}
+
+
+-- | Expose the list of packages to GHC. Then initialize GHC's package state
+-- and get the name of the actually loaded packages matching the supplied 
+-- list of packages. The matching packages might be newer versions of the 
+-- supplied ones. For each matching package, try to read its installed Haddock
+-- information.
+--
+-- It would be better to try to get the "in scope" packages from GHC instead.
+-- This would make the -use-package flag unnecessary. But currently it 
+-- seems all you can get from the GHC api is all packages that are linked in 
+-- (i.e the closure of the "in scope" packages).
+initAndReadPackages :: Session -> [String] -> IO [HaddockPackage] 
+initAndReadPackages session pkgStrs = do
+
+  -- expose the packages 
+
+  dfs <- getSessionDynFlags session
+  let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage pkgStrs }
+  setSessionDynFlags session dfs'
+
+  -- try to parse the packages and get their names, without versions
+  pkgNames <- mapM (handleParse . unpackPackageId . stringToPackageId) pkgStrs
+
+  -- init GHC's package state
+  (_, depPackages) <- initPackages dfs'
+
+  -- compute the pkgIds of the loaded packages matching the 
+  -- supplied ones
+  
+  let depPkgs = map (fromJust . unpackPackageId) depPackages      
+      matchingPackages = [ mkPackageId pkg | pkg <- depPkgs, 
+                           pkgName pkg `elem` pkgNames ]
+
+  -- read the Haddock information for the matching packages
+  getPackages session matchingPackages
+  where
+    handleParse (Just pkg) = return (pkgName pkg)
+    handleParse Nothing = throwE "Could not parse package identifier"
+
+
+-- | Try to create a HaddockPackage for each package.
+-- Print a warning on stdout if a HaddockPackage could not be created.
+getPackages :: Session -> [PackageId] -> IO [HaddockPackage]
+getPackages session packages = do
+
+  -- get InstalledPackageInfos for each package
+  dynflags <- getSessionDynFlags session
+  let pkgInfos = map (getPackageDetails (pkgState dynflags)) packages
+
+  -- try to read the installed haddock information (.haddock interface file and
+  -- html path) for the packages
+  liftM catMaybes $ mapM tryGetPackage pkgInfos
+  where
+    -- try to get a HaddockPackage, warn if we can't
+    tryGetPackage pkgInfo = 
+        (getPackage session 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 create a HaddockPackage structure for a package
+getPackage :: Session -> InstalledPackageInfo -> IO HaddockPackage
+getPackage session pkgInfo = do
+
+  html <- getHtml pkgInfo
+  ifacePath <- getIface pkgInfo
+  iface <- readInterfaceFile ifacePath
+  
+  let docEnv  = ifDocEnv iface
+      modules = packageModules pkgInfo
+
+  return $ HaddockPackage {
+    pdModules  = modules,
+    pdDocEnv   = docEnv,
+    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 doc 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.
+combineDocEnvs :: [HaddockPackage] -> DocEnv
+combineDocEnvs packages = Map.unions (map pdDocEnv packages)
diff --git a/src/Main.hs b/src/Main.hs
index e7b52e4d..8f3eda4e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -20,6 +20,7 @@ import Haddock.InterfaceFile
 import Haddock.Exception
 import Haddock.Options
 import Haddock.Typecheck
+import Haddock.Packages
 import Haddock.Utils.GHC
 import Paths_haddock
 
@@ -145,32 +146,23 @@ main = handleTopExceptions $ do
   restGhcFlags <- tryParseStaticFlags flags
   (session, _) <- startGHC libDir
 
-  -- get the -use-package packages, and expose them to ghc
-  usePackages <- getUsePackages flags session
-
   -- parse and set the ghc flags
   dynflags <- parseGhcFlags session restGhcFlags
   setSessionDynFlags session dynflags
 
-  -- init and get the package dependencies 
-  (_, depPackages) <- initPackages dynflags
-  let depPkgs = map (fromJust . unpackPackageId) depPackages
-
-  -- compute the exposed packages
-  let exposedPackages = [ mkPackageId pkg | pkg <- depPkgs, 
-                          pkgName pkg `elem` usePackages ]
-
-  -- get the HaddockPackages
-  packages <- getPackages session exposedPackages
+  -- get the -use-package packages, expose them to GHC,
+  -- and try to load their installed HaddockPackages
+  let usePackages = [ pkg | Flag_UsePackage pkg <- flags ]
+  packages <- initAndReadPackages session usePackages
 
-  -- typechecking
-  modules  <- typecheckFiles session fileArgs
+  -- typecheck argument modules using GHC
+  modules <- typecheckFiles session fileArgs
 
   -- update the html references for rendering phase (global variable)
   updateHTMLXRefs packages
 
-  -- combine the doc envs of the exposed packages into one
-  let env = packagesDocEnv packages
+  -- combine the doc envs of the read packages into one
+  let env = combineDocEnvs packages
 
   -- TODO: continue to break up the run function into parts
   run flags modules env
@@ -311,36 +303,6 @@ handleFlags flags fileArgs = do
   return ghcLibDir
 
 
--- | Handle the -use-package flags
--- 
--- Returns the names of the packages (without version number), if parsing
--- succeeded.
---
--- It would be better to try to get the "exposed" packages from GHC instead.
--- This would make the -use-package flag unnecessary. But currently it 
--- seems all you can get from the GHC api is all packages that are linked in 
--- (i.e the closure of the exposed packages).
-getUsePackages :: [Flag] -> Session -> IO [String]
-getUsePackages flags session = do
-
-  -- get the packages from the commandline flags
-  let packages = [ pkg | Flag_UsePackage pkg <- flags ]
-
-  -- expose these packages 
-  -- (makes "-use-package pkg" equal to "-g '-package pkg'")
-
-  dfs <- getSessionDynFlags session
-  let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage packages }
-  setSessionDynFlags session dfs'
-
-  -- try to parse these packages into PackageIndentifiers
-
-  mapM (handleParse . unpackPackageId . stringToPackageId) packages
-  where
-    handleParse (Just pkg) = return (pkgName pkg)
-    handleParse Nothing = throwE "Could not parse package identifier"
-
-
 -- | Filter out the GHC specific flags and try to parse and set them as static 
 -- flags. Return a list of flags that couldn't be parsed. 
 tryParseStaticFlags flags = do
@@ -1118,94 +1080,3 @@ toHsType t = case t of
 
 type ErrMsg = String
 type ErrMsgM a = Writer [ErrMsg] a
-
-
---------------------------------------------------------------------------------
--- Packages 
---------------------------------------------------------------------------------
-
-
--- | Represents the installed Haddock information of a package
-data HaddockPackage = HaddockPackage {
-  pdModules  :: [Module],
-  pdDocEnv   :: DocEnv,
-  pdHtmlPath :: FilePath
-}
-
-
--- | 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."
-
-
--- | Try to create a HaddockPackage structure for a package
-getPackage :: Session -> InstalledPackageInfo -> IO HaddockPackage
-getPackage session pkgInfo = do
-
-  html <- getHtml pkgInfo
-  ifacePath <- getIface pkgInfo
-  iface <- readInterfaceFile ifacePath
-  
-  let docEnv  = ifDocEnv iface
-      modules = packageModules pkgInfo
-
-  return $ HaddockPackage {
-    pdModules  = modules,
-    pdDocEnv   = docEnv,
-    pdHtmlPath = html
-  } 
-
-       
--- | Try to create a HaddockPackage for each package.
--- Print a warning on stdout if a HaddockPackage could not be created.
-getPackages :: Session -> [PackageId] -> IO [HaddockPackage]
-getPackages session packages = do
-
-  -- get InstalledPackageInfos for each package
-  dynflags <- getSessionDynFlags session
-  let pkgInfos = map (getPackageDetails (pkgState dynflags)) packages
-
-  -- try to read the installed haddock information (.haddock interface file and
-  -- html path) for the packages
-  liftM catMaybes $ mapM tryGetPackage pkgInfos
-  where
-    -- try to get a HaddockPackage, warn if we can't
-    tryGetPackage pkgInfo = 
-        (getPackage session pkgInfo >>= return . Just)
-      `catchDyn`
-        (\(e::HaddockException) -> do 
-          let pkgName = showPackageId (package pkgInfo)
-          putStrLn ("Warning: Cannot use package " ++ pkgName ++ ":")
-          putStrLn ("   " ++ show e)
-          return Nothing
-        )
-
-
--- | Build one big doc 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.
-packagesDocEnv :: [HaddockPackage] -> DocEnv
-packagesDocEnv packages = Map.unions (map pdDocEnv packages)