{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Haddock
-- Copyright   :  Isaac Jones 2003-2005
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module deals with the @haddock@ and @hscolour@ commands.
-- 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.

module Distribution.Simple.Haddock (
  haddock, createHaddockIndex, hscolour,

  haddockPackagePaths,
  Visibility(..)
  ) where

import Prelude ()
import Distribution.Compat.Prelude

import qualified Distribution.Simple.GHC   as GHC
import qualified Distribution.Simple.GHCJS as GHCJS

-- local
import Distribution.Backpack.DescribeUnitId
import Distribution.Backpack (OpenModule)
import Distribution.Types.ForeignLib
import Distribution.Types.UnqualComponentName
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.ExecutableScope
import Distribution.Types.LocalBuildInfo
import Distribution.Types.TargetInfo
import Distribution.Types.ExposedModule
import Distribution.Package
import qualified Distribution.ModuleName as ModuleName
import Distribution.PackageDescription
import Distribution.Simple.Compiler
import Distribution.Simple.Glob
import Distribution.Simple.Program.GHC
import Distribution.Simple.Program.ResponseFile
import Distribution.Simple.Program
import Distribution.Simple.PreProcess
import Distribution.Simple.Setup
import Distribution.Simple.Build
import Distribution.Simple.BuildTarget
import Distribution.Simple.InstallDirs
import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate)
import Distribution.Simple.BuildPaths
import Distribution.Simple.Register
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import qualified Distribution.Simple.PackageIndex as PackageIndex
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import Distribution.InstalledPackageInfo ( InstalledPackageInfo )
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Pretty
import Distribution.Parsec (simpleParsec)
import Distribution.Utils.NubList
import Distribution.Version
import qualified Distribution.Utils.ShortText as ShortText

import Distribution.Verbosity
import Language.Haskell.Extension

import Distribution.Compat.Semigroup (All (..), Any (..))

import Control.Monad
import Data.Either      ( rights )

import System.Directory (getCurrentDirectory, doesDirectoryExist, doesFileExist)
import System.FilePath  ( (</>), (<.>), normalise, isAbsolute )
import System.IO        (hClose, hPutStrLn, hSetEncoding, utf8)

-- ------------------------------------------------------------------------------
-- Types

-- | A record that represents the arguments to the haddock executable, a product
-- monoid.
data HaddockArgs = HaddockArgs {
 HaddockArgs -> Flag FilePath
argInterfaceFile :: Flag FilePath,
 -- ^ Path to the interface file, relative to argOutputDir, required.
 HaddockArgs -> Flag PackageIdentifier
argPackageName :: Flag PackageIdentifier,
 -- ^ Package name, required.
 HaddockArgs -> (All, [ModuleName])
argHideModules :: (All,[ModuleName.ModuleName]),
 -- ^ (Hide modules ?, modules to hide)
 HaddockArgs -> Any
argIgnoreExports :: Any,
 -- ^ Ignore export lists in modules?
 HaddockArgs -> Flag (FilePath, FilePath, FilePath)
argLinkSource :: Flag (Template,Template,Template),
 -- ^ (Template for modules, template for symbols, template for lines).
 HaddockArgs -> Flag Bool
argLinkedSource :: Flag Bool,
 -- ^ Generate hyperlinked sources
 HaddockArgs -> Flag Bool
argQuickJump :: Flag Bool,
 -- ^ Generate quickjump index
 HaddockArgs -> Flag FilePath
argCssFile :: Flag FilePath,
 -- ^ Optional custom CSS file.
 HaddockArgs -> Flag FilePath
argContents :: Flag String,
 -- ^ Optional URL to contents page.
 HaddockArgs -> Flag Bool
argGenContents :: Flag Bool,
 -- ^ Generate contents
 HaddockArgs -> Flag FilePath
argIndex :: Flag String,
 -- ^ Optional URL to index page.
 HaddockArgs -> Flag Bool
argGenIndex :: Flag Bool,
 -- ^ Generate index
 HaddockArgs -> Flag FilePath
argBaseUrl :: Flag String,
 -- ^ Optional base url from which static files will be loaded.
 HaddockArgs -> Any
argVerbose :: Any,
 HaddockArgs -> Flag [Output]
argOutput :: Flag [Output],
 -- ^ HTML or Hoogle doc or both? Required.
 HaddockArgs
-> [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
argInterfaces :: [(FilePath, Maybe String, Maybe String, Visibility)],
 -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)].
 HaddockArgs -> Directory
argOutputDir :: Directory,
 -- ^ Where to generate the documentation.
 HaddockArgs -> Flag FilePath
argTitle :: Flag String,
 -- ^ Page title, required.
 HaddockArgs -> Flag FilePath
argPrologue :: Flag String,
 -- ^ Prologue text, required for 'haddock', ignored by 'haddocks'.
 HaddockArgs -> Flag FilePath
argPrologueFile :: Flag FilePath,
 -- ^ Prologue file name, ignored by 'haddock', optional for 'haddocks'.
 HaddockArgs -> GhcOptions
argGhcOptions :: GhcOptions,
 -- ^ Additional flags to pass to GHC.
 HaddockArgs -> Flag FilePath
argGhcLibDir :: Flag FilePath,
 -- ^ To find the correct GHC, required.
 HaddockArgs -> [OpenModule]
argReexports :: [OpenModule],
 -- ^ Re-exported modules
 HaddockArgs -> [FilePath]
argTargets :: [FilePath],
 -- ^ Modules to process.
 HaddockArgs -> Flag FilePath
argLib :: Flag String
 -- ^ haddock's static \/ auxiliary files.
} deriving (forall x. HaddockArgs -> Rep HaddockArgs x)
-> (forall x. Rep HaddockArgs x -> HaddockArgs)
-> Generic HaddockArgs
forall x. Rep HaddockArgs x -> HaddockArgs
forall x. HaddockArgs -> Rep HaddockArgs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HaddockArgs -> Rep HaddockArgs x
from :: forall x. HaddockArgs -> Rep HaddockArgs x
$cto :: forall x. Rep HaddockArgs x -> HaddockArgs
to :: forall x. Rep HaddockArgs x -> HaddockArgs
Generic

-- | The FilePath of a directory, it's a monoid under '(</>)'.
newtype Directory = Dir { Directory -> FilePath
unDir' :: FilePath } deriving (ReadPrec [Directory]
ReadPrec Directory
Int -> ReadS Directory
ReadS [Directory]
(Int -> ReadS Directory)
-> ReadS [Directory]
-> ReadPrec Directory
-> ReadPrec [Directory]
-> Read Directory
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Directory
readsPrec :: Int -> ReadS Directory
$creadList :: ReadS [Directory]
readList :: ReadS [Directory]
$creadPrec :: ReadPrec Directory
readPrec :: ReadPrec Directory
$creadListPrec :: ReadPrec [Directory]
readListPrec :: ReadPrec [Directory]
Read,Int -> Directory -> ShowS
[Directory] -> ShowS
Directory -> FilePath
(Int -> Directory -> ShowS)
-> (Directory -> FilePath)
-> ([Directory] -> ShowS)
-> Show Directory
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Directory -> ShowS
showsPrec :: Int -> Directory -> ShowS
$cshow :: Directory -> FilePath
show :: Directory -> FilePath
$cshowList :: [Directory] -> ShowS
showList :: [Directory] -> ShowS
Show,Directory -> Directory -> Bool
(Directory -> Directory -> Bool)
-> (Directory -> Directory -> Bool) -> Eq Directory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Directory -> Directory -> Bool
== :: Directory -> Directory -> Bool
$c/= :: Directory -> Directory -> Bool
/= :: Directory -> Directory -> Bool
Eq,Eq Directory
Eq Directory =>
(Directory -> Directory -> Ordering)
-> (Directory -> Directory -> Bool)
-> (Directory -> Directory -> Bool)
-> (Directory -> Directory -> Bool)
-> (Directory -> Directory -> Bool)
-> (Directory -> Directory -> Directory)
-> (Directory -> Directory -> Directory)
-> Ord Directory
Directory -> Directory -> Bool
Directory -> Directory -> Ordering
Directory -> Directory -> Directory
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Directory -> Directory -> Ordering
compare :: Directory -> Directory -> Ordering
$c< :: Directory -> Directory -> Bool
< :: Directory -> Directory -> Bool
$c<= :: Directory -> Directory -> Bool
<= :: Directory -> Directory -> Bool
$c> :: Directory -> Directory -> Bool
> :: Directory -> Directory -> Bool
$c>= :: Directory -> Directory -> Bool
>= :: Directory -> Directory -> Bool
$cmax :: Directory -> Directory -> Directory
max :: Directory -> Directory -> Directory
$cmin :: Directory -> Directory -> Directory
min :: Directory -> Directory -> Directory
Ord)

unDir :: Directory -> FilePath
unDir :: Directory -> FilePath
unDir = ShowS
normalise ShowS -> (Directory -> FilePath) -> Directory -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directory -> FilePath
unDir'

type Template = String

data Output = Html | Hoogle
  deriving Output -> Output -> Bool
(Output -> Output -> Bool)
-> (Output -> Output -> Bool) -> Eq Output
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Output -> Output -> Bool
== :: Output -> Output -> Bool
$c/= :: Output -> Output -> Bool
/= :: Output -> Output -> Bool
Eq

-- ------------------------------------------------------------------------------
-- Haddock support

-- | Get Haddock program and check if it matches the request
getHaddockProg :: Verbosity
               -> ProgramDb
               -> Compiler
               -> HaddockArgs
               -> Flag Bool -- ^ quickjump feature
               -> IO (ConfiguredProgram, Version)
getHaddockProg :: Verbosity
-> ProgramDb
-> Compiler
-> HaddockArgs
-> Flag Bool
-> IO (ConfiguredProgram, Version)
getHaddockProg Verbosity
verbosity ProgramDb
programDb Compiler
comp HaddockArgs
args Flag Bool
quickJumpFlag = do
    let HaddockArgs { Flag Bool
argQuickJump :: HaddockArgs -> Flag Bool
argQuickJump :: Flag Bool
argQuickJump
                    , Flag [Output]
argOutput :: HaddockArgs -> Flag [Output]
argOutput :: Flag [Output]
argOutput
                    } = HaddockArgs
args
        hoogle :: Bool
hoogle = Output
Hoogle Output -> [Output] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Output] -> Flag [Output] -> [Output]
forall a. a -> Flag a -> a
fromFlagOrDefault [] Flag [Output]
argOutput

    (ConfiguredProgram
haddockProg, Version
version, ProgramDb
_) <-
      Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion Verbosity
verbosity Program
haddockProgram
        (Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
2,Int
0])) ProgramDb
programDb

    -- various sanity checks
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hoogle Bool -> Bool -> Bool
&& Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2,Int
2]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
"Haddock 2.0 and 2.1 do not support the --hoogle flag."

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag Flag Bool
argQuickJump Bool -> Bool -> Bool
&& Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2,Int
19]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let msg :: FilePath
msg = FilePath
"Haddock prior to 2.19 does not support the --quickjump flag."
          alt :: FilePath
alt = FilePath
"The generated documentation won't have the QuickJump feature."
      if Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True Flag Bool -> Flag Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Flag Bool
quickJumpFlag
        then Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
msg
        else Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath
msg FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\n" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
alt)

    FilePath
haddockGhcVersionStr <- Verbosity -> ConfiguredProgram -> [FilePath] -> IO FilePath
getProgramOutput Verbosity
verbosity ConfiguredProgram
haddockProg
                              [FilePath
"--ghc-version"]
    case (FilePath -> Maybe Version
forall a. Parsec a => FilePath -> Maybe a
simpleParsec FilePath
haddockGhcVersionStr, CompilerFlavor -> Compiler -> Maybe Version
compilerCompatVersion CompilerFlavor
GHC Compiler
comp) of
      (Maybe Version
Nothing, Maybe Version
_) -> Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
"Could not get GHC version from Haddock"
      (Maybe Version
_, Maybe Version
Nothing) -> Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
"Could not get GHC version from compiler"
      (Just Version
haddockGhcVersion, Just Version
ghcVersion)
        | Version
haddockGhcVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
ghcVersion -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise -> Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
               FilePath
"Haddock's internal GHC version must match the configured "
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"GHC version.\n"
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"The GHC version is " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Version
ghcVersion FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" but "
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"haddock is using GHC version " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Version
haddockGhcVersion

    (ConfiguredProgram, Version) -> IO (ConfiguredProgram, Version)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConfiguredProgram
haddockProg, Version
version)


haddock :: PackageDescription
        -> LocalBuildInfo
        -> [PPSuffixHandler]
        -> HaddockFlags
        -> IO ()
haddock :: PackageDescription
-> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO ()
haddock PackageDescription
pkg_descr LocalBuildInfo
_ [PPSuffixHandler]
_ HaddockFlags
haddockFlags
  |    Bool -> Bool
not (PackageDescription -> Bool
hasLibs PackageDescription
pkg_descr)
    Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockExecutables HaddockFlags
haddockFlags)
    Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockTestSuites  HaddockFlags
haddockFlags)
    Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockBenchmarks  HaddockFlags
haddockFlags)
    Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockForeignLibs HaddockFlags
haddockFlags)
    =
      Verbosity -> FilePath -> IO ()
warn (Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Verbosity
haddockVerbosity HaddockFlags
haddockFlags) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
           FilePath
"No documentation was generated as this package does not contain "
        FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"a library. Perhaps you want to use the --executables, --tests,"
        FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" --benchmarks or --foreign-libraries flags."

haddock PackageDescription
pkg_descr LocalBuildInfo
lbi [PPSuffixHandler]
suffixes HaddockFlags
flags' = do
    let verbosity :: Verbosity
verbosity     = (HaddockFlags -> Flag Verbosity) -> Verbosity
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Verbosity
haddockVerbosity
        comp :: Compiler
comp          = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
        platform :: Platform
platform      = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi

        quickJmpFlag :: Flag Bool
quickJmpFlag  = HaddockFlags -> Flag Bool
haddockQuickJump HaddockFlags
flags'
        flags :: HaddockFlags
flags = case HaddockTarget
haddockTarget of
          HaddockTarget
ForDevelopment -> HaddockFlags
flags'
          HaddockTarget
ForHackage -> HaddockFlags
flags'
            { haddockHoogle       = Flag True
            , haddockHtml         = Flag True
            , haddockHtmlLocation = Flag (pkg_url ++ "/docs")
            , haddockContents     = Flag (toPathTemplate pkg_url)
            , haddockLinkedSource = Flag True
            , haddockQuickJump    = Flag True
            }
        pkg_url :: FilePath
pkg_url       = FilePath
"/package/$pkg-$version"
        flag :: (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag a
f        = Flag a -> a
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag a -> a) -> Flag a -> a
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag a
f HaddockFlags
flags

        tmpFileOpts :: TempFileOptions
tmpFileOpts   = TempFileOptions
defaultTempFileOptions
                       { optKeepTempFiles = flag haddockKeepTempFiles }
        htmlTemplate :: Maybe PathTemplate
htmlTemplate  = (FilePath -> PathTemplate) -> Maybe FilePath -> Maybe PathTemplate
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> PathTemplate
toPathTemplate (Maybe FilePath -> Maybe PathTemplate)
-> (HaddockFlags -> Maybe FilePath)
-> HaddockFlags
-> Maybe PathTemplate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (HaddockFlags -> Flag FilePath)
-> HaddockFlags
-> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockFlags -> Flag FilePath
haddockHtmlLocation
                        (HaddockFlags -> Maybe PathTemplate)
-> HaddockFlags -> Maybe PathTemplate
forall a b. (a -> b) -> a -> b
$ HaddockFlags
flags
        haddockTarget :: HaddockTarget
haddockTarget =
          HaddockTarget -> Flag HaddockTarget -> HaddockTarget
forall a. a -> Flag a -> a
fromFlagOrDefault HaddockTarget
ForDevelopment (HaddockFlags -> Flag HaddockTarget
haddockForHackage HaddockFlags
flags')

    HaddockArgs
libdirArgs <- Verbosity -> LocalBuildInfo -> IO HaddockArgs
getGhcLibDir  Verbosity
verbosity LocalBuildInfo
lbi
    let commonArgs :: HaddockArgs
commonArgs = [HaddockArgs] -> HaddockArgs
forall a. Monoid a => [a] -> a
mconcat
            [ HaddockArgs
libdirArgs
            , PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags (LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
haddockTemplateEnv LocalBuildInfo
lbi (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)) HaddockFlags
flags
            , HaddockTarget -> PackageDescription -> HaddockArgs
fromPackageDescription HaddockTarget
haddockTarget PackageDescription
pkg_descr ]

    (ConfiguredProgram
haddockProg, Version
version) <-
      Verbosity
-> ProgramDb
-> Compiler
-> HaddockArgs
-> Flag Bool
-> IO (ConfiguredProgram, Version)
getHaddockProg Verbosity
verbosity (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi) Compiler
comp HaddockArgs
commonArgs Flag Bool
quickJmpFlag

    -- We fall back to using HsColour only for versions of Haddock which don't
    -- support '--hyperlinked-sources'.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Flag Bool) -> Bool
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockLinkedSource Bool -> Bool -> Bool
&& Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2,Int
17]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      (FilePath -> IO ())
-> HaddockTarget
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour' (Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity) HaddockTarget
haddockTarget PackageDescription
pkg_descr LocalBuildInfo
lbi [PPSuffixHandler]
suffixes
      (HscolourFlags
defaultHscolourFlags HscolourFlags -> HscolourFlags -> HscolourFlags
forall a. Monoid a => a -> a -> a
`mappend` HaddockFlags -> HscolourFlags
haddockToHscolour HaddockFlags
flags)

    [TargetInfo]
targets <- Verbosity
-> PackageDescription
-> LocalBuildInfo
-> [FilePath]
-> IO [TargetInfo]
readTargetInfos Verbosity
verbosity PackageDescription
pkg_descr LocalBuildInfo
lbi (HaddockFlags -> [FilePath]
haddockArgs HaddockFlags
flags)

    let
      targets' :: [TargetInfo]
targets' =
        case [TargetInfo]
targets of
          [] -> PackageDescription -> LocalBuildInfo -> [TargetInfo]
allTargetsInBuildOrder' PackageDescription
pkg_descr LocalBuildInfo
lbi
          [TargetInfo]
_  -> [TargetInfo]
targets

    PackageDB
internalPackageDB <-
      Verbosity -> LocalBuildInfo -> FilePath -> IO PackageDB
createInternalPackageDB Verbosity
verbosity LocalBuildInfo
lbi ((HaddockFlags -> Flag FilePath) -> FilePath
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag FilePath
haddockDistPref)

    (\InstalledPackageIndex -> TargetInfo -> IO InstalledPackageIndex
f -> (InstalledPackageIndex -> TargetInfo -> IO InstalledPackageIndex)
-> InstalledPackageIndex -> [TargetInfo] -> IO ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ InstalledPackageIndex -> TargetInfo -> IO InstalledPackageIndex
f (LocalBuildInfo -> InstalledPackageIndex
installedPkgs LocalBuildInfo
lbi) [TargetInfo]
targets') ((InstalledPackageIndex -> TargetInfo -> IO InstalledPackageIndex)
 -> IO ())
-> (InstalledPackageIndex
    -> TargetInfo -> IO InstalledPackageIndex)
-> IO ()
forall a b. (a -> b) -> a -> b
$ \InstalledPackageIndex
index TargetInfo
target -> do

      let component :: Component
component = TargetInfo -> Component
targetComponent TargetInfo
target
          clbi :: ComponentLocalBuildInfo
clbi      = TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
target

      FilePath
-> PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Verbosity
-> IO ()
componentInitialBuildSteps ((HaddockFlags -> Flag FilePath) -> FilePath
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag FilePath
haddockDistPref) PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Verbosity
verbosity

      let
        lbi' :: LocalBuildInfo
lbi' = LocalBuildInfo
lbi {
          withPackageDB = withPackageDB lbi ++ [internalPackageDB],
          installedPkgs = index
          }

      PackageDescription
-> Component
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Bool
-> Verbosity
-> [PPSuffixHandler]
-> IO ()
preprocessComponent PackageDescription
pkg_descr Component
component LocalBuildInfo
lbi' ComponentLocalBuildInfo
clbi Bool
False Verbosity
verbosity [PPSuffixHandler]
suffixes
      let
        doExe :: Component -> IO ()
doExe Component
com = case (Component -> Maybe Executable
compToExe Component
com) of
          Just Executable
exe -> do
            Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO a)
-> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
tmpFileOpts (LocalBuildInfo -> FilePath
buildDir LocalBuildInfo
lbi') FilePath
"tmp" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
              \FilePath
tmp -> do
                HaddockArgs
exeArgs <- Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> Executable
-> IO HaddockArgs
fromExecutable Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi' ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate
                             Version
version Executable
exe
                let exeArgs' :: HaddockArgs
exeArgs' = HaddockArgs
commonArgs HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Monoid a => a -> a -> a
`mappend` HaddockArgs
exeArgs
                Verbosity
-> TempFileOptions
-> Compiler
-> Platform
-> ConfiguredProgram
-> Bool
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
tmpFileOpts Compiler
comp Platform
platform
                  ConfiguredProgram
haddockProg Bool
True HaddockArgs
exeArgs'
          Maybe Executable
Nothing -> do
           Verbosity -> FilePath -> IO ()
warn (Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Verbosity
haddockVerbosity HaddockFlags
flags)
             FilePath
"Unsupported component, skipping..."
           () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- We define 'smsg' once and then reuse it inside the case, so that
        -- we don't say we are running Haddock when we actually aren't
        -- (e.g., Haddock is not run on non-libraries)
        smsg :: IO ()
        smsg :: IO ()
smsg = Verbosity
-> FilePath
-> PackageIdentifier
-> ComponentName
-> Maybe [(ModuleName, OpenModule)]
-> IO ()
forall a.
Pretty a =>
Verbosity
-> FilePath
-> PackageIdentifier
-> ComponentName
-> Maybe [(ModuleName, a)]
-> IO ()
setupMessage' Verbosity
verbosity FilePath
"Running Haddock on" (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)
                (ComponentLocalBuildInfo -> ComponentName
componentLocalName ComponentLocalBuildInfo
clbi) (ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)]
maybeComponentInstantiatedWith ComponentLocalBuildInfo
clbi)
      case Component
component of
        CLib Library
lib -> do
          Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO InstalledPackageIndex)
-> IO InstalledPackageIndex
forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO a)
-> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
tmpFileOpts (LocalBuildInfo -> FilePath
buildDir LocalBuildInfo
lbi) FilePath
"tmp" ((FilePath -> IO InstalledPackageIndex)
 -> IO InstalledPackageIndex)
-> (FilePath -> IO InstalledPackageIndex)
-> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$
            \FilePath
tmp -> do
              IO ()
smsg
              HaddockArgs
libArgs <- Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> Library
-> IO HaddockArgs
fromLibrary Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi' ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate
                           Version
version Library
lib
              let libArgs' :: HaddockArgs
libArgs' = HaddockArgs
commonArgs HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Monoid a => a -> a -> a
`mappend` HaddockArgs
libArgs
              Verbosity
-> TempFileOptions
-> Compiler
-> Platform
-> ConfiguredProgram
-> Bool
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
tmpFileOpts Compiler
comp Platform
platform ConfiguredProgram
haddockProg Bool
True HaddockArgs
libArgs'

              FilePath
pwd <- IO FilePath
getCurrentDirectory

              let
                ipi :: InstalledPackageInfo
ipi = FilePath
-> FilePath
-> PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstalledPackageInfo
inplaceInstalledPackageInfo
                        FilePath
pwd ((HaddockFlags -> Flag FilePath) -> FilePath
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag FilePath
haddockDistPref) PackageDescription
pkg_descr
                        (FilePath -> AbiHash
mkAbiHash FilePath
"inplace") Library
lib LocalBuildInfo
lbi' ComponentLocalBuildInfo
clbi

              Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Registering inplace:\n"
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ (InstalledPackageInfo -> FilePath
InstalledPackageInfo.showInstalledPackageInfo InstalledPackageInfo
ipi)

              Verbosity
-> Compiler
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage Verbosity
verbosity (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi') (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi')
                (LocalBuildInfo -> PackageDBStack
withPackageDB LocalBuildInfo
lbi') InstalledPackageInfo
ipi
                RegisterOptions
HcPkg.defaultRegisterOptions {
                  HcPkg.registerMultiInstance = True
                }

              InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageIndex -> IO InstalledPackageIndex)
-> InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo
-> InstalledPackageIndex -> InstalledPackageIndex
PackageIndex.insert InstalledPackageInfo
ipi InstalledPackageIndex
index

        CFLib ForeignLib
flib -> (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Flag Bool) -> Bool
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockForeignLibs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO a)
-> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
tmpFileOpts (LocalBuildInfo -> FilePath
buildDir LocalBuildInfo
lbi') FilePath
"tmp" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
            \FilePath
tmp -> do
              IO ()
smsg
              HaddockArgs
flibArgs <- Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> ForeignLib
-> IO HaddockArgs
fromForeignLib Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi' ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate
                            Version
version ForeignLib
flib
              let libArgs' :: HaddockArgs
libArgs' = HaddockArgs
commonArgs HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Monoid a => a -> a -> a
`mappend` HaddockArgs
flibArgs
              Verbosity
-> TempFileOptions
-> Compiler
-> Platform
-> ConfiguredProgram
-> Bool
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
tmpFileOpts Compiler
comp Platform
platform ConfiguredProgram
haddockProg Bool
True HaddockArgs
libArgs')

          IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
index

        CExe   Executable
_ -> (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Flag Bool) -> Bool
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockExecutables) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
smsg IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Component -> IO ()
doExe Component
component) IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
index
        CTest  TestSuite
_ -> (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Flag Bool) -> Bool
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockTestSuites)  (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
smsg IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Component -> IO ()
doExe Component
component) IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
index
        CBench Benchmark
_ -> (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Flag Bool) -> Bool
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockBenchmarks)  (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
smsg IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Component -> IO ()
doExe Component
component) IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
index

    [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (PackageDescription -> [FilePath]
extraDocFiles PackageDescription
pkg_descr) ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ FilePath
fpath -> do
      [FilePath]
files <- Verbosity
-> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath]
matchDirFileGlob Verbosity
verbosity (PackageDescription -> CabalSpecVersion
specVersion PackageDescription
pkg_descr) FilePath
"." FilePath
fpath
      [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [FilePath]
files ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> FilePath -> FilePath -> IO ()
copyFileTo Verbosity
verbosity (Directory -> FilePath
unDir (Directory -> FilePath) -> Directory -> FilePath
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Directory
argOutputDir HaddockArgs
commonArgs)


-- | Execute 'Haddock' configured with 'HaddocksFlags'.  It is used to build
-- index and contents for documentation of multiple packages.
--
createHaddockIndex :: Verbosity
                   -> ProgramDb
                   -> Compiler
                   -> Platform
                   -> HaddockProjectFlags
                   -> IO ()
createHaddockIndex :: Verbosity
-> ProgramDb
-> Compiler
-> Platform
-> HaddockProjectFlags
-> IO ()
createHaddockIndex Verbosity
verbosity ProgramDb
programDb Compiler
comp Platform
platform HaddockProjectFlags
flags = do
    let args :: HaddockArgs
args = HaddockProjectFlags -> HaddockArgs
fromHaddockProjectFlags HaddockProjectFlags
flags
    (ConfiguredProgram
haddockProg, Version
_version) <-
      Verbosity
-> ProgramDb
-> Compiler
-> HaddockArgs
-> Flag Bool
-> IO (ConfiguredProgram, Version)
getHaddockProg Verbosity
verbosity ProgramDb
programDb Compiler
comp HaddockArgs
args (HaddockProjectFlags -> Flag Bool
haddockProjectQuickJump HaddockProjectFlags
flags)
    Verbosity
-> TempFileOptions
-> Compiler
-> Platform
-> ConfiguredProgram
-> Bool
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
defaultTempFileOptions Compiler
comp Platform
platform ConfiguredProgram
haddockProg Bool
False HaddockArgs
args

-- ------------------------------------------------------------------------------
-- Contributions to HaddockArgs (see also Doctest.hs for very similar code).

fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags PathTemplateEnv
env HaddockFlags
flags =
    HaddockArgs
forall a. Monoid a => a
mempty {
      argHideModules = (maybe mempty (All . not)
                        $ flagToMaybe (haddockInternal flags), mempty),
      argLinkSource = if fromFlag (haddockLinkedSource flags)
                               then Flag ("src/%{MODULE/./-}.html"
                                         ,"src/%{MODULE/./-}.html#%{NAME}"
                                         ,"src/%{MODULE/./-}.html#line-%{LINE}")
                               else NoFlag,
      argLinkedSource = haddockLinkedSource flags,
      argQuickJump = haddockQuickJump flags,
      argCssFile = haddockCss flags,
      argContents = fmap (fromPathTemplate . substPathTemplate env)
                    (haddockContents flags),
      argGenContents = Flag False,
      argIndex = fmap (fromPathTemplate . substPathTemplate env)
                    (haddockIndex flags),
      argGenIndex = Flag False,
      argBaseUrl = haddockBaseUrl flags,
      argLib = haddockLib flags,
      argVerbose = maybe mempty (Any . (>= deafening))
                   . flagToMaybe $ haddockVerbosity flags,
      argOutput =
          Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++
                      [ Hoogle | Flag True <- [haddockHoogle flags] ]
                 of [] -> [ Output
Html ]
                    [Output]
os -> [Output]
os,
      argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags,

      argGhcOptions = mempty { ghcOptExtra = ghcArgs }
    }
    where
      ghcArgs :: [FilePath]
ghcArgs = [FilePath] -> Maybe [FilePath] -> [FilePath]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [FilePath] -> [FilePath])
-> (HaddockFlags -> Maybe [FilePath]) -> HaddockFlags -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [(FilePath, [FilePath])] -> Maybe [FilePath]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"ghc" ([(FilePath, [FilePath])] -> Maybe [FilePath])
-> (HaddockFlags -> [(FilePath, [FilePath])])
-> HaddockFlags
-> Maybe [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockFlags -> [(FilePath, [FilePath])]
haddockProgramArgs (HaddockFlags -> [FilePath]) -> HaddockFlags -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockFlags
flags

fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs
fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs
fromHaddockProjectFlags HaddockProjectFlags
flags =
    HaddockArgs
forall a. Monoid a => a
mempty
      { argOutputDir = Dir (fromFlag $ haddockProjectDir flags)
      , argQuickJump = haddockProjectQuickJump flags
      , argGenContents = haddockProjectGenContents flags
      , argGenIndex = haddockProjectGenIndex flags
      , argPrologueFile = haddockProjectPrologue flags
      , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags)
      , argLinkedSource = haddockProjectLinkedSource flags
      , argLib = haddockProjectLib flags
      }


fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs
fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs
fromPackageDescription HaddockTarget
haddockTarget PackageDescription
pkg_descr = HaddockArgs
forall a. Monoid a => a
mempty
    { argInterfaceFile = Flag $ haddockName pkg_descr
    , argPackageName = Flag $ packageId $ pkg_descr
    , argOutputDir = Dir $
        "doc" </> "html" </> haddockDirName haddockTarget pkg_descr
    , argPrologue = Flag $ ShortText.fromShortText $
        if ShortText.null desc
        then synopsis pkg_descr
        else desc
    , argTitle = Flag $ showPkg ++ subtitle
    }
  where
    desc :: ShortText
desc = PackageDescription -> ShortText
description PackageDescription
pkg_descr
    showPkg :: FilePath
showPkg = PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)
    subtitle :: FilePath
subtitle
        | ShortText -> Bool
ShortText.null (PackageDescription -> ShortText
synopsis PackageDescription
pkg_descr) = FilePath
""
        | Bool
otherwise                           = FilePath
": " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShortText -> FilePath
ShortText.fromShortText (PackageDescription -> ShortText
synopsis PackageDescription
pkg_descr)

componentGhcOptions :: Verbosity -> LocalBuildInfo
                 -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
                 -> GhcOptions
componentGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi FilePath
odir =
  let f :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
f = case Compiler -> CompilerFlavor
compilerFlavor (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) of
            CompilerFlavor
GHC   -> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
GHC.componentGhcOptions
            CompilerFlavor
GHCJS -> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
GHCJS.componentGhcOptions
            CompilerFlavor
_     -> FilePath
-> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
forall a. HasCallStack => FilePath -> a
error (FilePath
 -> Verbosity
 -> LocalBuildInfo
 -> BuildInfo
 -> ComponentLocalBuildInfo
 -> FilePath
 -> GhcOptions)
-> FilePath
-> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
forall a b. (a -> b) -> a -> b
$
                       FilePath
"Distribution.Simple.Haddock.componentGhcOptions:" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
                       FilePath
"haddock only supports GHC and GHCJS"
  in Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
f Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi FilePath
odir

mkHaddockArgs :: Verbosity
              -> FilePath
              -> LocalBuildInfo
              -> ComponentLocalBuildInfo
              -> Maybe PathTemplate -- ^ template for HTML location
              -> Version
              -> [FilePath]
              -> BuildInfo
              -> IO HaddockArgs
mkHaddockArgs :: Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> [FilePath]
-> BuildInfo
-> IO HaddockArgs
mkHaddockArgs Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate Version
haddockVersion [FilePath]
inFiles BuildInfo
bi = do
    HaddockArgs
ifaceArgs <- Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO HaddockArgs
getInterfaces Verbosity
verbosity LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate
    let vanillaOpts :: GhcOptions
vanillaOpts = (Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
componentGhcOptions Verbosity
normal LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi (LocalBuildInfo -> FilePath
buildDir LocalBuildInfo
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
                      } GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` Version -> BuildInfo -> GhcOptions
getGhcCppOpts Version
haddockVersion BuildInfo
bi
        sharedOpts :: GhcOptions
sharedOpts = GhcOptions
vanillaOpts {
                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,
                         ghcOptFPic        = toFlag True,
                         ghcOptHiSuffix    = toFlag "dyn_hi",
                         ghcOptObjSuffix   = toFlag "dyn_o",
                         ghcOptExtra       = hcSharedOptions GHC bi

                     }
    GhcOptions
opts <- if LocalBuildInfo -> Bool
withVanillaLib LocalBuildInfo
lbi
            then GhcOptions -> IO GhcOptions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GhcOptions
vanillaOpts
            else if LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi
            then GhcOptions -> IO GhcOptions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GhcOptions
sharedOpts
            else Verbosity -> FilePath -> IO GhcOptions
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO GhcOptions) -> FilePath -> IO GhcOptions
forall a b. (a -> b) -> a -> b
$ FilePath
"Must have vanilla or shared libraries "
                       FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"enabled in order to run haddock"

    HaddockArgs -> IO HaddockArgs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HaddockArgs
ifaceArgs
      { argGhcOptions  = opts
      , argTargets     = inFiles
      , argReexports   = getReexports clbi
      }

fromLibrary :: Verbosity
            -> FilePath
            -> LocalBuildInfo
            -> ComponentLocalBuildInfo
            -> Maybe PathTemplate -- ^ template for HTML location
            -> Version
            -> Library
            -> IO HaddockArgs
fromLibrary :: Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> Library
-> IO HaddockArgs
fromLibrary Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate Version
haddockVersion Library
lib = do
    [FilePath]
inFiles <- ((ModuleName, FilePath) -> FilePath)
-> [(ModuleName, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, FilePath) -> FilePath
forall a b. (a, b) -> b
snd ([(ModuleName, FilePath)] -> [FilePath])
-> IO [(ModuleName, FilePath)] -> IO [FilePath]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO [(ModuleName, FilePath)]
getLibSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi
    HaddockArgs
args    <- Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> [FilePath]
-> BuildInfo
-> IO HaddockArgs
mkHaddockArgs Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate Version
haddockVersion
                 [FilePath]
inFiles (Library -> BuildInfo
libBuildInfo Library
lib)
    HaddockArgs -> IO HaddockArgs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HaddockArgs
args {
      argHideModules = (mempty, otherModules (libBuildInfo lib))
    }

fromExecutable :: Verbosity
               -> FilePath
               -> LocalBuildInfo
               -> ComponentLocalBuildInfo
               -> Maybe PathTemplate -- ^ template for HTML location
               -> Version
               -> Executable
               -> IO HaddockArgs
fromExecutable :: Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> Executable
-> IO HaddockArgs
fromExecutable Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate Version
haddockVersion Executable
exe = do
    [FilePath]
inFiles <- ((ModuleName, FilePath) -> FilePath)
-> [(ModuleName, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, FilePath) -> FilePath
forall a b. (a, b) -> b
snd ([(ModuleName, FilePath)] -> [FilePath])
-> IO [(ModuleName, FilePath)] -> IO [FilePath]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO [(ModuleName, FilePath)]
getExeSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Executable
exe ComponentLocalBuildInfo
clbi
    HaddockArgs
args    <- Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> [FilePath]
-> BuildInfo
-> IO HaddockArgs
mkHaddockArgs Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate
                 Version
haddockVersion [FilePath]
inFiles (Executable -> BuildInfo
buildInfo Executable
exe)
    HaddockArgs -> IO HaddockArgs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HaddockArgs
args {
      argOutputDir  = Dir  $ unUnqualComponentName $ exeName exe,
      argTitle      = Flag $ unUnqualComponentName $ exeName exe
    }

fromForeignLib :: Verbosity
               -> FilePath
               -> LocalBuildInfo
               -> ComponentLocalBuildInfo
               -> Maybe PathTemplate -- ^ template for HTML location
               -> Version
               -> ForeignLib
               -> IO HaddockArgs
fromForeignLib :: Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> ForeignLib
-> IO HaddockArgs
fromForeignLib Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate Version
haddockVersion ForeignLib
flib = do
    [FilePath]
inFiles <- ((ModuleName, FilePath) -> FilePath)
-> [(ModuleName, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, FilePath) -> FilePath
forall a b. (a, b) -> b
snd ([(ModuleName, FilePath)] -> [FilePath])
-> IO [(ModuleName, FilePath)] -> IO [FilePath]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity
-> LocalBuildInfo
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO [(ModuleName, FilePath)]
getFLibSourceFiles Verbosity
verbosity LocalBuildInfo
lbi ForeignLib
flib ComponentLocalBuildInfo
clbi
    HaddockArgs
args    <- Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> [FilePath]
-> BuildInfo
-> IO HaddockArgs
mkHaddockArgs Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate
                 Version
haddockVersion [FilePath]
inFiles (ForeignLib -> BuildInfo
foreignLibBuildInfo ForeignLib
flib)
    HaddockArgs -> IO HaddockArgs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HaddockArgs
args {
      argOutputDir  = Dir  $ unUnqualComponentName $ foreignLibName flib,
      argTitle      = Flag $ unUnqualComponentName $ foreignLibName flib
    }

compToExe :: Component -> Maybe Executable
compToExe :: Component -> Maybe Executable
compToExe Component
comp =
  case Component
comp of
    CTest test :: TestSuite
test@TestSuite { testInterface :: TestSuite -> TestSuiteInterface
testInterface = TestSuiteExeV10 Version
_ FilePath
f } ->
      Executable -> Maybe Executable
forall a. a -> Maybe a
Just Executable {
        exeName :: UnqualComponentName
exeName    = TestSuite -> UnqualComponentName
testName TestSuite
test,
        modulePath :: FilePath
modulePath = FilePath
f,
        exeScope :: ExecutableScope
exeScope   = ExecutableScope
ExecutablePublic,
        buildInfo :: BuildInfo
buildInfo  = TestSuite -> BuildInfo
testBuildInfo TestSuite
test
      }
    CBench bench :: Benchmark
bench@Benchmark { benchmarkInterface :: Benchmark -> BenchmarkInterface
benchmarkInterface = BenchmarkExeV10 Version
_ FilePath
f } ->
      Executable -> Maybe Executable
forall a. a -> Maybe a
Just Executable {
        exeName :: UnqualComponentName
exeName    = Benchmark -> UnqualComponentName
benchmarkName Benchmark
bench,
        modulePath :: FilePath
modulePath = FilePath
f,
        exeScope :: ExecutableScope
exeScope   = ExecutableScope
ExecutablePublic,
        buildInfo :: BuildInfo
buildInfo  = Benchmark -> BuildInfo
benchmarkBuildInfo Benchmark
bench
      }
    CExe Executable
exe -> Executable -> Maybe Executable
forall a. a -> Maybe a
Just Executable
exe
    Component
_ -> Maybe Executable
forall a. Maybe a
Nothing

getInterfaces :: Verbosity
              -> LocalBuildInfo
              -> ComponentLocalBuildInfo
              -> Maybe PathTemplate -- ^ template for HTML location
              -> IO HaddockArgs
getInterfaces :: Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO HaddockArgs
getInterfaces Verbosity
verbosity LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate = do
    ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
packageFlags, Maybe FilePath
warnings) <- Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)],
      Maybe FilePath)
haddockPackageFlags Verbosity
verbosity LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate
    (FilePath -> IO ()) -> Maybe FilePath -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> FilePath -> IO ()
warn (Verbosity -> Verbosity
verboseUnmarkOutput Verbosity
verbosity)) Maybe FilePath
warnings
    HaddockArgs -> IO HaddockArgs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockArgs -> IO HaddockArgs) -> HaddockArgs -> IO HaddockArgs
forall a b. (a -> b) -> a -> b
$ HaddockArgs
forall a. Monoid a => a
mempty {
                 argInterfaces = packageFlags
               }

getReexports :: ComponentLocalBuildInfo -> [OpenModule]
getReexports :: ComponentLocalBuildInfo -> [OpenModule]
getReexports LibComponentLocalBuildInfo {componentExposedModules :: ComponentLocalBuildInfo -> [ExposedModule]
componentExposedModules = [ExposedModule]
mods } =
    (ExposedModule -> Maybe OpenModule)
-> [ExposedModule] -> [OpenModule]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ExposedModule -> Maybe OpenModule
exposedReexport [ExposedModule]
mods
getReexports ComponentLocalBuildInfo
_ = []

getGhcCppOpts :: Version
              -> BuildInfo
              -> GhcOptions
getGhcCppOpts :: Version -> BuildInfo -> GhcOptions
getGhcCppOpts Version
haddockVersion BuildInfo
bi =
    GhcOptions
forall a. Monoid a => a
mempty {
        ghcOptExtensions   = toNubListR [EnableExtension CPP | needsCpp],
        ghcOptCppOptions   = defines
    }
  where
    needsCpp :: Bool
needsCpp             = KnownExtension -> Extension
EnableExtension KnownExtension
CPP Extension -> [Extension] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` BuildInfo -> [Extension]
usedExtensions BuildInfo
bi
    defines :: [FilePath]
defines              = [FilePath
haddockVersionMacro]
    haddockVersionMacro :: FilePath
haddockVersionMacro  = FilePath
"-D__HADDOCK_VERSION__="
                           FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (Int
v1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
v2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
v3)
      where
        (Int
v1, Int
v2, Int
v3) = case Version -> [Int]
versionNumbers Version
haddockVersion of
            []        -> (Int
0,Int
0,Int
0)
            [Int
x]       -> (Int
x,Int
0,Int
0)
            [Int
x,Int
y]     -> (Int
x,Int
y,Int
0)
            (Int
x:Int
y:Int
z:[Int]
_) -> (Int
x,Int
y,Int
z)

getGhcLibDir :: Verbosity -> LocalBuildInfo
             -> IO HaddockArgs
getGhcLibDir :: Verbosity -> LocalBuildInfo -> IO HaddockArgs
getGhcLibDir Verbosity
verbosity LocalBuildInfo
lbi = do
    FilePath
l <- case Compiler -> CompilerFlavor
compilerFlavor (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) of
            CompilerFlavor
GHC   -> Verbosity -> LocalBuildInfo -> IO FilePath
GHC.getLibDir   Verbosity
verbosity LocalBuildInfo
lbi
            CompilerFlavor
GHCJS -> Verbosity -> LocalBuildInfo -> IO FilePath
GHCJS.getLibDir Verbosity
verbosity LocalBuildInfo
lbi
            CompilerFlavor
_     -> FilePath -> IO FilePath
forall a. HasCallStack => FilePath -> a
error FilePath
"haddock only supports GHC and GHCJS"
    HaddockArgs -> IO HaddockArgs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockArgs -> IO HaddockArgs) -> HaddockArgs -> IO HaddockArgs
forall a b. (a -> b) -> a -> b
$ HaddockArgs
forall a. Monoid a => a
mempty { argGhcLibDir = Flag l }

-- ------------------------------------------------------------------------------
-- | Call haddock with the specified arguments.
runHaddock :: Verbosity
              -> TempFileOptions
              -> Compiler
              -> Platform
              -> ConfiguredProgram
              -> Bool -- ^ require targets
              -> HaddockArgs
              -> IO ()
runHaddock :: Verbosity
-> TempFileOptions
-> Compiler
-> Platform
-> ConfiguredProgram
-> Bool
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
tmpFileOpts Compiler
comp Platform
platform ConfiguredProgram
haddockProg Bool
requireTargets HaddockArgs
args
  | Bool
requireTargets Bool -> Bool -> Bool
&& [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HaddockArgs -> [FilePath]
argTargets HaddockArgs
args) = Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
       FilePath
"Haddocks are being requested, but there aren't any modules given "
    FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"to create documentation for."
  | Bool
otherwise = do
    let haddockVersion :: Version
haddockVersion = Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Version
forall a. HasCallStack => FilePath -> a
error FilePath
"unable to determine haddock version")
                        (ConfiguredProgram -> Maybe Version
programVersion ConfiguredProgram
haddockProg)
    Verbosity
-> TempFileOptions
-> Version
-> Compiler
-> Platform
-> HaddockArgs
-> (([FilePath], FilePath) -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions
-> Version
-> Compiler
-> Platform
-> HaddockArgs
-> (([FilePath], FilePath) -> IO a)
-> IO a
renderArgs Verbosity
verbosity TempFileOptions
tmpFileOpts Version
haddockVersion Compiler
comp Platform
platform HaddockArgs
args ((([FilePath], FilePath) -> IO ()) -> IO ())
-> (([FilePath], FilePath) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
      \([FilePath]
flags,FilePath
result)-> do

        Verbosity -> ConfiguredProgram -> [FilePath] -> IO ()
runProgram Verbosity
verbosity ConfiguredProgram
haddockProg [FilePath]
flags

        Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Documentation created: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
result


renderArgs :: Verbosity
              -> TempFileOptions
              -> Version
              -> Compiler
              -> Platform
              -> HaddockArgs
              -> (([String], FilePath) -> IO a)
              -> IO a
renderArgs :: forall a.
Verbosity
-> TempFileOptions
-> Version
-> Compiler
-> Platform
-> HaddockArgs
-> (([FilePath], FilePath) -> IO a)
-> IO a
renderArgs Verbosity
verbosity TempFileOptions
tmpFileOpts Version
version Compiler
comp Platform
platform HaddockArgs
args ([FilePath], FilePath) -> IO a
k = do
  let haddockSupportsUTF8 :: Bool
haddockSupportsUTF8          = Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
2,Int
14,Int
4]
      haddockSupportsResponseFiles :: Bool
haddockSupportsResponseFiles = Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>  [Int] -> Version
mkVersion [Int
2,Int
16,Int
2]
  Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
outputDir
  case HaddockArgs -> Flag FilePath
argPrologue HaddockArgs
args of
    Flag FilePath
prologueText ->
      TempFileOptions
-> FilePath -> FilePath -> (FilePath -> Handle -> IO a) -> IO a
forall a.
TempFileOptions
-> FilePath -> FilePath -> (FilePath -> Handle -> IO a) -> IO a
withTempFileEx TempFileOptions
tmpFileOpts FilePath
outputDir FilePath
"haddock-prologue.txt" ((FilePath -> Handle -> IO a) -> IO a)
-> (FilePath -> Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
        \FilePath
prologueFileName Handle
h -> do
              do
                 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
haddockSupportsUTF8 (Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8)
                 Handle -> FilePath -> IO ()
hPutStrLn Handle
h FilePath
prologueText
                 Handle -> IO ()
hClose Handle
h
                 let pflag :: FilePath
pflag = FilePath
"--prologue=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
prologueFileName
                     renderedArgs :: [FilePath]
renderedArgs = FilePath
pflag FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Version -> Compiler -> Platform -> HaddockArgs -> [FilePath]
renderPureArgs Version
version Compiler
comp Platform
platform HaddockArgs
args
                 if Bool
haddockSupportsResponseFiles
                   then
                     Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> Maybe TextEncoding
-> [FilePath]
-> (FilePath -> IO a)
-> IO a
forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> Maybe TextEncoding
-> [FilePath]
-> (FilePath -> IO a)
-> IO a
withResponseFile
                       Verbosity
verbosity
                       TempFileOptions
tmpFileOpts
                       FilePath
outputDir
                       FilePath
"haddock-response.txt"
                       (if Bool
haddockSupportsUTF8 then TextEncoding -> Maybe TextEncoding
forall a. a -> Maybe a
Just TextEncoding
utf8 else Maybe TextEncoding
forall a. Maybe a
Nothing)
                       [FilePath]
renderedArgs
                       (\FilePath
responseFileName -> ([FilePath], FilePath) -> IO a
k ([FilePath
"@" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
responseFileName], FilePath
result))
                   else
                     ([FilePath], FilePath) -> IO a
k ([FilePath]
renderedArgs, FilePath
result)
    Flag FilePath
_ -> do
      let renderedArgs :: [FilePath]
renderedArgs = (case HaddockArgs -> Flag FilePath
argPrologueFile HaddockArgs
args of
                            Flag FilePath
pfile -> [FilePath
"--prologue="FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
pfile]
                            Flag FilePath
_          -> [])
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> Version -> Compiler -> Platform -> HaddockArgs -> [FilePath]
renderPureArgs Version
version Compiler
comp Platform
platform HaddockArgs
args
      if Bool
haddockSupportsResponseFiles
        then
          Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> Maybe TextEncoding
-> [FilePath]
-> (FilePath -> IO a)
-> IO a
forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> Maybe TextEncoding
-> [FilePath]
-> (FilePath -> IO a)
-> IO a
withResponseFile
            Verbosity
verbosity
            TempFileOptions
tmpFileOpts
            FilePath
outputDir
            FilePath
"haddock-response.txt"
            (if Bool
haddockSupportsUTF8 then TextEncoding -> Maybe TextEncoding
forall a. a -> Maybe a
Just TextEncoding
utf8 else Maybe TextEncoding
forall a. Maybe a
Nothing)
            [FilePath]
renderedArgs
            (\FilePath
responseFileName -> ([FilePath], FilePath) -> IO a
k ([FilePath
"@" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
responseFileName], FilePath
result))
        else
          ([FilePath], FilePath) -> IO a
k ([FilePath]
renderedArgs, FilePath
result)
    where
      outputDir :: FilePath
outputDir = (Directory -> FilePath
unDir (Directory -> FilePath) -> Directory -> FilePath
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Directory
argOutputDir HaddockArgs
args)
      result :: FilePath
result = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", "
             ([FilePath] -> FilePath)
-> (HaddockArgs -> [FilePath]) -> HaddockArgs -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Output -> FilePath) -> [Output] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\Output
o -> FilePath
outputDir FilePath -> ShowS
</>
                            case Output
o of
                              Output
Html -> FilePath
"index.html"
                              Output
Hoogle -> FilePath
pkgstr FilePath -> ShowS
<.> FilePath
"txt")
             ([Output] -> [FilePath])
-> (HaddockArgs -> [Output]) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Output] -> Flag [Output] -> [Output]
forall a. a -> Flag a -> a
fromFlagOrDefault [Output
Html]
             (Flag [Output] -> [Output])
-> (HaddockArgs -> Flag [Output]) -> HaddockArgs -> [Output]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag [Output]
argOutput
             (HaddockArgs -> FilePath) -> HaddockArgs -> FilePath
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
            where
              pkgstr :: FilePath
pkgstr = PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageName -> FilePath) -> PackageName -> FilePath
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid
              pkgid :: PackageIdentifier
pkgid = (HaddockArgs -> Flag PackageIdentifier) -> PackageIdentifier
forall {a}. (HaddockArgs -> Flag a) -> a
arg HaddockArgs -> Flag PackageIdentifier
argPackageName
      arg :: (HaddockArgs -> Flag a) -> a
arg HaddockArgs -> Flag a
f = Flag a -> a
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag a -> a) -> Flag a -> a
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Flag a
f HaddockArgs
args

renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String]
renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [FilePath]
renderPureArgs Version
version Compiler
comp Platform
platform HaddockArgs
args = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
f -> FilePath
"--dump-interface="FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Directory -> FilePath
unDir (HaddockArgs -> Directory
argOutputDir HaddockArgs
args) FilePath -> ShowS
</> FilePath
f)
      ([FilePath] -> [FilePath])
-> (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> [FilePath]
forall a. Flag a -> [a]
flagToList (Flag FilePath -> [FilePath])
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argInterfaceFile (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , if Bool
haddockSupportsPackageName
        then [FilePath]
-> (PackageIdentifier -> [FilePath])
-> Maybe PackageIdentifier
-> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\PackageIdentifier
pkg -> [ FilePath
"--package-name=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkg)
                               , FilePath
"--package-version=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> Version
pkgVersion PackageIdentifier
pkg)
                               ])
             (Maybe PackageIdentifier -> [FilePath])
-> (HaddockArgs -> Maybe PackageIdentifier)
-> HaddockArgs
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag PackageIdentifier -> Maybe PackageIdentifier
forall a. Flag a -> Maybe a
flagToMaybe (Flag PackageIdentifier -> Maybe PackageIdentifier)
-> (HaddockArgs -> Flag PackageIdentifier)
-> HaddockArgs
-> Maybe PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag PackageIdentifier
argPackageName (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
        else []

    , [ FilePath
"--since-qual=external" | Int -> Int -> Bool
isVersion Int
2 Int
20 ]

    , [ FilePath
"--quickjump" | Int -> Int -> Bool
isVersion Int
2 Int
19
                      , Bool
_ <- Flag Bool -> [Bool]
forall a. Flag a -> [a]
flagToList (Flag Bool -> [Bool])
-> (HaddockArgs -> Flag Bool) -> HaddockArgs -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag Bool
argQuickJump (HaddockArgs -> [Bool]) -> HaddockArgs -> [Bool]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args ]

    , [ FilePath
"--hyperlinked-source" | Int -> Int -> Bool
isVersion Int
2 Int
17
                               , Bool
True <- Flag Bool -> [Bool]
forall a. Flag a -> [a]
flagToList (Flag Bool -> [Bool])
-> (HaddockArgs -> Flag Bool) -> HaddockArgs -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag Bool
argLinkedSource (HaddockArgs -> [Bool]) -> HaddockArgs -> [Bool]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args ]

    , (\(All Bool
b,[ModuleName]
xs) -> [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall {p}. p -> p -> Bool -> p
bool ((ModuleName -> FilePath) -> [ModuleName] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
"--hide=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (ModuleName -> FilePath) -> ModuleName -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow) [ModuleName]
xs) [] Bool
b)
                     ((All, [ModuleName]) -> [FilePath])
-> (HaddockArgs -> (All, [ModuleName]))
-> HaddockArgs
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> (All, [ModuleName])
argHideModules (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall {p}. p -> p -> Bool -> p
bool [FilePath
"--ignore-all-exports"] [] (Bool -> [FilePath])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Bool
getAny (Any -> Bool) -> (HaddockArgs -> Any) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Any
argIgnoreExports (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , [FilePath]
-> ((FilePath, FilePath, FilePath) -> [FilePath])
-> Maybe (FilePath, FilePath, FilePath)
-> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(FilePath
m,FilePath
e,FilePath
l) ->
                 [FilePath
"--source-module=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
m
                 ,FilePath
"--source-entity=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
e]
                 [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ if Int -> Int -> Bool
isVersion Int
2 Int
14 then [FilePath
"--source-entity-line=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
l]
                    else []
               ) (Maybe (FilePath, FilePath, FilePath) -> [FilePath])
-> (HaddockArgs -> Maybe (FilePath, FilePath, FilePath))
-> HaddockArgs
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag (FilePath, FilePath, FilePath)
-> Maybe (FilePath, FilePath, FilePath)
forall a. Flag a -> Maybe a
flagToMaybe (Flag (FilePath, FilePath, FilePath)
 -> Maybe (FilePath, FilePath, FilePath))
-> (HaddockArgs -> Flag (FilePath, FilePath, FilePath))
-> HaddockArgs
-> Maybe (FilePath, FilePath, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag (FilePath, FilePath, FilePath)
argLinkSource (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[]) (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--css="FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe FilePath -> [FilePath])
-> (HaddockArgs -> Maybe FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argCssFile (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[]) (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--use-contents="FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe FilePath -> [FilePath])
-> (HaddockArgs -> Maybe FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argContents (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall {p}. p -> p -> Bool -> p
bool [FilePath
"--gen-contents"] [] (Bool -> [FilePath])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool)
-> (HaddockArgs -> Flag Bool) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag Bool
argGenContents (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[]) (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--use-index="FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe FilePath -> [FilePath])
-> (HaddockArgs -> Maybe FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argIndex (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall {p}. p -> p -> Bool -> p
bool [FilePath
"--gen-index"] [] (Bool -> [FilePath])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool)
-> (HaddockArgs -> Flag Bool) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag Bool
argGenIndex (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[]) (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--base-url="FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe FilePath -> [FilePath])
-> (HaddockArgs -> Maybe FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argBaseUrl (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall {p}. p -> p -> Bool -> p
bool [] [FilePath
verbosityFlag] (Bool -> [FilePath])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Bool
getAny (Any -> Bool) -> (HaddockArgs -> Any) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Any
argVerbose (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , (Output -> FilePath) -> [Output] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\Output
o -> case Output
o of Output
Hoogle -> FilePath
"--hoogle"; Output
Html -> FilePath
"--html")
      ([Output] -> [FilePath])
-> (HaddockArgs -> [Output]) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Output] -> Flag [Output] -> [Output]
forall a. a -> Flag a -> a
fromFlagOrDefault [] (Flag [Output] -> [Output])
-> (HaddockArgs -> Flag [Output]) -> HaddockArgs -> [Output]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag [Output]
argOutput (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
-> [FilePath]
renderInterfaces ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
 -> [FilePath])
-> (HaddockArgs
    -> [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)])
-> HaddockArgs
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs
-> [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
argInterfaces (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , (FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[]) (FilePath -> [FilePath])
-> (HaddockArgs -> FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--odir="FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (HaddockArgs -> FilePath) -> HaddockArgs -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directory -> FilePath
unDir (Directory -> FilePath)
-> (HaddockArgs -> Directory) -> HaddockArgs -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Directory
argOutputDir (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe []
        ( (FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[])
        (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--title="FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS -> Bool -> ShowS
forall {p}. p -> p -> Bool -> p
bool (FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
" (internal documentation)")
                ShowS
forall a. a -> a
id (Any -> Bool
getAny (Any -> Bool) -> Any -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Any
argIgnoreExports HaddockArgs
args))
        )
        (Maybe FilePath -> [FilePath])
-> (HaddockArgs -> Maybe FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argTitle (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , [ FilePath
"--optghc=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
opt | let opts :: GhcOptions
opts = HaddockArgs -> GhcOptions
argGhcOptions HaddockArgs
args
                           , FilePath
opt <- Compiler -> Platform -> GhcOptions -> [FilePath]
renderGhcOptions Compiler
comp Platform
platform GhcOptions
opts ]

    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
l -> [FilePath
"-B"FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
l]) (Maybe FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$
      Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (HaddockArgs -> Flag FilePath
argGhcLibDir HaddockArgs
args) -- error if Nothing?

      -- https://github.com/haskell/haddock/pull/547
    , [ FilePath
"--reexport=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ OpenModule -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow OpenModule
r
      | OpenModule
r <- HaddockArgs -> [OpenModule]
argReexports HaddockArgs
args
      , Int -> Int -> Bool
isVersion Int
2 Int
19
      ]

    , HaddockArgs -> [FilePath]
argTargets (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[]) (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--lib="FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe FilePath -> [FilePath])
-> (HaddockArgs -> Maybe FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argLib (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    ]
    where
      renderInterfaces :: [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
-> [FilePath]
renderInterfaces = ((FilePath, Maybe FilePath, Maybe FilePath, Visibility)
 -> FilePath)
-> [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
-> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> FilePath
renderInterface

      renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> String
      renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> FilePath
renderInterface (FilePath
i, Maybe FilePath
html, Maybe FilePath
hypsrc, Visibility
visibility) = FilePath
"--read-interface=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
        (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [ FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" Maybe FilePath
html ]
                                  , -- only render hypsrc path if html path
                                    -- is given and hyperlinked-source is
                                    -- enabled
                                    [ case (Maybe FilePath
html, Maybe FilePath
hypsrc) of
                                        (Maybe FilePath
Nothing, Maybe FilePath
_) -> FilePath
""
                                        (Maybe FilePath
_, Maybe FilePath
Nothing) -> FilePath
""
                                        (Maybe FilePath
_, Just FilePath
x)  | Int -> Int -> Bool
isVersion Int
2 Int
17
                                                     , Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool)
-> (HaddockArgs -> Flag Bool) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag Bool
argLinkedSource (HaddockArgs -> Bool) -> HaddockArgs -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
                                                     -> FilePath
x
                                                     | Bool
otherwise
                                                     -> FilePath
""
                                    ]
                                  , if Bool
haddockSupportsVisibility
                                      then [ case Visibility
visibility of
                                               Visibility
Visible -> FilePath
"visible"
                                               Visibility
Hidden  -> FilePath
"hidden"
                                           ]
                                      else []
                                  , [ FilePath
i ]
                                  ])

      bool :: p -> p -> Bool -> p
bool p
a p
b Bool
c = if Bool
c then p
a else p
b
      isVersion :: Int -> Int -> Bool
isVersion Int
major Int
minor  = Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
major,Int
minor]
      verbosityFlag :: FilePath
verbosityFlag
       | Int -> Int -> Bool
isVersion Int
2 Int
5 = FilePath
"--verbosity=1"
       | Bool
otherwise     = FilePath
"--verbose"
      haddockSupportsVisibility :: Bool
haddockSupportsVisibility = Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
2,Int
26,Int
1]
      haddockSupportsPackageName :: Bool
haddockSupportsPackageName = Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> [Int] -> Version
mkVersion [Int
2,Int
16]

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

-- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and
-- HTML paths, and an optional warning for packages with missing documentation.
haddockPackagePaths :: [InstalledPackageInfo]
                    -> Maybe (InstalledPackageInfo -> FilePath)
                    -> IO ([( FilePath        -- path to interface
                                                         -- file

                                       , Maybe FilePath  -- url to html
                                                         -- documentation

                                       , Maybe FilePath  -- url to hyperlinked
                                                         -- source
                                       , Visibility
                                       )]
                                     , Maybe String      -- warning about
                                                         -- missing documentation
                                     )
haddockPackagePaths :: [InstalledPackageInfo]
-> Maybe (InstalledPackageInfo -> FilePath)
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)],
      Maybe FilePath)
haddockPackagePaths [InstalledPackageInfo]
ipkgs Maybe (InstalledPackageInfo -> FilePath)
mkHtmlPath = do
  [Either
   PackageIdentifier
   (FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
interfaces <- [IO
   (Either
      PackageIdentifier
      (FilePath, Maybe FilePath, Maybe FilePath, Visibility))]
-> IO
     [Either
        PackageIdentifier
        (FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
    [ case InstalledPackageInfo -> Maybe (FilePath, Maybe FilePath)
interfaceAndHtmlPath InstalledPackageInfo
ipkg of
        Maybe (FilePath, Maybe FilePath)
Nothing -> Either
  PackageIdentifier
  (FilePath, Maybe FilePath, Maybe FilePath, Visibility)
-> IO
     (Either
        PackageIdentifier
        (FilePath, Maybe FilePath, Maybe FilePath, Visibility))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageIdentifier
-> Either
     PackageIdentifier
     (FilePath, Maybe FilePath, Maybe FilePath, Visibility)
forall a b. a -> Either a b
Left (InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId InstalledPackageInfo
ipkg))
        Just (FilePath
interface, Maybe FilePath
html) -> do

          (Maybe FilePath
html', Maybe FilePath
hypsrc') <-
            case Maybe FilePath
html of
              Just FilePath
htmlPath -> do
                let hypSrcPath :: FilePath
hypSrcPath = FilePath
htmlPath FilePath -> ShowS
</> FilePath
defaultHyperlinkedSourceDirectory
                Bool
hypSrcExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
hypSrcPath
                (Maybe FilePath, Maybe FilePath)
-> IO (Maybe FilePath, Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe FilePath, Maybe FilePath)
 -> IO (Maybe FilePath, Maybe FilePath))
-> (Maybe FilePath, Maybe FilePath)
-> IO (Maybe FilePath, Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ ( FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (ShowS
fixFileUrl FilePath
htmlPath)
                         , if Bool
hypSrcExists
                           then FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (ShowS
fixFileUrl FilePath
hypSrcPath)
                           else Maybe FilePath
forall a. Maybe a
Nothing
                         )
              Maybe FilePath
Nothing -> (Maybe FilePath, Maybe FilePath)
-> IO (Maybe FilePath, Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath
forall a. Maybe a
Nothing, Maybe FilePath
forall a. Maybe a
Nothing)

          Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
interface
          if Bool
exists
            then Either
  PackageIdentifier
  (FilePath, Maybe FilePath, Maybe FilePath, Visibility)
-> IO
     (Either
        PackageIdentifier
        (FilePath, Maybe FilePath, Maybe FilePath, Visibility))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath, Maybe FilePath, Maybe FilePath, Visibility)
-> Either
     PackageIdentifier
     (FilePath, Maybe FilePath, Maybe FilePath, Visibility)
forall a b. b -> Either a b
Right (FilePath
interface, Maybe FilePath
html', Maybe FilePath
hypsrc', Visibility
Visible))
            else Either
  PackageIdentifier
  (FilePath, Maybe FilePath, Maybe FilePath, Visibility)
-> IO
     (Either
        PackageIdentifier
        (FilePath, Maybe FilePath, Maybe FilePath, Visibility))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageIdentifier
-> Either
     PackageIdentifier
     (FilePath, Maybe FilePath, Maybe FilePath, Visibility)
forall a b. a -> Either a b
Left PackageIdentifier
pkgid)
    | InstalledPackageInfo
ipkg <- [InstalledPackageInfo]
ipkgs, let pkgid :: PackageIdentifier
pkgid = InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId InstalledPackageInfo
ipkg
    , PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgid PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageName]
noHaddockWhitelist
    ]

  let missing :: [PackageIdentifier]
missing = [ PackageIdentifier
pkgid | Left PackageIdentifier
pkgid <- [Either
   PackageIdentifier
   (FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
interfaces ]
      warning :: FilePath
warning = FilePath
"The documentation for the following packages are not "
             FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"installed. No links will be generated to these packages: "
             FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ((PackageIdentifier -> FilePath)
-> [PackageIdentifier] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow [PackageIdentifier]
missing)
      flags :: [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
flags = [Either
   PackageIdentifier
   (FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
-> [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
forall a b. [Either a b] -> [b]
rights [Either
   PackageIdentifier
   (FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
interfaces

  ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)],
 Maybe FilePath)
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)],
      Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
flags, if [PackageIdentifier] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageIdentifier]
missing then Maybe FilePath
forall a. Maybe a
Nothing else FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
warning)

  where
    -- Don't warn about missing documentation for these packages. See #1231.
    noHaddockWhitelist :: [PackageName]
noHaddockWhitelist = (FilePath -> PackageName) -> [FilePath] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> PackageName
mkPackageName [ FilePath
"rts" ]

    -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.
    interfaceAndHtmlPath :: InstalledPackageInfo
                         -> Maybe (FilePath, Maybe FilePath)
    interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, Maybe FilePath)
interfaceAndHtmlPath InstalledPackageInfo
pkg = do
      FilePath
interface <- [FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
listToMaybe (InstalledPackageInfo -> [FilePath]
InstalledPackageInfo.haddockInterfaces InstalledPackageInfo
pkg)
      FilePath
html <- case Maybe (InstalledPackageInfo -> FilePath)
mkHtmlPath of
        Maybe (InstalledPackageInfo -> FilePath)
Nothing     -> [FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
listToMaybe (InstalledPackageInfo -> [FilePath]
InstalledPackageInfo.haddockHTMLs InstalledPackageInfo
pkg)
        Just InstalledPackageInfo -> FilePath
mkPath -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (InstalledPackageInfo -> FilePath
mkPath InstalledPackageInfo
pkg)
      (FilePath, Maybe FilePath) -> Maybe (FilePath, Maybe FilePath)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
interface, if FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
html then Maybe FilePath
forall a. Maybe a
Nothing else FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
html)

    -- The 'haddock-html' field in the hc-pkg output is often set as a
    -- native path, but we need it as a URL. See #1064. Also don't "fix"
    -- the path if it is an interpolated one.
    fixFileUrl :: ShowS
fixFileUrl FilePath
f | Maybe (InstalledPackageInfo -> FilePath)
Nothing <- Maybe (InstalledPackageInfo -> FilePath)
mkHtmlPath
                 , FilePath -> Bool
isAbsolute FilePath
f = FilePath
"file://" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
f
                 | Bool
otherwise    = FilePath
f

    -- 'src' is the default hyperlinked source directory ever since. It is
    -- not possible to configure that directory in any way in haddock.
    defaultHyperlinkedSourceDirectory :: FilePath
defaultHyperlinkedSourceDirectory = FilePath
"src"


haddockPackageFlags :: Verbosity
                    -> LocalBuildInfo
                    -> ComponentLocalBuildInfo
                    -> Maybe PathTemplate
                    -> IO ([( FilePath        -- path to interface
                                              -- file

                            , Maybe FilePath  -- url to html
                                              -- documentation

                            , Maybe FilePath  -- url to hyperlinked
                                              -- source
                            , Visibility
                            )]
                          , Maybe String      -- warning about
                                              -- missing documentation
                          )
haddockPackageFlags :: Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)],
      Maybe FilePath)
haddockPackageFlags Verbosity
verbosity LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate = do
  let allPkgs :: InstalledPackageIndex
allPkgs = LocalBuildInfo -> InstalledPackageIndex
installedPkgs LocalBuildInfo
lbi
      directDeps :: [UnitId]
directDeps = ((UnitId, MungedPackageId) -> UnitId)
-> [(UnitId, MungedPackageId)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, MungedPackageId) -> UnitId
forall a b. (a, b) -> a
fst (ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
componentPackageDeps ComponentLocalBuildInfo
clbi)
  InstalledPackageIndex
transitiveDeps <- case InstalledPackageIndex
-> [UnitId]
-> Either InstalledPackageIndex [(InstalledPackageInfo, [UnitId])]
PackageIndex.dependencyClosure InstalledPackageIndex
allPkgs [UnitId]
directDeps of
    Left InstalledPackageIndex
x    -> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
x
    Right [(InstalledPackageInfo, [UnitId])]
inf -> Verbosity -> FilePath -> IO InstalledPackageIndex
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO InstalledPackageIndex)
-> FilePath -> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$ FilePath
"internal error when calculating transitive "
                    FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"package dependencies.\nDebug info: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [(InstalledPackageInfo, [UnitId])] -> FilePath
forall a. Show a => a -> FilePath
show [(InstalledPackageInfo, [UnitId])]
inf
  [InstalledPackageInfo]
-> Maybe (InstalledPackageInfo -> FilePath)
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)],
      Maybe FilePath)
haddockPackagePaths (InstalledPackageIndex -> [InstalledPackageInfo]
forall a. PackageIndex a -> [a]
PackageIndex.allPackages InstalledPackageIndex
transitiveDeps) Maybe (InstalledPackageInfo -> FilePath)
mkHtmlPath
    where
      mkHtmlPath :: Maybe (InstalledPackageInfo -> FilePath)
mkHtmlPath                  = (PathTemplate -> InstalledPackageInfo -> FilePath)
-> Maybe PathTemplate -> Maybe (InstalledPackageInfo -> FilePath)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> InstalledPackageInfo -> FilePath
forall {pkg}. Package pkg => PathTemplate -> pkg -> FilePath
expandTemplateVars Maybe PathTemplate
htmlTemplate
      expandTemplateVars :: PathTemplate -> pkg -> FilePath
expandTemplateVars PathTemplate
tmpl pkg
pkg =
        PathTemplate -> FilePath
fromPathTemplate (PathTemplate -> FilePath)
-> (PathTemplate -> PathTemplate) -> PathTemplate -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate (pkg -> PathTemplateEnv
forall {pkg}. Package pkg => pkg -> PathTemplateEnv
env pkg
pkg) (PathTemplate -> FilePath) -> PathTemplate -> FilePath
forall a b. (a -> b) -> a -> b
$ PathTemplate
tmpl
      env :: pkg -> PathTemplateEnv
env pkg
pkg                     = LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
haddockTemplateEnv LocalBuildInfo
lbi (pkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId pkg
pkg)


haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
haddockTemplateEnv LocalBuildInfo
lbi PackageIdentifier
pkg_id =
  (PathTemplateVariable
PrefixVar, InstallDirs PathTemplate -> PathTemplate
forall dir. InstallDirs dir -> dir
prefix (LocalBuildInfo -> InstallDirs PathTemplate
installDirTemplates LocalBuildInfo
lbi))
  -- We want the legacy unit ID here, because it gives us nice paths
  -- (Haddock people don't care about the dependencies)
  (PathTemplateVariable, PathTemplate)
-> PathTemplateEnv -> PathTemplateEnv
forall a. a -> [a] -> [a]
: PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv
      PackageIdentifier
pkg_id
      (PackageIdentifier -> UnitId
mkLegacyUnitId PackageIdentifier
pkg_id)
      (Compiler -> CompilerInfo
compilerInfo (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi))
      (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi)

-- ------------------------------------------------------------------------------
-- hscolour support.

hscolour :: PackageDescription
         -> LocalBuildInfo
         -> [PPSuffixHandler]
         -> HscolourFlags
         -> IO ()
hscolour :: PackageDescription
-> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO ()
hscolour = (FilePath -> IO ())
-> HaddockTarget
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour' FilePath -> IO ()
forall a. FilePath -> IO a
dieNoVerbosity HaddockTarget
ForDevelopment

hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found.
          -> HaddockTarget
          -> PackageDescription
          -> LocalBuildInfo
          -> [PPSuffixHandler]
          -> HscolourFlags
          -> IO ()
hscolour' :: (FilePath -> IO ())
-> HaddockTarget
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour' FilePath -> IO ()
onNoHsColour HaddockTarget
haddockTarget PackageDescription
pkg_descr LocalBuildInfo
lbi [PPSuffixHandler]
suffixes HscolourFlags
flags =
    (FilePath -> IO ())
-> ((ConfiguredProgram, Version, ProgramDb) -> IO ())
-> Either FilePath (ConfiguredProgram, Version, ProgramDb)
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO ()
onNoHsColour (\(ConfiguredProgram
hscolourProg, Version
_, ProgramDb
_) -> ConfiguredProgram -> IO ()
go ConfiguredProgram
hscolourProg) (Either FilePath (ConfiguredProgram, Version, ProgramDb) -> IO ())
-> IO (Either FilePath (ConfiguredProgram, Version, ProgramDb))
-> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (Either FilePath (ConfiguredProgram, Version, ProgramDb))
lookupProgramVersion Verbosity
verbosity Program
hscolourProgram
      (Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
1,Int
8])) (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
  where
    go :: ConfiguredProgram -> IO ()
    go :: ConfiguredProgram -> IO ()
go ConfiguredProgram
hscolourProg = do
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"the 'cabal hscolour' command is deprecated in favour of 'cabal " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
        FilePath
"haddock --hyperlink-source' and will be removed in the next major " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
        FilePath
"release."

      Verbosity -> FilePath -> PackageIdentifier -> IO ()
setupMessage Verbosity
verbosity FilePath
"Running hscolour for" (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)
      Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        HaddockTarget -> FilePath -> PackageDescription -> FilePath
hscolourPref HaddockTarget
haddockTarget FilePath
distPref PackageDescription
pkg_descr

      PackageDescription
-> LocalBuildInfo
-> (Component -> ComponentLocalBuildInfo -> IO ())
-> IO ()
withAllComponentsInBuildOrder PackageDescription
pkg_descr LocalBuildInfo
lbi ((Component -> ComponentLocalBuildInfo -> IO ()) -> IO ())
-> (Component -> ComponentLocalBuildInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Component
comp ComponentLocalBuildInfo
clbi -> do
        FilePath
-> PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Verbosity
-> IO ()
componentInitialBuildSteps FilePath
distPref PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Verbosity
verbosity
        PackageDescription
-> Component
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Bool
-> Verbosity
-> [PPSuffixHandler]
-> IO ()
preprocessComponent PackageDescription
pkg_descr Component
comp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Bool
False Verbosity
verbosity [PPSuffixHandler]
suffixes
        let
          doExe :: Component -> IO ()
doExe Component
com = case (Component -> Maybe Executable
compToExe Component
com) of
            Just Executable
exe -> do
              let outputDir :: FilePath
outputDir = HaddockTarget -> FilePath -> PackageDescription -> FilePath
hscolourPref HaddockTarget
haddockTarget FilePath
distPref PackageDescription
pkg_descr
                              FilePath -> ShowS
</> UnqualComponentName -> FilePath
unUnqualComponentName (Executable -> UnqualComponentName
exeName Executable
exe) FilePath -> ShowS
</> FilePath
"src"
              ConfiguredProgram -> FilePath -> [(ModuleName, FilePath)] -> IO ()
forall {t :: * -> *}.
Foldable t =>
ConfiguredProgram -> FilePath -> t (ModuleName, FilePath) -> IO ()
runHsColour ConfiguredProgram
hscolourProg FilePath
outputDir ([(ModuleName, FilePath)] -> IO ())
-> IO [(ModuleName, FilePath)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO [(ModuleName, FilePath)]
getExeSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Executable
exe ComponentLocalBuildInfo
clbi
            Maybe Executable
Nothing -> do
              Verbosity -> FilePath -> IO ()
warn (Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ HscolourFlags -> Flag Verbosity
hscolourVerbosity HscolourFlags
flags)
                FilePath
"Unsupported component, skipping..."
              () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        case Component
comp of
          CLib Library
lib -> do
            let outputDir :: FilePath
outputDir = HaddockTarget -> FilePath -> PackageDescription -> FilePath
hscolourPref HaddockTarget
haddockTarget FilePath
distPref PackageDescription
pkg_descr FilePath -> ShowS
</> FilePath
"src"
            ConfiguredProgram -> FilePath -> [(ModuleName, FilePath)] -> IO ()
forall {t :: * -> *}.
Foldable t =>
ConfiguredProgram -> FilePath -> t (ModuleName, FilePath) -> IO ()
runHsColour ConfiguredProgram
hscolourProg FilePath
outputDir ([(ModuleName, FilePath)] -> IO ())
-> IO [(ModuleName, FilePath)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO [(ModuleName, FilePath)]
getLibSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi
          CFLib ForeignLib
flib -> do
            let outputDir :: FilePath
outputDir = HaddockTarget -> FilePath -> PackageDescription -> FilePath
hscolourPref HaddockTarget
haddockTarget FilePath
distPref PackageDescription
pkg_descr
                              FilePath -> ShowS
</> UnqualComponentName -> FilePath
unUnqualComponentName (ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib) FilePath -> ShowS
</> FilePath
"src"
            ConfiguredProgram -> FilePath -> [(ModuleName, FilePath)] -> IO ()
forall {t :: * -> *}.
Foldable t =>
ConfiguredProgram -> FilePath -> t (ModuleName, FilePath) -> IO ()
runHsColour ConfiguredProgram
hscolourProg FilePath
outputDir ([(ModuleName, FilePath)] -> IO ())
-> IO [(ModuleName, FilePath)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity
-> LocalBuildInfo
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO [(ModuleName, FilePath)]
getFLibSourceFiles Verbosity
verbosity LocalBuildInfo
lbi ForeignLib
flib ComponentLocalBuildInfo
clbi
          CExe   Executable
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Flag Bool
hscolourExecutables HscolourFlags
flags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Component -> IO ()
doExe Component
comp
          CTest  TestSuite
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Flag Bool
hscolourTestSuites  HscolourFlags
flags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Component -> IO ()
doExe Component
comp
          CBench Benchmark
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Flag Bool
hscolourBenchmarks  HscolourFlags
flags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Component -> IO ()
doExe Component
comp

    stylesheet :: Maybe FilePath
stylesheet = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (HscolourFlags -> Flag FilePath
hscolourCSS HscolourFlags
flags)

    verbosity :: Verbosity
verbosity  = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Flag Verbosity
hscolourVerbosity HscolourFlags
flags)
    distPref :: FilePath
distPref   = Flag FilePath -> FilePath
forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Flag FilePath
hscolourDistPref HscolourFlags
flags)

    runHsColour :: ConfiguredProgram -> FilePath -> t (ModuleName, FilePath) -> IO ()
runHsColour ConfiguredProgram
prog FilePath
outputDir t (ModuleName, FilePath)
moduleFiles = do
         Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
outputDir

         case Maybe FilePath
stylesheet of -- copy the CSS file
           Maybe FilePath
Nothing | ConfiguredProgram -> Maybe Version
programVersion ConfiguredProgram
prog Maybe Version -> Maybe Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version -> Maybe Version
forall a. a -> Maybe a
Just ([Int] -> Version
mkVersion [Int
1,Int
9]) ->
                       Verbosity -> ConfiguredProgram -> [FilePath] -> IO ()
runProgram Verbosity
verbosity ConfiguredProgram
prog
                          [FilePath
"-print-css", FilePath
"-o" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
outputDir FilePath -> ShowS
</> FilePath
"hscolour.css"]
                   | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           Just FilePath
s -> Verbosity -> FilePath -> FilePath -> IO ()
copyFileVerbose Verbosity
verbosity FilePath
s (FilePath
outputDir FilePath -> ShowS
</> FilePath
"hscolour.css")

         t (ModuleName, FilePath)
-> ((ModuleName, FilePath) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ t (ModuleName, FilePath)
moduleFiles (((ModuleName, FilePath) -> IO ()) -> IO ())
-> ((ModuleName, FilePath) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ModuleName
m, FilePath
inFile) ->
             Verbosity -> ConfiguredProgram -> [FilePath] -> IO ()
runProgram Verbosity
verbosity ConfiguredProgram
prog
                    [FilePath
"-css", FilePath
"-anchor", FilePath
"-o" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ModuleName -> FilePath
outFile ModuleName
m, FilePath
inFile]
        where
          outFile :: ModuleName -> FilePath
outFile ModuleName
m = FilePath
outputDir FilePath -> ShowS
</>
                      FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"-" (ModuleName -> [FilePath]
ModuleName.components ModuleName
m) FilePath -> ShowS
<.> FilePath
"html"

haddockToHscolour :: HaddockFlags -> HscolourFlags
haddockToHscolour :: HaddockFlags -> HscolourFlags
haddockToHscolour HaddockFlags
flags =
    HscolourFlags {
      hscolourCSS :: Flag FilePath
hscolourCSS         = HaddockFlags -> Flag FilePath
haddockHscolourCss HaddockFlags
flags,
      hscolourExecutables :: Flag Bool
hscolourExecutables = HaddockFlags -> Flag Bool
haddockExecutables HaddockFlags
flags,
      hscolourTestSuites :: Flag Bool
hscolourTestSuites  = HaddockFlags -> Flag Bool
haddockTestSuites  HaddockFlags
flags,
      hscolourBenchmarks :: Flag Bool
hscolourBenchmarks  = HaddockFlags -> Flag Bool
haddockBenchmarks  HaddockFlags
flags,
      hscolourForeignLibs :: Flag Bool
hscolourForeignLibs = HaddockFlags -> Flag Bool
haddockForeignLibs HaddockFlags
flags,
      hscolourVerbosity :: Flag Verbosity
hscolourVerbosity   = HaddockFlags -> Flag Verbosity
haddockVerbosity   HaddockFlags
flags,
      hscolourDistPref :: Flag FilePath
hscolourDistPref    = HaddockFlags -> Flag FilePath
haddockDistPref    HaddockFlags
flags,
      hscolourCabalFilePath :: Flag FilePath
hscolourCabalFilePath = HaddockFlags -> Flag FilePath
haddockCabalFilePath HaddockFlags
flags
    }

-- ------------------------------------------------------------------------------
-- Boilerplate Monoid instance.
instance Monoid HaddockArgs where
    mempty :: HaddockArgs
mempty = HaddockArgs
forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
    mappend :: HaddockArgs -> HaddockArgs -> HaddockArgs
mappend = HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup HaddockArgs where
    <> :: HaddockArgs -> HaddockArgs -> HaddockArgs
(<>) = HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend

instance Monoid Directory where
    mempty :: Directory
mempty = FilePath -> Directory
Dir FilePath
"."
    mappend :: Directory -> Directory -> Directory
mappend = Directory -> Directory -> Directory
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup Directory where
    Dir FilePath
m <> :: Directory -> Directory -> Directory
<> Dir FilePath
n = FilePath -> Directory
Dir (FilePath -> Directory) -> FilePath -> Directory
forall a b. (a -> b) -> a -> b
$ FilePath
m FilePath -> ShowS
</> FilePath
n