Cabal/Distribution/Simple/Haddock.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE RankNTypes #-}
   4
   5 -----------------------------------------------------------------------------
   6 -- |
   7 -- Module      :  Distribution.Simple.Haddock
   8 -- Copyright   :  Isaac Jones 2003-2005
   9 -- License     :  BSD3
  10 --
  11 -- Maintainer  :  cabal-devel@haskell.org
  12 -- Portability :  portable
  13 --
  14 -- This module deals with the @haddock@ and @hscolour@ commands.
  15 -- It uses information about installed packages (from @ghc-pkg@) to find the
  16 -- locations of documentation for dependent packages, so it can create links.
  17 --
  18 -- The @hscolour@ support allows generating HTML versions of the original
  19 -- source, with coloured syntax highlighting.
  20
  21 module Distribution.Simple.Haddock (
  22   haddock, hscolour,
  23
  24   haddockPackagePaths
  25   ) where
  26
  27 import Prelude ()
  28 import Distribution.Compat.Prelude
  29
  30 import qualified Distribution.Simple.GHC   as GHC
  31 import qualified Distribution.Simple.GHCJS as GHCJS
  32
  33 -- local
  34 import Distribution.Backpack.DescribeUnitId
  35 import Distribution.Types.ForeignLib
  36 import Distribution.Types.UnqualComponentName
  37 import Distribution.Types.ComponentLocalBuildInfo
  38 import Distribution.Types.ExecutableScope
  39 import Distribution.Types.LocalBuildInfo
  40 import Distribution.Types.TargetInfo
  41 import Distribution.Package
  42 import qualified Distribution.ModuleName as ModuleName
  43 import Distribution.PackageDescription as PD hiding (Flag)
  44 import Distribution.Simple.Compiler hiding (Flag)
  45 import Distribution.Simple.Glob
  46 import Distribution.Simple.Program.GHC
  47 import Distribution.Simple.Program.ResponseFile
  48 import Distribution.Simple.Program
  49 import Distribution.Simple.PreProcess
  50 import Distribution.Simple.Setup
  51 import Distribution.Simple.Build
  52 import Distribution.Simple.BuildTarget
  53 import Distribution.Simple.InstallDirs
  54 import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate)
  55 import Distribution.Simple.BuildPaths
  56 import Distribution.Simple.Register
  57 import qualified Distribution.Simple.Program.HcPkg as HcPkg
  58 import qualified Distribution.Simple.PackageIndex as PackageIndex
  59 import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
  60 import Distribution.InstalledPackageInfo ( InstalledPackageInfo )
  61 import Distribution.Simple.Utils
  62 import Distribution.System
  63 import Distribution.Text
  64 import Distribution.Utils.NubList
  65 import Distribution.Version
  66 import Distribution.Verbosity
  67 import Language.Haskell.Extension
  68
  69 import Distribution.Compat.Semigroup (All (..), Any (..))
  70
  71 import Control.Monad
  72 import Data.Either      ( rights )
  73
  74 import System.Directory (getCurrentDirectory, doesDirectoryExist, doesFileExist)
  75 import System.FilePath  ( (</>), (<.>), normalise, isAbsolute )
  76 import System.IO        (hClose, hPutStrLn, hSetEncoding, utf8)
  77
  78 -- ------------------------------------------------------------------------------
  79 -- Types
  80
  81 -- | A record that represents the arguments to the haddock executable, a product
  82 -- monoid.
  83 data HaddockArgs = HaddockArgs {
  84  argInterfaceFile :: Flag FilePath,
  85  -- ^ Path to the interface file, relative to argOutputDir, required.
  86  argPackageName :: Flag PackageIdentifier,
  87  -- ^ Package name, required.
  88  argHideModules :: (All,[ModuleName.ModuleName]),
  89  -- ^ (Hide modules ?, modules to hide)
  90  argIgnoreExports :: Any,
  91  -- ^ Ignore export lists in modules?
  92  argLinkSource :: Flag (Template,Template,Template),
  93  -- ^ (Template for modules, template for symbols, template for lines).
  94  argLinkedSource :: Flag Bool,
  95  -- ^ Generate hyperlinked sources
  96  argQuickJump :: Flag Bool,
  97  -- ^ Generate quickjump index
  98  argCssFile :: Flag FilePath,
  99  -- ^ Optional custom CSS file.
 100  argContents :: Flag String,
 101  -- ^ Optional URL to contents page.
 102  argVerbose :: Any,
 103  argOutput :: Flag [Output],
 104  -- ^ HTML or Hoogle doc or both? Required.
 105  argInterfaces :: [(FilePath, Maybe String, Maybe String)],
 106  -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)].
 107  argOutputDir :: Directory,
 108  -- ^ Where to generate the documentation.
 109  argTitle :: Flag String,
 110  -- ^ Page title, required.
 111  argPrologue :: Flag String,
 112  -- ^ Prologue text, required.
 113  argGhcOptions :: GhcOptions,
 114  -- ^ Additional flags to pass to GHC.
 115  argGhcLibDir :: Flag FilePath,
 116  -- ^ To find the correct GHC, required.
 117  argTargets :: [FilePath]
 118  -- ^ Modules to process.
 119 } deriving Generic
 120
 121 -- | The FilePath of a directory, it's a monoid under '(</>)'.
 122 newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord)
 123
 124 unDir :: Directory -> FilePath
 125 unDir = normalise . unDir'
 126
 127 type Template = String
 128
 129 data Output = Html | Hoogle
 130
 131 -- ------------------------------------------------------------------------------
 132 -- Haddock support
 133
 134 haddock :: PackageDescription
 135         -> LocalBuildInfo
 136         -> [PPSuffixHandler]
 137         -> HaddockFlags
 138         -> IO ()
 139 haddock pkg_descr _ _ haddockFlags
 140   |    not (hasLibs pkg_descr)
 141     && not (fromFlag $ haddockExecutables haddockFlags)
 142     && not (fromFlag $ haddockTestSuites  haddockFlags)
 143     && not (fromFlag $ haddockBenchmarks  haddockFlags)
 144     && not (fromFlag $ haddockForeignLibs haddockFlags)
 145     =
 146       warn (fromFlag $ haddockVerbosity haddockFlags) $
 147            "No documentation was generated as this package does not contain "
 148         ++ "a library. Perhaps you want to use the --executables, --tests,"
 149         ++ " --benchmarks or --foreign-libraries flags."
 150
 151 haddock pkg_descr lbi suffixes flags' = do
 152     let verbosity     = flag haddockVerbosity
 153         comp          = compiler lbi
 154         platform      = hostPlatform lbi
 155
 156         quickJmpFlag  = haddockQuickJump flags'
 157         flags = case haddockTarget of
 158           ForDevelopment -> flags'
 159           ForHackage -> flags'
 160             { haddockHoogle       = Flag True
 161             , haddockHtml         = Flag True
 162             , haddockHtmlLocation = Flag (pkg_url ++ "/docs")
 163             , haddockContents     = Flag (toPathTemplate pkg_url)
 164             , haddockLinkedSource = Flag True
 165             , haddockQuickJump    = Flag True
 166             }
 167         pkg_url       = "/package/$pkg-$version"
 168         flag f        = fromFlag $ f flags
 169
 170         tmpFileOpts   = defaultTempFileOptions
 171                        { optKeepTempFiles = flag haddockKeepTempFiles }
 172         htmlTemplate  = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation
 173                         $ flags
 174         haddockTarget =
 175           fromFlagOrDefault ForDevelopment (haddockForHackage flags')
 176
 177     (haddockProg, version, _) <-
 178       requireProgramVersion verbosity haddockProgram
 179         (orLaterVersion (mkVersion [2,0])) (withPrograms lbi)
 180
 181     -- various sanity checks
 182     when (flag haddockHoogle && version < mkVersion [2,2]) $
 183       die' verbosity "Haddock 2.0 and 2.1 do not support the --hoogle flag."
 184
 185
 186     when (flag haddockQuickJump && version < mkVersion [2,19]) $ do
 187       let msg = "Haddock prior to 2.19 does not support the --quickjump flag."
 188           alt = "The generated documentation won't have the QuickJump feature."
 189       if Flag True == quickJmpFlag
 190         then die' verbosity msg
 191         else warn verbosity (msg ++ "\n" ++ alt)
 192
 193     haddockGhcVersionStr <- getProgramOutput verbosity haddockProg
 194                               ["--ghc-version"]
 195     case (simpleParse haddockGhcVersionStr, compilerCompatVersion GHC comp) of
 196       (Nothing, _) -> die' verbosity "Could not get GHC version from Haddock"
 197       (_, Nothing) -> die' verbosity "Could not get GHC version from compiler"
 198       (Just haddockGhcVersion, Just ghcVersion)
 199         | haddockGhcVersion == ghcVersion -> return ()
 200         | otherwise -> die' verbosity $
 201                "Haddock's internal GHC version must match the configured "
 202             ++ "GHC version.\n"
 203             ++ "The GHC version is " ++ display ghcVersion ++ " but "
 204             ++ "haddock is using GHC version " ++ display haddockGhcVersion
 205
 206     -- the tools match the requests, we can proceed
 207
 208     -- We fall back to using HsColour only for versions of Haddock which don't
 209     -- support '--hyperlinked-sources'.
 210     when (flag haddockLinkedSource && version < mkVersion [2,17]) $
 211       hscolour' (warn verbosity) haddockTarget pkg_descr lbi suffixes
 212       (defaultHscolourFlags `mappend` haddockToHscolour flags)
 213
 214     libdirArgs <- getGhcLibDir  verbosity lbi
 215     let commonArgs = mconcat
 216             [ libdirArgs
 217             , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags
 218             , fromPackageDescription haddockTarget pkg_descr ]
 219
 220     targets <- readTargetInfos verbosity pkg_descr lbi (haddockArgs flags)
 221
 222     let
 223       targets' =
 224         case targets of
 225           [] -> allTargetsInBuildOrder' pkg_descr lbi
 226           _  -> targets
 227
 228     internalPackageDB <-
 229       createInternalPackageDB verbosity lbi (flag haddockDistPref)
 230
 231     (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do
 232
 233       let component = targetComponent target
 234           clbi      = targetCLBI target
 235
 236       componentInitialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity
 237
 238       let
 239         lbi' = lbi {
 240           withPackageDB = withPackageDB lbi ++ [internalPackageDB],
 241           installedPkgs = index
 242           }
 243
 244       preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes
 245       let
 246         doExe com = case (compToExe com) of
 247           Just exe -> do
 248             withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $
 249               \tmp -> do
 250                 exeArgs <- fromExecutable verbosity tmp lbi' clbi htmlTemplate
 251                              version exe
 252                 let exeArgs' = commonArgs `mappend` exeArgs
 253                 runHaddock verbosity tmpFileOpts comp platform
 254                   haddockProg exeArgs'
 255           Nothing -> do
 256            warn (fromFlag $ haddockVerbosity flags)
 257              "Unsupported component, skipping..."
 258            return ()
 259         -- We define 'smsg' once and then reuse it inside the case, so that
 260         -- we don't say we are running Haddock when we actually aren't
 261         -- (e.g., Haddock is not run on non-libraries)
 262         smsg :: IO ()
 263         smsg = setupMessage' verbosity "Running Haddock on" (packageId pkg_descr)
 264                 (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
 265       case component of
 266         CLib lib -> do
 267           withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $
 268             \tmp -> do
 269               smsg
 270               libArgs <- fromLibrary verbosity tmp lbi' clbi htmlTemplate
 271                            version lib
 272               let libArgs' = commonArgs `mappend` libArgs
 273               runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs'
 274
 275               case libName lib of
 276                 Just _ -> do
 277                   pwd <- getCurrentDirectory
 278
 279                   let
 280                     ipi = inplaceInstalledPackageInfo
 281                             pwd (flag haddockDistPref) pkg_descr
 282                             (mkAbiHash "inplace") lib lbi' clbi
 283
 284                   debug verbosity $ "Registering inplace:\n"
 285                     ++ (InstalledPackageInfo.showInstalledPackageInfo ipi)
 286
 287                   registerPackage verbosity (compiler lbi') (withPrograms lbi')
 288                     (withPackageDB lbi') ipi
 289                     HcPkg.defaultRegisterOptions {
 290                       HcPkg.registerMultiInstance = True
 291                     }
 292
 293                   return $ PackageIndex.insert ipi index
 294                 Nothing ->
 295                   pure index
 296
 297         CFLib flib -> (when (flag haddockForeignLibs) $ do
 298           withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $
 299             \tmp -> do
 300               smsg
 301               flibArgs <- fromForeignLib verbosity tmp lbi' clbi htmlTemplate
 302                             version flib
 303               let libArgs' = commonArgs `mappend` flibArgs
 304               runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs')
 305
 306           >> return index
 307
 308         CExe   _ -> (when (flag haddockExecutables) $ smsg >> doExe component) >> return index
 309         CTest  _ -> (when (flag haddockTestSuites)  $ smsg >> doExe component) >> return index
 310         CBench _ -> (when (flag haddockBenchmarks)  $ smsg >> doExe component) >> return index
 311
 312     for_ (extraDocFiles pkg_descr) $ \ fpath -> do
 313       files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath
 314       for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)
 315
 316 -- ------------------------------------------------------------------------------
 317 -- Contributions to HaddockArgs (see also Doctest.hs for very similar code).
 318
 319 fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
 320 fromFlags env flags =
 321     mempty {
 322       argHideModules = (maybe mempty (All . not)
 323                         $ flagToMaybe (haddockInternal flags), mempty),
 324       argLinkSource = if fromFlag (haddockLinkedSource flags)
 325                                then Flag ("src/%{MODULE/./-}.html"
 326                                          ,"src/%{MODULE/./-}.html#%{NAME}"
 327                                          ,"src/%{MODULE/./-}.html#line-%{LINE}")
 328                                else NoFlag,
 329       argLinkedSource = haddockLinkedSource flags,
 330       argQuickJump = haddockQuickJump flags,
 331       argCssFile = haddockCss flags,
 332       argContents = fmap (fromPathTemplate . substPathTemplate env)
 333                     (haddockContents flags),
 334       argVerbose = maybe mempty (Any . (>= deafening))
 335                    . flagToMaybe $ haddockVerbosity flags,
 336       argOutput =
 337           Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++
 338                       [ Hoogle | Flag True <- [haddockHoogle flags] ]
 339                  of [] -> [ Html ]
 340                     os -> os,
 341       argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags,
 342
 343       argGhcOptions = mempty { ghcOptExtra = ghcArgs }
 344     }
 345     where
 346       ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags
 347
 348 fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs
 349 fromPackageDescription haddockTarget pkg_descr =
 350       mempty { argInterfaceFile = Flag $ haddockName pkg_descr,
 351                argPackageName = Flag $ packageId $ pkg_descr,
 352                argOutputDir = Dir $
 353                    "doc" </> "html" </> haddockDirName haddockTarget pkg_descr,
 354                argPrologue = Flag $ if null desc then synopsis pkg_descr
 355                                     else desc,
 356                argTitle = Flag $ showPkg ++ subtitle
 357              }
 358       where
 359         desc = PD.description pkg_descr
 360         showPkg = display (packageId pkg_descr)
 361         subtitle | null (synopsis pkg_descr) = ""
 362                  | otherwise                 = ": " ++ synopsis pkg_descr
 363
 364 componentGhcOptions :: Verbosity -> LocalBuildInfo
 365                  -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
 366                  -> GhcOptions
 367 componentGhcOptions verbosity lbi bi clbi odir =
 368   let f = case compilerFlavor (compiler lbi) of
 369             GHC   -> GHC.componentGhcOptions
 370             GHCJS -> GHCJS.componentGhcOptions
 371             _     -> error $
 372                        "Distribution.Simple.Haddock.componentGhcOptions:" ++
 373                        "haddock only supports GHC and GHCJS"
 374   in f verbosity lbi bi clbi odir
 375
 376 mkHaddockArgs :: Verbosity
 377               -> FilePath
 378               -> LocalBuildInfo
 379               -> ComponentLocalBuildInfo
 380               -> Maybe PathTemplate -- ^ template for HTML location
 381               -> Version
 382               -> [FilePath]
 383               -> BuildInfo
 384               -> IO HaddockArgs
 385 mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles bi = do
 386     ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
 387     let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
 388                           -- Noooooooooo!!!!!111
 389                           -- haddock stomps on our precious .hi
 390                           -- and .o files. Workaround by telling
 391                           -- haddock to write them elsewhere.
 392                           ghcOptObjDir     = toFlag tmp,
 393                           ghcOptHiDir      = toFlag tmp,
 394                           ghcOptStubDir    = toFlag tmp
 395                       } `mappend` getGhcCppOpts haddockVersion bi
 396         sharedOpts = vanillaOpts {
 397                          ghcOptDynLinkMode = toFlag GhcDynamicOnly,
 398                          ghcOptFPic        = toFlag True,
 399                          ghcOptHiSuffix    = toFlag "dyn_hi",
 400                          ghcOptObjSuffix   = toFlag "dyn_o",
 401                          ghcOptExtra       = hcSharedOptions GHC bi
 402
 403                      }
 404     opts <- if withVanillaLib lbi
 405             then return vanillaOpts
 406             else if withSharedLib lbi
 407             then return sharedOpts
 408             else die' verbosity $ "Must have vanilla or shared libraries "
 409                        ++ "enabled in order to run haddock"
 410
 411     return ifaceArgs {
 412       argGhcOptions  = opts,
 413       argTargets     = inFiles
 414     }
 415
 416 fromLibrary :: Verbosity
 417             -> FilePath
 418             -> LocalBuildInfo
 419             -> ComponentLocalBuildInfo
 420             -> Maybe PathTemplate -- ^ template for HTML location
 421             -> Version
 422             -> Library
 423             -> IO HaddockArgs
 424 fromLibrary verbosity tmp lbi clbi htmlTemplate haddockVersion lib = do
 425     inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi
 426     args    <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion
 427                  inFiles (libBuildInfo lib)
 428     return args {
 429       argHideModules = (mempty, otherModules (libBuildInfo lib))
 430     }
 431
 432 fromExecutable :: Verbosity
 433                -> FilePath
 434                -> LocalBuildInfo
 435                -> ComponentLocalBuildInfo
 436                -> Maybe PathTemplate -- ^ template for HTML location
 437                -> Version
 438                -> Executable
 439                -> IO HaddockArgs
 440 fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do
 441     inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi
 442     args    <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate
 443                  haddockVersion inFiles (buildInfo exe)
 444     return args {
 445       argOutputDir  = Dir  $ unUnqualComponentName $ exeName exe,
 446       argTitle      = Flag $ unUnqualComponentName $ exeName exe
 447     }
 448
 449 fromForeignLib :: Verbosity
 450                -> FilePath
 451                -> LocalBuildInfo
 452                -> ComponentLocalBuildInfo
 453                -> Maybe PathTemplate -- ^ template for HTML location
 454                -> Version
 455                -> ForeignLib
 456                -> IO HaddockArgs
 457 fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do
 458     inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi
 459     args    <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate
 460                  haddockVersion inFiles (foreignLibBuildInfo flib)
 461     return args {
 462       argOutputDir  = Dir  $ unUnqualComponentName $ foreignLibName flib,
 463       argTitle      = Flag $ unUnqualComponentName $ foreignLibName flib
 464     }
 465
 466 compToExe :: Component -> Maybe Executable
 467 compToExe comp =
 468   case comp of
 469     CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } ->
 470       Just Executable {
 471         exeName    = testName test,
 472         modulePath = f,
 473         exeScope   = ExecutablePublic,
 474         buildInfo  = testBuildInfo test
 475       }
 476     CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } ->
 477       Just Executable {
 478         exeName    = benchmarkName bench,
 479         modulePath = f,
 480         exeScope   = ExecutablePublic,
 481         buildInfo  = benchmarkBuildInfo bench
 482       }
 483     CExe exe -> Just exe
 484     _ -> Nothing
 485
 486 getInterfaces :: Verbosity
 487               -> LocalBuildInfo
 488               -> ComponentLocalBuildInfo
 489               -> Maybe PathTemplate -- ^ template for HTML location
 490               -> IO HaddockArgs
 491 getInterfaces verbosity lbi clbi htmlTemplate = do
 492     (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate
 493     traverse_ (warn (verboseUnmarkOutput verbosity)) warnings
 494     return $ mempty {
 495                  argInterfaces = packageFlags
 496                }
 497
 498 getGhcCppOpts :: Version
 499               -> BuildInfo
 500               -> GhcOptions
 501 getGhcCppOpts haddockVersion bi =
 502     mempty {
 503         ghcOptExtensions   = toNubListR [EnableExtension CPP | needsCpp],
 504         ghcOptCppOptions   = defines
 505     }
 506   where
 507     needsCpp             = EnableExtension CPP `elem` usedExtensions bi
 508     defines              = [haddockVersionMacro]
 509     haddockVersionMacro  = "-D__HADDOCK_VERSION__="
 510                            ++ show (v1 * 1000 + v2 * 10 + v3)
 511       where
 512         [v1, v2, v3] = take 3 $ versionNumbers haddockVersion ++ [0,0]
 513
 514 getGhcLibDir :: Verbosity -> LocalBuildInfo
 515              -> IO HaddockArgs
 516 getGhcLibDir verbosity lbi = do
 517     l <- case compilerFlavor (compiler lbi) of
 518             GHC   -> GHC.getLibDir   verbosity lbi
 519             GHCJS -> GHCJS.getLibDir verbosity lbi
 520             _     -> error "haddock only supports GHC and GHCJS"
 521     return $ mempty { argGhcLibDir = Flag l }
 522
 523 -- ------------------------------------------------------------------------------
 524 -- | Call haddock with the specified arguments.
 525 runHaddock :: Verbosity
 526               -> TempFileOptions
 527               -> Compiler
 528               -> Platform
 529               -> ConfiguredProgram
 530               -> HaddockArgs
 531               -> IO ()
 532 runHaddock verbosity tmpFileOpts comp platform haddockProg args
 533   | null (argTargets args) = warn verbosity $
 534        "Haddocks are being requested, but there aren't any modules given "
 535     ++ "to create documentation for."
 536   | otherwise = do
 537     let haddockVersion = fromMaybe (error "unable to determine haddock version")
 538                         (programVersion haddockProg)
 539     renderArgs verbosity tmpFileOpts haddockVersion comp platform args $
 540       \(flags,result)-> do
 541
 542         runProgram verbosity haddockProg flags
 543
 544         notice verbosity $ "Documentation created: " ++ result
 545
 546
 547 renderArgs :: Verbosity
 548               -> TempFileOptions
 549               -> Version
 550               -> Compiler
 551               -> Platform
 552               -> HaddockArgs
 553               -> (([String], FilePath) -> IO a)
 554               -> IO a
 555 renderArgs verbosity tmpFileOpts version comp platform args k = do
 556   let haddockSupportsUTF8          = version >= mkVersion [2,14,4]
 557       haddockSupportsResponseFiles = version >  mkVersion [2,16,2]
 558   createDirectoryIfMissingVerbose verbosity True outputDir
 559   withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $
 560     \prologueFileName h -> do
 561           do
 562              when haddockSupportsUTF8 (hSetEncoding h utf8)
 563              hPutStrLn h $ fromFlag $ argPrologue args
 564              hClose h
 565              let pflag = "--prologue=" ++ prologueFileName
 566                  renderedArgs = pflag : renderPureArgs version comp platform args
 567              if haddockSupportsResponseFiles
 568                then
 569                  withResponseFile
 570                    verbosity
 571                    tmpFileOpts
 572                    outputDir
 573                    "haddock-response.txt"
 574                    (if haddockSupportsUTF8 then Just utf8 else Nothing)
 575                    renderedArgs
 576                    (\responseFileName -> k (["@" ++ responseFileName], result))
 577                else
 578                  k (renderedArgs, result)
 579     where
 580       outputDir = (unDir $ argOutputDir args)
 581       result = intercalate ", "
 582              . map (\o -> outputDir </>
 583                             case o of
 584                               Html -> "index.html"
 585                               Hoogle -> pkgstr <.> "txt")
 586              $ arg argOutput
 587             where
 588               pkgstr = display $ packageName pkgid
 589               pkgid = arg argPackageName
 590       arg f = fromFlag $ f args
 591
 592 renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String]
 593 renderPureArgs version comp platform args = concat
 594     [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)
 595       . fromFlag . argInterfaceFile $ args
 596
 597     , if isVersion 2 16
 598         then (\pkg -> [ "--package-name=" ++ display (pkgName pkg)
 599                       , "--package-version="++display (pkgVersion pkg)
 600                       ])
 601              . fromFlag . argPackageName $ args
 602         else []
 603
 604     , [ "--since-qual=external" | isVersion 2 20 ]
 605
 606     , [ "--quickjump" | isVersion 2 19
 607                       , fromFlag . argQuickJump $ args ]
 608
 609     , [ "--hyperlinked-source" | isVersion 2 17
 610                                , fromFlag . argLinkedSource $ args ]
 611
 612     , (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b)
 613                      . argHideModules $ args
 614
 615     , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args
 616
 617     , maybe [] (\(m,e,l) ->
 618                  ["--source-module=" ++ m
 619                  ,"--source-entity=" ++ e]
 620                  ++ if isVersion 2 14 then ["--source-entity-line=" ++ l]
 621                     else []
 622                ) . flagToMaybe . argLinkSource $ args
 623
 624     , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args
 625
 626     , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args
 627
 628     , bool [] [verbosityFlag] . getAny . argVerbose $ args
 629
 630     , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html")
 631       . fromFlag . argOutput $ args
 632
 633     , renderInterfaces . argInterfaces $ args
 634
 635     , (:[]) . ("--odir="++) . unDir . argOutputDir $ args
 636
 637     , (:[]) . ("--title="++)
 638       . (bool (++" (internal documentation)")
 639          id (getAny $ argIgnoreExports args))
 640       . fromFlag . argTitle $ args
 641
 642     , [ "--optghc=" ++ opt | let opts = argGhcOptions args
 643                            , opt <- renderGhcOptions comp platform opts ]
 644
 645     , maybe [] (\l -> ["-B"++l]) $
 646       flagToMaybe (argGhcLibDir args) -- error if Nothing?
 647
 648     , argTargets $ args
 649     ]
 650     where
 651       renderInterfaces = map renderInterface
 652
 653       renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath) -> String
 654       renderInterface (i, html, hypsrc) = "--read-interface=" ++
 655         (intercalate "," $ concat [ [ x | Just x <- [html] ]
 656                                   , [ x | Just _ <- [html]
 657                                         -- only render hypsrc path if html path
 658                                         -- is given and hyperlinked-source is
 659                                         -- enabled
 660                                         , Just x <- [hypsrc]
 661                                         , isVersion 2 17
 662                                         , fromFlag . argLinkedSource $ args
 663                                         ]
 664                                   , [ i ]
 665                                   ])
 666
 667       bool a b c = if c then a else b
 668       isVersion major minor  = version >= mkVersion [major,minor]
 669       verbosityFlag
 670        | isVersion 2 5 = "--verbosity=1"
 671        | otherwise     = "--verbose"
 672
 673 ---------------------------------------------------------------------------------
 674
 675 -- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and
 676 -- HTML paths, and an optional warning for packages with missing documentation.
 677 haddockPackagePaths :: [InstalledPackageInfo]
 678                     -> Maybe (InstalledPackageInfo -> FilePath)
 679                     -> NoCallStackIO ([( FilePath        -- path to interface
 680                                                          -- file
 681
 682                                        , Maybe FilePath  -- url to html
 683                                                          -- documentation
 684
 685                                        , Maybe FilePath  -- url to hyperlinked
 686                                                          -- source
 687                                        )]
 688                                      , Maybe String      -- warning about
 689                                                          -- missing documentation
 690                                      )
 691 haddockPackagePaths ipkgs mkHtmlPath = do
 692   interfaces <- sequenceA
 693     [ case interfaceAndHtmlPath ipkg of
 694         Nothing -> return (Left (packageId ipkg))
 695         Just (interface, html) -> do
 696
 697           (html', hypsrc') <-
 698             case html of
 699               Just htmlPath -> do
 700                 let hypSrcPath = htmlPath </> defaultHyperlinkedSourceDirectory
 701                 hypSrcExists <- doesDirectoryExist hypSrcPath
 702                 return $ ( Just (fixFileUrl htmlPath)
 703                          , if hypSrcExists
 704                            then Just (fixFileUrl hypSrcPath)
 705                            else Nothing
 706                          )
 707               Nothing -> return (Nothing, Nothing)
 708
 709           exists <- doesFileExist interface
 710           if exists
 711             then return (Right (interface, html', hypsrc'))
 712             else return (Left pkgid)
 713     | ipkg <- ipkgs, let pkgid = packageId ipkg
 714     , pkgName pkgid `notElem` noHaddockWhitelist
 715     ]
 716
 717   let missing = [ pkgid | Left pkgid <- interfaces ]
 718       warning = "The documentation for the following packages are not "
 719              ++ "installed. No links will be generated to these packages: "
 720              ++ intercalate ", " (map display missing)
 721       flags = rights interfaces
 722
 723   return (flags, if null missing then Nothing else Just warning)
 724
 725   where
 726     -- Don't warn about missing documentation for these packages. See #1231.
 727     noHaddockWhitelist = map mkPackageName [ "rts" ]
 728
 729     -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.
 730     interfaceAndHtmlPath :: InstalledPackageInfo
 731                          -> Maybe (FilePath, Maybe FilePath)
 732     interfaceAndHtmlPath pkg = do
 733       interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)
 734       html <- case mkHtmlPath of
 735         Nothing     -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)
 736         Just mkPath -> Just (mkPath pkg)
 737       return (interface, if null html then Nothing else Just html)
 738
 739     -- The 'haddock-html' field in the hc-pkg output is often set as a
 740     -- native path, but we need it as a URL. See #1064. Also don't "fix"
 741     -- the path if it is an interpolated one.
 742     fixFileUrl f | Nothing <- mkHtmlPath
 743                  , isAbsolute f = "file://" ++ f
 744                  | otherwise    = f
 745
 746     -- 'src' is the default hyperlinked source directory ever since. It is
 747     -- not possible to configure that directory in any way in haddock.
 748     defaultHyperlinkedSourceDirectory = "src"
 749
 750
 751 haddockPackageFlags :: Verbosity
 752                     -> LocalBuildInfo
 753                     -> ComponentLocalBuildInfo
 754                     -> Maybe PathTemplate
 755                     -> IO ([( FilePath        -- path to interface
 756                                               -- file
 757
 758                             , Maybe FilePath  -- url to html
 759                                               -- documentation
 760
 761                             , Maybe FilePath  -- url to hyperlinked
 762                                               -- source
 763                             )]
 764                           , Maybe String      -- warning about
 765                                               -- missing documentation
 766                           )
 767 haddockPackageFlags verbosity lbi clbi htmlTemplate = do
 768   let allPkgs = installedPkgs lbi
 769       directDeps = map fst (componentPackageDeps clbi)
 770   transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of
 771     Left x    -> return x
 772     Right inf -> die' verbosity $ "internal error when calculating transitive "
 773                     ++ "package dependencies.\nDebug info: " ++ show inf
 774   haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath
 775     where
 776       mkHtmlPath                  = fmap expandTemplateVars htmlTemplate
 777       expandTemplateVars tmpl pkg =
 778         fromPathTemplate . substPathTemplate (env pkg) $ tmpl
 779       env pkg                     = haddockTemplateEnv lbi (packageId pkg)
 780
 781
 782 haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
 783 haddockTemplateEnv lbi pkg_id =
 784   (PrefixVar, prefix (installDirTemplates lbi))
 785   -- We want the legacy unit ID here, because it gives us nice paths
 786   -- (Haddock people don't care about the dependencies)
 787   : initialPathTemplateEnv
 788       pkg_id
 789       (mkLegacyUnitId pkg_id)
 790       (compilerInfo (compiler lbi))
 791       (hostPlatform lbi)
 792
 793 -- ------------------------------------------------------------------------------
 794 -- hscolour support.
 795
 796 hscolour :: PackageDescription
 797          -> LocalBuildInfo
 798          -> [PPSuffixHandler]
 799          -> HscolourFlags
 800          -> IO ()
 801 hscolour = hscolour' dieNoVerbosity ForDevelopment
 802
 803 hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found.
 804           -> HaddockTarget
 805           -> PackageDescription
 806           -> LocalBuildInfo
 807           -> [PPSuffixHandler]
 808           -> HscolourFlags
 809           -> IO ()
 810 hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags =
 811     either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<<
 812       lookupProgramVersion verbosity hscolourProgram
 813       (orLaterVersion (mkVersion [1,8])) (withPrograms lbi)
 814   where
 815     go :: ConfiguredProgram -> IO ()
 816     go hscolourProg = do
 817       warn verbosity $
 818         "the 'cabal hscolour' command is deprecated in favour of 'cabal " ++
 819         "haddock --hyperlink-source' and will be removed in the next major " ++
 820         "release."
 821
 822       setupMessage verbosity "Running hscolour for" (packageId pkg_descr)
 823       createDirectoryIfMissingVerbose verbosity True $
 824         hscolourPref haddockTarget distPref pkg_descr
 825
 826       withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do
 827         componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity
 828         preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
 829         let
 830           doExe com = case (compToExe com) of
 831             Just exe -> do
 832               let outputDir = hscolourPref haddockTarget distPref pkg_descr
 833                               </> unUnqualComponentName (exeName exe) </> "src"
 834               runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi
 835             Nothing -> do
 836               warn (fromFlag $ hscolourVerbosity flags)
 837                 "Unsupported component, skipping..."
 838               return ()
 839         case comp of
 840           CLib lib -> do
 841             let outputDir = hscolourPref haddockTarget distPref pkg_descr </> "src"
 842             runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi
 843           CFLib flib -> do
 844             let outputDir = hscolourPref haddockTarget distPref pkg_descr
 845                               </> unUnqualComponentName (foreignLibName flib) </> "src"
 846             runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi
 847           CExe   _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp
 848           CTest  _ -> when (fromFlag (hscolourTestSuites  flags)) $ doExe comp
 849           CBench _ -> when (fromFlag (hscolourBenchmarks  flags)) $ doExe comp
 850
 851     stylesheet = flagToMaybe (hscolourCSS flags)
 852
 853     verbosity  = fromFlag (hscolourVerbosity flags)
 854     distPref   = fromFlag (hscolourDistPref flags)
 855
 856     runHsColour prog outputDir moduleFiles = do
 857          createDirectoryIfMissingVerbose verbosity True outputDir
 858
 859          case stylesheet of -- copy the CSS file
 860            Nothing | programVersion prog >= Just (mkVersion [1,9]) ->
 861                        runProgram verbosity prog
 862                           ["-print-css", "-o" ++ outputDir </> "hscolour.css"]
 863                    | otherwise -> return ()
 864            Just s -> copyFileVerbose verbosity s (outputDir </> "hscolour.css")
 865
 866          for_ moduleFiles $ \(m, inFile) ->
 867              runProgram verbosity prog
 868                     ["-css", "-anchor", "-o" ++ outFile m, inFile]
 869         where
 870           outFile m = outputDir </>
 871                       intercalate "-" (ModuleName.components m) <.> "html"
 872
 873 haddockToHscolour :: HaddockFlags -> HscolourFlags
 874 haddockToHscolour flags =
 875     HscolourFlags {
 876       hscolourCSS         = haddockHscolourCss flags,
 877       hscolourExecutables = haddockExecutables flags,
 878       hscolourTestSuites  = haddockTestSuites  flags,
 879       hscolourBenchmarks  = haddockBenchmarks  flags,
 880       hscolourForeignLibs = haddockForeignLibs flags,
 881       hscolourVerbosity   = haddockVerbosity   flags,
 882       hscolourDistPref    = haddockDistPref    flags,
 883       hscolourCabalFilePath = haddockCabalFilePath flags
 884     }
 885
 886 -- ------------------------------------------------------------------------------
 887 -- Boilerplate Monoid instance.
 888 instance Monoid HaddockArgs where
 889     mempty = gmempty
 890     mappend = (<>)
 891
 892 instance Semigroup HaddockArgs where
 893     (<>) = gmappend
 894
 895 instance Monoid Directory where
 896     mempty = Dir "."
 897     mappend = (<>)
 898
 899 instance Semigroup Directory where
 900     Dir m <> Dir n = Dir $ m </> n