#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

cabal-install/Distribution/Client/Haddock.hs

+-----------------------------------------------------------------------------
+-- |
+-- 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)

cabal-install/Distribution/Client/Install.hs

@@ -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,

cabal-install/Distribution/Client/Setup.hs

@@ -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,

cabal-install/cabal-install.cabal

@@ -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