diff options
| -rw-r--r-- | src/Haddock/Packages.hs | 155 | ||||
| -rw-r--r-- | src/Main.hs | 147 |
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) |