Haddock.hs 19.7 KB
Newer Older
1
2
3
4
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Haddock
-- Copyright   :  Isaac Jones 2003-2005
5
--
Duncan Coutts's avatar
Duncan Coutts committed
6
-- Maintainer  :  cabal-devel@haskell.org
7
8
-- Portability :  portable
--
Duncan Coutts's avatar
Duncan Coutts committed
9
10
11
12
13
14
15
16
17
-- This module deals with the @haddock@ and @hscolour@ commands. Sadly this is
-- a rather complicated module. It deals with two versions of haddock (0.x and
-- 2.x). It has to do pre-processing for haddock 0.x which involves
-- \'unlit\'ing and using @-DHADDOCK@ for any source code that uses @cpp@. It
-- uses information about installed packages (from @ghc-pkg@) to find the
-- locations of documentation for dependent packages, so it can create links.
--
-- The @hscolour@ support allows generating html versions of the original
-- source, with coloured syntax highlighting.
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

{- 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
54
55
import Distribution.Package
         ( PackageIdentifier, Package(..) )
56
import qualified Distribution.ModuleName as ModuleName
57
import Distribution.PackageDescription as PD
58
59
60
         (PackageDescription(..), BuildInfo(..), hcOptions,
          Library(..), hasLibs, withLib,
          Executable(..), withExe)
61
62
import Distribution.Simple.Compiler
         ( Compiler(..), CompilerFlavor(..), compilerVersion
63
         , extensionsToFlags )
64
65
import Distribution.Simple.Program
         ( ConfiguredProgram(..), requireProgram
66
         , rawSystemProgram, rawSystemProgramStdoutConf, rawSystemProgramStdout
67
         , hscolourProgram, haddockProgram, ghcProgram )
68
import Distribution.Simple.PreProcess (ppCpp', ppUnlit, preprocessSources,
69
                                PPSuffixHandler, runSimplePreProcessor)
70
import Distribution.Simple.Setup
71
import Distribution.Simple.Build (initialBuildSteps)
72
import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate,
73
74
75
76
                                        PathTemplateVariable(..),
                                        toPathTemplate, fromPathTemplate,
                                        substPathTemplate,
                                        initialPathTemplateEnv)
77
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
78
import Distribution.Simple.BuildPaths ( haddockPref, haddockName,
79
                                        hscolourPref, autogenModulesDir )
80
import qualified Distribution.Simple.PackageIndex as PackageIndex
81
82
83
         ( lookupPackageId )
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
         ( InstalledPackageInfo_(..) )
84
import Distribution.Simple.Utils
85
86
         ( die, warn, notice, intercalate, setupMessage
         , createDirectoryIfMissingVerbose, withTempFile
87
         , findFileWithExtension, findFile )
88
import Distribution.Text
89
         ( display, simpleParse )
90
91
92
93

import Distribution.Verbosity
import Language.Haskell.Extension
-- Base
94
95
import System.Directory(removeFile, doesFileExist,
                        removeDirectoryRecursive, copyFile)
96

97
import Control.Monad ( when, unless )
98
import Data.Maybe    ( isJust, fromJust, listToMaybe )
David Waern's avatar
David Waern committed
99
import Data.Char     (isSpace)
100
import Data.List     (nub)
101
102

import System.FilePath((</>), (<.>), splitFileName, splitExtension,
103
                       replaceExtension, normalise)
104
import System.IO (hClose, hPutStrLn)
105
106
107
108
109
110
import Distribution.Version

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

haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO ()
111
haddock pkg_descr _ _ haddockFlags
Joachim Breitner's avatar
Joachim Breitner committed
112
  |    not (hasLibs pkg_descr)
113
    && not (fromFlag $ haddockExecutables haddockFlags) =
114
      warn (fromFlag $ haddockVerbosity haddockFlags) $
115
           "No documentation was generated as this package does not contain "
116
        ++ "a library. Perhaps you want to use the haddock command with the "
117
        ++ "--executables."
118

119
haddock pkg_descr lbi suffixes flags = do
120
121
    let distPref = fromFlag (haddockDistPref flags)
        doExes   = fromFlag (haddockExecutables flags)
122
123
124
125
        hsColour = fromFlag (haddockHscolour flags)
    when hsColour $ hscolour pkg_descr lbi suffixes defaultHscolourFlags {
      hscolourCSS         = haddockHscolourCss flags,
      hscolourExecutables = haddockExecutables flags,
126
      hscolourVerbosity   = haddockVerbosity flags
127
    }
128

129
130
    (confHaddock, _) <- requireProgram verbosity haddockProgram
                        (orLaterVersion (Version [0,6] [])) (withPrograms lbi)
131
132
133

    let tmpDir = buildDir lbi </> "tmp"
    createDirectoryIfMissingVerbose verbosity True tmpDir
134
135
    createDirectoryIfMissingVerbose verbosity True $
        haddockPref distPref pkg_descr
136
137
    preprocessSources pkg_descr lbi False verbosity suffixes

138
    setupMessage verbosity "Running Haddock for" (packageId pkg_descr)
139
140

    let replaceLitExts = map ( (tmpDir </>) . (`replaceExtension` "hs") )
141
    let showPkg    = display (packageId pkg_descr)
142
143
144
    let hoogle     = fromFlag (haddockHoogle flags)
        outputFlag | hoogle    = "--hoogle"
                   | otherwise = "--html"
145
    let Just version = programVersion confHaddock
146
    let have_src_hyperlink_flags = version >= Version [0,8] []
David Waern's avatar
David Waern committed
147
        isVersion2               = version >= Version [2,0] []
148

149
150
151
    when (hoogle && version > Version [2] []
                 && version < Version [2,2] []) $
      die $ "haddock 2.0 and 2.1 do not support the --hoogle flag."
152

153
154
155
156
157
158
    let mockFlags
          | isVersion2 = []
          | otherwise  = ["-D__HADDOCK__"]

    let mockAll bi = mapM_ (mockPP mockFlags bi tmpDir)

159
    let comp = compiler lbi
160
    let cssFileFlag = case flagToMaybe $ haddockCss flags of
161
162
                        Nothing -> []
                        Just cssFile -> ["--css=" ++ cssFile]
163
    let verboseFlags = if verbosity >= deafening then ["--verbose"] else []
164
    when (hsColour && not have_src_hyperlink_flags) $
165
         die "haddock --hyperlink-source requires Haddock version 0.8 or later"
166
167
168
169
170
    let linkToHscolour = if hsColour
            then ["--source-module=src/%{MODULE/./-}.html"
                 ,"--source-entity=src/%{MODULE/./-}.html#%{NAME}"]
            else []

171
172
173
174
175
176
    let htmlTemplate = fmap toPathTemplate $
                         flagToMaybe (haddockHtmlLocation flags)
    packageFlags <- do
      (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate
      maybe (return ()) (warn verbosity) warnings
      return packageFlags
177

David Waern's avatar
David Waern committed
178
    when isVersion2 $ do
179
      strHadGhcVers <- rawSystemProgramStdout verbosity confHaddock ["--ghc-version"]
180
181
      let mHadGhcVers :: Maybe Version
          mHadGhcVers = simpleParse strHadGhcVers
David Waern's avatar
David Waern committed
182
183
184
185
186
187
188
189
190
191
192
      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]

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

197
198
    when isVersion2 $
        initialBuildSteps distPref pkg_descr lbi verbosity suffixes
199

200
201
    withLib pkg_descr () $ \lib -> do
        let bi = libBuildInfo lib
202
            modules = PD.exposedModules lib ++ otherModules bi
203
        inFiles <- getLibSourceFiles lbi lib
204
        unless isVersion2 $ mockAll bi inFiles
205
        let template = showPkg ++ "-haddock-prolog.txt"
206
207
            prolog | null (PD.description pkg_descr) = synopsis pkg_descr
                   | otherwise                       = PD.description pkg_descr
208
209
            subtitle | null (synopsis pkg_descr) = ""
                     | otherwise                 = ": " ++ synopsis pkg_descr
Joachim Breitner's avatar
Joachim Breitner committed
210
211
            titleComment | fromFlag (haddockInternal flags) = " (internal documentation)"
                         | otherwise                        = ""
212
213
214
215
        withTempFile distPref template $ \prologFileName prologFileHandle -> do
          hPutStrLn prologFileHandle prolog
          hClose prologFileHandle
          let targets
216
                | isVersion2 = map display modules
217
                | otherwise  = replaceLitExts inFiles
218
219
          let haddockFile = haddockPref distPref pkg_descr
                        </> haddockName pkg_descr
220
          -- FIX: replace w/ rawSystemProgramConf?
Joachim Breitner's avatar
Joachim Breitner committed
221
          let hideArgs | fromFlag (haddockInternal flags) = []
222
223
                       | otherwise = [ "--hide=" ++ display m
                                     | m <- otherModules bi ]
Joachim Breitner's avatar
Joachim Breitner committed
224
225
          let exportsFlags | fromFlag (haddockInternal flags) = ["--ignore-all-exports"]
                           | otherwise                        = []
226
227
          rawSystemProgram verbosity confHaddock
                  ([ outputFlag
228
                   , "--odir=" ++ haddockPref distPref pkg_descr
Joachim Breitner's avatar
Joachim Breitner committed
229
                   , "--title=" ++ showPkg ++ subtitle ++ titleComment
230
231
232
233
234
235
236
                   , "--dump-interface=" ++ haddockFile
                   , "--prologue=" ++ prologFileName ]
                   ++ packageName
                   ++ cssFileFlag
                   ++ linkToHscolour
                   ++ packageFlags
                   ++ verboseFlags
Joachim Breitner's avatar
Joachim Breitner committed
237
238
                   ++ hideArgs
                   ++ exportsFlags
239
240
241
242
                   ++ haddock2options bi (buildDir lbi)
                   ++ targets
                  )
          notice verbosity $ "Documentation created: "
243
                          ++ (haddockPref distPref pkg_descr </> "index.html")
244
245
246

    withExe pkg_descr $ \exe -> when doExes $ do
        let bi = buildInfo exe
247
            exeTargetDir = haddockPref distPref pkg_descr </> exeName exe
248
        createDirectoryIfMissingVerbose verbosity True exeTargetDir
249
        inFiles@(srcMainPath:_) <- getExeSourceFiles lbi exe
250
        mockAll bi inFiles
251
        let template = showPkg ++ "-haddock-prolog.txt"
252
253
            prolog | null (PD.description pkg_descr) = synopsis pkg_descr
                   | otherwise                    = PD.description pkg_descr
254
255
            titleComment | fromFlag (haddockInternal flags) = " (internal documentation)"
                         | otherwise                        = ""
256
257
258
259
        withTempFile distPref template $ \prologFileName prologFileHandle -> do
          hPutStrLn prologFileHandle prolog
          hClose prologFileHandle
          let targets
260
                | isVersion2 = srcMainPath : map display (otherModules bi)
261
262
                | otherwise = replaceLitExts inFiles
          let preprocessDir = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp"
263
264
          let exportsFlags | fromFlag (haddockInternal flags) = ["--ignore-all-exports"]
                           | otherwise                        = []
265
266
267
          rawSystemProgram verbosity confHaddock
                  ([ outputFlag
                   , "--odir=" ++ exeTargetDir
268
                   , "--title=" ++ exeName exe ++ titleComment
269
270
271
272
                   , "--prologue=" ++ prologFileName ]
                   ++ linkToHscolour
                   ++ packageFlags
                   ++ verboseFlags
273
                   ++ exportsFlags
274
275
276
277
278
                   ++ haddock2options bi preprocessDir
                   ++ targets
                  )
          notice verbosity $ "Documentation created: "
                         ++ (exeTargetDir </> "index.html")
279
280
281

    removeDirectoryRecursive tmpDir
  where
282
        verbosity = fromFlag (haddockVerbosity flags)
283
284
285
286
287
        mockPP inputArgs bi pref file
            = do let (filePref, fileName) = splitFileName file
                 let targetDir  = pref </> filePref
                 let targetFile = targetDir </> fileName
                 let (targetFileNoext, targetFileExt) = splitExtension targetFile
288
289
                 let cppOutput = targetFileNoext <.> "hspp"
                 let hsFile = targetFileNoext <.> "hs"
290
                 createDirectoryIfMissingVerbose verbosity True targetDir
291
292
293
294
295
296
297
298
299
300
                 -- Run unlit first, then CPP
                 if (targetFileExt == ".lhs")
                     then runSimplePreProcessor ppUnlit file hsFile verbosity
                     else copyFile file hsFile
                 when (needsCpp bi) $ do
                     runSimplePreProcessor (ppCpp' inputArgs bi lbi)
                       hsFile cppOutput verbosity
                     removeFile hsFile
                     copyFile cppOutput hsFile
                     removeFile cppOutput
301
302
303
        needsCpp :: BuildInfo -> Bool
        needsCpp bi = CPP `elem` extensions bi

304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
haddockPackageFlags :: LocalBuildInfo
                    -> Maybe PathTemplate
                    -> IO ([String], Maybe String)
haddockPackageFlags lbi htmlTemplate = do
  interfaces <- sequence
    [ case interfaceAndHtmlPath pkgid of
        Nothing -> return (pkgid, Nothing)
        Just (interface, html) -> do
          exists <- doesFileExist interface
          if exists
            then return (pkgid, Just (interface, html))
            else return (pkgid, Nothing)
    | pkgid <- packageDeps lbi ]

  let missing = [ pkgid | (pkgid, Nothing) <- interfaces ]
      warning = "The documentation for the following packages are not "
320
             ++ "installed. No links will be generated to these packages: "
321
             ++ intercalate ", " (map display missing)
322
323
324
325
326
327
328
329
330
      flags = [ "--read-interface="
             ++ (if null html then "" else html ++ ",") ++ interface
              | (_, Just (interface, html)) <- interfaces ]

  return (flags, if null missing then Nothing else Just warning)

  where
    interfaceAndHtmlPath :: PackageIdentifier -> Maybe (FilePath, FilePath)
    interfaceAndHtmlPath pkgId = do
331
      pkg <- PackageIndex.lookupPackageId (installedPkgs lbi) pkgId
332
333
334
335
336
337
338
339
340
341
      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)
      html <- case htmlTemplate of
        Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)
        Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate)
      return (interface, html)

      where expandTemplateVars = fromPathTemplate . substPathTemplate env
            env = (PrefixVar, prefix (installDirTemplates lbi))
                : initialPathTemplateEnv pkgId (compilerId (compiler lbi))

David Waern's avatar
David Waern committed
342

343
344
ghcSimpleOptions :: LocalBuildInfo -> BuildInfo -> FilePath -> [String]
ghcSimpleOptions lbi bi mockDir
David Waern's avatar
David Waern committed
345
  =  ["-hide-all-packages"]
346
  ++ (concat [ ["-package", display pkg] | pkg <- packageDeps lbi ])
347
  ++ ["-i"]
348
  ++ hcOptions GHC bi
349
  ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]
350
  ++ ["-i" ++ autogenModulesDir lbi]
351
  ++ ["-i" ++ mockDir]
352
  ++ ["-I" ++ dir | dir <- PD.includeDirs bi]
353
  ++ ["-optP" ++ opt | opt <- cppOptions bi]
354
355
  ++ ["-odir", mockDir]
  ++ ["-hidir", mockDir]
David Waern's avatar
David Waern committed
356
357
358
359
  ++ extensionsToFlags c (extensions bi)
  where c = compiler lbi


360
361
362
363
-- --------------------------------------------------------------------------
-- hscolour support

hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO ()
364
hscolour pkg_descr lbi suffixes flags = do
365
    let distPref = fromFlag $ hscolourDistPref flags
366
    (hscolourProg, _) <- requireProgram verbosity hscolourProgram
367
                         (orLaterVersion (Version [1,8] [])) (withPrograms lbi)
368

369
370
    createDirectoryIfMissingVerbose verbosity True $
        hscolourPref distPref pkg_descr
371
372
    preprocessSources pkg_descr lbi False verbosity suffixes

373
    setupMessage verbosity "Running hscolour for" (packageId pkg_descr)
374
375
    let moduleNameToHtmlFilePath mn =
          intercalate "-" (ModuleName.components mn) <.> "html"
376
377
378

    withLib pkg_descr () $ \lib -> when (isJust $ library pkg_descr) $ do
        let bi = libBuildInfo lib
379
            modules = PD.exposedModules lib ++ otherModules bi
380
381
382
            outputDir = hscolourPref distPref pkg_descr </> "src"
        createDirectoryIfMissingVerbose verbosity True outputDir
        copyCSS hscolourProg outputDir
383
        inFiles <- getLibSourceFiles lbi lib
384
        flip mapM_ (zip modules inFiles) $ \(mo, inFile) ->
385
            let outFile = outputDir </> moduleNameToHtmlFilePath mo
386
             in rawSystemProgram verbosity hscolourProg
387
388
389
390
                     ["-css", "-anchor", "-o" ++ outFile, inFile]

    withExe pkg_descr $ \exe -> when doExes $ do
        let bi = buildInfo exe
391
            modules = ModuleName.main : otherModules bi
392
            outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"
393
        createDirectoryIfMissingVerbose verbosity True outputDir
394
        copyCSS hscolourProg outputDir
395
        inFiles <- getExeSourceFiles lbi exe
396
        flip mapM_ (zip modules inFiles) $ \(mo, inFile) ->
397
            let outFile = outputDir </> moduleNameToHtmlFilePath mo
398
            in rawSystemProgram verbosity hscolourProg
399
                     ["-css", "-anchor", "-o" ++ outFile, inFile]
400

401
402
403
404
405
406
  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")
407
408
        doExes     = fromFlag (hscolourExecutables flags)
        stylesheet = flagToMaybe (hscolourCSS flags)
409
        verbosity  = fromFlag (hscolourVerbosity flags)
410
411


412
413
414
getLibSourceFiles :: LocalBuildInfo -> Library -> IO [FilePath]
getLibSourceFiles lbi lib = sequence
  [ findFileWithExtension ["hs", "lhs"] (preprocessDir : hsSourceDirs bi)
415
      (ModuleName.toFilePath module_) >>= maybe (notFound module_) (return . normalise)
416
417
418
419
420
  | module_ <- modules ]
  where
    bi               = libBuildInfo lib
    modules          = PD.exposedModules lib ++ otherModules bi
    preprocessDir    = buildDir lbi
421
    notFound module_ = die $ "can't find source for module " ++ display module_
422
423
424
425
426
427

getExeSourceFiles :: LocalBuildInfo -> Executable -> IO [FilePath]
getExeSourceFiles lbi exe = do
  srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe)
  moduleFiles <- sequence
    [ findFileWithExtension ["hs", "lhs"] (preprocessDir : hsSourceDirs bi)
428
        (ModuleName.toFilePath module_) >>= maybe (notFound module_) (return . normalise)
429
430
431
432
433
434
    | module_ <- modules ]
  return (srcMainPath : moduleFiles)
  where
    bi               = buildInfo exe
    modules          = otherModules bi
    preprocessDir    = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp"
435
    notFound module_ = die $ "can't find source for module " ++ display module_