Haddock.hs 30.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
import Distribution.Package
55
56
57
         ( PackageIdentifier(..)
         , Package(..)
         , PackageName(..), packageName )
58
import qualified Distribution.ModuleName as ModuleName
59
import Distribution.PackageDescription as PD
60
         ( PackageDescription(..), BuildInfo(..), allExtensions
61
         , Library(..), hasLibs, Executable(..) )
62
import Distribution.Simple.Compiler
63
         ( Compiler(..), compilerVersion )
64
65
import Distribution.Simple.GHC ( componentGhcOptions, ghcLibDir )
import Distribution.Simple.Program.GHC ( GhcOptions(..), renderGhcOptions )
66
import Distribution.Simple.Program
67
         ( ConfiguredProgram(..), requireProgramVersion
68
69
         , rawSystemProgram, rawSystemProgramStdout
         , hscolourProgram, haddockProgram )
70
71
72
import Distribution.Simple.PreProcess (ppCpp', ppUnlit
                                      , PPSuffixHandler, runSimplePreProcessor
                                      , preprocessComponent)
73
import Distribution.Simple.Setup
74
        ( defaultHscolourFlags, Flag(..), toFlag, flagToMaybe, flagToList, fromFlag
75
        , HaddockFlags(..), HscolourFlags(..) )
76
import Distribution.Simple.Build (initialBuildSteps)
77
import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplateEnv, PathTemplate,
78
79
                                        PathTemplateVariable(..),
                                        toPathTemplate, fromPathTemplate,
80
                                        substPathTemplate, initialPathTemplateEnv)
81
import Distribution.Simple.LocalBuildInfo
refold's avatar
refold committed
82
         ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)
refold's avatar
refold committed
83
         , withAllComponentsInBuildOrder )
84
import Distribution.Simple.BuildPaths ( haddockName,
85
                                        hscolourPref, autogenModulesDir,
86
                                        )
87
import Distribution.Simple.PackageIndex (dependencyClosure)
88
import qualified Distribution.Simple.PackageIndex as PackageIndex
89
90
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
         ( InstalledPackageInfo_(..) )
91
92
import Distribution.InstalledPackageInfo
         ( InstalledPackageInfo )
93
import Distribution.Simple.Utils
94
         ( die, warn, notice, intercalate, setupMessage
95
         , createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose
96
         , withTempDirectory, matchFileGlob
97
         , findFileWithExtension, findFile )
98
import Distribution.Text
99
         ( display, simpleParse )
100
101
102
103

import Distribution.Verbosity
import Language.Haskell.Extension
-- Base
104
import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing)
105

106
import Control.Monad ( when, guard, forM_ )
107
108
109
import Control.Exception (assert)
import Data.Monoid
import Data.Maybe    ( fromMaybe, listToMaybe )
110
111

import System.FilePath((</>), (<.>), splitFileName, splitExtension,
refold's avatar
refold committed
112
                       normalise, splitPath, joinPath )
113
import System.IO (hClose, hPutStrLn)
114
import Distribution.Version
115
import Distribution.Simple.SrcDist (copyFileTo)
116

117
-- Types
118
119
120
121
122
123
124
125
126

-- | 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)
 argIgnoreExports :: Any,                         -- ^ ingore export lists in modules?
 argLinkSource :: Flag (Template,Template),       -- ^ (template for modules, template for symbols)
 argCssFile :: Flag FilePath,                     -- ^ optinal custom css file.
127
 argContents :: Flag String,                      -- ^ optional url to contents page
128
 argVerbose :: Any,
129
 argOutput :: Flag [Output],                      -- ^ Html or Hoogle doc or both?                                   required.
130
131
132
133
 argInterfaces :: [(FilePath, Maybe FilePath)],   -- ^ [(interface file, path to the html docs for links)]
 argOutputDir :: Directory,                       -- ^ where to generate the documentation.
 argTitle :: Flag String,                         -- ^ page's title,                                         required.
 argPrologue :: Flag String,                      -- ^ prologue text,                                        required.
134
 argGhcOptions :: Flag (GhcOptions, Version),     -- ^ additional flags to pass to ghc for haddock-2
135
136
137
138
139
140
141
142
143
144
145
146
147
148
 argGhcLibDir :: Flag FilePath,                   -- ^ to find the correct ghc,                              required by haddock-2.
 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

149
150
151
152
-- --------------------------------------------------------------------------
-- Haddock support

haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO ()
153
haddock pkg_descr _ _ haddockFlags
Joachim Breitner's avatar
Joachim Breitner committed
154
  |    not (hasLibs pkg_descr)
155
    && not (fromFlag $ haddockExecutables haddockFlags) =
156
      warn (fromFlag $ haddockVerbosity haddockFlags) $
157
           "No documentation was generated as this package does not contain "
158
        ++ "a library. Perhaps you want to use the --executables flag."
159

160
haddock pkg_descr lbi suffixes flags = do
161

162
    setupMessage verbosity "Running Haddock for" (packageId pkg_descr)
163
164
165
    (confHaddock, version, _) <-
      requireProgramVersion verbosity haddockProgram
        (orLaterVersion (Version [0,6] [])) (withPrograms lbi)
166

167
168
    -- various sanity checks
    let isVersion2   = version >= Version [2,0] []
169

170
    when ( flag haddockHoogle
171
172
173
           && version > Version [2] []
           && version < Version [2,2] []) $
         die "haddock 2.0 and 2.1 do not support the --hoogle flag."
174

175
    when (flag haddockHscolour && version < Version [0,8] []) $
176
         die "haddock --hyperlink-source requires Haddock version 0.8 or later"
177

David Waern's avatar
David Waern committed
178
    when isVersion2 $ do
179
180
181
      haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock
                                ["--ghc-version"]
      case simpleParse haddockGhcVersionStr of
182
        Nothing -> die "Could not get GHC version from Haddock"
183
184
185
186
187
188
189
190
        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 (compiler lbi)
191
192
193

    -- the tools match the requests, we can proceed

194
195
196
    initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity

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

199
200
201
202
    libdirArgs <- getGhcLibDir  verbosity lbi isVersion2
    let commonArgs = mconcat
            [ libdirArgs
            , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags
203
            , fromPackageDescription pkg_descr ]
David Waern's avatar
David Waern committed
204

205
    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes
206
    withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do
207
208
209
      pre comp
      case comp of
        CLib lib -> do
210
          withTempDirectory verbosity keepTempFiles (buildDir lbi) "tmp" $ \tmp -> do
211
            let bi = libBuildInfo lib
212
            libArgs  <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate
213
            libArgs' <- prepareSources verbosity tmp
214
                          lbi isVersion2 bi (commonArgs `mappend` libArgs)
215
            runHaddock verbosity keepTempFiles confHaddock libArgs'
216
        CExe exe -> when (flag haddockExecutables) $ do
217
          withTempDirectory verbosity keepTempFiles (buildDir lbi) "tmp" $ \tmp -> do
218
            let bi = buildInfo exe
219
            exeArgs  <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate
220
            exeArgs' <- prepareSources verbosity tmp
221
                          lbi isVersion2 bi (commonArgs `mappend` exeArgs)
222
            runHaddock verbosity keepTempFiles confHaddock exeArgs'
223
        _ -> return ()
224

John Wiegley's avatar
John Wiegley committed
225
    forM_ (extraHtmlFiles pkg_descr) $ \ fpath -> do
226
      files <- matchFileGlob fpath
refold's avatar
refold committed
227
      forM_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)
228
  where
229
230
231
    verbosity     = flag haddockVerbosity
    keepTempFiles = flag haddockKeepTempFiles
    flag f        = fromFlag $ f flags
232
    htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags
233
234
235
236

-- | performs cpp and unlit preprocessing where needed on the files in
-- | argTargets, which must have an .hs or .lhs extension.
prepareSources :: Verbosity
237
                  -> FilePath
238
                  -> LocalBuildInfo
239
                  -> Bool            -- haddock == 2.*
240
241
                  -> BuildInfo
                  -> HaddockArgs
242
243
244
                  -> IO HaddockArgs
prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files} =
              mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets}
245
          where
246
            mockPP pref file = do
247
248
249
250
251
                 let (filePref, fileName) = splitFileName file
                     targetDir  = pref </> filePref
                     targetFile = targetDir </> fileName
                     (targetFileNoext, targetFileExt) = splitExtension $ targetFile
                     hsFile = targetFileNoext <.> "hs"
252

253
254
255
256
257
258
                 assert (targetFileExt `elem` [".lhs",".hs"]) $ return ()

                 createDirectoryIfMissing True targetDir

                 if needsCpp
                    then do
259
                      runSimplePreProcessor (ppCpp' defines bi lbi)
260
261
262
263
264
265
266
267
268
                                            file targetFile verbosity
                    else
                      copyFileVerbose verbosity file targetFile

                 when (targetFileExt == ".lhs") $ do
                     runSimplePreProcessor ppUnlit targetFile hsFile verbosity
                     removeFile targetFile

                 return hsFile
269
            needsCpp = EnableExtension CPP `elem` allExtensions bi
270
271
            defines | isVersion2 = []
                    | otherwise  = ["-D__HADDOCK__"]
272
273
274
275

--------------------------------------------------------------------------------------------------
-- constributions to HaddockArgs

276
277
fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags env flags =
278
279
280
281
282
283
284
    mempty {
      argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty),
      argLinkSource = if fromFlag (haddockHscolour flags)
                               then Flag ("src/%{MODULE/./-}.html"
                                         ,"src/%{MODULE/./-}.html#%{NAME}")
                               else NoFlag,
      argCssFile = haddockCss flags,
285
      argContents = fmap (fromPathTemplate . substPathTemplate env) (haddockContents flags),
286
      argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags,
287
288
289
290
291
      argOutput = 
          Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++
                      [ Hoogle | Flag True <- [haddockHoogle flags] ]
                 of [] -> [ Html ]
                    os -> os,
292
293
294
295
      argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags
    }

fromPackageDescription :: PackageDescription -> HaddockArgs
296
fromPackageDescription pkg_descr =
297
      mempty {
298
299
                argInterfaceFile = Flag $ haddockName pkg_descr,
                argPackageName = Flag $ packageId $ pkg_descr,
300
301
302
303
                argOutputDir = Dir $ "doc" </> "html" </> display (packageName pkg_descr),
                argPrologue = Flag $ if null desc then synopsis pkg_descr else desc,
                argTitle = Flag $ showPkg ++ subtitle
             }
304
      where
305
306
307
308
309
        desc = PD.description pkg_descr
        showPkg = display (packageId pkg_descr)
        subtitle | null (synopsis pkg_descr) = ""
                 | otherwise                 = ": " ++ synopsis pkg_descr

310
311
fromLibrary :: Verbosity
            -> FilePath
312
            -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo
313
            -> Maybe PathTemplate -- ^ template for html location
314
            -> IO HaddockArgs
315
316
317
fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do
    inFiles <- map snd `fmap` getLibSourceFiles lbi lib
    ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
    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
                      }
        sharedOpts = vanillaOpts {
                         ghcOptDynamic   = toFlag True,
                         ghcOptFPic      = toFlag True,
                         ghcOptHiSuffix  = toFlag "dyn_hi",
                         ghcOptObjSuffix = toFlag "dyn_o",
                         ghcOptExtra     = ghcSharedOptions bi
                     }
    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"
339
340
    return ifaceArgs {
      argHideModules = (mempty,otherModules $ bi),
341
      argGhcOptions  = toFlag (opts, ghcVersion),
342
343
344
345
346
      argTargets     = inFiles
    }
  where
    bi = libBuildInfo lib
    ghcVersion = compilerVersion (compiler lbi)
347

348
349
fromExecutable :: Verbosity
               -> FilePath
350
               -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo
351
               -> Maybe PathTemplate -- ^ template for html location
352
               -> IO HaddockArgs
353
354
355
fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do
    inFiles <- map snd `fmap` getExeSourceFiles lbi exe
    ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
    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
                      }
        sharedOpts = vanillaOpts {
                         ghcOptDynamic   = toFlag True,
                         ghcOptFPic      = toFlag True,
                         ghcOptHiSuffix  = toFlag "dyn_hi",
                         ghcOptObjSuffix = toFlag "dyn_o",
                         ghcOptExtra     = ghcSharedOptions bi
                     }
    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"
377
    return ifaceArgs {
378
      argGhcOptions = toFlag (opts, ghcVersion),
379
380
381
382
383
384
385
      argOutputDir  = Dir (exeName exe),
      argTitle      = Flag (exeName exe),
      argTargets    = inFiles
    }
  where
    bi = buildInfo exe
    ghcVersion = compilerVersion (compiler lbi)
386
387

getInterfaces :: Verbosity
388
389
390
391
392
393
              -> LocalBuildInfo
              -> ComponentLocalBuildInfo
              -> Maybe PathTemplate -- ^ template for html location
              -> IO HaddockArgs
getInterfaces verbosity lbi clbi htmlTemplate = do
    (packageFlags, warnings) <- haddockPackageFlags lbi clbi htmlTemplate
394
    maybe (return ()) (warn verbosity) warnings
395
    return $ mempty {
396
397
398
                 argInterfaces = packageFlags
               }

399
getGhcLibDir :: Verbosity -> LocalBuildInfo
400
401
             -> Bool -- ^ are we using haddock-2.x ?
             -> IO HaddockArgs
402
403
404
405
getGhcLibDir verbosity lbi isVersion2
    | isVersion2 =
        do l <- ghcLibDir verbosity lbi
           return $ mempty { argGhcLibDir = Flag l }
406
407
408
409
410
411
    | otherwise  =
        return mempty

----------------------------------------------------------------------------------------------

-- | Call haddock with the specified arguments.
412
413
runHaddock :: Verbosity -> Bool -> ConfiguredProgram -> HaddockArgs -> IO ()
runHaddock verbosity keepTempFiles confHaddock args = do
414
415
  let haddockVersion = fromMaybe (error "unable to determine haddock version")
                       (programVersion confHaddock)
416
  renderArgs verbosity keepTempFiles haddockVersion args $ \(flags,result)-> do
417
418
419
420
421
422
423

      rawSystemProgram verbosity confHaddock flags

      notice verbosity $ "Documentation created: " ++ result


renderArgs :: Verbosity
424
              -> Bool
425
426
              -> Version
              -> HaddockArgs
427
              -> (([String], FilePath) -> IO a)
428
              -> IO a
429
renderArgs verbosity keepTempFiles version args k = do
430
  createDirectoryIfMissingVerbose verbosity True outputDir
431
  withTempFile keepTempFiles outputDir "haddock-prolog.txt" $ \prologFileName h -> do
432
433
          do
             hPutStrLn h $ fromFlag $ argPrologue args
434
             hClose h
ian@well-typed.com's avatar
ian@well-typed.com committed
435
436
             let pflag = "--prologue=" ++ prologFileName
             k (pflag : renderPureArgs version args, result)
437
    where
438
439
      isVersion2 = version >= Version [2,0] []
      outputDir = (unDir $ argOutputDir args)
440
441
442
443
444
445
446
447
448
449
      result = intercalate ", "
             . map (\o -> outputDir </>
                            case o of
                              Html -> "index.html"
                              Hoogle -> pkgstr <.> "txt")
             $ arg argOutput
            where
              pkgstr | isVersion2 = display $ packageName pkgid
                     | otherwise = display pkgid
              pkgid = arg argPackageName
450
      arg f = fromFlag $ f args
451

452
renderPureArgs :: Version -> HaddockArgs -> [String]
453
454
renderPureArgs version args = concat
    [
455
     (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)
456
457
     . fromFlag . argInterfaceFile $ args,
     (\pkgName -> if isVersion2
458
                  then ["--optghc=-package-name", "--optghc=" ++ pkgName]
459
                  else ["--package=" ++ pkgName]) . display . fromFlag . argPackageName $ args,
460
461
462
463
464
     (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args,
     bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args,
     maybe [] (\(m,e) -> ["--source-module=" ++ m
                         ,"--source-entity=" ++ e]) . flagToMaybe . argLinkSource $ args,
     maybe [] ((:[]).("--css="++)) . flagToMaybe . argCssFile $ args,
465
     maybe [] ((:[]).("--use-contents="++)) . flagToMaybe . argContents $ args,
Ian Lynagh's avatar
Ian Lynagh committed
466
     bool [] [verbosityFlag] . getAny . argVerbose $ args,
467
     map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") . fromFlag . argOutput $ args,
468
469
     renderInterfaces . argInterfaces $ args,
     (:[]).("--odir="++) . unDir . argOutputDir $ args,
470
     (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args))
471
              . fromFlag . argTitle $ args,
472
473
474
     [ "--optghc=" ++ opt | isVersion2
                          , (opts, ghcVersion) <- flagToList (argGhcOptions args)
                          , opt <- renderGhcOptions ghcVersion opts ],
475
476
     maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing?
     argTargets $ args
477
478
479
    ]
    where
      renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i)
480
      bool a b c = if c then a else b
Ian Lynagh's avatar
Ian Lynagh committed
481
482
483
484
485
      isVersion2 = version >= Version [2,0] []
      isVersion2_5 = version >= Version [2,5] []
      verbosityFlag
       | isVersion2_5 = "--verbosity=1"
       | otherwise = "--verbose"
486
487

-----------------------------------------------------------------------------------------------------------
488

489
haddockPackageFlags :: LocalBuildInfo
490
                    -> ComponentLocalBuildInfo
491
                    -> Maybe PathTemplate
492
                    -> IO ([(FilePath,Maybe FilePath)], Maybe String)
493
haddockPackageFlags lbi clbi htmlTemplate = do
494
  let allPkgs = installedPkgs lbi
495
      directDeps = map fst (componentPackageDeps clbi)
496
  transitiveDeps <- case dependencyClosure allPkgs directDeps of
497
498
499
    Left x    -> return x
    Right inf -> die $ "internal error when calculating transative "
                    ++ "package dependencies.\nDebug info: " ++ show inf
500
  interfaces <- sequence
501
502
    [ case interfaceAndHtmlPath ipkg of
        Nothing -> return (Left (packageId ipkg))
503
504
505
        Just (interface, html) -> do
          exists <- doesFileExist interface
          if exists
506
507
            then return (Right (interface, html))
            else return (Left (packageId ipkg))
508
509
510
    | ipkg <- PackageIndex.allPackages transitiveDeps
    , pkgName (packageId ipkg) `notElem` noHaddockWhitelist
    ]
511

512
  let missing = [ pkgid | Left pkgid <- interfaces ]
513
      warning = "The documentation for the following packages are not "
514
             ++ "installed. No links will be generated to these packages: "
515
             ++ intercalate ", " (map display missing)
516
      flags = [ (interface, if null html then Nothing else Just html)
517
              | Right (interface, html) <- interfaces ]
518
519
520
521

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

  where
522
    noHaddockWhitelist = map PackageName [ "rts" ]
523
524
    interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath)
    interfaceAndHtmlPath pkg = do
525
526
527
528
529
530
531
      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
532
533
534
535
536
            env = haddockTemplateEnv lbi (packageId pkg)

haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
haddockTemplateEnv lbi pkg_id = (PrefixVar, prefix (installDirTemplates lbi))
                                : initialPathTemplateEnv pkg_id (compilerId (compiler lbi))
537
                                  (hostPlatform lbi)
538

539
540
541
542
-- --------------------------------------------------------------------------
-- hscolour support

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

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

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

567
    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes
568
    withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do
569
570
571
572
573
574
575
576
577
578
      pre comp
      case comp of
        CLib lib -> do
          let outputDir = hscolourPref distPref pkg_descr </> "src"
          runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib
        CExe exe | fromFlag (hscolourExecutables flags) -> do
          let outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"
          runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe
        _ -> return ()
  where
579
    stylesheet = flagToMaybe (hscolourCSS flags)
580

581
582
    verbosity  = fromFlag (hscolourVerbosity flags)

583
    runHsColour prog outputDir moduleFiles = do
584
585
         createDirectoryIfMissingVerbose verbosity True outputDir

586
         case stylesheet of -- copy the CSS file
587
588
589
590
591
592
           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
593
         forM_ moduleFiles $ \(m, inFile) ->
594
595
596
597
598
599
             rawSystemProgram verbosity prog
                    ["-css", "-anchor", "-o" ++ outFile m, inFile]
        where
          outFile m = outputDir </> intercalate "-" (ModuleName.components m) <.> "html"

haddockToHscolour :: HaddockFlags -> HscolourFlags
600
601
haddockToHscolour flags =
    HscolourFlags {
602
603
604
      hscolourCSS         = haddockHscolourCss flags,
      hscolourExecutables = haddockExecutables flags,
      hscolourVerbosity   = haddockVerbosity   flags,
605
      hscolourDistPref    = haddockDistPref    flags
606
607
608
609
610
611
612
613
    }
----------------------------------------------------------------------------------------------
-- TODO these should be moved elsewhere.

getLibSourceFiles :: LocalBuildInfo
                     -> Library
                     -> IO [(ModuleName.ModuleName, FilePath)]
getLibSourceFiles lbi lib = getSourceFiles searchpaths modules
614
615
616
  where
    bi               = libBuildInfo lib
    modules          = PD.exposedModules lib ++ otherModules bi
617
    searchpaths      = autogenModulesDir lbi : buildDir lbi : hsSourceDirs bi
618

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

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

---------------------------------------------------------------------------------------------




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