Haddock.hs 16.4 KB
Newer Older
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
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Haddock
-- Copyright   :  Isaac Jones 2003-2005
-- 
-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>
-- Stability   :  alpha
-- Portability :  portable
--
-- Invokes haddock to generate api documentation for libraries and optinally
-- executables in this package. Also has support for generating
-- syntax-highlighted source with HsColour and linking the haddock docs to it.

{- All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

module Distribution.Simple.Haddock (
  haddock, hscolour
  ) where

-- local
49
import Distribution.Compat.ReadP(readP_to_S)
50
51
import Distribution.Package (showPackageId)
import Distribution.PackageDescription
52
import Distribution.ParseUtils(Field(..), readFields, parseCommaList, parseFilePathQ)
53
54
import Distribution.Simple.Program(ConfiguredProgram(..), requireProgram, 
                            lookupProgram, programPath, ghcPkgProgram,
David Waern's avatar
David Waern committed
55
56
			    hscolourProgram, haddockProgram, rawSystemProgram, rawSystemProgramStdoutConf,
          ghcProgram)
57
import Distribution.Simple.PreProcess (ppCpp', ppUnlit, preprocessSources,
58
                                PPSuffixHandler, runSimplePreProcessor)
59
import Distribution.Simple.Setup
60
import Distribution.Simple.Build (initialBuildSteps)
61
import Distribution.Simple.InstallDirs (InstallDirs(..),
62
63
64
65
                                        PathTemplateVariable(..),
                                        toPathTemplate, fromPathTemplate,
                                        substPathTemplate,
                                        initialPathTemplateEnv)
66
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), hscolourPref,
David Waern's avatar
David Waern committed
67
                                            haddockPref, distPref, autogenModulesDir )
68
import Distribution.Simple.Utils (die, warn, notice, createDirectoryIfMissingVerbose,
69
70
71
72
73
74
                                  moduleToFilePath, findFile)

import Distribution.Simple.Utils (rawSystemStdout)
import Distribution.Verbosity
import Language.Haskell.Extension
-- Base
75
76
import System.Directory(removeFile, doesFileExist,
                        removeDirectoryRecursive, copyFile)
77

78
import Control.Monad (liftM, when, unless, join)
David Waern's avatar
David Waern committed
79
80
import Data.Maybe    ( isJust, catMaybes, fromJust )
import Data.Char     (isSpace)
81
import Data.List     (nub)
82
83
84
85

import System.FilePath((</>), (<.>), splitFileName, splitExtension,
                       replaceExtension)
import Distribution.Version
David Waern's avatar
David Waern committed
86
import Distribution.Simple.Compiler (compilerVersion, extensionsToFlags)
87
88
89
90
91

-- --------------------------------------------------------------------------
-- Haddock support

haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO ()
92
haddock pkg_descr _ _ haddockFlags
93
94
  | not (hasLibs pkg_descr) && not (fromFlag $ haddockExecutables haddockFlags) =
      warn (fromFlag $ haddockVerbose haddockFlags) $
95
96
97
           "No documentation was generated as this package does not contain "
        ++ "a\nlibrary. Perhaps you want to use the haddock command with the "
        ++ "--executables flag."
98

99
100
101
102
103
104
105
106
haddock pkg_descr lbi suffixes flags = do
    let doExes   = fromFlag (haddockExecutables flags)
        hsColour = fromFlag (haddockHscolour flags)
    when hsColour $ hscolour pkg_descr lbi suffixes defaultHscolourFlags {
      hscolourCSS         = haddockHscolourCss flags,
      hscolourExecutables = haddockExecutables flags,
      hscolourVerbose     = haddockVerbose flags
    }
107

108
109
    (confHaddock, _) <- requireProgram verbosity haddockProgram
                        (orLaterVersion (Version [0,6] [])) (withPrograms lbi)
110
111
112
113
114
115
116
117
118

    let tmpDir = buildDir lbi </> "tmp"
    createDirectoryIfMissingVerbose verbosity True tmpDir
    createDirectoryIfMissingVerbose verbosity True $ haddockPref pkg_descr
    preprocessSources pkg_descr lbi False verbosity suffixes

    setupMessage verbosity "Running Haddock for" pkg_descr

    let replaceLitExts = map ( (tmpDir </>) . (`replaceExtension` "hs") )
119
    let showPkg    = showPackageId (package pkg_descr)
120
    let outputFlag = if fromFlag (haddockHoogle flags)
121
122
                     then "--hoogle"
                     else "--html"
123
    let Just version = programVersion confHaddock
124
    let have_src_hyperlink_flags = version >= Version [0,8] []
David Waern's avatar
David Waern committed
125
        isVersion2               = version >= Version [2,0] []
126
127
128
129
130
131
132

    let mockFlags
          | isVersion2 = []
          | otherwise  = ["-D__HADDOCK__"]

    let mockAll bi = mapM_ (mockPP mockFlags bi tmpDir)

133
    let comp = compiler lbi
134
        Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi)
135
    let cssFileFlag = case flagToMaybe $ haddockCss flags of
136
137
138
139
                        Nothing -> []
                        Just cssFile -> ["--css=" ++ cssFile]
    let verboseFlags = if verbosity > deafening then ["--verbose"] else []
    when (hsColour && not have_src_hyperlink_flags) $
140
         die "haddock --hyperlink-source requires Haddock version 0.8 or later"
141
142
143
144
145
146
147
    let linkToHscolour = if hsColour
            then ["--source-module=src/%{MODULE/./-}.html"
                 ,"--source-entity=src/%{MODULE/./-}.html#%{NAME}"]
            else []

    let getField pkgId f = do
            let name = showPackageId pkgId
148
            s <- rawSystemStdout verbosity (programPath pkgTool) ["field", name, f]
149
150
151
152
153
            case readFields s of
                (ParseOk _ ((F _ _ fieldVal):_)) ->
                    return . join . join . take 1 . map fst . filter (null . snd)
                        . readP_to_S (parseCommaList parseFilePathQ) $ fieldVal
                _ -> do
154
155
                    warn verbosity $ "Unrecognised output from ghc-pkg field "
		                  ++ name ++ " " ++ f ++ ": " ++ s
156
                    return []
157
158
    let makeReadInterface pkgId = do
            interface <- getField pkgId "haddock-interfaces"
159
            html <- case flagToMaybe $ haddockHtmlLocation flags of
160
                Nothing -> getField pkgId "haddock-html"
161
162
                Just htmlStrTemplate ->
                  let env0 = initialPathTemplateEnv pkgId (compilerId comp)
163
                      prefixSubst = prefix (installDirTemplates lbi)
164
165
166
167
168
                      env = (PrefixVar, prefixSubst) : env0
                      expandTemplateVars = fromPathTemplate
                                         . substPathTemplate env
                                         . toPathTemplate
                   in return (expandTemplateVars htmlStrTemplate)
169
170
171
172
173
174
175
176
177
178
            interfaceExists <- doesFileExist interface
            if interfaceExists
              then return $ Just $ "--read-interface="
                         ++ (if null html then "" else html ++ ",")
                         ++ interface
              else do warn verbosity $ "The documentation for package "
                         ++ showPackageId pkgId ++ " is not installed. "
                         ++ "No links to it will be generated."
                      return Nothing

179
180
    packageFlags <- liftM catMaybes $ mapM makeReadInterface (packageDeps lbi)

David Waern's avatar
David Waern committed
181
182
183
184
185
186
187
188
189
190
191
192
193
194
    when isVersion2 $ do
      strHadGhcVers <- rawSystemProgramStdoutConf verbosity haddockProgram (withPrograms lbi) ["--ghc-version"]
      let mHadGhcVers = readVersion strHadGhcVers
      when (mHadGhcVers == Nothing) $ die "Could not get GHC version from Haddock"
      when (fromJust mHadGhcVers /= compilerVersion comp) $
        die "Haddock's internal GHC version must match the configured GHC version"

    ghcLibDir0 <- rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"]
    let ghcLibDir = reverse $ dropWhile isSpace $ reverse ghcLibDir0

    let packageName = if isVersion2
          then ["--optghc=-package-name", "--optghc=" ++ showPkg]
          else ["--package=" ++ showPkg]

195
196
    let haddock2options bi preprocessDir = if isVersion2
          then ("-B" ++ ghcLibDir) : map ("--optghc=" ++) (ghcSimpleOptions lbi bi preprocessDir)
David Waern's avatar
David Waern committed
197
198
          else []

199
200
    when isVersion2 $ initialBuildSteps pkg_descr lbi verbosity suffixes

201
202
    withLib pkg_descr () $ \lib -> do
        let bi = libBuildInfo lib
203
204
205
            modules = exposedModules lib ++ otherModules bi
        inFiles <- getModulePaths lbi bi modules
        unless isVersion2 $ mockAll bi inFiles
206
        let prologName = distPref </> showPkg ++ "-haddock-prolog.txt"
207
208
209
210
211
            prolog | null (description pkg_descr) = synopsis pkg_descr
                   | otherwise                    = description pkg_descr
            subtitle | null (synopsis pkg_descr) = ""
                     | otherwise                 = ": " ++ synopsis pkg_descr
        writeFile prologName (prolog ++ "\n")
212
213
214
        let targets
              | isVersion2 = modules
              | otherwise  = replaceLitExts inFiles
215
216
217
218
219
        let haddockFile = haddockPref pkg_descr </> haddockName pkg_descr
        -- FIX: replace w/ rawSystemProgramConf?
        rawSystemProgram verbosity confHaddock
                ([outputFlag,
                  "--odir=" ++ haddockPref pkg_descr,
220
                  "--title=" ++ showPkg ++ subtitle,
221
222
                  "--dump-interface=" ++ haddockFile,
                  "--prologue=" ++ prologName]
David Waern's avatar
David Waern committed
223
                 ++ packageName
224
225
226
227
228
229
		 ++ cssFileFlag
                 ++ linkToHscolour
                 ++ packageFlags
                 ++ programArgs confHaddock
                 ++ verboseFlags
                 ++ map ("--hide=" ++) (otherModules bi)
230
231
                 ++ haddock2options bi (buildDir lbi)
                 ++ targets
232
233
                )
        removeFile prologName
234
235
        notice verbosity $ "Documentation created: "
                        ++ (haddockPref pkg_descr </> "index.html")
236
237
238
239
240
241
242
243
244

    withExe pkg_descr $ \exe -> when doExes $ do
        let bi = buildInfo exe
            exeTargetDir = haddockPref pkg_descr </> exeName exe
        createDirectoryIfMissingVerbose verbosity True exeTargetDir
        inFiles' <- getModulePaths lbi bi (otherModules bi)
        srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe)
        let inFiles = srcMainPath : inFiles'
        mockAll bi inFiles
245
246
247
248
        let prologName = distPref </> showPkg ++ "-haddock-prolog.txt"
            prolog | null (description pkg_descr) = synopsis pkg_descr
                   | otherwise                    = description pkg_descr
        writeFile prologName (prolog ++ "\n")
249
250
251
252
        let targets
              | isVersion2 = srcMainPath : otherModules bi
              | otherwise = replaceLitExts inFiles
        let preprocessDir = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp"
253
254
255
        rawSystemProgram verbosity confHaddock
                ([outputFlag,
                  "--odir=" ++ exeTargetDir,
256
257
                  "--title=" ++ exeName exe,
                  "--prologue=" ++ prologName]
258
259
260
261
                 ++ linkToHscolour
                 ++ packageFlags
                 ++ programArgs confHaddock
                 ++ verboseFlags
262
263
                 ++ haddock2options bi preprocessDir
                 ++ targets
264
                )
265
        removeFile prologName
266
267
        notice verbosity $ "Documentation created: "
                       ++ (exeTargetDir </> "index.html")
268
269
270

    removeDirectoryRecursive tmpDir
  where
271
        verbosity = fromFlag (haddockVerbose flags)
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
        mockPP inputArgs bi pref file
            = do let (filePref, fileName) = splitFileName file
                 let targetDir  = pref </> filePref
                 let targetFile = targetDir </> fileName
                 let (targetFileNoext, targetFileExt) = splitExtension targetFile
                 createDirectoryIfMissingVerbose verbosity True targetDir
                 if needsCpp bi
                    then runSimplePreProcessor (ppCpp' inputArgs bi lbi)
                           file targetFile verbosity
                    else copyFile file targetFile
                 when (targetFileExt == ".lhs") $ do
                       runSimplePreProcessor ppUnlit
                         targetFile (targetFileNoext <.> "hs") verbosity
                       return ()
        needsCpp :: BuildInfo -> Bool
        needsCpp bi = CPP `elem` extensions bi

David Waern's avatar
David Waern committed
289

290
291
ghcSimpleOptions :: LocalBuildInfo -> BuildInfo -> FilePath -> [String]
ghcSimpleOptions lbi bi mockDir
David Waern's avatar
David Waern committed
292
293
  =  ["-hide-all-packages"]
  ++ (concat [ ["-package", showPackageId pkg] | pkg <- packageDeps lbi ])
294
  ++ ["-i"]
David Waern's avatar
David Waern committed
295
  ++ hcOptions GHC (options bi)
296
297
298
299
300
301
  ++ ["-i" ++ autogenModulesDir lbi]
  ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]
  ++ ["-i" ++ mockDir]
  ++ ["-I" ++ dir | dir <- includeDirs bi]
  ++ ["-odir", mockDir]
  ++ ["-hidir", mockDir]
David Waern's avatar
David Waern committed
302
303
304
305
  ++ extensionsToFlags c (extensions bi)
  where c = compiler lbi


306
307
308
309
-- --------------------------------------------------------------------------
-- hscolour support

hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO ()
310
hscolour pkg_descr lbi suffixes flags = do
311
    (hscolourProg, _) <- requireProgram verbosity hscolourProgram
312
                         (orLaterVersion (Version [1,8] [])) (withPrograms lbi)
313
314
315
316
317
318
319
320
321

    createDirectoryIfMissingVerbose verbosity True $ hscolourPref pkg_descr
    preprocessSources pkg_descr lbi False verbosity suffixes

    setupMessage verbosity "Running hscolour for" pkg_descr
    let replaceDot = map (\c -> if c == '.' then '-' else c)

    withLib pkg_descr () $ \lib -> when (isJust $ library pkg_descr) $ do
        let bi = libBuildInfo lib
322
323
324
325
            modules = exposedModules lib ++ otherModules bi
	    outputDir = hscolourPref pkg_descr </> "src"
	createDirectoryIfMissingVerbose verbosity True outputDir
	copyCSS hscolourProg outputDir
326
        inFiles <- getModulePaths lbi bi modules
327
        flip mapM_ (zip modules inFiles) $ \(mo, inFile) ->
328
            let outFile = outputDir </> replaceDot mo <.> "html"
329
             in rawSystemProgram verbosity hscolourProg
330
331
332
333
                     ["-css", "-anchor", "-o" ++ outFile, inFile]

    withExe pkg_descr $ \exe -> when doExes $ do
        let bi = buildInfo exe
334
335
            modules = "Main" : otherModules bi
            outputDir = hscolourPref pkg_descr </> exeName exe </> "src"
336
        createDirectoryIfMissingVerbose verbosity True outputDir
337
        copyCSS hscolourProg outputDir
338
339
        srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe)
        inFiles <- liftM (srcMainPath :) $ getModulePaths lbi bi (otherModules bi)
340
        flip mapM_ (zip modules inFiles) $ \(mo, inFile) ->
341
            let outFile = outputDir </> replaceDot mo <.> "html"
342
            in rawSystemProgram verbosity hscolourProg
343
                     ["-css", "-anchor", "-o" ++ outFile, inFile]
344

345
346
347
348
349
350
  where copyCSS hscolourProg dir = case stylesheet of
          Nothing | programVersion hscolourProg >= Just (Version [1,9] []) ->
                    rawSystemProgram verbosity hscolourProg
                      ["-print-css", "-o" ++ dir </> "hscolour.css"]
                  | otherwise -> return ()
          Just s -> copyFile s (dir </> "hscolour.css")
351
352
353
        doExes     = fromFlag (hscolourExecutables flags)
        stylesheet = flagToMaybe (hscolourCSS flags)
        verbosity  = fromFlag (hscolourVerbose flags)
354
355
356
357
358
359
360


--TODO: where to put this? it's duplicated in .Simple too
getModulePaths :: LocalBuildInfo -> BuildInfo -> [String] -> IO [FilePath]
getModulePaths lbi bi =
   fmap concat .
      mapM (flip (moduleToFilePath (buildDir lbi : hsSourceDirs bi)) ["hs", "lhs"])