[commit: Cabal] master: Move regenerateHaddockIndex more out-of-line in the Install module (ddd9adc)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/ddd9adc7e5a4014d3cf9d22d8bbc63eaab876668

>---------------------------------------------------------------

commit ddd9adc7e5a4014d3cf9d22d8bbc63eaab876668
Author: Duncan Coutts <duncan at haskell.org>
Date:   Tue Jul 7 00:37:22 2009 +0000

    Move regenerateHaddockIndex more out-of-line in the Install module
    Also update the code somewhat following the changes in
    the Cabal API for path templates and substitutions.

>---------------------------------------------------------------

 cabal-install/Distribution/Client/Install.hs |  105 ++++++++++++++++----------
 1 files changed, 66 insertions(+), 39 deletions(-)

diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index 3846ec2..ac29253 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -72,7 +72,7 @@ import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
 import Paths_cabal_install (getBinDir)
 
 import Distribution.Simple.Compiler
-         ( CompilerId(..), Compiler(compilerId)
+         ( CompilerId(..), Compiler(compilerId), compilerFlavor
          , PackageDB(..), PackageDBStack )
 import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)
 import Distribution.Simple.Configure (getInstalledPackages)
@@ -87,9 +87,9 @@ import qualified Distribution.Simple.Setup as Cabal
          ( installCommand, InstallFlags(..), emptyInstallFlags )
 import Distribution.Simple.Utils
          ( defaultPackageDesc, rawSystemExit, comparing )
-import Distribution.Simple.InstallDirs
-         ( PathTemplate, fromPathTemplate, toPathTemplate
-         , initialPathTemplateEnv, substPathTemplate, systemPathTemplateEnv )
+import Distribution.Simple.InstallDirs as InstallDirs
+         ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
+         , initialPathTemplateEnv, compilerTemplateEnv, installDirsTemplateEnv )
 import Distribution.Package
          ( PackageName, PackageIdentifier, packageName, packageVersion
          , Package(..), PackageFixedDeps(..)
@@ -220,45 +220,12 @@ installWithPlanner planner verbosity packageDBs repos comp conf
           BuildReports.storeAnonymous buildReports
         when (reportingLevel == DetailedReports) $
           storeDetailedBuildReports verbosity logsDir buildReports
-
-        regenerateHaddockIndex installPlan'
-
+        regenerateHaddockIndex verbosity packageDBs comp conf
+                               configFlags installFlags 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,
@@ -332,6 +299,66 @@ storeDetailedBuildReports verbosity logsDir reports = sequence_
       | isDoesNotExistError ioe  = Just ioe
     missingFile _                = Nothing
 
+regenerateHaddockIndex :: Verbosity
+                       -> [PackageDB]
+                       -> Compiler
+                       -> ProgramConfiguration
+                       -> ConfigFlags
+                       -> InstallFlags
+                       -> InstallPlan
+                       -> IO ()
+regenerateHaddockIndex verbosity packageDBs comp conf
+                       configFlags installFlags installPlan
+  | haddockIndexFileIsSpecified && shouldRegenerateHaddockIndex = do
+
+  defaultDirs <- InstallDirs.defaultInstallDirs
+                   (compilerFlavor comp)
+                   (fromFlag (configUserInstall configFlags))
+                   True
+  let indexFileTemplate = fromFlag (installHaddockIndex installFlags)
+      indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate
+
+  notice verbosity $
+     "Updating documentation index " ++ indexFile
+
+  --TODO: might be nice if the install plan gave us the new InstalledPackageInfo
+  installed <- getInstalledPackages verbosity comp packageDBs conf
+  case installed of
+    Nothing    -> return () -- warning ?
+    Just index -> Haddock.regenerateHaddockIndex verbosity index conf indexFile
+
+  | otherwise = return ()
+  where
+    haddockIndexFileIsSpecified =
+      isJust (flagToMaybe (installHaddockIndex installFlags))
+
+    -- We want to regenerate the index if some new documentation was actually
+    -- installed. Since the index is per-user, we don't do it for global
+    -- installs or special cases where we're installing into a specific db.
+    shouldRegenerateHaddockIndex = normalUserInstall
+                                && someDocsWereInstalled installPlan
+      where
+        someDocsWereInstalled = any installedDocs . InstallPlan.toList
+        normalUserInstall     = (UserPackageDB `elem` packageDBs)
+                             && all (not . isSpecificPackageDB) packageDBs
+
+        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True
+        installedDocs _                                            = False
+        isSpecificPackageDB (SpecificPackageDB _) = True
+        isSpecificPackageDB _                     = False
+
+    substHaddockIndexFileName defaultDirs = fromPathTemplate
+                                          . substPathTemplate env
+      where
+        env  = env0 ++ installDirsTemplateEnv absoluteDirs
+        env0 = InstallDirs.compilerTemplateEnv (compilerId comp)
+            ++ InstallDirs.platformTemplateEnv (buildPlatform)
+        absoluteDirs = InstallDirs.substituteInstallDirTemplates
+                         env0 templateDirs
+        templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
+                         defaultDirs (configInstallDirs configFlags)
+
+
 -- | Make an 'InstallPlan' for the unpacked package in the current directory,
 -- and all its dependencies.
 --