-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

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

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' Maybe (InstalledPackageInfo -> FilePath)
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]
  Maybe FilePath -> (FilePath -> IO ()) -> IO ()
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

  Verbosity -> FilePath -> FilePath -> (FilePath -> IO ()) -> IO ()
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
destDir FilePath
"tmphaddock" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
tempDir -> do
    let flags :: [FilePath]
flags =
          [ FilePath
"--gen-contents"
          , FilePath
"--gen-index"
          , FilePath
"--odir=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tempDir
          , FilePath
"--title=Haskell modules on this system"
          ]
            [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [ FilePath
"--read-interface=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
html FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"," FilePath -> FilePath -> 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' =
      [ (InstalledPackageInfo -> InstalledPackageInfo -> Ordering)
-> [InstalledPackageInfo] -> InstalledPackageInfo
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((InstalledPackageInfo -> Version)
-> InstalledPackageInfo -> InstalledPackageInfo -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing InstalledPackageInfo -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion) [InstalledPackageInfo]
pkgvers'
      | (PackageName
_pname, [InstalledPackageInfo]
pkgvers) <- InstalledPackageIndex -> [(PackageName, [InstalledPackageInfo])]
forall a. PackageIndex a -> [(PackageName, [a])]
allPackagesByName InstalledPackageIndex
pkgs
      , let pkgvers' :: [InstalledPackageInfo]
pkgvers' = (InstalledPackageInfo -> Bool)
-> [InstalledPackageInfo] -> [InstalledPackageInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter InstalledPackageInfo -> Bool
exposed [InstalledPackageInfo]
pkgvers
      , Bool -> Bool
not ([InstalledPackageInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstalledPackageInfo]
pkgvers')
      ]