aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Packages.hs
diff options
context:
space:
mode:
authorDavid Waern <unknown>2007-08-17 16:55:35 +0000
committerDavid Waern <unknown>2007-08-17 16:55:35 +0000
commitc9746ad9a53e84c3a46ff8fd77f0fb3656ca7697 (patch)
tree8c5cd9cc969505070eca777b96ac395004df22a9 /src/Haddock/Packages.hs
parentbedd431c75f7660655347d9210dc5043b83232e1 (diff)
Factor out package code to Haddock.Packages
Diffstat (limited to 'src/Haddock/Packages.hs')
-rw-r--r--src/Haddock/Packages.hs155
1 files changed, 155 insertions, 0 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)