Haddock.hs 30.3 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
23
  ) where

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

import Distribution.Verbosity
import Language.Haskell.Extension
-- Base
78
import System.Directory(doesFileExist)
79

80
import Control.Monad ( when, forM_ )
81
import Data.Either   ( rights )
82
83
import Data.Monoid
import Data.Maybe    ( fromMaybe, listToMaybe )
84

85
import System.FilePath((</>), (<.>),
86
                       normalise, splitPath, joinPath, isAbsolute )
87
import System.IO (hClose, hPutStrLn, hSetEncoding, utf8)
88
89
import Distribution.Version

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
90
-- ------------------------------------------------------------------------------
91
-- Types
92
93
94
95
96
97

-- | record that represents the arguments to the haddock executable, a product monoid.
data HaddockArgs = HaddockArgs {
 argInterfaceFile :: Flag FilePath,               -- ^ path of the interface file, relative to argOutputDir, required.
 argPackageName :: Flag PackageIdentifier,        -- ^ package name,                                         required.
 argHideModules :: (All,[ModuleName.ModuleName]), -- ^ (hide modules ?, modules to hide)
Ian D. Bollinger's avatar
Ian D. Bollinger committed
98
 argIgnoreExports :: Any,                         -- ^ ignore export lists in modules?
99
 argLinkSource :: Flag (Template,Template,Template), -- ^ (template for modules, template for symbols, template for lines)
Ian D. Bollinger's avatar
Ian D. Bollinger committed
100
101
 argCssFile :: Flag FilePath,                     -- ^ optional custom CSS file.
 argContents :: Flag String,                      -- ^ optional URL to contents page
102
 argVerbose :: Any,
Ian D. Bollinger's avatar
Ian D. Bollinger committed
103
104
 argOutput :: Flag [Output],                      -- ^ HTML or Hoogle doc or both?                                   required.
 argInterfaces :: [(FilePath, Maybe String)],     -- ^ [(interface file, URL to the HTML docs for links)]
105
106
107
 argOutputDir :: Directory,                       -- ^ where to generate the documentation.
 argTitle :: Flag String,                         -- ^ page's title,                                         required.
 argPrologue :: Flag String,                      -- ^ prologue text,                                        required.
108
109
 argGhcOptions :: Flag (GhcOptions, Version),     -- ^ additional flags to pass to ghc
 argGhcLibDir :: Flag FilePath,                   -- ^ to find the correct ghc,                              required.
110
111
112
113
114
115
116
117
118
119
120
121
122
 argTargets :: [FilePath]                         -- ^ modules to process.
}

-- | the FilePath of a directory, it's a monoid under (</>)
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
123
-- ------------------------------------------------------------------------------
124
125
126
-- Haddock support

haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO ()
127
haddock pkg_descr _ _ haddockFlags
Joachim Breitner's avatar
Joachim Breitner committed
128
  |    not (hasLibs pkg_descr)
129
130
131
    && not (fromFlag $ haddockExecutables haddockFlags)
    && not (fromFlag $ haddockTestSuites  haddockFlags)
    && not (fromFlag $ haddockBenchmarks  haddockFlags) =
132
      warn (fromFlag $ haddockVerbosity haddockFlags) $
133
           "No documentation was generated as this package does not contain "
134
135
        ++ "a library. Perhaps you want to use the --executables, --tests or"
        ++ " --benchmarks flags."
136

137
haddock pkg_descr lbi suffixes flags = do
138

139
    setupMessage verbosity "Running Haddock for" (packageId pkg_descr)
140
141
    (confHaddock, version, _) <-
      requireProgramVersion verbosity haddockProgram
142
        (orLaterVersion (Version [2,0] [])) (withPrograms lbi)
143

144
    -- various sanity checks
145
    when ( flag haddockHoogle
146
147
           && version < Version [2,2] []) $
         die "haddock 2.0 and 2.1 do not support the --hoogle flag."
148

149
150
151
152
153
154
155
156
157
158
159
160
    haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock
                              ["--ghc-version"]
    case simpleParse haddockGhcVersionStr of
      Nothing -> die "Could not get GHC version from Haddock"
      Just haddockGhcVersion
        | 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
        where ghcVersion = compilerVersion comp
161
162
163

    -- the tools match the requests, we can proceed

164
165
166
    initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity

    when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $
167
         defaultHscolourFlags `mappend` haddockToHscolour flags
168

169
    libdirArgs <- getGhcLibDir  verbosity lbi
170
171
172
    let commonArgs = mconcat
            [ libdirArgs
            , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags
173
            , fromPackageDescription pkg_descr ]
David Waern's avatar
David Waern committed
174

175
    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes
176
177
    withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do
      pre component
178
179
180
      let
        doExe com = case (compToExe com) of
          Just exe -> do
181
            withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do
182
183
184
              exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate
                                        version
              let exeArgs' = commonArgs `mappend` exeArgs
185
              runHaddock verbosity tmpFileOpts comp confHaddock exeArgs'
186
187
188
189
          Nothing -> do
           warn (fromFlag $ haddockVerbosity flags)
             "Unsupported component, skipping..."
           return ()
190
      case component of
191
        CLib lib -> do
192
          withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do
193
194
195
            libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate
                                   version
            let libArgs' = commonArgs `mappend` libArgs
196
197
198
199
            runHaddock verbosity tmpFileOpts comp confHaddock libArgs'
        CExe   _ -> when (flag haddockExecutables) $ doExe component
        CTest  _ -> when (flag haddockTestSuites)  $ doExe component
        CBench _ -> when (flag haddockBenchmarks)  $ doExe component
200

201
    forM_ (extraDocFiles pkg_descr) $ \ fpath -> do
202
      files <- matchFileGlob fpath
refold's avatar
refold committed
203
      forM_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)
204
  where
205
206
    verbosity     = flag haddockVerbosity
    keepTempFiles = flag haddockKeepTempFiles
207
    comp          = compiler lbi
208
    tmpFileOpts   = defaultTempFileOptions { optKeepTempFiles = keepTempFiles }
209
    flag f        = fromFlag $ f flags
210
    htmlTemplate  = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags
211

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
212
213
-- ------------------------------------------------------------------------------
-- Contributions to HaddockArgs.
214

215
216
fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags env flags =
217
218
219
220
    mempty {
      argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty),
      argLinkSource = if fromFlag (haddockHscolour flags)
                               then Flag ("src/%{MODULE/./-}.html"
221
222
                                         ,"src/%{MODULE/./-}.html#%{NAME}"
                                         ,"src/%{MODULE/./-}.html#line-%{LINE}")
223
224
                               else NoFlag,
      argCssFile = haddockCss flags,
225
      argContents = fmap (fromPathTemplate . substPathTemplate env) (haddockContents flags),
226
      argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags,
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
227
      argOutput =
228
229
230
231
          Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++
                      [ Hoogle | Flag True <- [haddockHoogle flags] ]
                 of [] -> [ Html ]
                    os -> os,
232
233
234
235
      argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags
    }

fromPackageDescription :: PackageDescription -> HaddockArgs
236
fromPackageDescription pkg_descr =
237
      mempty {
238
239
                argInterfaceFile = Flag $ haddockName pkg_descr,
                argPackageName = Flag $ packageId $ pkg_descr,
240
241
242
243
                argOutputDir = Dir $ "doc" </> "html" </> display (packageName pkg_descr),
                argPrologue = Flag $ if null desc then synopsis pkg_descr else desc,
                argTitle = Flag $ showPkg ++ subtitle
             }
244
      where
245
246
247
248
249
        desc = PD.description pkg_descr
        showPkg = display (packageId pkg_descr)
        subtitle | null (synopsis pkg_descr) = ""
                 | otherwise                 = ": " ++ synopsis pkg_descr

250
251
fromLibrary :: Verbosity
            -> FilePath
252
            -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo
Ian D. Bollinger's avatar
Ian D. Bollinger committed
253
            -> Maybe PathTemplate -- ^ template for HTML location
254
            -> Version
255
            -> IO HaddockArgs
256
fromLibrary verbosity tmp lbi lib clbi htmlTemplate haddockVersion = do
257
258
    inFiles <- map snd `fmap` getLibSourceFiles lbi lib
    ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
259
260
261
262
263
264
265
266
    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
267
                      } `mappend` getGhcCppOpts haddockVersion bi
268
        sharedOpts = vanillaOpts {
269
270
271
272
273
                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,
                         ghcOptFPic        = toFlag True,
                         ghcOptHiSuffix    = toFlag "dyn_hi",
                         ghcOptObjSuffix   = toFlag "dyn_o",
                         ghcOptExtra       = ghcSharedOptions bi
274
275
276
277
278
279
                     }
    opts <- if withVanillaLib lbi
            then return vanillaOpts
            else if withSharedLib lbi
            then return sharedOpts
            else die "Must have vanilla or shared libraries enabled in order to run haddock"
280
281
    return ifaceArgs {
      argHideModules = (mempty,otherModules $ bi),
282
      argGhcOptions  = toFlag (opts, ghcVersion),
283
284
285
286
287
      argTargets     = inFiles
    }
  where
    bi = libBuildInfo lib
    ghcVersion = compilerVersion (compiler lbi)
288

289
290
fromExecutable :: Verbosity
               -> FilePath
291
               -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo
Ian D. Bollinger's avatar
Ian D. Bollinger committed
292
               -> Maybe PathTemplate -- ^ template for HTML location
293
               -> Version
294
               -> IO HaddockArgs
295
fromExecutable verbosity tmp lbi exe clbi htmlTemplate haddockVersion = do
296
297
    inFiles <- map snd `fmap` getExeSourceFiles lbi exe
    ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
298
299
300
301
302
303
304
305
    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
306
                      } `mappend` getGhcCppOpts haddockVersion bi
307
        sharedOpts = vanillaOpts {
308
309
310
311
312
                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,
                         ghcOptFPic        = toFlag True,
                         ghcOptHiSuffix    = toFlag "dyn_hi",
                         ghcOptObjSuffix   = toFlag "dyn_o",
                         ghcOptExtra       = ghcSharedOptions bi
313
314
315
316
317
318
                     }
    opts <- if withVanillaLib lbi
            then return vanillaOpts
            else if withSharedLib lbi
            then return sharedOpts
            else die "Must have vanilla or shared libraries enabled in order to run haddock"
319
    return ifaceArgs {
320
      argGhcOptions = toFlag (opts, ghcVersion),
321
322
323
324
325
326
327
      argOutputDir  = Dir (exeName exe),
      argTitle      = Flag (exeName exe),
      argTargets    = inFiles
    }
  where
    bi = buildInfo exe
    ghcVersion = compilerVersion (compiler lbi)
328

329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
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

347
getInterfaces :: Verbosity
348
349
              -> LocalBuildInfo
              -> ComponentLocalBuildInfo
Ian D. Bollinger's avatar
Ian D. Bollinger committed
350
              -> Maybe PathTemplate -- ^ template for HTML location
351
352
353
              -> IO HaddockArgs
getInterfaces verbosity lbi clbi htmlTemplate = do
    (packageFlags, warnings) <- haddockPackageFlags lbi clbi htmlTemplate
354
    maybe (return ()) (warn verbosity) warnings
355
    return $ mempty {
356
357
358
                 argInterfaces = packageFlags
               }

359
360
361
362
363
364
365
366
367
getGhcCppOpts :: Version
              -> BuildInfo
              -> GhcOptions
getGhcCppOpts haddockVersion bi =
    mempty {
        ghcOptExtensions   = [EnableExtension CPP | needsCpp],
        ghcOptCppOptions   = defines
    }
  where
368
    needsCpp             = EnableExtension CPP `elem` usedExtensions bi
369
370
371
372
373
374
    defines              = [haddockVersionMacro]
    haddockVersionMacro  = "-D__HADDOCK_VERSION__="
                           ++ show (v1 * 1000 + v2 * 10 + v3)
      where
        [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0]

375
getGhcLibDir :: Verbosity -> LocalBuildInfo
376
             -> IO HaddockArgs
377
378
379
getGhcLibDir verbosity lbi = do
    l <- ghcLibDir verbosity lbi
    return $ mempty { argGhcLibDir = Flag l }
380

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
381
-- ------------------------------------------------------------------------------
382
-- | Call haddock with the specified arguments.
383
384
runHaddock :: Verbosity
              -> TempFileOptions
385
              -> Compiler
386
387
388
              -> ConfiguredProgram
              -> HaddockArgs
              -> IO ()
389
runHaddock verbosity tmpFileOpts comp confHaddock args = do
390
391
  let haddockVersion = fromMaybe (error "unable to determine haddock version")
                       (programVersion confHaddock)
392
393
  renderArgs verbosity tmpFileOpts haddockVersion comp args $
    \(flags,result)-> do
394
395
396
397
398
399
400

      rawSystemProgram verbosity confHaddock flags

      notice verbosity $ "Documentation created: " ++ result


renderArgs :: Verbosity
401
              -> TempFileOptions
402
              -> Version
403
              -> Compiler
404
              -> HaddockArgs
405
              -> (([String], FilePath) -> IO a)
406
              -> IO a
407
renderArgs verbosity tmpFileOpts version comp args k = do
408
  createDirectoryIfMissingVerbose verbosity True outputDir
409
  withTempFileEx tmpFileOpts outputDir "haddock-prolog.txt" $ \prologFileName h -> do
410
          do
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
411
             when (version >= Version [2,14,4] []) (hSetEncoding h utf8)
412
             hPutStrLn h $ fromFlag $ argPrologue args
413
             hClose h
ian@well-typed.com's avatar
ian@well-typed.com committed
414
             let pflag = "--prologue=" ++ prologFileName
415
             k (pflag : renderPureArgs version comp args, result)
416
    where
417
      outputDir = (unDir $ argOutputDir args)
418
419
420
421
422
423
424
      result = intercalate ", "
             . map (\o -> outputDir </>
                            case o of
                              Html -> "index.html"
                              Hoogle -> pkgstr <.> "txt")
             $ arg argOutput
            where
425
              pkgstr = display $ packageName pkgid
426
              pkgid = arg argPackageName
427
      arg f = fromFlag $ f args
428

429
430
renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String]
renderPureArgs version comp args = concat
431
    [
432
     (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)
433
     . fromFlag . argInterfaceFile $ args,
434
435
     (\pname ->   ["--optghc=-package-name", "--optghc=" ++ pname]
                  ) . display . fromFlag . argPackageName $ args,
436
437
     (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args,
     bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args,
438
439
     maybe [] (\(m,e,l) -> ["--source-module=" ++ m
                           ,"--source-entity=" ++ e]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
440
                           ++ if isVersion2_14 then ["--source-entity-line=" ++ l]
441
442
                                               else []
              ) . flagToMaybe . argLinkSource $ args,
443
     maybe [] ((:[]).("--css="++)) . flagToMaybe . argCssFile $ args,
444
     maybe [] ((:[]).("--use-contents="++)) . flagToMaybe . argContents $ args,
Ian Lynagh's avatar
Ian Lynagh committed
445
     bool [] [verbosityFlag] . getAny . argVerbose $ args,
446
     map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") . fromFlag . argOutput $ args,
447
448
     renderInterfaces . argInterfaces $ args,
     (:[]).("--odir="++) . unDir . argOutputDir $ args,
449
     (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args))
450
              . fromFlag . argTitle $ args,
451
     [ "--optghc=" ++ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args)
452
                          , opt <- renderGhcOptions comp opts ],
453
     maybe [] (\l -> ["-B"++l]) $ flagToMaybe (argGhcLibDir args), -- error if Nothing?
454
     argTargets $ args
455
456
    ]
    where
457
458
      renderInterfaces =
        map (\(i,mh) -> "--read-interface=" ++
459
          maybe "" (++",") mh ++ i)
460
      bool a b c = if c then a else b
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
461
      isVersion2_5  = version >= Version [2,5]  []
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
462
      isVersion2_14 = version >= Version [2,14] []
Ian Lynagh's avatar
Ian Lynagh committed
463
464
465
      verbosityFlag
       | isVersion2_5 = "--verbosity=1"
       | otherwise = "--verbose"
466

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
467
---------------------------------------------------------------------------------
468

469
470
471
472
473
474
-- | 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
475
  interfaces <- sequence
476
477
    [ case interfaceAndHtmlPath ipkg of
        Nothing -> return (Left (packageId ipkg))
478
479
480
        Just (interface, html) -> do
          exists <- doesFileExist interface
          if exists
481
            then return (Right (interface, html))
482
483
484
            else return (Left pkgid)
    | ipkg <- ipkgs, let pkgid = packageId ipkg
    , pkgName pkgid `notElem` noHaddockWhitelist
485
    ]
486

487
  let missing = [ pkgid | Left pkgid <- interfaces ]
488
      warning = "The documentation for the following packages are not "
489
             ++ "installed. No links will be generated to these packages: "
490
             ++ intercalate ", " (map display missing)
491
      flags = rights interfaces
492
493
494
495

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

  where
496
    -- Don't warn about missing documentation for these packages. See #1231.
497
    noHaddockWhitelist = map PackageName [ "rts" ]
498
499
500
501

    -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.
    interfaceAndHtmlPath :: InstalledPackageInfo
                         -> Maybe (FilePath, Maybe FilePath)
502
    interfaceAndHtmlPath pkg = do
503
      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)
504
      html <- case mkHtmlPath of
505
506
        Nothing -> fmap fixFileUrl
                        (listToMaybe (InstalledPackageInfo.haddockHTMLs pkg))
507
508
        Just mkPath -> Just (mkPath pkg)
      return (interface, if null html then Nothing else Just html)
509
      where
510
511
        -- 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.
512
513
        fixFileUrl f | isAbsolute f = "file://" ++ f
                     | otherwise    = f
514

515
516
517
518
519
520
521
522
523
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
524
    Right inf -> die $ "internal error when calculating transitive "
525
526
527
528
529
530
531
532
533
                    ++ "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)


534
haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
535
536
haddockTemplateEnv lbi pkg_id =
  (PrefixVar, prefix (installDirTemplates lbi))
537
  : initialPathTemplateEnv pkg_id (pkgKey lbi) (compilerId (compiler lbi))
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
538
  (hostPlatform lbi)
539

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
540
541
-- ------------------------------------------------------------------------------
-- hscolour support.
542
543

hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO ()
544
hscolour pkg_descr lbi suffixes flags = do
545
546
  -- we preprocess even if hscolour won't be found on the machine
  -- will this upset someone?
547
548
  initialBuildSteps distPref pkg_descr lbi verbosity
  hscolour' pkg_descr lbi suffixes flags
549
550
551
552
553
 where
   verbosity  = fromFlag (hscolourVerbosity flags)
   distPref = fromFlag $ hscolourDistPref flags

hscolour' :: PackageDescription
554
555
556
557
558
          -> LocalBuildInfo
          -> [PPSuffixHandler]
          -> HscolourFlags
          -> IO ()
hscolour' pkg_descr lbi suffixes flags = do
559
    let distPref = fromFlag $ hscolourDistPref flags
560
561
562
563
    (hscolourProg, _, _) <-
      requireProgramVersion
        verbosity hscolourProgram
        (orLaterVersion (Version [1,8] [])) (withPrograms lbi)
564

565
    setupMessage verbosity "Running hscolour for" (packageId pkg_descr)
566
    createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr
567

568
    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes
569
    withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do
570
      pre comp
571
572
573
574
575
576
577
578
579
      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 ()
580
581
582
583
      case comp of
        CLib lib -> do
          let outputDir = hscolourPref distPref pkg_descr </> "src"
          runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib
584
585
586
        CExe   _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp
        CTest  _ -> when (fromFlag (hscolourTestSuites  flags)) $ doExe comp
        CBench _ -> when (fromFlag (hscolourBenchmarks  flags)) $ doExe comp
587
  where
588
    stylesheet = flagToMaybe (hscolourCSS flags)
589

590
591
    verbosity  = fromFlag (hscolourVerbosity flags)

592
    runHsColour prog outputDir moduleFiles = do
593
594
         createDirectoryIfMissingVerbose verbosity True outputDir

595
         case stylesheet of -- copy the CSS file
596
597
598
599
600
601
           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
602
         forM_ moduleFiles $ \(m, inFile) ->
603
604
605
606
607
608
             rawSystemProgram verbosity prog
                    ["-css", "-anchor", "-o" ++ outFile m, inFile]
        where
          outFile m = outputDir </> intercalate "-" (ModuleName.components m) <.> "html"

haddockToHscolour :: HaddockFlags -> HscolourFlags
609
610
haddockToHscolour flags =
    HscolourFlags {
611
612
      hscolourCSS         = haddockHscolourCss flags,
      hscolourExecutables = haddockExecutables flags,
613
614
      hscolourTestSuites  = haddockTestSuites  flags,
      hscolourBenchmarks  = haddockBenchmarks  flags,
615
      hscolourVerbosity   = haddockVerbosity   flags,
616
      hscolourDistPref    = haddockDistPref    flags
617
    }
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
618
---------------------------------------------------------------------------------
619
620
621
622
623
624
-- TODO these should be moved elsewhere.

getLibSourceFiles :: LocalBuildInfo
                     -> Library
                     -> IO [(ModuleName.ModuleName, FilePath)]
getLibSourceFiles lbi lib = getSourceFiles searchpaths modules
625
626
627
  where
    bi               = libBuildInfo lib
    modules          = PD.exposedModules lib ++ otherModules bi
628
    searchpaths      = autogenModulesDir lbi : buildDir lbi : hsSourceDirs bi
629

630
631
632
getExeSourceFiles :: LocalBuildInfo
                     -> Executable
                     -> IO [(ModuleName.ModuleName, FilePath)]
633
getExeSourceFiles lbi exe = do
634
635
636
637
638
639
640
641
642
643
644
    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)]
645
getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $
646
    findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m)
647
      >>= maybe (notFound m) (return . normalise)
648
  where
649
    notFound module_ = die $ "can't find source for module " ++ display module_
650
651
652
653
654

-- | 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
655
656
-- ------------------------------------------------------------------------------
-- Boilerplate Monoid instance.
657
658
instance Monoid HaddockArgs where
    mempty = HaddockArgs {
659
660
                argInterfaceFile = mempty,
                argPackageName = mempty,
661
662
663
664
                argHideModules = mempty,
                argIgnoreExports = mempty,
                argLinkSource = mempty,
                argCssFile = mempty,
665
                argContents = mempty,
666
667
668
669
670
671
                argVerbose = mempty,
                argOutput = mempty,
                argInterfaces = mempty,
                argOutputDir = mempty,
                argTitle = mempty,
                argPrologue = mempty,
672
                argGhcOptions = mempty,
673
674
675
676
                argGhcLibDir = mempty,
                argTargets = mempty
             }
    mappend a b = HaddockArgs {
677
678
                argInterfaceFile = mult argInterfaceFile,
                argPackageName = mult argPackageName,
679
680
681
682
                argHideModules = mult argHideModules,
                argIgnoreExports = mult argIgnoreExports,
                argLinkSource = mult argLinkSource,
                argCssFile = mult argCssFile,
683
                argContents = mult argContents,
684
685
686
687
688
689
                argVerbose = mult argVerbose,
                argOutput = mult argOutput,
                argInterfaces = mult argInterfaces,
                argOutputDir = mult argOutputDir,
                argTitle = mult argTitle,
                argPrologue = mult argPrologue,
690
                argGhcOptions = mult argGhcOptions,
691
692
693
694
695
696
697
698
                argGhcLibDir = mult argGhcLibDir,
                argTargets = mult argTargets
             }
      where mult f = f a `mappend` f b

instance Monoid Directory where
    mempty = Dir "."
    mappend (Dir m) (Dir n) = Dir $ m </> n