{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

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

-- |
-- 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
  , haddock_setupHooks
  , createHaddockIndex
  , hscolour
  , hscolour_setupHooks
  , haddockPackagePaths
  , Visibility (..)
  ) where

import Distribution.Compat.Prelude
import Prelude ()

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

-- local

import Distribution.Backpack (OpenModule)
import Distribution.Backpack.DescribeUnitId
import Distribution.Compat.Semigroup (All (..), Any (..))
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import qualified Distribution.ModuleName as ModuleName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Parsec (simpleParsec)
import Distribution.Pretty
import Distribution.Simple.Build
import Distribution.Simple.BuildPaths
import Distribution.Simple.BuildTarget
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.Flag
import Distribution.Simple.Glob (matchDirFileGlob)
import Distribution.Simple.InstallDirs
import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PreProcess
import Distribution.Simple.Program
import Distribution.Simple.Program.GHC
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import Distribution.Simple.Program.ResponseFile
import Distribution.Simple.Register
import Distribution.Simple.Setup.Common
import Distribution.Simple.Setup.Haddock
import Distribution.Simple.Setup.Hscolour
import Distribution.Simple.SetupHooks.Internal
  ( BuildHooks (..)
  , BuildingWhat (..)
  , noBuildHooks
  )
import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks
import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.ExposedModule
import Distribution.Types.LocalBuildInfo
import Distribution.Types.TargetInfo
import Distribution.Utils.Path hiding
  ( Dir
  )
import qualified Distribution.Utils.Path as Path
import qualified Distribution.Utils.ShortText as ShortText
import Distribution.Verbosity
import Distribution.Version

import Control.Monad
import Data.Bool (bool)
import Data.Either (rights)
import System.Directory (doesDirectoryExist, doesFileExist)
import System.FilePath (isAbsolute, normalise)
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 String
argInterfaceFile :: Flag FilePath
  -- ^ Path to the interface file, relative to argOutputDir, required.
  , HaddockArgs -> Flag PackageIdentifier
argPackageName :: Flag PackageIdentifier
  -- ^ Package name, required.
  , HaddockArgs -> Flag String
argComponentName :: Flag String
  -- ^ Optional name used to construct haddock's `--package-name` option for
  -- various components (tests suites, sublibriaries, etc).
  , HaddockArgs -> (All, [ModuleName])
argHideModules :: (All, [ModuleName.ModuleName])
  -- ^ (Hide modules ?, modules to hide)
  , HaddockArgs -> Any
argIgnoreExports :: Any
  -- ^ Ignore export lists in modules?
  , HaddockArgs -> Flag (String, String, String)
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 String
argCssFile :: Flag FilePath
  -- ^ Optional custom CSS file.
  , HaddockArgs -> Flag String
argContents :: Flag String
  -- ^ Optional URL to contents page.
  , HaddockArgs -> Flag Bool
argGenContents :: Flag Bool
  -- ^ Generate contents
  , HaddockArgs -> Flag String
argIndex :: Flag String
  -- ^ Optional URL to index page.
  , HaddockArgs -> Flag Bool
argGenIndex :: Flag Bool
  -- ^ Generate index
  , HaddockArgs -> Flag String
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 -> [(String, Maybe String, Maybe String, 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 String
argTitle :: Flag String
  -- ^ Page title, required.
  , HaddockArgs -> Flag String
argPrologue :: Flag String
  -- ^ Prologue text, required for 'haddock', ignored by 'haddocks'.
  , HaddockArgs -> Flag String
argPrologueFile :: Flag FilePath
  -- ^ Prologue file name, ignored by 'haddock', optional for 'haddocks'.
  , HaddockArgs -> GhcOptions
argGhcOptions :: GhcOptions
  -- ^ Additional flags to pass to GHC.
  , HaddockArgs -> Flag String
argGhcLibDir :: Flag FilePath
  -- ^ To find the correct GHC, required.
  , HaddockArgs -> [OpenModule]
argReexports :: [OpenModule]
  -- ^ Re-exported modules
  , HaddockArgs -> [String]
argTargets :: [FilePath]
  -- ^ Modules to process.
  , HaddockArgs -> Flag String
argResourcesDir :: Flag String
  -- ^ haddock's static \/ auxiliary files.
  , HaddockArgs -> Flag Bool
argUseUnicode :: Flag Bool
  -- ^ haddock's `--use-unicode` flag
  }
  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 -> String
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 -> String
(Int -> Directory -> ShowS)
-> (Directory -> String)
-> ([Directory] -> ShowS)
-> Show Directory
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Directory -> ShowS
showsPrec :: Int -> Directory -> ShowS
$cshow :: Directory -> String
show :: Directory -> String
$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)

-- NB: only correct at the top-level, after we have combined monoidally
-- the top-level output directory with the component subdir.
unDir :: Directory -> SymbolicPath Pkg (Path.Dir Artifacts)
unDir :: Directory -> SymbolicPath Pkg ('Dir Artifacts)
unDir = String -> SymbolicPath Pkg ('Dir Artifacts)
forall from (to :: FileOrDir). String -> SymbolicPath from to
makeSymbolicPath (String -> SymbolicPath Pkg ('Dir Artifacts))
-> (Directory -> String)
-> Directory
-> SymbolicPath Pkg ('Dir Artifacts)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
normalise ShowS -> (Directory -> String) -> Directory -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directory -> String
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

  (haddockProg, version, _) <-
    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
  when (hoogle && version < mkVersion [2, 2]) $
    dieWithException verbosity NoSupportForHoogle

  when (fromFlag argQuickJump && version < mkVersion [2, 19]) $ do
    let msg = String
"Haddock prior to 2.19 does not support the --quickjump flag."
        alt = String
"The generated documentation won't have the QuickJump feature."
    if Flag True == quickJumpFlag
      then dieWithException verbosity NoSupportForQuickJumpFlag
      else warn verbosity (msg ++ "\n" ++ alt)

  haddockGhcVersionStr <-
    getProgramOutput
      verbosity
      haddockProg
      ["--ghc-version"]
  case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of
    (Maybe Version
Nothing, Maybe Version
_) -> Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
NoGHCVersionFromHaddock
    (Maybe Version
_, Maybe Version
Nothing) -> Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
NoGHCVersionFromCompiler
    (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 -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ()) -> CabalException -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> Version -> CabalException
HaddockAndGHCVersionDoesntMatch Version
ghcVersion Version
haddockGhcVersion

  return (haddockProg, version)

haddock
  :: PackageDescription
  -> LocalBuildInfo
  -> [PPSuffixHandler]
  -> HaddockFlags
  -> IO ()
haddock :: PackageDescription
-> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO ()
haddock = BuildHooks
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HaddockFlags
-> IO ()
haddock_setupHooks BuildHooks
noBuildHooks

haddock_setupHooks
  :: BuildHooks
  -> PackageDescription
  -> LocalBuildInfo
  -> [PPSuffixHandler]
  -> HaddockFlags
  -> IO ()
haddock_setupHooks :: BuildHooks
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HaddockFlags
-> IO ()
haddock_setupHooks
  BuildHooks
_
  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 -> String -> 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
$ CommonSetupFlags -> Flag Verbosity
setupVerbosity (CommonSetupFlags -> Flag Verbosity)
-> CommonSetupFlags -> Flag Verbosity
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> CommonSetupFlags
haddockCommonFlags HaddockFlags
haddockFlags) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"No documentation was generated as this package does not contain "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"a library. Perhaps you want to use the --executables, --tests,"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" --benchmarks or --foreign-libraries flags."
haddock_setupHooks
  (BuildHooks{preBuildComponentRules :: BuildHooks -> Maybe PreBuildComponentRules
preBuildComponentRules = Maybe PreBuildComponentRules
mbPbcRules})
  PackageDescription
pkg_descr
  LocalBuildInfo
lbi
  [PPSuffixHandler]
suffixes
  HaddockFlags
flags' = do
    let verbosity :: Verbosity
verbosity = 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
        mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a -> Maybe a
flagToMaybe (Flag (SymbolicPath CWD ('Dir Pkg))
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
haddockWorkingDir HaddockFlags
flags
        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 :: String
pkg_url = String
"/package/$pkg-$version"
        flag :: (HaddockFlags -> Flag b) -> b
flag HaddockFlags -> Flag b
f = Flag b -> b
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag b -> b) -> Flag b -> b
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag b
f HaddockFlags
flags

        tmpFileOpts :: TempFileOptions
tmpFileOpts =
          TempFileOptions
defaultTempFileOptions
            { optKeepTempFiles = flag haddockKeepTempFiles
            }
        htmlTemplate :: Maybe PathTemplate
htmlTemplate =
          (String -> PathTemplate) -> Maybe String -> Maybe PathTemplate
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> PathTemplate
toPathTemplate (Maybe String -> Maybe PathTemplate)
-> (HaddockFlags -> Maybe String)
-> HaddockFlags
-> Maybe PathTemplate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> Maybe String)
-> (HaddockFlags -> Flag String) -> HaddockFlags -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockFlags -> Flag String
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')

    libdirArgs <- Verbosity -> LocalBuildInfo -> IO HaddockArgs
getGhcLibDir Verbosity
verbosity LocalBuildInfo
lbi
    -- The haddock-output-dir flag overrides any other documentation placement concerns.
    -- The point is to give the user full freedom over the location if they need it.
    let overrideWithOutputDir HaddockArgs
args = case HaddockFlags -> Flag String
haddockOutputDir HaddockFlags
flags of
          Flag String
NoFlag -> HaddockArgs
args
          Flag String
dir -> HaddockArgs
args{argOutputDir = Dir dir}
    let commonArgs =
          HaddockArgs -> HaddockArgs
overrideWithOutputDir (HaddockArgs -> HaddockArgs) -> HaddockArgs -> HaddockArgs
forall a b. (a -> b) -> a -> b
$
            [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
              ]

    (haddockProg, version) <-
      getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag

    -- We fall back to using HsColour only for versions of Haddock which don't
    -- support '--hyperlinked-sources'.
    let using_hscolour = (HaddockFlags -> Flag Bool) -> Bool
forall {b}. (HaddockFlags -> Flag b) -> b
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]
    when using_hscolour $
      hscolour'
        noBuildHooks
        -- NB: we are not passing the user BuildHooks here,
        -- because we are already running the pre/post build hooks
        -- for Haddock.
        (warn verbosity)
        haddockTarget
        pkg_descr
        lbi
        suffixes
        (defaultHscolourFlags `mappend` haddockToHscolour flags)

    targets <- readTargetInfos verbosity pkg_descr lbi (haddockTargets flags)

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

    internalPackageDB <-
      createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags)

    (\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
index TargetInfo
target -> do
      let
        component :: Component
component = TargetInfo -> Component
targetComponent TargetInfo
target
        clbi :: ComponentLocalBuildInfo
clbi = TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
target
        bi :: BuildInfo
bi = Component -> BuildInfo
componentBuildInfo Component
component
        -- Include any build-tool-depends on build tools internal to the current package.
        progs' :: ProgramDb
progs' = PackageDescription
-> LocalBuildInfo -> BuildInfo -> ProgramDb -> ProgramDb
addInternalBuildTools PackageDescription
pkg_descr LocalBuildInfo
lbi BuildInfo
bi (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
        lbi' :: LocalBuildInfo
lbi' =
          LocalBuildInfo
lbi
            { withPrograms = progs'
            , withPackageDB = withPackageDB lbi ++ [internalPackageDB]
            , installedPkgs = index
            }

        runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()
        runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()
runPreBuildHooks LocalBuildInfo
lbi2 TargetInfo
tgt =
          let inputs :: PreBuildComponentInputs
inputs =
                SetupHooks.PreBuildComponentInputs
                  { buildingWhat :: BuildingWhat
SetupHooks.buildingWhat = HaddockFlags -> BuildingWhat
BuildHaddock HaddockFlags
flags
                  , localBuildInfo :: LocalBuildInfo
SetupHooks.localBuildInfo = LocalBuildInfo
lbi2
                  , targetInfo :: TargetInfo
SetupHooks.targetInfo = TargetInfo
tgt
                  }
           in Maybe PreBuildComponentRules
-> (PreBuildComponentRules -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe PreBuildComponentRules
mbPbcRules ((PreBuildComponentRules -> IO ()) -> IO ())
-> (PreBuildComponentRules -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PreBuildComponentRules
pbcRules -> do
                (ruleFromId, _mons) <- Verbosity
-> PreBuildComponentInputs
-> PreBuildComponentRules
-> IO (Map RuleId Rule, [MonitorFilePath])
forall env.
Verbosity
-> env -> Rules env -> IO (Map RuleId Rule, [MonitorFilePath])
SetupHooks.computeRules Verbosity
verbosity PreBuildComponentInputs
inputs PreBuildComponentRules
pbcRules
                SetupHooks.executeRules verbosity lbi2 tgt ruleFromId

      -- See Note [Hi Haddock Recompilation Avoidance]
      Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> Version
-> ((SymbolicPath Pkg ('Dir Artifacts),
     SymbolicPath Pkg ('Dir Artifacts),
     SymbolicPath Pkg ('Dir Artifacts))
    -> IO InstalledPackageIndex)
-> IO InstalledPackageIndex
forall r.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> Version
-> ((SymbolicPath Pkg ('Dir Artifacts),
     SymbolicPath Pkg ('Dir Artifacts),
     SymbolicPath Pkg ('Dir Artifacts))
    -> IO r)
-> IO r
reusingGHCCompilationArtifacts Verbosity
verbosity TempFileOptions
tmpFileOpts Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi Version
version (((SymbolicPath Pkg ('Dir Artifacts),
   SymbolicPath Pkg ('Dir Artifacts),
   SymbolicPath Pkg ('Dir Artifacts))
  -> IO InstalledPackageIndex)
 -> IO InstalledPackageIndex)
-> ((SymbolicPath Pkg ('Dir Artifacts),
     SymbolicPath Pkg ('Dir Artifacts),
     SymbolicPath Pkg ('Dir Artifacts))
    -> IO InstalledPackageIndex)
-> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$ \(SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
haddockArtifactsDirs -> do
        (LocalBuildInfo -> TargetInfo -> IO ())
-> Verbosity -> LocalBuildInfo -> TargetInfo -> IO ()
preBuildComponent LocalBuildInfo -> TargetInfo -> IO ()
runPreBuildHooks Verbosity
verbosity LocalBuildInfo
lbi' TargetInfo
target
        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
              exeArgs <-
                Verbosity
-> (SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts))
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> HaddockTarget
-> PackageDescription
-> Executable
-> HaddockArgs
-> IO HaddockArgs
fromExecutable
                  Verbosity
verbosity
                  (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
haddockArtifactsDirs
                  LocalBuildInfo
lbi'
                  ComponentLocalBuildInfo
clbi
                  Maybe PathTemplate
htmlTemplate
                  HaddockTarget
haddockTarget
                  PackageDescription
pkg_descr
                  Executable
exe
                  HaddockArgs
commonArgs
              runHaddock
                verbosity
                mbWorkDir
                tmpFileOpts
                comp
                platform
                haddockProg
                True
                exeArgs
            Maybe Executable
Nothing -> do
              Verbosity -> String -> IO ()
warn
                Verbosity
verbosity
                String
"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
-> String
-> PackageIdentifier
-> ComponentName
-> Maybe [(ModuleName, OpenModule)]
-> IO ()
forall a.
Pretty a =>
Verbosity
-> String
-> PackageIdentifier
-> ComponentName
-> Maybe [(ModuleName, a)]
-> IO ()
setupMessage'
              Verbosity
verbosity
              String
"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)
        ipi <- case Component
component of
          CLib Library
lib -> do
            IO ()
smsg
            libArgs <-
              Verbosity
-> (SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts))
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> HaddockTarget
-> PackageDescription
-> Library
-> HaddockArgs
-> IO HaddockArgs
fromLibrary
                Verbosity
verbosity
                (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
haddockArtifactsDirs
                LocalBuildInfo
lbi'
                ComponentLocalBuildInfo
clbi
                Maybe PathTemplate
htmlTemplate
                HaddockTarget
haddockTarget
                PackageDescription
pkg_descr
                Library
lib
                HaddockArgs
commonArgs
            runHaddock
              verbosity
              mbWorkDir
              tmpFileOpts
              comp
              platform
              haddockProg
              True
              libArgs
            inplaceDir <- absoluteWorkingDirLBI lbi

            let
              ipi =
                AbsolutePath ('Dir Pkg)
-> SymbolicPath Pkg ('Dir Dist)
-> PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstalledPackageInfo
inplaceInstalledPackageInfo
                  AbsolutePath ('Dir Pkg)
inplaceDir
                  ((HaddockFlags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> SymbolicPath Pkg ('Dir Dist)
forall {b}. (HaddockFlags -> Flag b) -> b
flag ((HaddockFlags -> Flag (SymbolicPath Pkg ('Dir Dist)))
 -> SymbolicPath Pkg ('Dir Dist))
-> (HaddockFlags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> SymbolicPath Pkg ('Dir Dist)
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref (CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> (HaddockFlags -> CommonSetupFlags)
-> HaddockFlags
-> Flag (SymbolicPath Pkg ('Dir Dist))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockFlags -> CommonSetupFlags
haddockCommonFlags)
                  PackageDescription
pkg_descr
                  (String -> AbiHash
mkAbiHash String
"inplace")
                  Library
lib
                  LocalBuildInfo
lbi'
                  ComponentLocalBuildInfo
clbi

            debug verbosity $
              "Registering inplace:\n"
                ++ (InstalledPackageInfo.showInstalledPackageInfo ipi)

            registerPackage
              verbosity
              (compiler lbi')
              (withPrograms lbi')
              mbWorkDir
              (withPackageDB lbi')
              ipi
              HcPkg.defaultRegisterOptions
                { HcPkg.registerMultiInstance = True
                }

            return $ PackageIndex.insert ipi index
          CFLib ForeignLib
flib ->
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
              ((HaddockFlags -> Flag Bool) -> Bool
forall {b}. (HaddockFlags -> Flag b) -> b
flag HaddockFlags -> Flag Bool
haddockForeignLibs)
              ( do
                  IO ()
smsg
                  flibArgs <-
                    Verbosity
-> (SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts))
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> HaddockTarget
-> PackageDescription
-> ForeignLib
-> HaddockArgs
-> IO HaddockArgs
fromForeignLib
                      Verbosity
verbosity
                      (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
haddockArtifactsDirs
                      LocalBuildInfo
lbi'
                      ComponentLocalBuildInfo
clbi
                      Maybe PathTemplate
htmlTemplate
                      HaddockTarget
haddockTarget
                      PackageDescription
pkg_descr
                      ForeignLib
flib
                      HaddockArgs
commonArgs
                  runHaddock
                    verbosity
                    mbWorkDir
                    tmpFileOpts
                    comp
                    platform
                    haddockProg
                    True
                    flibArgs
              )
              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 {b}. (HaddockFlags -> Flag b) -> b
flag HaddockFlags -> Flag Bool
haddockExecutables) (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
test -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Flag Bool) -> Bool
forall {b}. (HaddockFlags -> Flag b) -> b
flag HaddockFlags -> Flag Bool
haddockTestSuites) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              IO ()
smsg
              testArgs <-
                Verbosity
-> (SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts))
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> HaddockTarget
-> PackageDescription
-> TestSuite
-> HaddockArgs
-> IO HaddockArgs
fromTest
                  Verbosity
verbosity
                  (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
haddockArtifactsDirs
                  LocalBuildInfo
lbi'
                  ComponentLocalBuildInfo
clbi
                  Maybe PathTemplate
htmlTemplate
                  HaddockTarget
haddockTarget
                  PackageDescription
pkg_descr
                  TestSuite
test
                  HaddockArgs
commonArgs
              runHaddock
                verbosity
                mbWorkDir
                tmpFileOpts
                comp
                platform
                haddockProg
                True
                testArgs
            InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
index
          CBench Benchmark
bench -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Flag Bool) -> Bool
forall {b}. (HaddockFlags -> Flag b) -> b
flag HaddockFlags -> Flag Bool
haddockBenchmarks) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              IO ()
smsg
              benchArgs <-
                Verbosity
-> (SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts))
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> HaddockTarget
-> PackageDescription
-> Benchmark
-> HaddockArgs
-> IO HaddockArgs
fromBenchmark
                  Verbosity
verbosity
                  (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
haddockArtifactsDirs
                  LocalBuildInfo
lbi'
                  ComponentLocalBuildInfo
clbi
                  Maybe PathTemplate
htmlTemplate
                  HaddockTarget
haddockTarget
                  PackageDescription
pkg_descr
                  Benchmark
bench
                  HaddockArgs
commonArgs
              runHaddock
                verbosity
                mbWorkDir
                tmpFileOpts
                comp
                platform
                haddockProg
                True
                benchArgs
            InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
index

        return ipi

    for_ (extraDocFiles pkg_descr) $ \RelativePath Pkg 'File
fpath -> do
      files <- Verbosity
-> CabalSpecVersion
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> RelativePath Pkg 'File
-> IO [RelativePath Pkg 'File]
forall dir (allowAbs :: AllowAbsolute) (file :: FileOrDir).
Verbosity
-> CabalSpecVersion
-> Maybe (SymbolicPath CWD ('Dir dir))
-> SymbolicPathX allowAbs dir file
-> IO [SymbolicPathX allowAbs dir file]
matchDirFileGlob Verbosity
verbosity (PackageDescription -> CabalSpecVersion
specVersion PackageDescription
pkg_descr) Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir RelativePath Pkg 'File
fpath
      let targetDir = String -> Directory
Dir (String -> Directory) -> String -> Directory
forall a b. (a -> b) -> a -> b
$ Directory -> String
unDir' (HaddockArgs -> Directory
argOutputDir HaddockArgs
commonArgs) String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> HaddockTarget -> PackageDescription -> String
haddockDirName HaddockTarget
haddockTarget PackageDescription
pkg_descr
      for_ files $
        copyFileToCwd verbosity mbWorkDir (unDir targetDir)

-- | Execute 'Haddock' configured with 'HaddocksFlags'.  It is used to build
-- index and contents for documentation of multiple packages.
createHaddockIndex
  :: Verbosity
  -> ProgramDb
  -> Compiler
  -> Platform
  -> Maybe (SymbolicPath CWD (Path.Dir Pkg))
  -> HaddockProjectFlags
  -> IO ()
createHaddockIndex :: Verbosity
-> ProgramDb
-> Compiler
-> Platform
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> HaddockProjectFlags
-> IO ()
createHaddockIndex Verbosity
verbosity ProgramDb
programDb Compiler
comp Platform
platform Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir HaddockProjectFlags
flags = do
  let args :: HaddockArgs
args = HaddockProjectFlags -> HaddockArgs
fromHaddockProjectFlags HaddockProjectFlags
flags
  (haddockProg, _version) <-
    Verbosity
-> ProgramDb
-> Compiler
-> HaddockArgs
-> Flag Bool
-> IO (ConfiguredProgram, Version)
getHaddockProg Verbosity
verbosity ProgramDb
programDb Compiler
comp HaddockArgs
args (Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True)
  runHaddock verbosity mbWorkDir defaultTempFileOptions comp platform haddockProg False 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
    , argResourcesDir = haddockResourcesDir flags
    , argVerbose =
        maybe mempty (Any . (>= deafening))
          . flagToMaybe
          $ setupVerbosity commonFlags
    , argOutput =
        Flag $ case [Html | Flag True <- [haddockHtml flags]]
          ++ [Hoogle | Flag True <- [haddockHoogle flags]] of
          [] -> [Output
Html]
          [Output]
os -> [Output]
os
    , argOutputDir = maybe mempty (Dir . getSymbolicPath) . flagToMaybe $ setupDistPref commonFlags
    , argGhcOptions = mempty{ghcOptExtra = ghcArgs}
    , argUseUnicode = haddockUseUnicode flags
    }
  where
    ghcArgs :: [String]
ghcArgs = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [String] -> [String])
-> (HaddockFlags -> Maybe [String]) -> HaddockFlags -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, [String])] -> Maybe [String]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"ghc" ([(String, [String])] -> Maybe [String])
-> (HaddockFlags -> [(String, [String])])
-> HaddockFlags
-> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockFlags -> [(String, [String])]
haddockProgramArgs (HaddockFlags -> [String]) -> HaddockFlags -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockFlags
flags
    commonFlags :: CommonSetupFlags
commonFlags = HaddockFlags -> CommonSetupFlags
haddockCommonFlags HaddockFlags
flags

fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs
fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs
fromHaddockProjectFlags HaddockProjectFlags
flags =
  HaddockArgs
forall a. Monoid a => a
mempty
    { argOutputDir = Dir (fromFlag $ haddockProjectDir flags)
    , argQuickJump = Flag True
    , argGenContents = Flag True
    , argGenIndex = Flag True
    , argPrologueFile = haddockProjectPrologue flags
    , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags)
    , argLinkedSource = Flag True
    , argResourcesDir = haddockProjectResourcesDir flags
    }

fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs
fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs
fromPackageDescription HaddockTarget
_haddockTarget PackageDescription
pkg_descr =
  HaddockArgs
forall a. Monoid a => a
mempty
    { argInterfaceFile = Flag $ haddockPath pkg_descr
    , argPackageName = Flag $ packageId $ pkg_descr
    , argOutputDir = Dir $ "doc" </> "html"
    , 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 :: String
showPkg = PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)
    subtitle :: String
subtitle
      | ShortText -> Bool
ShortText.null (PackageDescription -> ShortText
synopsis PackageDescription
pkg_descr) = String
""
      | Bool
otherwise = String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShortText -> String
ShortText.fromShortText (PackageDescription -> ShortText
synopsis PackageDescription
pkg_descr)

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

{-
Note [Hi Haddock Recompilation Avoidance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Starting with Haddock 2.28, we no longer want to run Haddock's GHC session in
an arbitrary temporary directory. Doing so always causes recompilation during
documentation generation, which can now be avoided thanks to Hi Haddock.

Instead, we want to re-use the interface and object files produced by GHC.
We copy these intermediate files produced by GHC to temporary directories and
point haddock to them.

The reason why we can't use the GHC files /inplace/ is that haddock may have to
recompile (e.g. because of `haddock-options`). In that case, we want to be sure
the files produced by GHC do not get overwritten.

See https://github.com/haskell/cabal/pull/9177 for discussion.

(W.1) As it turns out, -stubdir is included in GHC's recompilation fingerprint.
This means that if we use a temporary directory for stubfiles produced by GHC
for the haddock invocation, haddock will trigger full recompilation since the
stubdir would be different.

So we don't use a temporary stubdir, despite the tmp o-dir and hi-dir:

We want to avoid at all costs haddock accidentally overwriting o-files and
hi-files (e.g. if a user specified haddock-option triggers recompilation), and
thus copy them to a temporary directory to pass them on to haddock. However,
stub files are much less problematic since ABI-incompatibility isn't at play
here, that is, there doesn't seem to be a GHC flag that could accidentally make
a stub file incompatible with the one produced by GHC from the same module.
-}

mkHaddockArgs
  :: Verbosity
  -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))
  -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.
  -- See Note [Hi Haddock Recompilation Avoidance]
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Maybe PathTemplate
  -- ^ template for HTML location
  -> [SymbolicPath Pkg File]
  -> BuildInfo
  -> IO HaddockArgs
mkHaddockArgs :: Verbosity
-> (SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts))
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> [SymbolicPath Pkg 'File]
-> BuildInfo
-> IO HaddockArgs
mkHaddockArgs Verbosity
verbosity (SymbolicPath Pkg ('Dir Artifacts)
tmpObjDir, SymbolicPath Pkg ('Dir Artifacts)
tmpHiDir, SymbolicPath Pkg ('Dir Artifacts)
tmpStubDir) LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate [SymbolicPath Pkg 'File]
inFiles BuildInfo
bi = do
  let
    vanillaOpts' :: GhcOptions
vanillaOpts' =
      Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Build)
-> GhcOptions
forall build.
Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
componentGhcOptions Verbosity
normal LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi (LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi)
    vanillaOpts :: GhcOptions
vanillaOpts =
      GhcOptions
vanillaOpts'
        { -- See Note [Hi Haddock Recompilation Avoidance]
          ghcOptObjDir = toFlag tmpObjDir
        , ghcOptHiDir = toFlag tmpHiDir
        , ghcOptStubDir = toFlag tmpStubDir
        }
    sharedOpts :: GhcOptions
sharedOpts =
      GhcOptions
vanillaOpts
        { ghcOptDynLinkMode = toFlag GhcDynamicOnly
        , ghcOptFPic = toFlag True
        , ghcOptHiSuffix = toFlag "dyn_hi"
        , ghcOptObjSuffix = toFlag "dyn_o"
        , ghcOptExtra = hcSharedOptions GHC bi
        }
  ifaceArgs <- Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO HaddockArgs
getInterfaces Verbosity
verbosity LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate
  opts <-
    if withVanillaLib lbi
      then return vanillaOpts
      else
        if withSharedLib lbi
          then return sharedOpts
          else dieWithException verbosity MustHaveSharedLibraries

  return
    ifaceArgs
      { argGhcOptions = opts
      , argTargets = map getSymbolicPath inFiles
      , argReexports = getReexports clbi
      }

fromLibrary
  :: Verbosity
  -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))
  -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.
  -- See Note [Hi Haddock Recompilation Avoidance]
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Maybe PathTemplate
  -- ^ template for HTML location
  -> HaddockTarget
  -> PackageDescription
  -> Library
  -> HaddockArgs
  -- ^ common args
  -> IO HaddockArgs
fromLibrary :: Verbosity
-> (SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts))
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> HaddockTarget
-> PackageDescription
-> Library
-> HaddockArgs
-> IO HaddockArgs
fromLibrary Verbosity
verbosity (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
haddockArtifactsDirs LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate HaddockTarget
haddockTarget PackageDescription
pkg_descr Library
lib HaddockArgs
commonArgs = do
  inFiles <- ((ModuleName, SymbolicPath Pkg 'File) -> SymbolicPath Pkg 'File)
-> [(ModuleName, SymbolicPath Pkg 'File)]
-> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, SymbolicPath Pkg 'File) -> SymbolicPath Pkg 'File
forall a b. (a, b) -> b
snd ([(ModuleName, SymbolicPath Pkg 'File)]
 -> [SymbolicPath Pkg 'File])
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
-> IO [SymbolicPath Pkg 'File]
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, SymbolicPath Pkg 'File)]
getLibSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi
  args <-
    mkHaddockArgs
      verbosity
      haddockArtifactsDirs
      lbi
      clbi
      htmlTemplate
      inFiles
      (libBuildInfo lib)
  let args' =
        HaddockArgs
commonArgs
          HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Semigroup a => a -> a -> a
<> HaddockArgs
args
            { argOutputDir =
                Dir $ haddockLibraryDirPath haddockTarget pkg_descr lib
            , argInterfaceFile = Flag $ haddockLibraryPath pkg_descr lib
            }
      args'' =
        HaddockArgs
args'
          { argHideModules = (mempty, otherModules (libBuildInfo lib))
          , argTitle = Flag $ haddockPackageLibraryName pkg_descr lib
          , argComponentName = toFlag (haddockPackageLibraryName' (pkgName (package pkg_descr)) (libName lib))
          , -- we need to accommodate for `argOutputDir`, see `haddockLibraryPath`
            argBaseUrl = case (libName lib, argBaseUrl args') of
              (LSubLibName UnqualComponentName
_, Flag String
url) -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
              (LibraryName
_, Flag String
a) -> Flag String
a
          , argContents = case (libName lib, argContents args') of
              (LSubLibName UnqualComponentName
_, Flag String
url) -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
              (LibraryName
_, Flag String
a) -> Flag String
a
          , argIndex = case (libName lib, argIndex args') of
              (LSubLibName UnqualComponentName
_, Flag String
url) -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
              (LibraryName
_, Flag String
a) -> Flag String
a
          }
  return args''

fromExecutable
  :: Verbosity
  -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))
  -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.
  -- See Note [Hi Haddock Recompilation Avoidance]
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Maybe PathTemplate
  -- ^ template for HTML location
  -> HaddockTarget
  -> PackageDescription
  -> Executable
  -> HaddockArgs
  -- ^ common args
  -> IO HaddockArgs
fromExecutable :: Verbosity
-> (SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts))
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> HaddockTarget
-> PackageDescription
-> Executable
-> HaddockArgs
-> IO HaddockArgs
fromExecutable Verbosity
verbosity (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
haddockArtifactsDirs LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate HaddockTarget
haddockTarget PackageDescription
pkg_descr Executable
exe HaddockArgs
commonArgs = do
  inFiles <- ((ModuleName, SymbolicPath Pkg 'File) -> SymbolicPath Pkg 'File)
-> [(ModuleName, SymbolicPath Pkg 'File)]
-> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, SymbolicPath Pkg 'File) -> SymbolicPath Pkg 'File
forall a b. (a, b) -> b
snd ([(ModuleName, SymbolicPath Pkg 'File)]
 -> [SymbolicPath Pkg 'File])
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
-> IO [SymbolicPath Pkg 'File]
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, SymbolicPath Pkg 'File)]
getExeSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Executable
exe ComponentLocalBuildInfo
clbi
  args <-
    mkHaddockArgs
      verbosity
      haddockArtifactsDirs
      lbi
      clbi
      htmlTemplate
      inFiles
      (buildInfo exe)
  let args' =
        HaddockArgs
commonArgs
          HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Semigroup a => a -> a -> a
<> HaddockArgs
args
            { argOutputDir =
                Dir $
                  haddockDirName haddockTarget pkg_descr
                    </> unUnqualComponentName (exeName exe)
            }
  return
    args'
      { argTitle = Flag $ unUnqualComponentName $ exeName exe
      , -- we need to accommodate `argOutputDir`
        argBaseUrl = case argBaseUrl args' of
          Flag String
url -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
          Flag String
NoFlag -> Flag String
forall a. Flag a
NoFlag
      , argContents = case argContents args' of
          Flag String
url -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
          Flag String
NoFlag -> Flag String
forall a. Flag a
NoFlag
      , argIndex = case argIndex args' of
          Flag String
url -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
          Flag String
NoFlag -> Flag String
forall a. Flag a
NoFlag
      }

fromTest
  :: Verbosity
  -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))
  -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.
  -- See Note [Hi Haddock Recompilation Avoidance]
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Maybe PathTemplate
  -- ^ template for HTML location
  -> HaddockTarget
  -> PackageDescription
  -> TestSuite
  -> HaddockArgs
  -- ^ common args
  -> IO HaddockArgs
fromTest :: Verbosity
-> (SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts))
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> HaddockTarget
-> PackageDescription
-> TestSuite
-> HaddockArgs
-> IO HaddockArgs
fromTest Verbosity
verbosity (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
haddockArtifactsDirs LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate HaddockTarget
haddockTarget PackageDescription
pkg_descr TestSuite
test HaddockArgs
commonArgs = do
  inFiles <- ((ModuleName, SymbolicPath Pkg 'File) -> SymbolicPath Pkg 'File)
-> [(ModuleName, SymbolicPath Pkg 'File)]
-> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, SymbolicPath Pkg 'File) -> SymbolicPath Pkg 'File
forall a b. (a, b) -> b
snd ([(ModuleName, SymbolicPath Pkg 'File)]
 -> [SymbolicPath Pkg 'File])
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
-> IO [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity
-> LocalBuildInfo
-> TestSuite
-> ComponentLocalBuildInfo
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
getTestSourceFiles Verbosity
verbosity LocalBuildInfo
lbi TestSuite
test ComponentLocalBuildInfo
clbi
  args <-
    mkHaddockArgs
      verbosity
      haddockArtifactsDirs
      lbi
      clbi
      htmlTemplate
      inFiles
      (testBuildInfo test)
  let args' =
        HaddockArgs
commonArgs
          HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Semigroup a => a -> a -> a
<> HaddockArgs
args
            { argOutputDir =
                Dir $
                  haddockDirName haddockTarget pkg_descr
                    </> unUnqualComponentName (testName test)
            }
  return
    args'
      { argTitle = Flag $ prettyShow (packageName pkg_descr)
      , argComponentName = Flag $ prettyShow (packageName pkg_descr) ++ ":" ++ unUnqualComponentName (testName test)
      , -- we need to accommodate `argOutputDir`
        argBaseUrl = case argBaseUrl args' of
          Flag String
url -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
          Flag String
NoFlag -> Flag String
forall a. Flag a
NoFlag
      , argContents = case argContents args' of
          Flag String
url -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
          Flag String
NoFlag -> Flag String
forall a. Flag a
NoFlag
      , argIndex = case argIndex args' of
          Flag String
url -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
          Flag String
NoFlag -> Flag String
forall a. Flag a
NoFlag
      }

fromBenchmark
  :: Verbosity
  -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))
  -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.
  -- See Note [Hi Haddock Recompilation Avoidance]
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Maybe PathTemplate
  -- ^ template for HTML location
  -> HaddockTarget
  -> PackageDescription
  -> Benchmark
  -> HaddockArgs
  -- ^ common args
  -> IO HaddockArgs
fromBenchmark :: Verbosity
-> (SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts))
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> HaddockTarget
-> PackageDescription
-> Benchmark
-> HaddockArgs
-> IO HaddockArgs
fromBenchmark Verbosity
verbosity (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
haddockArtifactsDirs LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate HaddockTarget
haddockTarget PackageDescription
pkg_descr Benchmark
bench HaddockArgs
commonArgs = do
  inFiles <- ((ModuleName, SymbolicPath Pkg 'File) -> SymbolicPath Pkg 'File)
-> [(ModuleName, SymbolicPath Pkg 'File)]
-> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, SymbolicPath Pkg 'File) -> SymbolicPath Pkg 'File
forall a b. (a, b) -> b
snd ([(ModuleName, SymbolicPath Pkg 'File)]
 -> [SymbolicPath Pkg 'File])
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
-> IO [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity
-> LocalBuildInfo
-> Benchmark
-> ComponentLocalBuildInfo
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
getBenchmarkSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Benchmark
bench ComponentLocalBuildInfo
clbi
  args <-
    mkHaddockArgs
      verbosity
      haddockArtifactsDirs
      lbi
      clbi
      htmlTemplate
      inFiles
      (benchmarkBuildInfo bench)
  let args' =
        HaddockArgs
commonArgs
          HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Semigroup a => a -> a -> a
<> HaddockArgs
args
            { argOutputDir =
                Dir $
                  haddockDirName haddockTarget pkg_descr
                    </> unUnqualComponentName (benchmarkName bench)
            }
  return
    args'
      { argTitle = Flag $ prettyShow (packageName pkg_descr)
      , argComponentName = Flag $ prettyShow (packageName pkg_descr) ++ ":" ++ unUnqualComponentName (benchmarkName bench)
      , -- we need to accommodate `argOutputDir`
        argBaseUrl = case argBaseUrl args' of
          Flag String
url -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
          Flag String
NoFlag -> Flag String
forall a. Flag a
NoFlag
      , argContents = case argContents args' of
          Flag String
url -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
          Flag String
NoFlag -> Flag String
forall a. Flag a
NoFlag
      , argIndex = case argIndex args' of
          Flag String
url -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
          Flag String
NoFlag -> Flag String
forall a. Flag a
NoFlag
      }

fromForeignLib
  :: Verbosity
  -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))
  -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.
  -- See Note [Hi Haddock Recompilation Avoidance]
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Maybe PathTemplate
  -- ^ template for HTML location
  -> HaddockTarget
  -> PackageDescription
  -> ForeignLib
  -> HaddockArgs
  -- ^ common args
  -> IO HaddockArgs
fromForeignLib :: Verbosity
-> (SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Artifacts))
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> HaddockTarget
-> PackageDescription
-> ForeignLib
-> HaddockArgs
-> IO HaddockArgs
fromForeignLib Verbosity
verbosity (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
haddockArtifactsDirs LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate HaddockTarget
haddockTarget PackageDescription
pkg_descr ForeignLib
flib HaddockArgs
commonArgs = do
  inFiles <- ((ModuleName, SymbolicPath Pkg 'File) -> SymbolicPath Pkg 'File)
-> [(ModuleName, SymbolicPath Pkg 'File)]
-> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, SymbolicPath Pkg 'File) -> SymbolicPath Pkg 'File
forall a b. (a, b) -> b
snd ([(ModuleName, SymbolicPath Pkg 'File)]
 -> [SymbolicPath Pkg 'File])
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
-> IO [SymbolicPath Pkg 'File]
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, SymbolicPath Pkg 'File)]
getFLibSourceFiles Verbosity
verbosity LocalBuildInfo
lbi ForeignLib
flib ComponentLocalBuildInfo
clbi
  args <-
    mkHaddockArgs
      verbosity
      haddockArtifactsDirs
      lbi
      clbi
      htmlTemplate
      inFiles
      (foreignLibBuildInfo flib)
  let args' =
        HaddockArgs
commonArgs
          HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Semigroup a => a -> a -> a
<> HaddockArgs
args
            { argOutputDir =
                Dir $
                  haddockDirName haddockTarget pkg_descr
                    </> unUnqualComponentName (foreignLibName flib)
            }
  return
    args'
      { argTitle = Flag $ unUnqualComponentName $ foreignLibName flib
      , -- we need to accommodate `argOutputDir`
        argBaseUrl = case argBaseUrl args' of
          Flag String
url -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
          Flag String
NoFlag -> Flag String
forall a. Flag a
NoFlag
      , argContents = case argContents args' of
          Flag String
url -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
          Flag String
NoFlag -> Flag String
forall a. Flag a
NoFlag
      , argIndex = case argIndex args' of
          Flag String
url -> String -> Flag String
forall a. a -> Flag a
Flag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String
".." String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
url
          Flag String
NoFlag -> Flag String
forall a. Flag a
NoFlag
      }

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
_ RelativePath Source 'File
f} ->
      Executable -> Maybe Executable
forall a. a -> Maybe a
Just
        Executable
          { exeName :: UnqualComponentName
exeName = TestSuite -> UnqualComponentName
testName TestSuite
test
          , modulePath :: RelativePath Source 'File
modulePath = RelativePath Source 'File
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
_ RelativePath Source 'File
f} ->
      Executable -> Maybe Executable
forall a. a -> Maybe a
Just
        Executable
          { exeName :: UnqualComponentName
exeName = Benchmark -> UnqualComponentName
benchmarkName Benchmark
bench
          , modulePath :: RelativePath Source 'File
modulePath = RelativePath Source 'File
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
  (packageFlags, warnings) <- Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO
     ([(String, Maybe String, Maybe String, Visibility)], Maybe String)
haddockPackageFlags Verbosity
verbosity LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate
  traverse_ (warn (verboseUnmarkOutput verbosity)) warnings
  return $
    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
_ = []

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

-- | If Hi Haddock is supported, this function creates temporary directories
-- and copies existing interface and object files produced by GHC into them,
-- then passes them off to the given continuation.
--
-- If Hi Haddock is _not_ supported, we can't re-use GHC's compilation files.
-- Instead, we use a clean temporary directory to the continuation,
-- with no hope for recompilation avoidance.
--
-- See Note [Hi Haddock Recompilation Avoidance]
reusingGHCCompilationArtifacts
  :: Verbosity
  -> TempFileOptions
  -> Maybe (SymbolicPath CWD (Path.Dir Pkg))
  -- ^ Working directory
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> Version
  -- ^ Haddock's version
  -> ((SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) -> IO r)
  -- ^ Continuation
  -> IO r
reusingGHCCompilationArtifacts :: forall r.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> Version
-> ((SymbolicPath Pkg ('Dir Artifacts),
     SymbolicPath Pkg ('Dir Artifacts),
     SymbolicPath Pkg ('Dir Artifacts))
    -> IO r)
-> IO r
reusingGHCCompilationArtifacts Verbosity
verbosity TempFileOptions
tmpFileOpts Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi Version
version (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
-> IO r
act
  | Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
2, Int
28, Int
0] = do
      Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Dist)
-> String
-> (SymbolicPath Pkg ('Dir Artifacts) -> IO r)
-> IO r
forall a tmpDir1 tmpDir2.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> String
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
withTempDirectoryCwdEx Verbosity
verbosity TempFileOptions
tmpFileOpts Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (LocalBuildInfo -> SymbolicPath Pkg ('Dir Dist)
distPrefLBI LocalBuildInfo
lbi) String
"haddock-objs" ((SymbolicPath Pkg ('Dir Artifacts) -> IO r) -> IO r)
-> (SymbolicPath Pkg ('Dir Artifacts) -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \SymbolicPath Pkg ('Dir Artifacts)
tmpObjDir ->
        Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Dist)
-> String
-> (SymbolicPath Pkg ('Dir Artifacts) -> IO r)
-> IO r
forall a tmpDir1 tmpDir2.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> String
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
withTempDirectoryCwdEx Verbosity
verbosity TempFileOptions
tmpFileOpts Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (LocalBuildInfo -> SymbolicPath Pkg ('Dir Dist)
distPrefLBI LocalBuildInfo
lbi) String
"haddock-his" ((SymbolicPath Pkg ('Dir Artifacts) -> IO r) -> IO r)
-> (SymbolicPath Pkg ('Dir Artifacts) -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \SymbolicPath Pkg ('Dir Artifacts)
tmpHiDir -> do
          -- Re-use ghc's interface and obj files, but first copy them to
          -- somewhere where it is safe if haddock overwrites them
          let
            vanillaOpts :: GhcOptions
vanillaOpts = Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Build)
-> GhcOptions
forall build.
Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
componentGhcOptions Verbosity
normal LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi (LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi)
            i :: SymbolicPathX allowAbsolute Pkg to -> String
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg to -> String
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
            copyDir :: (GhcOptions -> Flag (SymbolicPathX allowAbsolute Pkg to))
-> SymbolicPathX allowAbsolute Pkg to -> IO ()
copyDir GhcOptions -> Flag (SymbolicPathX allowAbsolute Pkg to)
ghcDir SymbolicPathX allowAbsolute Pkg to
tmpDir = Verbosity -> String -> String -> IO ()
copyDirectoryRecursive Verbosity
verbosity (SymbolicPathX allowAbsolute Pkg to -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i (SymbolicPathX allowAbsolute Pkg to -> String)
-> SymbolicPathX allowAbsolute Pkg to -> String
forall a b. (a -> b) -> a -> b
$ Flag (SymbolicPathX allowAbsolute Pkg to)
-> SymbolicPathX allowAbsolute Pkg to
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag (SymbolicPathX allowAbsolute Pkg to)
 -> SymbolicPathX allowAbsolute Pkg to)
-> Flag (SymbolicPathX allowAbsolute Pkg to)
-> SymbolicPathX allowAbsolute Pkg to
forall a b. (a -> b) -> a -> b
$ GhcOptions -> Flag (SymbolicPathX allowAbsolute Pkg to)
ghcDir GhcOptions
vanillaOpts) (SymbolicPathX allowAbsolute Pkg to -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i SymbolicPathX allowAbsolute Pkg to
tmpDir)
          (GhcOptions -> Flag (SymbolicPath Pkg ('Dir Artifacts)))
-> SymbolicPath Pkg ('Dir Artifacts) -> IO ()
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}
       {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
(GhcOptions -> Flag (SymbolicPathX allowAbsolute Pkg to))
-> SymbolicPathX allowAbsolute Pkg to -> IO ()
copyDir GhcOptions -> Flag (SymbolicPath Pkg ('Dir Artifacts))
ghcOptObjDir SymbolicPath Pkg ('Dir Artifacts)
tmpObjDir
          (GhcOptions -> Flag (SymbolicPath Pkg ('Dir Artifacts)))
-> SymbolicPath Pkg ('Dir Artifacts) -> IO ()
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}
       {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
(GhcOptions -> Flag (SymbolicPathX allowAbsolute Pkg to))
-> SymbolicPathX allowAbsolute Pkg to -> IO ()
copyDir GhcOptions -> Flag (SymbolicPath Pkg ('Dir Artifacts))
ghcOptHiDir SymbolicPath Pkg ('Dir Artifacts)
tmpHiDir
          -- copyDir ghcOptStubDir tmpStubDir -- (see W.1 in Note [Hi Haddock Recompilation Avoidance])

          (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
-> IO r
act (SymbolicPath Pkg ('Dir Artifacts)
tmpObjDir, SymbolicPath Pkg ('Dir Artifacts)
tmpHiDir, Flag (SymbolicPath Pkg ('Dir Artifacts))
-> SymbolicPath Pkg ('Dir Artifacts)
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag (SymbolicPath Pkg ('Dir Artifacts))
 -> SymbolicPath Pkg ('Dir Artifacts))
-> Flag (SymbolicPath Pkg ('Dir Artifacts))
-> SymbolicPath Pkg ('Dir Artifacts)
forall a b. (a -> b) -> a -> b
$ GhcOptions -> Flag (SymbolicPath Pkg ('Dir Artifacts))
ghcOptHiDir GhcOptions
vanillaOpts)
  | Bool
otherwise = do
      Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Dist)
-> String
-> (SymbolicPath Pkg ('Dir Artifacts) -> IO r)
-> IO r
forall a tmpDir1 tmpDir2.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> String
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
withTempDirectoryCwdEx Verbosity
verbosity TempFileOptions
tmpFileOpts Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (LocalBuildInfo -> SymbolicPath Pkg ('Dir Dist)
distPrefLBI LocalBuildInfo
lbi) String
"tmp" ((SymbolicPath Pkg ('Dir Artifacts) -> IO r) -> IO r)
-> (SymbolicPath Pkg ('Dir Artifacts) -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$
        \SymbolicPath Pkg ('Dir Artifacts)
tmpFallback -> (SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts),
 SymbolicPath Pkg ('Dir Artifacts))
-> IO r
act (SymbolicPath Pkg ('Dir Artifacts)
tmpFallback, SymbolicPath Pkg ('Dir Artifacts)
tmpFallback, SymbolicPath Pkg ('Dir Artifacts)
tmpFallback)

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

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

renderArgs
  :: forall a
   . Verbosity
  -> Maybe (SymbolicPath CWD (Path.Dir Pkg))
  -> TempFileOptions
  -> Version
  -> Compiler
  -> Platform
  -> HaddockArgs
  -> ([String] -> FilePath -> IO a)
  -> IO a
renderArgs :: forall a.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> TempFileOptions
-> Version
-> Compiler
-> Platform
-> HaddockArgs
-> ([String] -> String -> IO a)
-> IO a
renderArgs Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir TempFileOptions
tmpFileOpts Version
version Compiler
comp Platform
platform HaddockArgs
args [String] -> String -> 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 -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 4) -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 4)
forall {to2 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg to2
outputDir)
  let withPrologueArgs :: [String] -> IO a
withPrologueArgs [String]
prologueArgs =
        let renderedArgs :: [String]
renderedArgs = [String]
prologueArgs [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> Version -> Compiler -> Platform -> HaddockArgs -> [String]
renderPureArgs Version
version Compiler
comp Platform
platform HaddockArgs
args
         in if Bool
haddockSupportsResponseFiles
              then
                Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Response)
-> String
-> Maybe TextEncoding
-> [String]
-> (String -> IO a)
-> IO a
forall a.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Response)
-> String
-> Maybe TextEncoding
-> [String]
-> (String -> IO a)
-> IO a
withResponseFile
                  Verbosity
verbosity
                  TempFileOptions
tmpFileOpts
                  Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
                  SymbolicPath Pkg ('Dir Response)
forall {to2 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg to2
outputDir
                  String
"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)
                  [String]
renderedArgs
                  (\String
responseFileName -> [String] -> String -> IO a
k [String
"@" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
responseFileName] String
result)
              else [String] -> String -> IO a
k [String]
renderedArgs String
result
  case (HaddockArgs -> Flag String
argPrologueFile HaddockArgs
args, HaddockArgs -> Flag String
argPrologue HaddockArgs
args) of
    (Flag String
pfile, Flag String
_) ->
      [String] -> IO a
withPrologueArgs [String
"--prologue=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pfile]
    (Flag String
_, Flag String
prologueText) ->
      TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir (ZonkAny 5))
-> String
-> (SymbolicPath Pkg 'File -> Handle -> IO a)
-> IO a
forall a tmpDir.
TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir)
-> String
-> (SymbolicPath Pkg 'File -> Handle -> IO a)
-> IO a
withTempFileEx TempFileOptions
tmpFileOpts Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir (ZonkAny 5))
forall {to2 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg to2
outputDir String
"haddock-prologue.txt" ((SymbolicPath Pkg 'File -> Handle -> IO a) -> IO a)
-> (SymbolicPath Pkg 'File -> Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
        \SymbolicPath Pkg 'File
prologueFileName Handle
h -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
haddockSupportsUTF8 (Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8)
          Handle -> String -> IO ()
hPutStrLn Handle
h String
prologueText
          Handle -> IO ()
hClose Handle
h
          [String] -> IO a
withPrologueArgs [String
"--prologue=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg 'File -> String
forall (to :: FileOrDir). SymbolicPath Pkg to -> String
u SymbolicPath Pkg 'File
prologueFileName]
    (Flag String
NoFlag, Flag String
NoFlag) ->
      [String] -> IO a
withPrologueArgs []
  where
    -- See Note [Symbolic paths] in Distribution.Utils.Path
    i :: SymbolicPathX allowAbsolute Pkg to -> String
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg to -> String
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
    u :: SymbolicPath Pkg to -> FilePath
    u :: forall (to :: FileOrDir). SymbolicPath Pkg to -> String
u = SymbolicPathX 'AllowAbsolute Pkg to -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPathCWD

    outputDir :: SymbolicPathX 'AllowAbsolute Pkg to2
outputDir = SymbolicPath Pkg ('Dir Artifacts)
-> SymbolicPathX 'AllowAbsolute Pkg to2
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath (SymbolicPath Pkg ('Dir Artifacts)
 -> SymbolicPathX 'AllowAbsolute Pkg to2)
-> SymbolicPath Pkg ('Dir Artifacts)
-> SymbolicPathX 'AllowAbsolute Pkg to2
forall a b. (a -> b) -> a -> b
$ Directory -> SymbolicPath Pkg ('Dir Artifacts)
unDir (Directory -> SymbolicPath Pkg ('Dir Artifacts))
-> Directory -> SymbolicPath Pkg ('Dir Artifacts)
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Directory
argOutputDir HaddockArgs
args
    isNotArgContents :: Bool
isNotArgContents = Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> Maybe String) -> Flag String -> Maybe String
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Flag String
argContents HaddockArgs
args)
    isNotArgIndex :: Bool
isNotArgIndex = Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> Maybe String) -> Flag String -> Maybe String
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Flag String
argIndex HaddockArgs
args)
    isArgGenIndex :: Bool
isArgGenIndex = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockArgs -> Flag Bool
argGenIndex HaddockArgs
args)
    -- Haddock, when generating HTML, does not generate an index if the options
    -- --use-contents or --use-index are passed to it. See
    -- https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-use-contents
    isIndexGenerated :: Bool
isIndexGenerated = Bool
isArgGenIndex Bool -> Bool -> Bool
&& Bool
isNotArgContents Bool -> Bool -> Bool
&& Bool
isNotArgIndex
    result :: String
result =
      String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", "
        ([String] -> String)
-> (HaddockArgs -> [String]) -> HaddockArgs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Output -> String) -> [Output] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \Output
o ->
              SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 3) -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 3)
forall {to2 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg to2
outputDir
                String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> case Output
o of
                  Output
Html
                    | Bool
isIndexGenerated ->
                        String
"index.html"
                  Output
Html
                    | Bool
otherwise ->
                        String
forall a. Monoid a => a
mempty
                  Output
Hoogle -> String
pkgstr String -> ShowS
forall p. FileLike p => p -> String -> p
<.> String
"txt"
          )
        ([Output] -> [String])
-> (HaddockArgs -> [Output]) -> HaddockArgs -> [String]
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 -> String) -> HaddockArgs -> String
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
      where
        pkgstr :: String
pkgstr = PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageName -> String) -> PackageName -> String
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 {b}. (HaddockArgs -> Flag b) -> b
arg HaddockArgs -> Flag PackageIdentifier
argPackageName
    arg :: (HaddockArgs -> Flag b) -> b
arg HaddockArgs -> Flag b
f = Flag b -> b
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag b -> b) -> Flag b -> b
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Flag b
f HaddockArgs
args

renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String]
renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String]
renderPureArgs Version
version Compiler
comp Platform
platform HaddockArgs
args =
  [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
f -> String
"--dump-interface=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Artifacts) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
u (Directory -> SymbolicPath Pkg ('Dir Artifacts)
unDir (HaddockArgs -> Directory
argOutputDir HaddockArgs
args)) String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
f)
        ([String] -> [String])
-> (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag String -> [String]
forall a. Flag a -> [a]
flagToList
        (Flag String -> [String])
-> (HaddockArgs -> Flag String) -> HaddockArgs -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag String
argInterfaceFile
        (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , if Bool
haddockSupportsPackageName
        then
          [String]
-> (PackageIdentifier -> [String])
-> Maybe PackageIdentifier
-> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            []
            ( \PackageIdentifier
pkg ->
                [ String
"--package-name="
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ case HaddockArgs -> Flag String
argComponentName HaddockArgs
args of
                      Flag String
name -> String
name
                      Flag String
_ -> PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkg)
                , String
"--package-version=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> Version
pkgVersion PackageIdentifier
pkg)
                ]
            )
            (Maybe PackageIdentifier -> [String])
-> (HaddockArgs -> Maybe PackageIdentifier)
-> HaddockArgs
-> [String]
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 -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
        else []
    , [String
"--since-qual=external" | Int -> Int -> Bool
isVersion Int
2 Int
20]
    , [ String
"--quickjump" | Int -> Int -> Bool
isVersion Int
2 Int
19, 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
argQuickJump (HaddockArgs -> [Bool]) -> HaddockArgs -> [Bool]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
      ]
    , [String
"--hyperlinked-source" | Bool
isHyperlinkedSource]
    , (\(All Bool
b, [ModuleName]
xs) -> [String] -> [String] -> Bool -> [String]
forall a. a -> a -> Bool -> a
bool [] ((ModuleName -> String) -> [ModuleName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"--hide=" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (ModuleName -> String) -> ModuleName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
forall a. Pretty a => a -> String
prettyShow) [ModuleName]
xs) Bool
b)
        ((All, [ModuleName]) -> [String])
-> (HaddockArgs -> (All, [ModuleName])) -> HaddockArgs -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> (All, [ModuleName])
argHideModules
        (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [String] -> [String] -> Bool -> [String]
forall a. a -> a -> Bool -> a
bool [] [String
"--ignore-all-exports"] (Bool -> [String])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [String]
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 -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , -- Haddock's --source-* options are ignored once --hyperlinked-source is
      -- set.
      -- See https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-hyperlinked-source
      -- To avoid Haddock's warning, we only set --source-* options if
      -- --hyperlinked-source is not set.
      if Bool
isHyperlinkedSource
        then []
        else
          [String]
-> ((String, String, String) -> [String])
-> Maybe (String, String, String)
-> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            []
            ( \(String
m, String
e, String
l) ->
                [ String
"--source-module=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
m
                , String
"--source-entity=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e
                ]
                  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ if Int -> Int -> Bool
isVersion Int
2 Int
14
                    then [String
"--source-entity-line=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l]
                    else []
            )
            (Maybe (String, String, String) -> [String])
-> (HaddockArgs -> Maybe (String, String, String))
-> HaddockArgs
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag (String, String, String) -> Maybe (String, String, String)
forall a. Flag a -> Maybe a
flagToMaybe
            (Flag (String, String, String) -> Maybe (String, String, String))
-> (HaddockArgs -> Flag (String, String, String))
-> HaddockArgs
-> Maybe (String, String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag (String, String, String)
argLinkSource
            (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((String -> [String] -> [String]
forall a. a -> [a] -> [a]
: []) (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"--css=" String -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe String -> [String])
-> (HaddockArgs -> Maybe String) -> HaddockArgs -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> Maybe String)
-> (HaddockArgs -> Flag String) -> HaddockArgs -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag String
argCssFile (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((String -> [String] -> [String]
forall a. a -> [a] -> [a]
: []) (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"--use-contents=" String -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe String -> [String])
-> (HaddockArgs -> Maybe String) -> HaddockArgs -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> Maybe String)
-> (HaddockArgs -> Flag String) -> HaddockArgs -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag String
argContents (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [String] -> [String] -> Bool -> [String]
forall a. a -> a -> Bool -> a
bool [] [String
"--gen-contents"] (Bool -> [String])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [String]
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 -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((String -> [String] -> [String]
forall a. a -> [a] -> [a]
: []) (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"--use-index=" String -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe String -> [String])
-> (HaddockArgs -> Maybe String) -> HaddockArgs -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> Maybe String)
-> (HaddockArgs -> Flag String) -> HaddockArgs -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag String
argIndex (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [String] -> [String] -> Bool -> [String]
forall a. a -> a -> Bool -> a
bool [] [String
"--gen-index"] (Bool -> [String])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [String]
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 -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((String -> [String] -> [String]
forall a. a -> [a] -> [a]
: []) (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"--base-url=" String -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe String -> [String])
-> (HaddockArgs -> Maybe String) -> HaddockArgs -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> Maybe String)
-> (HaddockArgs -> Flag String) -> HaddockArgs -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag String
argBaseUrl (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [String] -> [String] -> Bool -> [String]
forall a. a -> a -> Bool -> a
bool [String
verbosityFlag] [] (Bool -> [String])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [String]
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 -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , (Output -> String) -> [Output] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Output
o -> case Output
o of Output
Hoogle -> String
"--hoogle"; Output
Html -> String
"--html")
        ([Output] -> [String])
-> (HaddockArgs -> [Output]) -> HaddockArgs -> [String]
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 -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [(String, Maybe String, Maybe String, Visibility)] -> [String]
renderInterfaces ([(String, Maybe String, Maybe String, Visibility)] -> [String])
-> (HaddockArgs
    -> [(String, Maybe String, Maybe String, Visibility)])
-> HaddockArgs
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> [(String, Maybe String, Maybe String, Visibility)]
argInterfaces (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , (String -> [String] -> [String]
forall a. a -> [a] -> [a]
: []) (String -> [String])
-> (HaddockArgs -> String) -> HaddockArgs -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"--odir=" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (HaddockArgs -> String) -> HaddockArgs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg ('Dir Artifacts) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
u (SymbolicPath Pkg ('Dir Artifacts) -> String)
-> (HaddockArgs -> SymbolicPath Pkg ('Dir Artifacts))
-> HaddockArgs
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directory -> SymbolicPath Pkg ('Dir Artifacts)
unDir (Directory -> SymbolicPath Pkg ('Dir Artifacts))
-> (HaddockArgs -> Directory)
-> HaddockArgs
-> SymbolicPath Pkg ('Dir Artifacts)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Directory
argOutputDir (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        []
        ( (String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [])
            (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"--title=" String -> ShowS
forall a. [a] -> [a] -> [a]
++)
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( ShowS -> ShowS -> Bool -> ShowS
forall a. a -> a -> Bool -> a
bool
                  ShowS
forall a. a -> a
id
                  (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (internal documentation)")
                  (Any -> Bool
getAny (Any -> Bool) -> Any -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Any
argIgnoreExports HaddockArgs
args)
              )
        )
        (Maybe String -> [String])
-> (HaddockArgs -> Maybe String) -> HaddockArgs -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe
        (Flag String -> Maybe String)
-> (HaddockArgs -> Flag String) -> HaddockArgs -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag String
argTitle
        (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [ String
"--optghc=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
opt | let opts :: GhcOptions
opts = HaddockArgs -> GhcOptions
argGhcOptions HaddockArgs
args, String
opt <- Compiler -> Platform -> GhcOptions -> [String]
renderGhcOptions Compiler
comp Platform
platform GhcOptions
opts
      ]
    , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
l -> [String
"-B" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l]) (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$
        Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (HaddockArgs -> Flag String
argGhcLibDir HaddockArgs
args) -- error if Nothing?
    , -- https://github.com/haskell/haddock/pull/547
      [ String
"--reexport=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ OpenModule -> String
forall a. Pretty a => a -> String
prettyShow OpenModule
r
      | OpenModule
r <- HaddockArgs -> [OpenModule]
argReexports HaddockArgs
args
      , Int -> Int -> Bool
isVersion Int
2 Int
19
      ]
    , HaddockArgs -> [String]
argTargets (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((String -> [String] -> [String]
forall a. a -> [a] -> [a]
: []) (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
resourcesDirFlag String -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe String -> [String])
-> (HaddockArgs -> Maybe String) -> HaddockArgs -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> Maybe String)
-> (HaddockArgs -> Flag String) -> HaddockArgs -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag String
argResourcesDir (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , -- Do not re-direct compilation output to a temporary directory (--no-tmp-comp-dir)
      -- We pass this option by default to haddock to avoid recompilation
      -- See Note [Hi Haddock Recompilation Avoidance]
      [String
"--no-tmp-comp-dir" | Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
2, Int
28, Int
0]]
    , [String] -> [String] -> Bool -> [String]
forall a. a -> a -> Bool -> a
bool [] [String
"--use-unicode"] (Bool -> [String])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [String]
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
argUseUnicode (HaddockArgs -> [String]) -> HaddockArgs -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    ]
  where
    -- See Note [Symbolic paths] in Distribution.Utils.Path
    u :: SymbolicPathX allowAbsolute from to -> String
u = SymbolicPathX allowAbsolute from to -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPathCWD
    renderInterfaces :: [(String, Maybe String, Maybe String, Visibility)] -> [String]
renderInterfaces = ((String, Maybe String, Maybe String, Visibility) -> String)
-> [(String, Maybe String, Maybe String, Visibility)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe String, Maybe String, Visibility) -> String
renderInterface

    renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> String
    renderInterface :: (String, Maybe String, Maybe String, Visibility) -> String
renderInterface (String
i, Maybe String
html, Maybe String
hypsrc, Visibility
visibility) =
      String
"--read-interface="
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
          String
","
          ( [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
html]
              , -- only render hypsrc path if html path
                -- is given and hyperlinked-source is
                -- enabled

                [ case (Maybe String
html, Maybe String
hypsrc) of
                    (Maybe String
Nothing, Maybe String
_) -> String
""
                    (Maybe String
_, Maybe String
Nothing) -> String
""
                    (Maybe String
_, Just String
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 ->
                          String
x
                      | Bool
otherwise ->
                          String
""
                ]
              , if Bool
haddockSupportsVisibility
                  then
                    [ case Visibility
visibility of
                        Visibility
Visible -> String
"visible"
                        Visibility
Hidden -> String
"hidden"
                    ]
                  else []
              , [String
i]
              ]
          )

    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 :: String
verbosityFlag
      | Int -> Int -> Bool
isVersion Int
2 Int
5 = String
"--verbosity=1"
      | Bool
otherwise = String
"--verbose"
    resourcesDirFlag :: String
resourcesDirFlag
      | Int -> Int -> Bool
isVersion Int
2 Int
29 = String
"--resources-dir="
      | Bool
otherwise = String
"--lib="
    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]
    haddockSupportsHyperlinkedSource :: Bool
haddockSupportsHyperlinkedSource = Int -> Int -> Bool
isVersion Int
2 Int
17
    isHyperlinkedSource :: Bool
isHyperlinkedSource =
      Bool
haddockSupportsHyperlinkedSource
        Bool -> Bool -> Bool
&& Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockArgs -> Flag Bool
argLinkedSource HaddockArgs
args)

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

-- | 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 -> String)
-> IO
     ([(String, Maybe String, Maybe String, Visibility)], Maybe String)
haddockPackagePaths [InstalledPackageInfo]
ipkgs Maybe (InstalledPackageInfo -> String)
mkHtmlPath = do
  interfaces <-
    [IO
   (Either
      PackageIdentifier
      (String, Maybe String, Maybe String, Visibility))]
-> IO
     [Either
        PackageIdentifier (String, Maybe String, Maybe String, 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 (String, Maybe String)
interfaceAndHtmlPath InstalledPackageInfo
ipkg of
        Maybe (String, Maybe String)
Nothing -> do
          Either
  PackageIdentifier (String, Maybe String, Maybe String, Visibility)
-> IO
     (Either
        PackageIdentifier (String, Maybe String, Maybe String, Visibility))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageIdentifier
-> Either
     PackageIdentifier (String, Maybe String, Maybe String, Visibility)
forall a b. a -> Either a b
Left (InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId InstalledPackageInfo
ipkg))
        Just (String
interface, Maybe String
html) -> do
          (html', hypsrc') <-
            case Maybe String
html of
              Just String
htmlPath -> do
                let hypSrcPath :: String
hypSrcPath = String
htmlPath String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
defaultHyperlinkedSourceDirectory
                hypSrcExists <- String -> IO Bool
doesDirectoryExist String
hypSrcPath
                return $
                  ( Just (fixFileUrl htmlPath)
                  , if hypSrcExists
                      then Just (fixFileUrl hypSrcPath)
                      else Nothing
                  )
              Maybe String
Nothing -> (Maybe String, Maybe String) -> IO (Maybe String, Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
forall a. Maybe a
Nothing, Maybe String
forall a. Maybe a
Nothing)

          exists <- doesFileExist interface
          if exists
            then return (Right (interface, html', hypsrc', Visible))
            else return (Left 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
pkgid | Left PackageIdentifier
pkgid <- [Either
   PackageIdentifier (String, Maybe String, Maybe String, Visibility)]
interfaces]
      warning =
        String
"The documentation for the following packages are not "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"installed. No links will be generated to these packages: "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow [PackageIdentifier]
missing)
      flags = [Either
   PackageIdentifier (String, Maybe String, Maybe String, Visibility)]
-> [(String, Maybe String, Maybe String, Visibility)]
forall a b. [Either a b] -> [b]
rights [Either
   PackageIdentifier (String, Maybe String, Maybe String, Visibility)]
interfaces

  return (flags, if null missing then Nothing else Just warning)
  where
    -- Don't warn about missing documentation for these packages. See #1231.
    noHaddockWhitelist :: [PackageName]
noHaddockWhitelist = (String -> PackageName) -> [String] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map String -> PackageName
mkPackageName [String
"rts"]

    -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.
    interfaceAndHtmlPath
      :: InstalledPackageInfo
      -> Maybe (FilePath, Maybe FilePath)
    interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (String, Maybe String)
interfaceAndHtmlPath InstalledPackageInfo
pkg = do
      interface <- [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe (InstalledPackageInfo -> [String]
InstalledPackageInfo.haddockInterfaces InstalledPackageInfo
pkg)
      html <- case mkHtmlPath of
        Maybe (InstalledPackageInfo -> String)
Nothing -> [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe (InstalledPackageInfo -> [String]
InstalledPackageInfo.haddockHTMLs InstalledPackageInfo
pkg)
        Just InstalledPackageInfo -> String
mkPath -> String -> Maybe String
forall a. a -> Maybe a
Just (InstalledPackageInfo -> String
mkPath InstalledPackageInfo
pkg)
      return (interface, if null html then Nothing else Just 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 String
f
      | Maybe (InstalledPackageInfo -> String)
Nothing <- Maybe (InstalledPackageInfo -> String)
mkHtmlPath
      , String -> Bool
isAbsolute String
f =
          String
"file://" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f
      | Bool
otherwise = String
f

    -- 'src' is the default hyperlinked source directory ever since. It is
    -- not possible to configure that directory in any way in haddock.
    defaultHyperlinkedSourceDirectory :: String
defaultHyperlinkedSourceDirectory = String
"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
     ([(String, Maybe String, Maybe String, Visibility)], Maybe String)
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)
  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 -> CabalException -> IO InstalledPackageIndex
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO InstalledPackageIndex)
-> CabalException -> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$ [(InstalledPackageInfo, [UnitId])] -> CabalException
HaddockPackageFlags [(InstalledPackageInfo, [UnitId])]
inf

  haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath
  where
    mkHtmlPath :: Maybe (InstalledPackageInfo -> String)
mkHtmlPath = (PathTemplate -> InstalledPackageInfo -> String)
-> Maybe PathTemplate -> Maybe (InstalledPackageInfo -> String)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> InstalledPackageInfo -> String
forall {pkg}. Package pkg => PathTemplate -> pkg -> String
expandTemplateVars Maybe PathTemplate
htmlTemplate
    expandTemplateVars :: PathTemplate -> pkg -> String
expandTemplateVars PathTemplate
tmpl pkg
pkg =
      PathTemplate -> String
fromPathTemplate (PathTemplate -> String)
-> (PathTemplate -> PathTemplate) -> PathTemplate -> String
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 -> String) -> PathTemplate -> String
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 = BuildHooks
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour_setupHooks BuildHooks
noBuildHooks

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

hscolour'
  :: BuildHooks
  -> (String -> IO ())
  -- ^ Called when the 'hscolour' exe is not found.
  -> HaddockTarget
  -> PackageDescription
  -> LocalBuildInfo
  -> [PPSuffixHandler]
  -> HscolourFlags
  -> IO ()
hscolour' :: BuildHooks
-> (String -> IO ())
-> HaddockTarget
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour'
  (BuildHooks{preBuildComponentRules :: BuildHooks -> Maybe PreBuildComponentRules
preBuildComponentRules = Maybe PreBuildComponentRules
mbPbcRules})
  String -> IO ()
onNoHsColour
  HaddockTarget
haddockTarget
  PackageDescription
pkg_descr
  LocalBuildInfo
lbi
  [PPSuffixHandler]
suffixes
  HscolourFlags
flags =
    (CabalException -> IO ())
-> ((ConfiguredProgram, Version, ProgramDb) -> IO ())
-> Either CabalException (ConfiguredProgram, Version, ProgramDb)
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\CabalException
excep -> String -> IO ()
onNoHsColour (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ CabalException -> String
exceptionMessage CabalException
excep) (\(ConfiguredProgram
hscolourProg, Version
_, ProgramDb
_) -> ConfiguredProgram -> IO ()
go ConfiguredProgram
hscolourProg)
      (Either CabalException (ConfiguredProgram, Version, ProgramDb)
 -> IO ())
-> IO
     (Either CabalException (ConfiguredProgram, Version, ProgramDb))
-> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO
     (Either CabalException (ConfiguredProgram, Version, ProgramDb))
lookupProgramVersion
        Verbosity
verbosity
        Program
hscolourProgram
        (Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
1, Int
8]))
        (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
    where
      common :: CommonSetupFlags
common = HscolourFlags -> CommonSetupFlags
hscolourCommonFlags HscolourFlags
flags
      verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag Verbosity
setupVerbosity CommonSetupFlags
common
      distPref :: SymbolicPath Pkg ('Dir Dist)
distPref = Flag (SymbolicPath Pkg ('Dir Dist)) -> SymbolicPath Pkg ('Dir Dist)
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag (SymbolicPath Pkg ('Dir Dist))
 -> SymbolicPath Pkg ('Dir Dist))
-> Flag (SymbolicPath Pkg ('Dir Dist))
-> SymbolicPath Pkg ('Dir Dist)
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref CommonSetupFlags
common
      mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi
      i :: SymbolicPathX allowAbsolute Pkg to -> String
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> String
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> String
interpretSymbolicPathLBI LocalBuildInfo
lbi -- See Note [Symbolic paths] in Distribution.Utils.Path
      u :: SymbolicPath Pkg to -> FilePath
      u :: forall (to :: FileOrDir). SymbolicPath Pkg to -> String
u = SymbolicPathX 'AllowAbsolute Pkg to -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPathCWD

      go :: ConfiguredProgram -> IO ()
      go :: ConfiguredProgram -> IO ()
go ConfiguredProgram
hscolourProg = do
        Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"the 'cabal hscolour' command is deprecated in favour of 'cabal "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"haddock --hyperlink-source' and will be removed in the next major "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"release."

        Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage Verbosity
verbosity String
"Running hscolour for" (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)
        Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          SymbolicPath Pkg ('Dir Artifacts) -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i (SymbolicPath Pkg ('Dir Artifacts) -> String)
-> SymbolicPath Pkg ('Dir Artifacts) -> String
forall a b. (a -> b) -> a -> b
$
            HaddockTarget
-> SymbolicPath Pkg ('Dir Dist)
-> PackageDescription
-> SymbolicPath Pkg ('Dir Artifacts)
forall root.
HaddockTarget
-> SymbolicPath root ('Dir Dist)
-> PackageDescription
-> SymbolicPath root ('Dir Artifacts)
hscolourPref HaddockTarget
haddockTarget SymbolicPath Pkg ('Dir Dist)
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
          let tgt :: TargetInfo
tgt = ComponentLocalBuildInfo -> Component -> TargetInfo
TargetInfo ComponentLocalBuildInfo
clbi Component
comp
              runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()
              runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()
runPreBuildHooks LocalBuildInfo
lbi2 TargetInfo
target =
                let inputs :: PreBuildComponentInputs
inputs =
                      SetupHooks.PreBuildComponentInputs
                        { buildingWhat :: BuildingWhat
SetupHooks.buildingWhat = HscolourFlags -> BuildingWhat
BuildHscolour HscolourFlags
flags
                        , localBuildInfo :: LocalBuildInfo
SetupHooks.localBuildInfo = LocalBuildInfo
lbi2
                        , targetInfo :: TargetInfo
SetupHooks.targetInfo = TargetInfo
target
                        }
                 in Maybe PreBuildComponentRules
-> (PreBuildComponentRules -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe PreBuildComponentRules
mbPbcRules ((PreBuildComponentRules -> IO ()) -> IO ())
-> (PreBuildComponentRules -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PreBuildComponentRules
pbcRules -> do
                      (ruleFromId, _mons) <- Verbosity
-> PreBuildComponentInputs
-> PreBuildComponentRules
-> IO (Map RuleId Rule, [MonitorFilePath])
forall env.
Verbosity
-> env -> Rules env -> IO (Map RuleId Rule, [MonitorFilePath])
SetupHooks.computeRules Verbosity
verbosity PreBuildComponentInputs
inputs PreBuildComponentRules
pbcRules
                      SetupHooks.executeRules verbosity lbi2 tgt ruleFromId
          (LocalBuildInfo -> TargetInfo -> IO ())
-> Verbosity -> LocalBuildInfo -> TargetInfo -> IO ()
preBuildComponent LocalBuildInfo -> TargetInfo -> IO ()
runPreBuildHooks Verbosity
verbosity LocalBuildInfo
lbi TargetInfo
tgt
          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 :: SymbolicPathX 'AllowAbsolute Pkg c3
outputDir =
                      HaddockTarget
-> SymbolicPath Pkg ('Dir Dist)
-> PackageDescription
-> SymbolicPath Pkg ('Dir Artifacts)
forall root.
HaddockTarget
-> SymbolicPath root ('Dir Dist)
-> PackageDescription
-> SymbolicPath root ('Dir Artifacts)
hscolourPref HaddockTarget
haddockTarget SymbolicPath Pkg ('Dir Dist)
distPref PackageDescription
pkg_descr
                        SymbolicPath Pkg ('Dir Artifacts)
-> RelativePath Artifacts c3 -> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Artifacts c3
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx (UnqualComponentName -> String
unUnqualComponentName (Executable -> UnqualComponentName
exeName Executable
exe) String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
"src")
                ConfiguredProgram
-> SymbolicPath Pkg (ZonkAny 0)
-> [(ModuleName, SymbolicPath Pkg 'File)]
-> IO ()
forall (to :: FileOrDir) (to1 :: FileOrDir).
ConfiguredProgram
-> SymbolicPath Pkg to
-> [(ModuleName, SymbolicPath Pkg to1)]
-> IO ()
runHsColour ConfiguredProgram
hscolourProg SymbolicPath Pkg (ZonkAny 0)
forall {to2 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg to2
outputDir ([(ModuleName, SymbolicPath Pkg 'File)] -> IO ())
-> IO [(ModuleName, SymbolicPath Pkg 'File)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
getExeSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Executable
exe ComponentLocalBuildInfo
clbi
              Maybe Executable
Nothing -> do
                Verbosity -> String -> IO ()
warn Verbosity
verbosity String
"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 :: SymbolicPathX 'AllowAbsolute Pkg c3
outputDir = HaddockTarget
-> SymbolicPath Pkg ('Dir Dist)
-> PackageDescription
-> SymbolicPath Pkg ('Dir Artifacts)
forall root.
HaddockTarget
-> SymbolicPath root ('Dir Dist)
-> PackageDescription
-> SymbolicPath root ('Dir Artifacts)
hscolourPref HaddockTarget
haddockTarget SymbolicPath Pkg ('Dir Dist)
distPref PackageDescription
pkg_descr SymbolicPath Pkg ('Dir Artifacts)
-> RelativePath Artifacts c3 -> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Artifacts c3
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx String
"src"
              ConfiguredProgram
-> SymbolicPath Pkg (ZonkAny 1)
-> [(ModuleName, SymbolicPath Pkg 'File)]
-> IO ()
forall (to :: FileOrDir) (to1 :: FileOrDir).
ConfiguredProgram
-> SymbolicPath Pkg to
-> [(ModuleName, SymbolicPath Pkg to1)]
-> IO ()
runHsColour ConfiguredProgram
hscolourProg SymbolicPath Pkg (ZonkAny 1)
forall {to2 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg to2
outputDir ([(ModuleName, SymbolicPath Pkg 'File)] -> IO ())
-> IO [(ModuleName, SymbolicPath Pkg 'File)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
getLibSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi
            CFLib ForeignLib
flib -> do
              let outputDir :: SymbolicPathX 'AllowAbsolute Pkg c3
outputDir =
                    HaddockTarget
-> SymbolicPath Pkg ('Dir Dist)
-> PackageDescription
-> SymbolicPath Pkg ('Dir Artifacts)
forall root.
HaddockTarget
-> SymbolicPath root ('Dir Dist)
-> PackageDescription
-> SymbolicPath root ('Dir Artifacts)
hscolourPref HaddockTarget
haddockTarget SymbolicPath Pkg ('Dir Dist)
distPref PackageDescription
pkg_descr
                      SymbolicPath Pkg ('Dir Artifacts)
-> RelativePath Artifacts c3 -> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Artifacts c3
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx
                        ( UnqualComponentName -> String
unUnqualComponentName (ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib)
                            String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
"src"
                        )
              ConfiguredProgram
-> SymbolicPath Pkg (ZonkAny 2)
-> [(ModuleName, SymbolicPath Pkg 'File)]
-> IO ()
forall (to :: FileOrDir) (to1 :: FileOrDir).
ConfiguredProgram
-> SymbolicPath Pkg to
-> [(ModuleName, SymbolicPath Pkg to1)]
-> IO ()
runHsColour ConfiguredProgram
hscolourProg SymbolicPath Pkg (ZonkAny 2)
forall {to2 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg to2
outputDir ([(ModuleName, SymbolicPath Pkg 'File)] -> IO ())
-> IO [(ModuleName, SymbolicPath Pkg 'File)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity
-> LocalBuildInfo
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
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 String
stylesheet = Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (HscolourFlags -> Flag String
hscolourCSS HscolourFlags
flags)

      runHsColour
        :: ConfiguredProgram
        -> SymbolicPath Pkg to
        -> [(ModuleName.ModuleName, SymbolicPath Pkg to1)]
        -> IO ()
      runHsColour :: forall (to :: FileOrDir) (to1 :: FileOrDir).
ConfiguredProgram
-> SymbolicPath Pkg to
-> [(ModuleName, SymbolicPath Pkg to1)]
-> IO ()
runHsColour ConfiguredProgram
prog SymbolicPath Pkg to
outputDir [(ModuleName, SymbolicPath Pkg to1)]
moduleFiles = do
        Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (SymbolicPath Pkg to -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i SymbolicPath Pkg to
outputDir)

        case Maybe String
stylesheet of -- copy the CSS file
          Maybe String
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
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram
-> [String]
-> IO ()
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram
-> [String]
-> IO ()
runProgramCwd
                  Verbosity
verbosity
                  Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
                  ConfiguredProgram
prog
                  [String
"-print-css", String
"-o" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg to -> String
forall (to :: FileOrDir). SymbolicPath Pkg to -> String
u SymbolicPath Pkg to
outputDir String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
"hscolour.css"]
            | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just String
s -> Verbosity -> String -> String -> IO ()
copyFileVerbose Verbosity
verbosity String
s (SymbolicPath Pkg to -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i SymbolicPath Pkg to
outputDir String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
"hscolour.css")

        [(ModuleName, SymbolicPath Pkg to1)]
-> ((ModuleName, SymbolicPath Pkg to1) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(ModuleName, SymbolicPath Pkg to1)]
moduleFiles (((ModuleName, SymbolicPath Pkg to1) -> IO ()) -> IO ())
-> ((ModuleName, SymbolicPath Pkg to1) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ModuleName
m, SymbolicPath Pkg to1
inFile) ->
          Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram
-> [String]
-> IO ()
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram
-> [String]
-> IO ()
runProgramCwd
            Verbosity
verbosity
            Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
            ConfiguredProgram
prog
            [String
"-css", String
"-anchor", String
"-o" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
outFile ModuleName
m, SymbolicPath Pkg to1 -> String
forall (to :: FileOrDir). SymbolicPath Pkg to -> String
u SymbolicPath Pkg to1
inFile]
        where
          outFile :: ModuleName -> String
outFile ModuleName
m =
            SymbolicPath Pkg to -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i SymbolicPath Pkg to
outputDir
              String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" (ModuleName -> [String]
ModuleName.components ModuleName
m)
                String -> ShowS
forall p. FileLike p => p -> String -> p
<.> String
"html"

haddockToHscolour :: HaddockFlags -> HscolourFlags
haddockToHscolour :: HaddockFlags -> HscolourFlags
haddockToHscolour HaddockFlags
flags =
  HscolourFlags
    { hscolourCommonFlags :: CommonSetupFlags
hscolourCommonFlags = HaddockFlags -> CommonSetupFlags
haddockCommonFlags HaddockFlags
flags
    , hscolourCSS :: Flag String
hscolourCSS = HaddockFlags -> Flag String
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
    }

-- ------------------------------------------------------------------------------
-- 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 = String -> Directory
Dir String
"."
  mappend :: Directory -> Directory -> Directory
mappend = Directory -> Directory -> Directory
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup Directory where
  Dir String
m <> :: Directory -> Directory -> Directory
<> Dir String
n = String -> Directory
Dir (String -> Directory) -> String -> Directory
forall a b. (a -> b) -> a -> b
$ String
m String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
n