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

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

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

import System.FilePath((</>), (<.>), splitFileName, splitExtension,
111
                       normalise, splitPath, joinPath)
112
import System.IO (hClose, hPutStrLn)
113
114
import Distribution.Version

115
-- Types
116
117
118
119
120
121
122
123
124

-- | 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.
125
 argVerbose :: Any,
126
 argOutput :: Flag [Output],                      -- ^ Html or Hoogle doc or both?                                   required.
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
 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.
 argGhcFlags :: [String],                         -- ^ additional flags to pass to ghc for haddock-2
 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

146
147
148
149
-- --------------------------------------------------------------------------
-- Haddock support

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

157
haddock pkg_descr lbi suffixes flags = do
158

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

164
165
    -- various sanity checks
    let isVersion2   = version >= Version [2,0] []
166

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

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

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

    -- the tools match the requests, we can proceed

191
192
193
    initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity

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

    args <- fmap mconcat . sequence $
            [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags))
            , getGhcLibDir  verbosity lbi isVersion2 ]
           ++ map return
200
201
            [ fromFlags flags
            , fromPackageDescription pkg_descr ]
David Waern's avatar
David Waern committed
202

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

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

245
246
247
248
249
250
                 assert (targetFileExt `elem` [".lhs",".hs"]) $ return ()

                 createDirectoryIfMissing True targetDir

                 if needsCpp
                    then do
251
                      runSimplePreProcessor (ppCpp' defines bi lbi)
252
253
254
255
256
257
258
259
260
                                            file targetFile verbosity
                    else
                      copyFileVerbose verbosity file targetFile

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

                 return hsFile
261
            needsCpp = EnableExtension CPP `elem` allExtensions bi
262
263
            defines | isVersion2 = []
                    | otherwise  = ["-D__HADDOCK__"]
264
265
266
267
268

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

fromFlags :: HaddockFlags -> HaddockArgs
269
fromFlags flags =
270
271
272
273
274
275
276
277
    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,
      argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags,
278
279
280
281
282
      argOutput = 
          Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++
                      [ Hoogle | Flag True <- [haddockHoogle flags] ]
                 of [] -> [ Html ]
                    os -> os,
283
284
285
286
      argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags
    }

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

301
302
303
304
fromLibrary :: FilePath
            -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo
            -> IO HaddockArgs
fromLibrary tmp lbi lib clbi =
305
306
307
            do inFiles <- map snd `fmap` getLibSourceFiles lbi lib
               return $ mempty {
                            argHideModules = (mempty,otherModules $ bi),
308
309
310
311
312
                            argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi)
                                       -- Noooooooooo!!!!!111
                                       -- haddock stomps on our precious .hi
                                       -- and .o files. Workaround by telling
                                       -- haddock to write them elsewhere.
313
314
                                       ++ [ "-odir", tmp, "-hidir", tmp
                                          , "-stubdir", tmp ],
315
                            argTargets = inFiles
316
                          }
317
    where
318
      bi = libBuildInfo lib
319

320
321
322
323
fromExecutable :: FilePath
               -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo
               -> IO HaddockArgs
fromExecutable tmp lbi exe clbi =
324
325
            do inFiles <- map snd `fmap` getExeSourceFiles lbi exe
               return $ mempty {
326
327
328
329
330
                            argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi)
                                       -- Noooooooooo!!!!!111
                                       -- haddock stomps on our precious .hi
                                       -- and .o files. Workaround by telling
                                       -- haddock to write them elsewhere.
331
332
                                       ++ [ "-odir", tmp, "-hidir", tmp
                                          , "-stubdir", tmp ],
333
334
                            argOutputDir = Dir (exeName exe),
                            argTitle = Flag (exeName exe),
335
                            argTargets = inFiles
336
                          }
337
    where
338
339
340
341
342
343
344
345
346
347
      bi = buildInfo exe

getInterfaces :: Verbosity
                 -> LocalBuildInfo
                 -> Maybe String -- ^ template for html location
                 -> IO HaddockArgs
getInterfaces verbosity lbi location = do
    let htmlTemplate = fmap toPathTemplate $ location
    (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate
    maybe (return ()) (warn verbosity) warnings
348
    return $ mempty {
349
350
351
                 argInterfaces = packageFlags
               }

352
getGhcLibDir :: Verbosity -> LocalBuildInfo
353
354
             -> Bool -- ^ are we using haddock-2.x ?
             -> IO HaddockArgs
355
356
357
358
getGhcLibDir verbosity lbi isVersion2
    | isVersion2 =
        do l <- ghcLibDir verbosity lbi
           return $ mempty { argGhcLibDir = Flag l }
359
360
361
362
363
364
365
366
367
368
    | otherwise  =
        return mempty

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

-- | Call haddock with the specified arguments.
runHaddock :: Verbosity -> ConfiguredProgram -> HaddockArgs -> IO ()
runHaddock verbosity confHaddock args = do
  let haddockVersion = fromMaybe (error "unable to determine haddock version")
                       (programVersion confHaddock)
369
  renderArgs verbosity haddockVersion args $ \(flags,result)-> do
370
371
372
373
374
375
376
377
378
379
380

      rawSystemProgram verbosity confHaddock flags

      notice verbosity $ "Documentation created: " ++ result


renderArgs :: Verbosity
              -> Version
              -> HaddockArgs
              -> (([[Char]], FilePath) -> IO a)
              -> IO a
381
renderArgs verbosity version args k = do
382
383
384
385
  createDirectoryIfMissingVerbose verbosity True outputDir
  withTempFile outputDir "haddock-prolog.txt" $ \prologFileName h -> do
          do
             hPutStrLn h $ fromFlag $ argPrologue args
386
             hClose h
387
             let pflag = (:[]).("--prologue="++) $ prologFileName
Ian Lynagh's avatar
Ian Lynagh committed
388
             k $ (pflag ++ renderPureArgs version args, result)
389
    where
390
391
      isVersion2 = version >= Version [2,0] []
      outputDir = (unDir $ argOutputDir args)
392
393
394
395
396
397
398
399
400
401
      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
402
      arg f = fromFlag $ f args
403

Ian Lynagh's avatar
Ian Lynagh committed
404
renderPureArgs :: Version -> HaddockArgs -> [[Char]]
405
406
renderPureArgs version args = concat
    [
407
     (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)
408
409
     . fromFlag . argInterfaceFile $ args,
     (\pkgName -> if isVersion2
410
                  then ["--optghc=-package-name", "--optghc=" ++ pkgName]
411
                  else ["--package=" ++ pkgName]) . display . fromFlag . argPackageName $ args,
412
413
414
415
416
     (\(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,
Ian Lynagh's avatar
Ian Lynagh committed
417
     bool [] [verbosityFlag] . getAny . argVerbose $ args,
418
     map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") . fromFlag . argOutput $ args,
419
420
     renderInterfaces . argInterfaces $ args,
     (:[]).("--odir="++) . unDir . argOutputDir $ args,
421
     (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args))
422
423
424
425
              . fromFlag . argTitle $ args,
     bool id (const []) isVersion2 . map ("--optghc=" ++) . argGhcFlags $ args,
     maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing?
     argTargets $ args
426
427
428
    ]
    where
      renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i)
429
      bool a b c = if c then a else b
Ian Lynagh's avatar
Ian Lynagh committed
430
431
432
433
434
      isVersion2 = version >= Version [2,0] []
      isVersion2_5 = version >= Version [2,5] []
      verbosityFlag
       | isVersion2_5 = "--verbosity=1"
       | otherwise = "--verbose"
435
436

-----------------------------------------------------------------------------------------------------------
437

438
439
haddockPackageFlags :: LocalBuildInfo
                    -> Maybe PathTemplate
440
                    -> IO ([(FilePath,Maybe FilePath)], Maybe String)
441
haddockPackageFlags lbi htmlTemplate = do
442
  let allPkgs = installedPkgs lbi
443
      directDeps = map fst (externalPackageDeps lbi)
444
  transitiveDeps <- case dependencyClosure allPkgs directDeps of
445
446
447
    Left x    -> return x
    Right inf -> die $ "internal error when calculating transative "
                    ++ "package dependencies.\nDebug info: " ++ show inf
448
  interfaces <- sequence
449
450
    [ case interfaceAndHtmlPath ipkg of
        Nothing -> return (Left (packageId ipkg))
451
452
453
        Just (interface, html) -> do
          exists <- doesFileExist interface
          if exists
454
455
            then return (Right (interface, html))
            else return (Left (packageId ipkg))
Duncan Coutts's avatar
Duncan Coutts committed
456
    | ipkg <- PackageIndex.allPackages transitiveDeps ]
457

458
  let missing = [ pkgid | Left pkgid <- interfaces ]
459
      warning = "The documentation for the following packages are not "
460
             ++ "installed. No links will be generated to these packages: "
461
             ++ intercalate ", " (map display missing)
462
      flags = [ (interface, if null html then Nothing else Just html)
463
              | Right (interface, html) <- interfaces ]
464
465
466
467

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

  where
468
469
    interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath)
    interfaceAndHtmlPath pkg = do
470
471
472
473
474
475
476
477
      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)
      html <- case htmlTemplate of
        Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)
        Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate)
      return (interface, html)

      where expandTemplateVars = fromPathTemplate . substPathTemplate env
            env = (PrefixVar, prefix (installDirTemplates lbi))
478
                : initialPathTemplateEnv (packageId pkg) (compilerId (compiler lbi))
479

480
481
482
483
-- --------------------------------------------------------------------------
-- hscolour support

hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO ()
484
hscolour pkg_descr lbi suffixes flags = do
485
486
  -- we preprocess even if hscolour won't be found on the machine
  -- will this upset someone?
487
488
  initialBuildSteps distPref pkg_descr lbi verbosity
  hscolour' pkg_descr lbi suffixes flags
489
490
491
492
493
 where
   verbosity  = fromFlag (hscolourVerbosity flags)
   distPref = fromFlag $ hscolourDistPref flags

hscolour' :: PackageDescription
494
495
496
497
498
          -> LocalBuildInfo
          -> [PPSuffixHandler]
          -> HscolourFlags
          -> IO ()
hscolour' pkg_descr lbi suffixes flags = do
499
    let distPref = fromFlag $ hscolourDistPref flags
500
501
502
503
    (hscolourProg, _, _) <-
      requireProgramVersion
        verbosity hscolourProgram
        (orLaterVersion (Version [1,8] [])) (withPrograms lbi)
504

505
    setupMessage verbosity "Running hscolour for" (packageId pkg_descr)
506
    createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr
507

508
    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes
509
    withComponentsLBI pkg_descr lbi $ \comp _ -> do
510
511
512
513
514
515
516
517
518
519
      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
520
    stylesheet = flagToMaybe (hscolourCSS flags)
521

522
523
    verbosity  = fromFlag (hscolourVerbosity flags)

524
    runHsColour prog outputDir moduleFiles = do
525
526
         createDirectoryIfMissingVerbose verbosity True outputDir

527
         case stylesheet of -- copy the CSS file
528
529
530
531
532
533
534
535
536
537
538
539
540
           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")

         flip mapM_ moduleFiles $ \(m, inFile) ->
             rawSystemProgram verbosity prog
                    ["-css", "-anchor", "-o" ++ outFile m, inFile]
        where
          outFile m = outputDir </> intercalate "-" (ModuleName.components m) <.> "html"

haddockToHscolour :: HaddockFlags -> HscolourFlags
541
542
haddockToHscolour flags =
    HscolourFlags {
543
544
545
      hscolourCSS         = haddockHscolourCss flags,
      hscolourExecutables = haddockExecutables flags,
      hscolourVerbosity   = haddockVerbosity   flags,
546
      hscolourDistPref    = haddockDistPref    flags
547
548
549
550
551
552
553
554
    }
----------------------------------------------------------------------------------------------
-- TODO these should be moved elsewhere.

getLibSourceFiles :: LocalBuildInfo
                     -> Library
                     -> IO [(ModuleName.ModuleName, FilePath)]
getLibSourceFiles lbi lib = getSourceFiles searchpaths modules
555
556
557
  where
    bi               = libBuildInfo lib
    modules          = PD.exposedModules lib ++ otherModules bi
558
    searchpaths      = autogenModulesDir lbi : buildDir lbi : hsSourceDirs bi
559

560
561
562
getExeSourceFiles :: LocalBuildInfo
                     -> Executable
                     -> IO [(ModuleName.ModuleName, FilePath)]
563
getExeSourceFiles lbi exe = do
564
565
566
567
568
569
570
571
572
573
574
    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)]
575
getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $
576
    findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m)
577
      >>= maybe (notFound m) (return . normalise)
578
  where
579
    notFound module_ = die $ "can't find source for module " ++ display module_
580
581
582
583
584
585
586
587
588
589
590
591
592

-- | 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 {
593
594
                argInterfaceFile = mempty,
                argPackageName = mempty,
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
                argHideModules = mempty,
                argIgnoreExports = mempty,
                argLinkSource = mempty,
                argCssFile = mempty,
                argVerbose = mempty,
                argOutput = mempty,
                argInterfaces = mempty,
                argOutputDir = mempty,
                argTitle = mempty,
                argPrologue = mempty,
                argGhcFlags = mempty,
                argGhcLibDir = mempty,
                argTargets = mempty
             }
    mappend a b = HaddockArgs {
610
611
                argInterfaceFile = mult argInterfaceFile,
                argPackageName = mult argPackageName,
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
                argHideModules = mult argHideModules,
                argIgnoreExports = mult argIgnoreExports,
                argLinkSource = mult argLinkSource,
                argCssFile = mult argCssFile,
                argVerbose = mult argVerbose,
                argOutput = mult argOutput,
                argInterfaces = mult argInterfaces,
                argOutputDir = mult argOutputDir,
                argTitle = mult argTitle,
                argPrologue = mult argPrologue,
                argGhcFlags = mult argGhcFlags,
                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