-----------------------------------------------------------------------------
-- |
-- 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 Distribution.Client.Compat.Prelude
import Prelude ()

import Data.List (maximumBy)
import System.Directory (createDirectoryIfMissing, renameFile)
import System.FilePath ((</>), splitFileName)
import Distribution.Package
         ( packageVersion )
import Distribution.Simple.Haddock (haddockPackagePaths)
import Distribution.Simple.Program (haddockProgram, ProgramDb
                                   , runProgram, requireProgramVersion)
import Distribution.Version (mkVersion, orLaterVersion)
import Distribution.Simple.PackageIndex
         ( InstalledPackageIndex, allPackagesByName )
import Distribution.Simple.Utils
         ( debug, installDirectoryContents, withTempDirectory )
import Distribution.InstalledPackageInfo as InstalledPackageInfo
         ( InstalledPackageInfo(exposed) )

regenerateHaddockIndex :: Verbosity
                       -> InstalledPackageIndex -> ProgramDb
                       -> FilePath
                       -> IO ()
regenerateHaddockIndex :: Verbosity
-> InstalledPackageIndex -> ProgramDb -> FilePath -> IO ()
regenerateHaddockIndex Verbosity
verbosity InstalledPackageIndex
pkgs ProgramDb
progdb FilePath
index = do
      ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
paths, Maybe FilePath
warns) <- [InstalledPackageInfo]
-> Maybe (InstalledPackageInfo -> FilePath)
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)],
      Maybe FilePath)
haddockPackagePaths [InstalledPackageInfo]
pkgs' forall a. Maybe a
Nothing
      let paths' :: [(FilePath, FilePath)]
paths' = [ (FilePath
interface, FilePath
html) | (FilePath
interface, Just FilePath
html, Maybe FilePath
_, Visibility
_) <- [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
paths]
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe FilePath
warns (Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity)

      (ConfiguredProgram
confHaddock, Version
_, ProgramDb
_) <-
          Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion Verbosity
verbosity Program
haddockProgram
                                    (Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
0,Int
6])) ProgramDb
progdb

      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
destDir

      forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
destDir FilePath
"tmphaddock" forall a b. (a -> b) -> a -> b
$ \FilePath
tempDir -> do

        let flags :: [FilePath]
flags = [ FilePath
"--gen-contents"
                    , FilePath
"--gen-index"
                    , FilePath
"--odir=" forall a. [a] -> [a] -> [a]
++ FilePath
tempDir
                    , FilePath
"--title=Haskell modules on this system" ]
                 forall a. [a] -> [a] -> [a]
++ [ FilePath
"--read-interface=" forall a. [a] -> [a] -> [a]
++ FilePath
html forall a. [a] -> [a] -> [a]
++ FilePath
"," forall a. [a] -> [a] -> [a]
++ FilePath
interface
                    | (FilePath
interface, FilePath
html) <- [(FilePath, FilePath)]
paths' ]
        Verbosity -> ConfiguredProgram -> [FilePath] -> IO ()
runProgram Verbosity
verbosity ConfiguredProgram
confHaddock [FilePath]
flags
        FilePath -> FilePath -> IO ()
renameFile (FilePath
tempDir FilePath -> FilePath -> FilePath
</> FilePath
"index.html") (FilePath
tempDir FilePath -> FilePath -> FilePath
</> FilePath
destFile)
        Verbosity -> FilePath -> FilePath -> IO ()
installDirectoryContents Verbosity
verbosity FilePath
tempDir FilePath
destDir

  where
    (FilePath
destDir,FilePath
destFile) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
index
    pkgs' :: [InstalledPackageInfo]
    pkgs' :: [InstalledPackageInfo]
pkgs' = [ forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall pkg. Package pkg => pkg -> Version
packageVersion) [InstalledPackageInfo]
pkgvers'
            | (PackageName
_pname, [InstalledPackageInfo]
pkgvers) <- forall a. PackageIndex a -> [(PackageName, [a])]
allPackagesByName InstalledPackageIndex
pkgs
            , let pkgvers' :: [InstalledPackageInfo]
pkgvers' = forall a. (a -> Bool) -> [a] -> [a]
filter InstalledPackageInfo -> Bool
exposed [InstalledPackageInfo]
pkgvers
            , Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstalledPackageInfo]
pkgvers') ]