1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
-----------------------------------------------------------------------------
-- |
-- 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.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, ProgramConfiguration
, rawSystemProgram, requireProgramVersion)
import Distribution.Version (Version(Version), orLaterVersion)
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.PackageIndex
( PackageIndex, allPackagesByName )
import Distribution.Simple.Utils
( comparing, debug, installDirectoryContents, withTempDirectory )
import Distribution.InstalledPackageInfo as InstalledPackageInfo
( InstalledPackageInfo_(exposed) )
regenerateHaddockIndex :: Verbosity
-> PackageIndex -> ProgramConfiguration -> FilePath
-> IO ()
regenerateHaddockIndex verbosity pkgs conf index = do
(paths, warns) <- haddockPackagePaths pkgs' Nothing
let paths' = [ (interface, html) | (interface, Just html) <- paths]
case warns of
Nothing -> return ()
Just m -> debug verbosity m
(confHaddock, _, _) <-
requireProgramVersion verbosity haddockProgram
(orLaterVersion (Version [0,6] [])) conf
createDirectoryIfMissing True destDir
withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do
let flags = [ "--gen-contents"
, "--gen-index"
, "--odir=" ++ tempDir
, "--title=Haskell modules on this system" ]
++ [ "--read-interface=" ++ html ++ "," ++ interface
| (interface, html) <- paths' ]
rawSystemProgram verbosity confHaddock flags
renameFile (tempDir </> "index.html") (tempDir </> destFile)
installDirectoryContents verbosity tempDir destDir
where
(destDir,destFile) = splitFileName index
pkgs' = [ maximumBy (comparing packageVersion) pkgvers'
| (_pname, pkgvers) <- allPackagesByName pkgs
, let pkgvers' = filter exposed pkgvers
, not (null pkgvers') ]
|
