Commit 0984dd50 authored by Saizan's avatar Saizan

#516, maintains a per-user index of haddock docs

If the haddock-index flag is set it keeps an index 
of the haddock documentation of the packages in 
the global and user databases
parent f2b2f009
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Haddock
-- Copyright : (c) Andrea Vezzosi 2009
-- License : BSD-like
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Interfacing with Haddock
--
-----------------------------------------------------------------------------
module Distribution.Client.Haddock
(
regenerateHaddockIndex
)
where
import Data.Maybe (Maybe(..), listToMaybe)
import Data.List (maximumBy)
import Control.Monad (Monad(return), sequence, guard)
import System.Directory (createDirectoryIfMissing, doesFileExist,
renameFile)
import System.FilePath (FilePath, (</>), splitFileName)
import Distribution.Package (Package(..))
import Distribution.Simple.Program (haddockProgram, ProgramConfiguration
, rawSystemProgram, requireProgramVersion)
import Distribution.Version (Version(Version), orLaterVersion)
import Distribution.Verbosity (Verbosity)
import Distribution.Text (display)
import Distribution.Simple.PackageIndex(PackageIndex, allPackages,
allPackagesByName, fromList)
import Distribution.Simple.Utils (comparing, installDirectoryContents
, intercalate, warn, withTempDirectory)
import Distribution.InstalledPackageInfo as InstalledPackageInfo
(InstalledPackageInfo,InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed, package))
regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackageInfo -> ProgramConfiguration -> FilePath -> IO ()
regenerateHaddockIndex verbosity pkgs conf index = do
(paths,warns) <- haddockPackagePaths pkgs'
case warns of
Nothing -> return ()
Just m -> warn verbosity m
(confHaddock, _, _) <-
requireProgramVersion verbosity haddockProgram
(orLaterVersion (Version [0,6] [])) conf
createDirectoryIfMissing True destDir
withTempDirectory verbosity destDir "htemp" $ \tempDir -> do
let flags = ["--gen-contents", "--gen-index", "--odir="++tempDir]
++ map (\(i,h) -> "--read-interface=" ++ h ++ "," ++ i) paths
rawSystemProgram verbosity confHaddock flags
renameFile (tempDir </> "index.html") (tempDir </> destFile)
installDirectoryContents verbosity tempDir destDir
where
(destDir,destFile) = splitFileName index
pkgs' = map (maximumBy $ comparing packageId)
. allPackagesByName
. fromList
. filter exposed
. allPackages
$ pkgs
haddockPackagePaths :: [InstalledPackageInfo_ m]
-> IO ([(FilePath, FilePath)], Maybe [Char])
haddockPackagePaths pkgs = do
interfaces <- sequence
[ case interfaceAndHtmlPath pkg of
Just (interface, html) -> do
exists <- doesFileExist interface
if exists
then return (pkgid, Just (interface, html))
else return (pkgid, Nothing)
Nothing -> return (pkgid, Nothing)
| pkg <- pkgs, let pkgid = InstalledPackageInfo.package pkg ]
let missing = [ pkgid | (pkgid, Nothing) <- interfaces ]
warning = "The documentation for the following packages are not "
++ "installed. No links will be generated to these packages: "
++ intercalate ", " (map display missing)
flags = [ x | (_, Just x) <- interfaces ]
return (flags, if null missing then Nothing else Just warning)
where
interfaceAndHtmlPath pkg = do
interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)
html <- listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)
guard (not . null $ html)
return (interface, html)
......@@ -41,6 +41,7 @@ import Distribution.Client.Dependency
, upgradableDependencies
, Progress(..), foldProgress, )
import Distribution.Client.Fetch (fetchPackage)
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
-- import qualified Distribution.Client.Info as Info
import Distribution.Client.IndexUtils as IndexUtils
( getAvailablePackages, disambiguateDependencies )
......@@ -88,7 +89,7 @@ import Distribution.Simple.Utils
( defaultPackageDesc, rawSystemExit, comparing )
import Distribution.Simple.InstallDirs
( PathTemplate, fromPathTemplate, toPathTemplate
, initialPathTemplateEnv, substPathTemplate )
, initialPathTemplateEnv, substPathTemplate, systemPathTemplateEnv )
import Distribution.Package
( PackageName, PackageIdentifier, packageName, packageVersion
, Package(..), PackageFixedDeps(..)
......@@ -220,10 +221,44 @@ installWithPlanner planner verbosity packageDBs repos comp conf
when (reportingLevel == DetailedReports) $
storeDetailedBuildReports verbosity logsDir buildReports
regenerateHaddockIndex installPlan'
symlinkBinaries verbosity configFlags installFlags installPlan'
printBuildFailures installPlan'
where
regenerateHaddockIndex installPlan' = do
let regenIndex = and [not . null . filter installedDocs . InstallPlan.toList $ installPlan'
,UserPackageDB `elem` packageDBs
,null [() | SpecificPackageDB _ <- packageDBs]
]
when (regenIndex && isJust (flagToMaybe haddockIndex)) $ do
installed <- getInstalledPackages verbosity comp packageDBs conf
case installed of
Nothing -> return () -- warning ?
Just index -> do
defaultDirs <- InstallDirs.defaultInstallDirs
((\(CompilerId x _) -> x) $ compilerId comp)
(fromFlag (configUserInstall configFlags))
True
Haddock.regenerateHaddockIndex verbosity index conf
(substHaddockIndexFileName defaultDirs . fromFlag $ haddockIndex)
where
installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True
installedDocs _ = False
haddockIndex = installHaddockIndex installFlags
substHaddockIndexFileName defaultDirs template = fromPathTemplate
. substPathTemplate env
$ template
where env = systemPathTemplateEnv (compilerId comp) absoluteDirs
templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
defaultDirs (configInstallDirs configFlags)
absoluteDirs = InstallDirs.absoluteInstallDirs'
(InstallDirs.compilerToTemplateEnv (compilerId comp)
++ InstallDirs.platformToTemplateEnv (buildPlatform))
templateDirs
setupScriptOptions index = SetupScriptOptions {
useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions),
useCompiler = Just comp,
......
......@@ -448,6 +448,7 @@ instance Monoid InfoFlags where
--
data InstallFlags = InstallFlags {
installDocumentation:: Flag Bool,
installHaddockIndex :: Flag PathTemplate,
installDryRun :: Flag Bool,
installReinstall :: Flag Bool,
installOnly :: Flag Bool,
......@@ -461,6 +462,7 @@ data InstallFlags = InstallFlags {
defaultInstallFlags :: InstallFlags
defaultInstallFlags = InstallFlags {
installDocumentation= Flag False,
installHaddockIndex = Flag . toPathTemplate $ "$datadir" </> "doc" </> "index.html",
installDryRun = Flag False,
installReinstall = Flag False,
installOnly = Flag False,
......@@ -508,6 +510,11 @@ installOptions showOrParseArgs =
installDocumentation (\v flags -> flags { installDocumentation = v })
(boolOpt [] [])
, option [] ["haddock-index"]
"Haddock html index file (name template shouldn't use $pkgid)"
installHaddockIndex (\v flags -> flags { installHaddockIndex = v })
(reqArg' "TEMPLATE" (toFlag.toPathTemplate)
(flagToList . fmap fromPathTemplate))
, option [] ["dry-run"]
"Do not install anything, only print what would be installed."
installDryRun (\v flags -> flags { installDryRun = v })
......@@ -559,6 +566,7 @@ installOptions showOrParseArgs =
instance Monoid InstallFlags where
mempty = InstallFlags {
installDocumentation= mempty,
installHaddockIndex = mempty,
installDryRun = mempty,
installReinstall = mempty,
installOnly = mempty,
......@@ -570,6 +578,7 @@ instance Monoid InstallFlags where
}
mappend a b = InstallFlags {
installDocumentation= combine installDocumentation,
installHaddockIndex = combine installHaddockIndex,
installDryRun = combine installDryRun,
installReinstall = combine installReinstall,
installOnly = combine installOnly,
......
......@@ -54,6 +54,7 @@ Executable cabal
Distribution.Client.Dependency.TopDown.Types
Distribution.Client.Dependency.Types
Distribution.Client.Fetch
Distribution.Client.Haddock
Distribution.Client.HttpUtils
Distribution.Client.IndexUtils
Distribution.Client.Install
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment