Haddock.hs 34 KB
Newer Older
1
2
3
4
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Haddock
-- Copyright   :  Isaac Jones 2003-2005
5
-- License     :  BSD3
6
--
Duncan Coutts's avatar
Duncan Coutts committed
7
-- Maintainer  :  cabal-devel@haskell.org
8
9
-- Portability :  portable
--
10
-- This module deals with the @haddock@ and @hscolour@ commands.
11
12
-- It uses information about installed packages (from @ghc-pkg@) to find the
-- locations of documentation for dependent packages, so it can create links.
Duncan Coutts's avatar
Duncan Coutts committed
13
--
Ian D. Bollinger's avatar
Ian D. Bollinger committed
14
-- The @hscolour@ support allows generating HTML versions of the original
Duncan Coutts's avatar
Duncan Coutts committed
15
-- source, with coloured syntax highlighting.
16
17

module Distribution.Simple.Haddock (
18
19
20
  haddock, hscolour,

  haddockPackagePaths
21
22
  ) where

23
24
25
import qualified Distribution.Simple.GHC   as GHC
import qualified Distribution.Simple.GHCJS as GHCJS

26
-- local
27
import Distribution.Compat.Semigroup as Semi
28
import Distribution.Package
29
30
         ( PackageIdentifier(..)
         , Package(..)
31
         , PackageName(..), packageName, ComponentId(..) )
32
import qualified Distribution.ModuleName as ModuleName
33
import Distribution.PackageDescription as PD
34
         ( PackageDescription(..), BuildInfo(..), usedExtensions
35
         , hcSharedOptions
36
37
38
         , Library(..), hasLibs, Executable(..)
         , TestSuite(..), TestSuiteInterface(..)
         , Benchmark(..), BenchmarkInterface(..) )
39
import Distribution.Simple.Compiler
40
41
         ( Compiler, compilerInfo, CompilerFlavor(..)
         , compilerFlavor, compilerCompatVersion )
42
43
import Distribution.Simple.Program.GHC
         ( GhcOptions(..), GhcDynLinkMode(..), renderGhcOptions )
44
import Distribution.Simple.Program
45
         ( ConfiguredProgram(..), lookupProgramVersion, requireProgramVersion
46
47
         , rawSystemProgram, rawSystemProgramStdout
         , hscolourProgram, haddockProgram )
48
49
import Distribution.Simple.PreProcess
         ( PPSuffixHandler, preprocessComponent)
50
import Distribution.Simple.Setup
51
52
         ( defaultHscolourFlags
         , Flag(..), toFlag, flagToMaybe, flagToList, fromFlag
53
         , fromFlagOrDefault, HaddockFlags(..), HscolourFlags(..) )
54
import Distribution.Simple.Build (initialBuildSteps)
55
56
57
58
59
import Distribution.Simple.InstallDirs
         ( InstallDirs(..)
         , PathTemplateEnv, PathTemplate, PathTemplateVariable(..)
         , toPathTemplate, fromPathTemplate
         , substPathTemplate, initialPathTemplateEnv )
60
import Distribution.Simple.LocalBuildInfo
refold's avatar
refold committed
61
         ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)
refold's avatar
refold committed
62
         , withAllComponentsInBuildOrder )
63
64
import Distribution.Simple.BuildPaths
         ( haddockName, hscolourPref, autogenModulesDir)
65
import Distribution.Simple.PackageIndex (dependencyClosure)
66
import qualified Distribution.Simple.PackageIndex as PackageIndex
67
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
68
         ( InstalledPackageInfo(..) )
69
70
import Distribution.InstalledPackageInfo
         ( InstalledPackageInfo )
71
import Distribution.Simple.Utils
refold's avatar
refold committed
72
         ( die, copyFileTo, warn, notice, intercalate, setupMessage
73
74
75
76
         , createDirectoryIfMissingVerbose
         , TempFileOptions(..), defaultTempFileOptions
         , withTempFileEx, copyFileVerbose
         , withTempDirectoryEx, matchFileGlob
77
         , findFileWithExtension, findFile )
78
import Distribution.Text
79
         ( display, simpleParse )
80
81
import Distribution.Utils.NubList
         ( toNubListR )
82
83
84
85

import Distribution.Verbosity
import Language.Haskell.Extension

86
87

import Control.Monad    ( when, forM_ )
88
import Data.Char        ( isSpace )
89
import Data.Either      ( rights )
randen's avatar
randen committed
90
import Data.Foldable    ( traverse_, foldl' )
91
import Data.Maybe       ( fromMaybe, listToMaybe )
92

93
94
95
import System.Directory (doesFileExist)
import System.FilePath  ( (</>), (<.>)
                        , normalise, splitPath, joinPath, isAbsolute )
96
import System.IO        (hClose, hPutStr, hPutStrLn, hSetEncoding, utf8)
97
98
import Distribution.Version

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
99
-- ------------------------------------------------------------------------------
100
-- Types
101

102
103
-- | A record that represents the arguments to the haddock executable, a product
-- monoid.
104
data HaddockArgs = HaddockArgs {
105
106
107
108
109
110
111
112
113
114
115
116
117
118
 argInterfaceFile :: Flag FilePath,
 -- ^ Path to the interface file, relative to argOutputDir, required.
 argPackageName :: Flag PackageIdentifier,
 -- ^ Package name, required.
 argHideModules :: (All,[ModuleName.ModuleName]),
 -- ^ (Hide modules ?, modules to hide)
 argIgnoreExports :: Any,
 -- ^ Ignore export lists in modules?
 argLinkSource :: Flag (Template,Template,Template),
 -- ^ (Template for modules, template for symbols, template for lines).
 argCssFile :: Flag FilePath,
 -- ^ Optional custom CSS file.
 argContents :: Flag String,
 -- ^ Optional URL to contents page.
119
 argVerbose :: Any,
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
 argOutput :: Flag [Output],
 -- ^ HTML or Hoogle doc or both? Required.
 argInterfaces :: [(FilePath, Maybe String)],
 -- ^ [(Interface file, URL to the HTML docs for links)].
 argOutputDir :: Directory,
 -- ^ Where to generate the documentation.
 argTitle :: Flag String,
 -- ^ Page title, required.
 argPrologue :: Flag String,
 -- ^ Prologue text, required.
 argGhcOptions :: Flag (GhcOptions, Version),
 -- ^ Additional flags to pass to GHC.
 argGhcLibDir :: Flag FilePath,
 -- ^ To find the correct GHC, required.
 argTargets :: [FilePath]
 -- ^ Modules to process.
136
137
}

138
-- | The FilePath of a directory, it's a monoid under '(</>)'.
139
140
141
142
143
144
145
146
147
newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord)

unDir :: Directory -> FilePath
unDir = joinPath . filter (\p -> p /="./" && p /= ".") . splitPath . unDir'

type Template = String

data Output = Html | Hoogle

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
148
-- ------------------------------------------------------------------------------
149
150
-- Haddock support

151
152
153
154
155
haddock :: PackageDescription
        -> LocalBuildInfo
        -> [PPSuffixHandler]
        -> HaddockFlags
        -> IO ()
156
haddock pkg_descr _ _ haddockFlags
Joachim Breitner's avatar
Joachim Breitner committed
157
  |    not (hasLibs pkg_descr)
158
159
160
    && not (fromFlag $ haddockExecutables haddockFlags)
    && not (fromFlag $ haddockTestSuites  haddockFlags)
    && not (fromFlag $ haddockBenchmarks  haddockFlags) =
161
      warn (fromFlag $ haddockVerbosity haddockFlags) $
162
           "No documentation was generated as this package does not contain "
163
164
        ++ "a library. Perhaps you want to use the --executables, --tests or"
        ++ " --benchmarks flags."
165

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
haddock pkg_descr lbi suffixes flags' = do
    let verbosity     = flag haddockVerbosity
        comp          = compiler lbi

        flags
          | fromFlag (haddockForHackage flags') = flags'
            { haddockHoogle       = Flag True
            , haddockHtml         = Flag True
            , haddockHtmlLocation = Flag (pkg_url ++ "/docs")
            , haddockContents     = Flag (toPathTemplate pkg_url)
            , haddockHscolour     = Flag True
            }
          | otherwise = flags'
        pkg_url       = "/package/$pkg-$version"
        flag f        = fromFlag $ f flags

        tmpFileOpts   = defaultTempFileOptions
                       { optKeepTempFiles = flag haddockKeepTempFiles }
        htmlTemplate  = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation
                        $ flags

187
    setupMessage verbosity "Running Haddock for" (packageId pkg_descr)
188
189
    (confHaddock, version, _) <-
      requireProgramVersion verbosity haddockProgram
190
        (orLaterVersion (Version [2,0] [])) (withPrograms lbi)
191

192
    -- various sanity checks
193
    when ( flag haddockHoogle
194
195
           && version < Version [2,2] []) $
         die "haddock 2.0 and 2.1 do not support the --hoogle flag."
196

197
198
    haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock
                              ["--ghc-version"]
199
200
201
202
    case (simpleParse haddockGhcVersionStr, compilerCompatVersion GHC comp) of
      (Nothing, _) -> die "Could not get GHC version from Haddock"
      (_, Nothing) -> die "Could not get GHC version from compiler"
      (Just haddockGhcVersion, Just ghcVersion)
203
204
205
206
207
208
        | haddockGhcVersion == ghcVersion -> return ()
        | otherwise -> die $
               "Haddock's internal GHC version must match the configured "
            ++ "GHC version.\n"
            ++ "The GHC version is " ++ display ghcVersion ++ " but "
            ++ "haddock is using GHC version " ++ display haddockGhcVersion
209
210
211

    -- the tools match the requests, we can proceed

212
213
    initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity

214
215
    when (flag haddockHscolour) $
      hscolour' (warn verbosity) pkg_descr lbi suffixes
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
216
      (defaultHscolourFlags `mappend` haddockToHscolour flags)
217

218
    libdirArgs <- getGhcLibDir  verbosity lbi
219
220
    let commonArgs = mconcat
            [ libdirArgs
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
221
            , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags
222
223
            , fromPackageDescription forDist pkg_descr ]
        forDist = fromFlagOrDefault False (haddockForHackage flags)
David Waern's avatar
David Waern committed
224

225
    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes
226
227
    withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do
      pre component
228
229
230
      let
        doExe com = case (compToExe com) of
          Just exe -> do
231
232
233
234
235
236
            withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $
              \tmp -> do
                exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate
                           version
                let exeArgs' = commonArgs `mappend` exeArgs
                runHaddock verbosity tmpFileOpts comp confHaddock exeArgs'
237
          Nothing -> do
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
238
           warn (fromFlag $ haddockVerbosity flags)
239
240
             "Unsupported component, skipping..."
           return ()
241
      case component of
242
        CLib lib -> do
243
244
245
246
247
248
          withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $
            \tmp -> do
              libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate
                         version
              let libArgs' = commonArgs `mappend` libArgs
              runHaddock verbosity tmpFileOpts comp confHaddock libArgs'
249
250
251
        CExe   _ -> when (flag haddockExecutables) $ doExe component
        CTest  _ -> when (flag haddockTestSuites)  $ doExe component
        CBench _ -> when (flag haddockBenchmarks)  $ doExe component
252

253
    forM_ (extraDocFiles pkg_descr) $ \ fpath -> do
254
      files <- matchFileGlob fpath
refold's avatar
refold committed
255
      forM_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)
256

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
257
258
-- ------------------------------------------------------------------------------
-- Contributions to HaddockArgs.
259

260
261
fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags env flags =
262
    mempty {
263
264
      argHideModules = (maybe mempty (All . not)
                        $ flagToMaybe (haddockInternal flags), mempty),
265
266
      argLinkSource = if fromFlag (haddockHscolour flags)
                               then Flag ("src/%{MODULE/./-}.html"
267
268
                                         ,"src/%{MODULE/./-}.html#%{NAME}"
                                         ,"src/%{MODULE/./-}.html#line-%{LINE}")
269
270
                               else NoFlag,
      argCssFile = haddockCss flags,
271
272
273
274
      argContents = fmap (fromPathTemplate . substPathTemplate env)
                    (haddockContents flags),
      argVerbose = maybe mempty (Any . (>= deafening))
                   . flagToMaybe $ haddockVerbosity flags,
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
275
      argOutput =
276
277
278
279
          Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++
                      [ Hoogle | Flag True <- [haddockHoogle flags] ]
                 of [] -> [ Html ]
                    os -> os,
280
281
282
      argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags
    }

283
284
fromPackageDescription :: Bool -> PackageDescription -> HaddockArgs
fromPackageDescription forDist pkg_descr =
285
286
      mempty { argInterfaceFile = Flag $ haddockName pkg_descr,
               argPackageName = Flag $ packageId $ pkg_descr,
287
               argOutputDir = Dir $ "doc" </> "html" </> name,
288
289
290
               argPrologue = Flag $ if null desc then synopsis pkg_descr
                                    else desc,
               argTitle = Flag $ showPkg ++ subtitle
291
             }
292
      where
293
294
        desc = PD.description pkg_descr
        showPkg = display (packageId pkg_descr)
295
296
297
        name
          | forDist = showPkg ++ "-docs"
          | otherwise = display (packageName pkg_descr)
298
299
300
        subtitle | null (synopsis pkg_descr) = ""
                 | otherwise                 = ": " ++ synopsis pkg_descr

301
302
303
304
305
306
307
308
309
310
311
312
componentGhcOptions :: Verbosity -> LocalBuildInfo
                 -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
                 -> GhcOptions
componentGhcOptions verbosity lbi bi clbi odir =
  let f = case compilerFlavor (compiler lbi) of
            GHC   -> GHC.componentGhcOptions
            GHCJS -> GHCJS.componentGhcOptions
            _     -> error $
                       "Distribution.Simple.Haddock.componentGhcOptions:" ++
                       "haddock only supports GHC and GHCJS"
  in f verbosity lbi bi clbi odir

313
314
fromLibrary :: Verbosity
            -> FilePath
315
            -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo
Ian D. Bollinger's avatar
Ian D. Bollinger committed
316
            -> Maybe PathTemplate -- ^ template for HTML location
317
            -> Version
318
            -> IO HaddockArgs
319
fromLibrary verbosity tmp lbi lib clbi htmlTemplate haddockVersion = do
320
321
    inFiles <- map snd `fmap` getLibSourceFiles lbi lib
    ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
322
323
324
325
326
    let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
                          -- Noooooooooo!!!!!111
                          -- haddock stomps on our precious .hi
                          -- and .o files. Workaround by telling
                          -- haddock to write them elsewhere.
327
328
                          ghcOptObjDir     = toFlag tmp,
                          ghcOptHiDir      = toFlag tmp,
329
                          ghcOptStubDir    = toFlag tmp
330
                      } `mappend` getGhcCppOpts haddockVersion bi
331
        sharedOpts = vanillaOpts {
332
333
334
335
                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,
                         ghcOptFPic        = toFlag True,
                         ghcOptHiSuffix    = toFlag "dyn_hi",
                         ghcOptObjSuffix   = toFlag "dyn_o",
336
337
338
                         ghcOptExtra       =
                           toNubListR $ hcSharedOptions GHC bi

339
340
341
342
343
                     }
    opts <- if withVanillaLib lbi
            then return vanillaOpts
            else if withSharedLib lbi
            then return sharedOpts
344
345
            else die $ "Must have vanilla or shared libraries "
                       ++ "enabled in order to run haddock"
346
347
348
349
    ghcVersion <- maybe (die "Compiler has no GHC version")
                        return
                        (compilerCompatVersion GHC (compiler lbi))

350
351
    return ifaceArgs {
      argHideModules = (mempty,otherModules $ bi),
352
      argGhcOptions  = toFlag (opts, ghcVersion),
353
354
355
356
      argTargets     = inFiles
    }
  where
    bi = libBuildInfo lib
357

358
359
fromExecutable :: Verbosity
               -> FilePath
360
               -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo
Ian D. Bollinger's avatar
Ian D. Bollinger committed
361
               -> Maybe PathTemplate -- ^ template for HTML location
362
               -> Version
363
               -> IO HaddockArgs
364
fromExecutable verbosity tmp lbi exe clbi htmlTemplate haddockVersion = do
365
366
    inFiles <- map snd `fmap` getExeSourceFiles lbi exe
    ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
367
368
369
370
371
372
373
374
    let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
                          -- Noooooooooo!!!!!111
                          -- haddock stomps on our precious .hi
                          -- and .o files. Workaround by telling
                          -- haddock to write them elsewhere.
                          ghcOptObjDir  = toFlag tmp,
                          ghcOptHiDir   = toFlag tmp,
                          ghcOptStubDir = toFlag tmp
375
                      } `mappend` getGhcCppOpts haddockVersion bi
376
        sharedOpts = vanillaOpts {
377
378
379
380
                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,
                         ghcOptFPic        = toFlag True,
                         ghcOptHiSuffix    = toFlag "dyn_hi",
                         ghcOptObjSuffix   = toFlag "dyn_o",
381
382
                         ghcOptExtra       =
                           toNubListR $ hcSharedOptions GHC bi
383
384
385
386
387
                     }
    opts <- if withVanillaLib lbi
            then return vanillaOpts
            else if withSharedLib lbi
            then return sharedOpts
388
389
            else die $ "Must have vanilla or shared libraries "
                       ++ "enabled in order to run haddock"
390
391
392
393
    ghcVersion <- maybe (die "Compiler has no GHC version")
                        return
                        (compilerCompatVersion GHC (compiler lbi))

394
    return ifaceArgs {
395
      argGhcOptions = toFlag (opts, ghcVersion),
396
397
398
399
400
401
      argOutputDir  = Dir (exeName exe),
      argTitle      = Flag (exeName exe),
      argTargets    = inFiles
    }
  where
    bi = buildInfo exe
402

403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
compToExe :: Component -> Maybe Executable
compToExe comp =
  case comp of
    CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } ->
      Just Executable {
        exeName    = testName test,
        modulePath = f,
        buildInfo  = testBuildInfo test
      }
    CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } ->
      Just Executable {
        exeName    = benchmarkName bench,
        modulePath = f,
        buildInfo  = benchmarkBuildInfo bench
      }
    CExe exe -> Just exe
    _ -> Nothing

421
getInterfaces :: Verbosity
422
423
              -> LocalBuildInfo
              -> ComponentLocalBuildInfo
Ian D. Bollinger's avatar
Ian D. Bollinger committed
424
              -> Maybe PathTemplate -- ^ template for HTML location
425
426
427
              -> IO HaddockArgs
getInterfaces verbosity lbi clbi htmlTemplate = do
    (packageFlags, warnings) <- haddockPackageFlags lbi clbi htmlTemplate
428
    traverse_ (warn verbosity) warnings
429
    return $ mempty {
430
431
432
                 argInterfaces = packageFlags
               }

433
434
435
436
437
getGhcCppOpts :: Version
              -> BuildInfo
              -> GhcOptions
getGhcCppOpts haddockVersion bi =
    mempty {
438
439
        ghcOptExtensions   = toNubListR [EnableExtension CPP | needsCpp],
        ghcOptCppOptions   = toNubListR defines
440
441
    }
  where
442
    needsCpp             = EnableExtension CPP `elem` usedExtensions bi
443
444
445
446
447
448
    defines              = [haddockVersionMacro]
    haddockVersionMacro  = "-D__HADDOCK_VERSION__="
                           ++ show (v1 * 1000 + v2 * 10 + v3)
      where
        [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0]

449
getGhcLibDir :: Verbosity -> LocalBuildInfo
450
             -> IO HaddockArgs
451
getGhcLibDir verbosity lbi = do
452
453
454
455
    l <- case compilerFlavor (compiler lbi) of
            GHC   -> GHC.getLibDir   verbosity lbi
            GHCJS -> GHCJS.getLibDir verbosity lbi
            _     -> error "haddock only supports GHC and GHCJS"
456
    return $ mempty { argGhcLibDir = Flag l }
457

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
458
-- ------------------------------------------------------------------------------
459
-- | Call haddock with the specified arguments.
460
461
runHaddock :: Verbosity
              -> TempFileOptions
462
              -> Compiler
463
464
465
              -> ConfiguredProgram
              -> HaddockArgs
              -> IO ()
466
runHaddock verbosity tmpFileOpts comp confHaddock args = do
467
468
  let haddockVersion = fromMaybe (error "unable to determine haddock version")
                       (programVersion confHaddock)
469
470
  renderArgs verbosity tmpFileOpts haddockVersion comp args $
    \(flags,result)-> do
471
472
473
474
475
476
477

      rawSystemProgram verbosity confHaddock flags

      notice verbosity $ "Documentation created: " ++ result


renderArgs :: Verbosity
478
              -> TempFileOptions
479
              -> Version
480
              -> Compiler
481
              -> HaddockArgs
482
              -> (([String], FilePath) -> IO a)
483
              -> IO a
484
renderArgs verbosity tmpFileOpts version comp args k = do
485
  let haddockSupportsUTF8          = version >= Version [2,14,4] []
486
      haddockSupportsResponseFiles = version >  Version [2,16,2] []
487
  createDirectoryIfMissingVerbose verbosity True outputDir
488
489
  withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $
    \prologueFileName h -> do
490
          do
491
             when haddockSupportsUTF8 (hSetEncoding h utf8)
492
             hPutStrLn h $ fromFlag $ argPrologue args
493
             hClose h
494
             let pflag = "--prologue=" ++ prologueFileName
495
                 renderedArgs = pflag : renderPureArgs version comp args
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
496
             if haddockSupportsResponseFiles
497
498
499
500
               then
                 withTempFileEx tmpFileOpts outputDir "haddock-response.txt" $
                    \responseFileName hf -> do
                         when haddockSupportsUTF8 (hSetEncoding hf utf8)
501
                         hPutStr hf $ unlines $ map escapeArg renderedArgs
502
503
504
505
506
                         hClose hf
                         let respFile = "@" ++ responseFileName
                         k ([respFile], result)
               else
                 k (renderedArgs, result)
507
    where
508
      outputDir = (unDir $ argOutputDir args)
509
510
511
512
513
514
515
      result = intercalate ", "
             . map (\o -> outputDir </>
                            case o of
                              Html -> "index.html"
                              Hoogle -> pkgstr <.> "txt")
             $ arg argOutput
            where
516
              pkgstr = display $ packageName pkgid
517
              pkgid = arg argPackageName
518
      arg f = fromFlag $ f args
519
520
521
522
523
524
525
526
527
528
529
530
531
      -- Support a gcc-like response file syntax.  Each separate
      -- argument and its possible parameter(s), will be separated in the
      -- response file by an actual newline; all other whitespace,
      -- single quotes, double quotes, and the character used for escaping
      -- (backslash) are escaped.  The called program will need to do a similar
      -- inverse operation to de-escape and re-constitute the argument list.
      escape cs c
        |    isSpace c
          || '\\' == c
          || '\'' == c
          || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result
        | otherwise    = c:cs
      escapeArg = reverse . foldl' escape []
532

533
534
renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String]
renderPureArgs version comp args = concat
535
536
537
    [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)
      . fromFlag . argInterfaceFile $ args

538
539
540
541
542
    , if isVersion 2 16
        then (\pkg -> [ "--package-name=" ++ display (pkgName pkg)
                      , "--package-version="++display (pkgVersion pkg)
                      ])
             . fromFlag . argPackageName $ args
543
        else []
544
545
546
547
548
549
550
551
552

    , (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b)
                     . argHideModules $ args

    , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args

    , maybe [] (\(m,e,l) ->
                 ["--source-module=" ++ m
                 ,"--source-entity=" ++ e]
553
                 ++ if isVersion 2 14 then ["--source-entity-line=" ++ l]
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
                    else []
               ) . flagToMaybe . argLinkSource $ args

    , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args

    , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args

    , bool [] [verbosityFlag] . getAny . argVerbose $ args

    , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html")
      . fromFlag . argOutput $ args

    , renderInterfaces . argInterfaces $ args

    , (:[]) . ("--odir="++) . unDir . argOutputDir $ args

    , (:[]) . ("--title="++)
      . (bool (++" (internal documentation)")
         id (getAny $ argIgnoreExports args))
      . fromFlag . argTitle $ args

    , [ "--optghc=" ++ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args)
                           , opt <- renderGhcOptions comp opts ]

    , maybe [] (\l -> ["-B"++l]) $
      flagToMaybe (argGhcLibDir args) -- error if Nothing?

    , argTargets $ args
582
583
    ]
    where
584
585
      renderInterfaces =
        map (\(i,mh) -> "--read-interface=" ++
586
          maybe "" (++",") mh ++ i)
587
      bool a b c = if c then a else b
588
      isVersion major minor  = version >= Version [major,minor]  []
Ian Lynagh's avatar
Ian Lynagh committed
589
      verbosityFlag
590
591
       | isVersion 2 5 = "--verbosity=1"
       | otherwise     = "--verbose"
592

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
593
---------------------------------------------------------------------------------
594

595
596
597
598
599
600
-- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and
-- HTML paths, and an optional warning for packages with missing documentation.
haddockPackagePaths :: [InstalledPackageInfo]
                    -> Maybe (InstalledPackageInfo -> FilePath)
                    -> IO ([(FilePath, Maybe FilePath)], Maybe String)
haddockPackagePaths ipkgs mkHtmlPath = do
601
  interfaces <- sequence
602
603
    [ case interfaceAndHtmlPath ipkg of
        Nothing -> return (Left (packageId ipkg))
604
605
606
        Just (interface, html) -> do
          exists <- doesFileExist interface
          if exists
607
            then return (Right (interface, html))
608
609
610
            else return (Left pkgid)
    | ipkg <- ipkgs, let pkgid = packageId ipkg
    , pkgName pkgid `notElem` noHaddockWhitelist
611
    ]
612

613
  let missing = [ pkgid | Left pkgid <- interfaces ]
614
      warning = "The documentation for the following packages are not "
615
             ++ "installed. No links will be generated to these packages: "
616
             ++ intercalate ", " (map display missing)
617
      flags = rights interfaces
618
619
620
621

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

  where
622
    -- Don't warn about missing documentation for these packages. See #1231.
623
    noHaddockWhitelist = map PackageName [ "rts" ]
624
625
626
627

    -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.
    interfaceAndHtmlPath :: InstalledPackageInfo
                         -> Maybe (FilePath, Maybe FilePath)
628
    interfaceAndHtmlPath pkg = do
629
      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)
630
      html <- case mkHtmlPath of
631
632
        Nothing -> fmap fixFileUrl
                        (listToMaybe (InstalledPackageInfo.haddockHTMLs pkg))
633
634
        Just mkPath -> Just (mkPath pkg)
      return (interface, if null html then Nothing else Just html)
635
      where
636
637
        -- The 'haddock-html' field in the hc-pkg output is often set as a
        -- native path, but we need it as a URL. See #1064.
638
639
        fixFileUrl f | isAbsolute f = "file://" ++ f
                     | otherwise    = f
640

641
642
643
644
645
646
647
648
649
haddockPackageFlags :: LocalBuildInfo
                    -> ComponentLocalBuildInfo
                    -> Maybe PathTemplate
                    -> IO ([(FilePath, Maybe FilePath)], Maybe String)
haddockPackageFlags lbi clbi htmlTemplate = do
  let allPkgs = installedPkgs lbi
      directDeps = map fst (componentPackageDeps clbi)
  transitiveDeps <- case dependencyClosure allPkgs directDeps of
    Left x    -> return x
Mikhail Glushenkov's avatar
Typo.    
Mikhail Glushenkov committed
650
    Right inf -> die $ "internal error when calculating transitive "
651
652
653
654
655
656
657
658
659
                    ++ "package dependencies.\nDebug info: " ++ show inf
  haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath
    where
      mkHtmlPath                  = fmap expandTemplateVars htmlTemplate
      expandTemplateVars tmpl pkg =
        fromPathTemplate . substPathTemplate (env pkg) $ tmpl
      env pkg                     = haddockTemplateEnv lbi (packageId pkg)


660
haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
661
662
haddockTemplateEnv lbi pkg_id =
  (PrefixVar, prefix (installDirTemplates lbi))
663
  : initialPathTemplateEnv pkg_id (ComponentId (display pkg_id)) (compilerInfo (compiler lbi))
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
664
  (hostPlatform lbi)
665

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
666
667
-- ------------------------------------------------------------------------------
-- hscolour support.
668

669
670
671
672
673
hscolour :: PackageDescription
         -> LocalBuildInfo
         -> [PPSuffixHandler]
         -> HscolourFlags
         -> IO ()
674
hscolour pkg_descr lbi suffixes flags = do
675
676
  -- we preprocess even if hscolour won't be found on the machine
  -- will this upset someone?
677
  initialBuildSteps distPref pkg_descr lbi verbosity
678
  hscolour' die pkg_descr lbi suffixes flags
679
680
681
682
 where
   verbosity  = fromFlag (hscolourVerbosity flags)
   distPref = fromFlag $ hscolourDistPref flags

683
684
hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found.
          -> PackageDescription
685
686
687
688
          -> LocalBuildInfo
          -> [PPSuffixHandler]
          -> HscolourFlags
          -> IO ()
689
690
691
692
hscolour' onNoHsColour pkg_descr lbi suffixes flags =
    either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<<
      lookupProgramVersion verbosity hscolourProgram
      (orLaterVersion (Version [1,8] [])) (withPrograms lbi)
693
  where
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
    go :: ConfiguredProgram -> IO ()
    go hscolourProg = do
      setupMessage verbosity "Running hscolour for" (packageId pkg_descr)
      createDirectoryIfMissingVerbose verbosity True $
        hscolourPref distPref pkg_descr

      let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes
      withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do
        pre comp
        let
          doExe com = case (compToExe com) of
            Just exe -> do
              let outputDir = hscolourPref distPref pkg_descr
                              </> exeName exe </> "src"
              runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe
            Nothing -> do
              warn (fromFlag $ hscolourVerbosity flags)
                "Unsupported component, skipping..."
              return ()
        case comp of
          CLib lib -> do
            let outputDir = hscolourPref distPref pkg_descr </> "src"
            runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib
          CExe   _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp
          CTest  _ -> when (fromFlag (hscolourTestSuites  flags)) $ doExe comp
          CBench _ -> when (fromFlag (hscolourBenchmarks  flags)) $ doExe comp

721
    stylesheet = flagToMaybe (hscolourCSS flags)
722

723
    verbosity  = fromFlag (hscolourVerbosity flags)
724
    distPref   = fromFlag (hscolourDistPref flags)
725

726
    runHsColour prog outputDir moduleFiles = do
727
728
         createDirectoryIfMissingVerbose verbosity True outputDir

729
         case stylesheet of -- copy the CSS file
730
731
732
733
734
735
           Nothing | programVersion prog >= Just (Version [1,9] []) ->
                       rawSystemProgram verbosity prog
                          ["-print-css", "-o" ++ outputDir </> "hscolour.css"]
                   | otherwise -> return ()
           Just s -> copyFileVerbose verbosity s (outputDir </> "hscolour.css")

John Wiegley's avatar
John Wiegley committed
736
         forM_ moduleFiles $ \(m, inFile) ->
737
738
739
             rawSystemProgram verbosity prog
                    ["-css", "-anchor", "-o" ++ outFile m, inFile]
        where
740
741
          outFile m = outputDir </>
                      intercalate "-" (ModuleName.components m) <.> "html"
742
743

haddockToHscolour :: HaddockFlags -> HscolourFlags
744
745
haddockToHscolour flags =
    HscolourFlags {
746
747
      hscolourCSS         = haddockHscolourCss flags,
      hscolourExecutables = haddockExecutables flags,
748
749
      hscolourTestSuites  = haddockTestSuites  flags,
      hscolourBenchmarks  = haddockBenchmarks  flags,
750
      hscolourVerbosity   = haddockVerbosity   flags,
751
      hscolourDistPref    = haddockDistPref    flags
752
    }
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
753
---------------------------------------------------------------------------------
754
755
756
757
758
759
-- TODO these should be moved elsewhere.

getLibSourceFiles :: LocalBuildInfo
                     -> Library
                     -> IO [(ModuleName.ModuleName, FilePath)]
getLibSourceFiles lbi lib = getSourceFiles searchpaths modules
760
761
762
  where
    bi               = libBuildInfo lib
    modules          = PD.exposedModules lib ++ otherModules bi
763
    searchpaths      = autogenModulesDir lbi : buildDir lbi : hsSourceDirs bi
764

765
766
767
getExeSourceFiles :: LocalBuildInfo
                     -> Executable
                     -> IO [(ModuleName.ModuleName, FilePath)]
768
getExeSourceFiles lbi exe = do
769
770
771
772
773
774
775
776
777
778
779
    moduleFiles <- getSourceFiles searchpaths modules
    srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe)
    return ((ModuleName.main, srcMainPath) : moduleFiles)
  where
    bi          = buildInfo exe
    modules     = otherModules bi
    searchpaths = autogenModulesDir lbi : exeBuildDir lbi exe : hsSourceDirs bi

getSourceFiles :: [FilePath]
                  -> [ModuleName.ModuleName]
                  -> IO [(ModuleName.ModuleName, FilePath)]
780
getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $
781
    findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m)
782
      >>= maybe (notFound m) (return . normalise)
783
  where
784
    notFound module_ = die $ "can't find source for module " ++ display module_
785
786
787
788
789

-- | The directory where we put build results for an executable
exeBuildDir :: LocalBuildInfo -> Executable -> FilePath
exeBuildDir lbi exe = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp"

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
790
791
-- ------------------------------------------------------------------------------
-- Boilerplate Monoid instance.
792
793
instance Monoid HaddockArgs where
    mempty = HaddockArgs {
794
795
                argInterfaceFile = mempty,
                argPackageName = mempty,
796
797
798
799
                argHideModules = mempty,
                argIgnoreExports = mempty,
                argLinkSource = mempty,
                argCssFile = mempty,
800
                argContents = mempty,
801
802
803
804
805
806
                argVerbose = mempty,
                argOutput = mempty,
                argInterfaces = mempty,
                argOutputDir = mempty,
                argTitle = mempty,
                argPrologue = mempty,
807
                argGhcOptions = mempty,
808
809
810
                argGhcLibDir = mempty,
                argTargets = mempty
             }
811
812
813
814
    mappend = (Semi.<>)

instance Semigroup HaddockArgs where
    a <> b = HaddockArgs {
815
816
                argInterfaceFile = mult argInterfaceFile,
                argPackageName = mult argPackageName,
817
818
819
820
                argHideModules = mult argHideModules,
                argIgnoreExports = mult argIgnoreExports,
                argLinkSource = mult argLinkSource,
                argCssFile = mult argCssFile,
821
                argContents = mult argContents,
822
823
824
825
826
827
                argVerbose = mult argVerbose,
                argOutput = mult argOutput,
                argInterfaces = mult argInterfaces,
                argOutputDir = mult argOutputDir,
                argTitle = mult argTitle,
                argPrologue = mult argPrologue,
828
                argGhcOptions = mult argGhcOptions,
829
830
831
832
833
834
835
                argGhcLibDir = mult argGhcLibDir,
                argTargets = mult argTargets
             }
      where mult f = f a `mappend` f b

instance Monoid Directory where
    mempty = Dir "."
836
837
838
839
    mappend = (Semi.<>)

instance Semigroup Directory where
    Dir m <> Dir n = Dir $ m </> n