diff --git a/src/Haddock/Packages.hs b/src/Haddock/Packages.hs
new file mode 100644
index 0000000000000000000000000000000000000000..18383c4cf34c61b1ace84b1ba4adb4620217c26d
--- /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 e7b52e4dc9a8ec5b842e3379088bd81bca98c876..8f3eda4e94991dce4d41d1003d80772795ae9292 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)