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

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

-- |
-- 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
import Distribution.Simple.SetupHooks.Internal
  ( BuildHooks (..)
  , 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 [Char]
argInterfaceFile :: Flag FilePath
  -- ^ Path to the interface file, relative to argOutputDir, required.
  , HaddockArgs -> Flag PackageIdentifier
argPackageName :: Flag PackageIdentifier
  -- ^ Package name, required.
  , HaddockArgs -> Flag [Char]
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 ([Char], [Char], [Char])
argLinkSource :: Flag (Template, Template, Template)
  -- ^ (Template for modules, template for symbols, template for lines).
  , HaddockArgs -> Last Bool
argLinkedSource :: Flag Bool
  -- ^ Generate hyperlinked sources
  , HaddockArgs -> Last Bool
argQuickJump :: Flag Bool
  -- ^ Generate quickjump index
  , HaddockArgs -> Flag [Char]
argCssFile :: Flag FilePath
  -- ^ Optional custom CSS file.
  , HaddockArgs -> Flag [Char]
argContents :: Flag String
  -- ^ Optional URL to contents page.
  , HaddockArgs -> Last Bool
argGenContents :: Flag Bool
  -- ^ Generate contents
  , HaddockArgs -> Flag [Char]
argIndex :: Flag String
  -- ^ Optional URL to index page.
  , HaddockArgs -> Last Bool
argGenIndex :: Flag Bool
  -- ^ Generate index
  , HaddockArgs -> Flag [Char]
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 -> [([Char], Maybe [Char], Maybe [Char], 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 [Char]
argTitle :: Flag String
  -- ^ Page title, required.
  , HaddockArgs -> Flag [Char]
argPrologue :: Flag String
  -- ^ Prologue text, required for 'haddock', ignored by 'haddocks'.
  , HaddockArgs -> Flag [Char]
argPrologueFile :: Flag FilePath
  -- ^ Prologue file name, ignored by 'haddock', optional for 'haddocks'.
  , HaddockArgs -> GhcOptions
argGhcOptions :: GhcOptions
  -- ^ Additional flags to pass to GHC.
  , HaddockArgs -> Flag [Char]
argGhcLibDir :: Flag FilePath
  -- ^ To find the correct GHC, required.
  , HaddockArgs -> [OpenModule]
argReexports :: [OpenModule]
  -- ^ Re-exported modules
  , HaddockArgs -> [[Char]]
argTargets :: [FilePath]
  -- ^ Modules to process.
  , HaddockArgs -> Flag [Char]
argResourcesDir :: Flag String
  -- ^ haddock's static \/ auxiliary files.
  , HaddockArgs -> Last 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 -> [Char]
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 -> [Char]
(Int -> Directory -> ShowS)
-> (Directory -> [Char])
-> ([Directory] -> ShowS)
-> Show Directory
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Directory -> ShowS
showsPrec :: Int -> Directory -> ShowS
$cshow :: Directory -> [Char]
show :: Directory -> [Char]
$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 = [Char] -> SymbolicPath Pkg ('Dir Artifacts)
forall from (to :: FileOrDir). [Char] -> SymbolicPath from to
makeSymbolicPath ([Char] -> SymbolicPath Pkg ('Dir Artifacts))
-> (Directory -> [Char])
-> Directory
-> SymbolicPath Pkg ('Dir Artifacts)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
normalise ShowS -> (Directory -> [Char]) -> Directory -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directory -> [Char]
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
-> Last Bool
-> IO (ConfiguredProgram, Version)
getHaddockProg Verbosity
verbosity ProgramDb
programDb Compiler
comp HaddockArgs
args Last Bool
quickJumpFlag = do
  let HaddockArgs
        { Last Bool
argQuickJump :: HaddockArgs -> Last Bool
argQuickJump :: Last 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 = [Char]
"Haddock prior to 2.19 does not support the --quickjump flag."
        alt = [Char]
"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 (Last Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Last Bool -> Bool) -> Last Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Last Bool
haddockExecutables HaddockFlags
haddockFlags)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Last Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Last Bool -> Bool) -> Last Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Last Bool
haddockTestSuites HaddockFlags
haddockFlags)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Last Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Last Bool -> Bool) -> Last Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Last Bool
haddockBenchmarks HaddockFlags
haddockFlags)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Last Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Last Bool -> Bool) -> Last Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Last Bool
haddockForeignLibs HaddockFlags
haddockFlags) =
        Verbosity -> [Char] -> 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) ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Char]
"No documentation was generated as this package does not contain "
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"a library. Perhaps you want to use the --executables, --tests,"
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" --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
        config :: ConfigFlags
config = LocalBuildInfo -> ConfigFlags
configFlags LocalBuildInfo
lbi

        quickJmpFlag :: Last Bool
quickJmpFlag = HaddockFlags -> Last 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 :: [Char]
pkg_url = [Char]
"/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 =
          CommonSetupFlags -> TempFileOptions
commonSetupTempFileOptions (CommonSetupFlags -> TempFileOptions)
-> CommonSetupFlags -> TempFileOptions
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
config
        htmlTemplate :: Maybe PathTemplate
htmlTemplate =
          ([Char] -> PathTemplate) -> Maybe [Char] -> Maybe PathTemplate
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> PathTemplate
toPathTemplate (Maybe [Char] -> Maybe PathTemplate)
-> (HaddockFlags -> Maybe [Char])
-> HaddockFlags
-> Maybe PathTemplate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag [Char] -> Maybe [Char]
forall a. Flag a -> Maybe a
flagToMaybe (Flag [Char] -> Maybe [Char])
-> (HaddockFlags -> Flag [Char]) -> HaddockFlags -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockFlags -> Flag [Char]
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 [Char]
haddockOutputDir HaddockFlags
flags of
          Flag [Char]
NoFlag -> HaddockArgs
args
          Flag [Char]
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 -> Last Bool) -> Bool
forall {b}. (HaddockFlags -> Flag b) -> b
flag HaddockFlags -> Last 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)

    (\PackageIndex InstalledPackageInfo
-> TargetInfo -> IO (PackageIndex InstalledPackageInfo)
f -> (PackageIndex InstalledPackageInfo
 -> TargetInfo -> IO (PackageIndex InstalledPackageInfo))
-> PackageIndex InstalledPackageInfo -> [TargetInfo] -> IO ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ PackageIndex InstalledPackageInfo
-> TargetInfo -> IO (PackageIndex InstalledPackageInfo)
f (LocalBuildInfo -> PackageIndex InstalledPackageInfo
installedPkgs LocalBuildInfo
lbi) [TargetInfo]
targets') $ \PackageIndex InstalledPackageInfo
index TargetInfo
target -> do
      curDir <- LocalBuildInfo -> IO (AbsolutePath ('Dir Pkg))
absoluteWorkingDirLBI LocalBuildInfo
lbi
      let
        component = TargetInfo -> Component
targetComponent TargetInfo
target
        clbi = TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
target
        bi = Component -> BuildInfo
componentBuildInfo Component
component
        -- Include any build-tool-depends on build tools internal to the current package.
        progs' = AbsolutePath ('Dir Pkg)
-> PackageDescription
-> LocalBuildInfo
-> BuildInfo
-> ProgramDb
-> ProgramDb
addInternalBuildTools AbsolutePath ('Dir Pkg)
curDir PackageDescription
pkg_descr LocalBuildInfo
lbi BuildInfo
bi (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
        lbi' =
          LocalBuildInfo
lbi
            { withPrograms = progs'
            , withPackageDB = withPackageDB lbi ++ [internalPackageDB]
            , installedPkgs = index
            }

        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]
      reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version $ \(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 -> [Char] -> IO ()
warn
                Verbosity
verbosity
                [Char]
"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
-> [Char]
-> PackageIdentifier
-> ComponentName
-> Maybe [(ModuleName, OpenModule)]
-> IO ()
forall a.
Pretty a =>
Verbosity
-> [Char]
-> PackageIdentifier
-> ComponentName
-> Maybe [(ModuleName, a)]
-> IO ()
setupMessage'
              Verbosity
verbosity
              [Char]
"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
                  ([Char] -> AbiHash
mkAbiHash [Char]
"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 -> Last Bool) -> Bool
forall {b}. (HaddockFlags -> Flag b) -> b
flag HaddockFlags -> Last 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 (PackageIndex InstalledPackageInfo)
-> IO (PackageIndex InstalledPackageInfo)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PackageIndex InstalledPackageInfo
-> IO (PackageIndex InstalledPackageInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PackageIndex InstalledPackageInfo
index
          CExe Executable
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Last Bool) -> Bool
forall {b}. (HaddockFlags -> Flag b) -> b
flag HaddockFlags -> Last 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 (PackageIndex InstalledPackageInfo)
-> IO (PackageIndex InstalledPackageInfo)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PackageIndex InstalledPackageInfo
-> IO (PackageIndex InstalledPackageInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PackageIndex InstalledPackageInfo
index
          CTest TestSuite
test -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Last Bool) -> Bool
forall {b}. (HaddockFlags -> Flag b) -> b
flag HaddockFlags -> Last 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
            PackageIndex InstalledPackageInfo
-> IO (PackageIndex InstalledPackageInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PackageIndex InstalledPackageInfo
index
          CBench Benchmark
bench -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Last Bool) -> Bool
forall {b}. (HaddockFlags -> Flag b) -> b
flag HaddockFlags -> Last 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
            PackageIndex InstalledPackageInfo
-> IO (PackageIndex InstalledPackageInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PackageIndex InstalledPackageInfo
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 = [Char] -> Directory
Dir ([Char] -> Directory) -> [Char] -> Directory
forall a b. (a -> b) -> a -> b
$ Directory -> [Char]
unDir' (HaddockArgs -> Directory
argOutputDir HaddockArgs
commonArgs) [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> HaddockTarget -> PackageDescription -> [Char]
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
      tmpFileOpts :: TempFileOptions
tmpFileOpts =
        CommonSetupFlags -> TempFileOptions
commonSetupTempFileOptions (CommonSetupFlags -> TempFileOptions)
-> CommonSetupFlags -> TempFileOptions
forall a b. (a -> b) -> a -> b
$ HaddockProjectFlags -> CommonSetupFlags
haddockProjectCommonFlags (HaddockProjectFlags -> CommonSetupFlags)
-> HaddockProjectFlags -> CommonSetupFlags
forall a b. (a -> b) -> a -> b
$ HaddockProjectFlags
flags
  (haddockProg, _version) <-
    Verbosity
-> ProgramDb
-> Compiler
-> HaddockArgs
-> Last Bool
-> IO (ConfiguredProgram, Version)
getHaddockProg Verbosity
verbosity ProgramDb
programDb Compiler
comp HaddockArgs
args (Bool -> Last Bool
forall a. a -> Last a
Flag Bool
True)
  runHaddock verbosity mbWorkDir tmpFileOpts 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 :: [[Char]]
ghcArgs = [[Char]] -> Maybe [[Char]] -> [[Char]]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [[Char]] -> [[Char]])
-> (HaddockFlags -> Maybe [[Char]]) -> HaddockFlags -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [([Char], [[Char]])] -> Maybe [[Char]]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"ghc" ([([Char], [[Char]])] -> Maybe [[Char]])
-> (HaddockFlags -> [([Char], [[Char]])])
-> HaddockFlags
-> Maybe [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockFlags -> [([Char], [[Char]])]
haddockProgramArgs (HaddockFlags -> [[Char]]) -> HaddockFlags -> [[Char]]
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
    , argCssFile = haddockProjectCss 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 :: [Char]
showPkg = PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)
    subtitle :: [Char]
subtitle
      | ShortText -> Bool
ShortText.null (PackageDescription -> ShortText
synopsis PackageDescription
pkg_descr) = [Char]
""
      | Bool
otherwise = [Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShortText -> [Char]
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
_ ->
          [Char]
-> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> Verbosity
 -> LocalBuildInfo
 -> BuildInfo
 -> ComponentLocalBuildInfo
 -> SymbolicPath Pkg ('Dir build)
 -> GhcOptions)
-> [Char]
-> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
forall a b. (a -> b) -> a -> b
$
            [Char]
"Distribution.Simple.Haddock.componentGhcOptions:"
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"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 [Char]
url) -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
              (LibraryName
_, Flag [Char]
a) -> Flag [Char]
a
          , argContents = case (libName lib, argContents args') of
              (LSubLibName UnqualComponentName
_, Flag [Char]
url) -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
              (LibraryName
_, Flag [Char]
a) -> Flag [Char]
a
          , argIndex = case (libName lib, argIndex args') of
              (LSubLibName UnqualComponentName
_, Flag [Char]
url) -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
              (LibraryName
_, Flag [Char]
a) -> Flag [Char]
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 [Char]
url -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
          Flag [Char]
NoFlag -> Flag [Char]
forall a. Last a
NoFlag
      , argContents = case argContents args' of
          Flag [Char]
url -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
          Flag [Char]
NoFlag -> Flag [Char]
forall a. Last a
NoFlag
      , argIndex = case argIndex args' of
          Flag [Char]
url -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
          Flag [Char]
NoFlag -> Flag [Char]
forall a. Last 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 [Char]
url -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
          Flag [Char]
NoFlag -> Flag [Char]
forall a. Last a
NoFlag
      , argContents = case argContents args' of
          Flag [Char]
url -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
          Flag [Char]
NoFlag -> Flag [Char]
forall a. Last a
NoFlag
      , argIndex = case argIndex args' of
          Flag [Char]
url -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
          Flag [Char]
NoFlag -> Flag [Char]
forall a. Last 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 [Char]
url -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
          Flag [Char]
NoFlag -> Flag [Char]
forall a. Last a
NoFlag
      , argContents = case argContents args' of
          Flag [Char]
url -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
          Flag [Char]
NoFlag -> Flag [Char]
forall a. Last a
NoFlag
      , argIndex = case argIndex args' of
          Flag [Char]
url -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
          Flag [Char]
NoFlag -> Flag [Char]
forall a. Last 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 [Char]
url -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
          Flag [Char]
NoFlag -> Flag [Char]
forall a. Last a
NoFlag
      , argContents = case argContents args' of
          Flag [Char]
url -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
          Flag [Char]
NoFlag -> Flag [Char]
forall a. Last a
NoFlag
      , argIndex = case argIndex args' of
          Flag [Char]
url -> [Char] -> Flag [Char]
forall a. a -> Last a
Flag ([Char] -> Flag [Char]) -> [Char] -> Flag [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
".." [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
url
          Flag [Char]
NoFlag -> Flag [Char]
forall a. Last 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
     ([([Char], Maybe [Char], Maybe [Char], Visibility)], Maybe [Char])
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 [Char]
GHC.getLibDir Verbosity
verbosity LocalBuildInfo
lbi
    CompilerFlavor
GHCJS -> Verbosity -> LocalBuildInfo -> IO [Char]
GHCJS.getLibDir Verbosity
verbosity LocalBuildInfo
lbi
    CompilerFlavor
_ -> [Char] -> IO [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"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)
-> [Char]
-> (SymbolicPath Pkg ('Dir Artifacts) -> IO r)
-> IO r
forall a tmpDir1 tmpDir2.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> [Char]
-> (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) [Char]
"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)
-> [Char]
-> (SymbolicPath Pkg ('Dir Artifacts) -> IO r)
-> IO r
forall a tmpDir1 tmpDir2.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> [Char]
-> (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) [Char]
"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 -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg to -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
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)
getGhcDir SymbolicPathX allowAbsolute Pkg to
tmpDir = do
              let ghcDir :: [Char]
ghcDir = SymbolicPathX allowAbsolute Pkg to -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i (SymbolicPathX allowAbsolute Pkg to -> [Char])
-> SymbolicPathX allowAbsolute Pkg to -> [Char]
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)
getGhcDir GhcOptions
vanillaOpts
              ghcDirExists <- [Char] -> IO Bool
doesDirectoryExist [Char]
ghcDir
              -- Don't try to copy artifacts if they don't exist, e.g. if
              -- we have not yet run the 'build' command.
              when ghcDirExists $
                copyDirectoryRecursive verbosity ghcDir (i 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)
-> [Char]
-> (SymbolicPath Pkg ('Dir Artifacts) -> IO r)
-> IO r
forall a tmpDir1 tmpDir2.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> [Char]
-> (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) [Char]
"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
&& [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HaddockArgs -> [[Char]]
argTargets HaddockArgs
args) =
      Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char]
"Haddocks are being requested, but there aren't any modules given "
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"to create documentation for."
  | Bool
otherwise = do
      let haddockVersion :: Version
haddockVersion =
            Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe
              ([Char] -> Version
forall a. HasCallStack => [Char] -> a
error [Char]
"unable to determine haddock version")
              (ConfiguredProgram -> Maybe Version
programVersion ConfiguredProgram
haddockProg)
      Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> TempFileOptions
-> Version
-> Compiler
-> Platform
-> HaddockArgs
-> ([[Char]] -> [Char] -> IO ())
-> IO ()
forall a.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> TempFileOptions
-> Version
-> Compiler
-> Platform
-> HaddockArgs
-> ([[Char]] -> [Char] -> IO a)
-> IO a
renderArgs Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir TempFileOptions
tmpFileOpts Version
haddockVersion Compiler
comp Platform
platform HaddockArgs
args (([[Char]] -> [Char] -> IO ()) -> IO ())
-> ([[Char]] -> [Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        \[[Char]]
flags [Char]
result -> do
          Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram
-> [[Char]]
-> IO ()
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram
-> [[Char]]
-> IO ()
runProgramCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
haddockProg [[Char]]
flags
          Verbosity -> [Char] -> IO ()
notice Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Documentation created: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
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
-> ([[Char]] -> [Char] -> IO a)
-> IO a
renderArgs Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir TempFileOptions
tmpFileOpts Version
version Compiler
comp Platform
platform HaddockArgs
args [[Char]] -> [Char] -> 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 -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 4) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 4)
forall {to2 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg to2
outputDir)
  let withPrologueArgs :: [[Char]] -> IO a
withPrologueArgs [[Char]]
prologueArgs =
        let renderedArgs :: [[Char]]
renderedArgs = [[Char]]
prologueArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Version -> Compiler -> Platform -> HaddockArgs -> [[Char]]
renderPureArgs Version
version Compiler
comp Platform
platform HaddockArgs
args
         in if Bool
haddockSupportsResponseFiles
              then
                Verbosity
-> TempFileOptions
-> [Char]
-> Maybe TextEncoding
-> [[Char]]
-> ([Char] -> IO a)
-> IO a
forall a.
Verbosity
-> TempFileOptions
-> [Char]
-> Maybe TextEncoding
-> [[Char]]
-> ([Char] -> IO a)
-> IO a
withResponseFile
                  Verbosity
verbosity
                  TempFileOptions
tmpFileOpts
                  [Char]
"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)
                  [[Char]]
renderedArgs
                  (\[Char]
responseFileName -> [[Char]] -> [Char] -> IO a
k [[Char]
"@" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
responseFileName] [Char]
result)
              else [[Char]] -> [Char] -> IO a
k [[Char]]
renderedArgs [Char]
result
  case (HaddockArgs -> Flag [Char]
argPrologueFile HaddockArgs
args, HaddockArgs -> Flag [Char]
argPrologue HaddockArgs
args) of
    (Flag [Char]
pfile, Flag [Char]
_) ->
      [[Char]] -> IO a
withPrologueArgs [[Char]
"--prologue=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
pfile]
    (Flag [Char]
_, Flag [Char]
prologueText) ->
      TempFileOptions
-> [Char] -> (SymbolicPath Pkg 'File -> Handle -> IO a) -> IO a
forall a.
TempFileOptions
-> [Char] -> (SymbolicPath Pkg 'File -> Handle -> IO a) -> IO a
withTempFileEx TempFileOptions
tmpFileOpts [Char]
"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 -> [Char] -> IO ()
hPutStrLn Handle
h [Char]
prologueText
          Handle -> IO ()
hClose Handle
h
          [[Char]] -> IO a
withPrologueArgs [[Char]
"--prologue=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg 'File -> [Char]
forall (to :: FileOrDir). SymbolicPath Pkg to -> [Char]
u SymbolicPath Pkg 'File
prologueFileName]
    (Flag [Char]
NoFlag, Flag [Char]
NoFlag) ->
      [[Char]] -> IO a
withPrologueArgs []
  where
    -- See Note [Symbolic paths] in Distribution.Utils.Path
    i :: SymbolicPathX allowAbsolute Pkg to -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg to -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
    u :: SymbolicPath Pkg to -> FilePath
    u :: forall (to :: FileOrDir). SymbolicPath Pkg to -> [Char]
u = SymbolicPathX 'AllowAbsolute Pkg to -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
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 [Char] -> Bool
forall a. Maybe a -> Bool
isNothing (Flag [Char] -> Maybe [Char]
forall a. Flag a -> Maybe a
flagToMaybe (Flag [Char] -> Maybe [Char]) -> Flag [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Flag [Char]
argContents HaddockArgs
args)
    isNotArgIndex :: Bool
isNotArgIndex = Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isNothing (Flag [Char] -> Maybe [Char]
forall a. Flag a -> Maybe a
flagToMaybe (Flag [Char] -> Maybe [Char]) -> Flag [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Flag [Char]
argIndex HaddockArgs
args)
    isArgGenIndex :: Bool
isArgGenIndex = Bool -> Last Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockArgs -> Last 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 :: [Char]
result =
      [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", "
        ([[Char]] -> [Char])
-> (HaddockArgs -> [[Char]]) -> HaddockArgs -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Output -> [Char]) -> [Output] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \Output
o ->
              SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 3) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 3)
forall {to2 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg to2
outputDir
                [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> case Output
o of
                  Output
Html
                    | Bool
isIndexGenerated ->
                        [Char]
"index.html"
                  Output
Html
                    | Bool
otherwise ->
                        [Char]
forall a. Monoid a => a
mempty
                  Output
Hoogle -> [Char]
pkgstr [Char] -> ShowS
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
"txt"
          )
        ([Output] -> [[Char]])
-> (HaddockArgs -> [Output]) -> HaddockArgs -> [[Char]]
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 -> [Char]) -> HaddockArgs -> [Char]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
      where
        pkgstr :: [Char]
pkgstr = PackageName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (PackageName -> [Char]) -> PackageName -> [Char]
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 -> [[Char]]
renderPureArgs Version
version Compiler
comp Platform
platform HaddockArgs
args =
  [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
f -> [Char]
"--dump-interface=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Artifacts) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
u (Directory -> SymbolicPath Pkg ('Dir Artifacts)
unDir (HaddockArgs -> Directory
argOutputDir HaddockArgs
args)) [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
f)
        ([[Char]] -> [[Char]])
-> (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag [Char] -> [[Char]]
forall a. Flag a -> [a]
flagToList
        (Flag [Char] -> [[Char]])
-> (HaddockArgs -> Flag [Char]) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag [Char]
argInterfaceFile
        (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , if Bool
haddockSupportsPackageName
        then
          [[Char]]
-> (PackageIdentifier -> [[Char]])
-> Maybe PackageIdentifier
-> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            []
            ( \PackageIdentifier
pkg ->
                [ [Char]
"--package-name="
                    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ case HaddockArgs -> Flag [Char]
argComponentName HaddockArgs
args of
                      Flag [Char]
name -> [Char]
name
                      Flag [Char]
_ -> PackageName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkg)
                , [Char]
"--package-version=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (PackageIdentifier -> Version
pkgVersion PackageIdentifier
pkg)
                ]
            )
            (Maybe PackageIdentifier -> [[Char]])
-> (HaddockArgs -> Maybe PackageIdentifier)
-> HaddockArgs
-> [[Char]]
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 -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
        else []
    , [[Char]
"--since-qual=external" | Int -> Int -> Bool
isVersion Int
2 Int
20]
    , [ [Char]
"--quickjump" | Int -> Int -> Bool
isVersion Int
2 Int
19, Bool
True <- Last Bool -> [Bool]
forall a. Flag a -> [a]
flagToList (Last Bool -> [Bool])
-> (HaddockArgs -> Last Bool) -> HaddockArgs -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Last Bool
argQuickJump (HaddockArgs -> [Bool]) -> HaddockArgs -> [Bool]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
      ]
    , [[Char]
"--hyperlinked-source" | Bool
isHyperlinkedSource]
    , (\(All Bool
b, [ModuleName]
xs) -> [[Char]] -> [[Char]] -> Bool -> [[Char]]
forall a. a -> a -> Bool -> a
bool [] ((ModuleName -> [Char]) -> [ModuleName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char]
"--hide=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (ModuleName -> [Char]) -> ModuleName -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow) [ModuleName]
xs) Bool
b)
        ((All, [ModuleName]) -> [[Char]])
-> (HaddockArgs -> (All, [ModuleName])) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> (All, [ModuleName])
argHideModules
        (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [[Char]] -> [[Char]] -> Bool -> [[Char]]
forall a. a -> a -> Bool -> a
bool [] [[Char]
"--ignore-all-exports"] (Bool -> [[Char]])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [[Char]]
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 -> [[Char]]) -> HaddockArgs -> [[Char]]
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
          [[Char]]
-> (([Char], [Char], [Char]) -> [[Char]])
-> Maybe ([Char], [Char], [Char])
-> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            []
            ( \([Char]
m, [Char]
e, [Char]
l) ->
                [ [Char]
"--source-module=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
m
                , [Char]
"--source-entity=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
e
                ]
                  [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ if Int -> Int -> Bool
isVersion Int
2 Int
14
                    then [[Char]
"--source-entity-line=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
l]
                    else []
            )
            (Maybe ([Char], [Char], [Char]) -> [[Char]])
-> (HaddockArgs -> Maybe ([Char], [Char], [Char]))
-> HaddockArgs
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag ([Char], [Char], [Char]) -> Maybe ([Char], [Char], [Char])
forall a. Flag a -> Maybe a
flagToMaybe
            (Flag ([Char], [Char], [Char]) -> Maybe ([Char], [Char], [Char]))
-> (HaddockArgs -> Flag ([Char], [Char], [Char]))
-> HaddockArgs
-> Maybe ([Char], [Char], [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag ([Char], [Char], [Char])
argLinkSource
            (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: []) ([Char] -> [[Char]]) -> ShowS -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"--css=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe [Char] -> [[Char]])
-> (HaddockArgs -> Maybe [Char]) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag [Char] -> Maybe [Char]
forall a. Flag a -> Maybe a
flagToMaybe (Flag [Char] -> Maybe [Char])
-> (HaddockArgs -> Flag [Char]) -> HaddockArgs -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag [Char]
argCssFile (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: []) ([Char] -> [[Char]]) -> ShowS -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"--use-contents=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe [Char] -> [[Char]])
-> (HaddockArgs -> Maybe [Char]) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag [Char] -> Maybe [Char]
forall a. Flag a -> Maybe a
flagToMaybe (Flag [Char] -> Maybe [Char])
-> (HaddockArgs -> Flag [Char]) -> HaddockArgs -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag [Char]
argContents (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [[Char]] -> [[Char]] -> Bool -> [[Char]]
forall a. a -> a -> Bool -> a
bool [] [[Char]
"--gen-contents"] (Bool -> [[Char]])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Last Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Last Bool -> Bool)
-> (HaddockArgs -> Last Bool) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Last Bool
argGenContents (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: []) ([Char] -> [[Char]]) -> ShowS -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"--use-index=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe [Char] -> [[Char]])
-> (HaddockArgs -> Maybe [Char]) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag [Char] -> Maybe [Char]
forall a. Flag a -> Maybe a
flagToMaybe (Flag [Char] -> Maybe [Char])
-> (HaddockArgs -> Flag [Char]) -> HaddockArgs -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag [Char]
argIndex (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [[Char]] -> [[Char]] -> Bool -> [[Char]]
forall a. a -> a -> Bool -> a
bool [] [[Char]
"--gen-index"] (Bool -> [[Char]])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Last Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Last Bool -> Bool)
-> (HaddockArgs -> Last Bool) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Last Bool
argGenIndex (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: []) ([Char] -> [[Char]]) -> ShowS -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"--base-url=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe [Char] -> [[Char]])
-> (HaddockArgs -> Maybe [Char]) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag [Char] -> Maybe [Char]
forall a. Flag a -> Maybe a
flagToMaybe (Flag [Char] -> Maybe [Char])
-> (HaddockArgs -> Flag [Char]) -> HaddockArgs -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag [Char]
argBaseUrl (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [[Char]] -> [[Char]] -> Bool -> [[Char]]
forall a. a -> a -> Bool -> a
bool [[Char]
verbosityFlag] [] (Bool -> [[Char]])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [[Char]]
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 -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , (Output -> [Char]) -> [Output] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\Output
o -> case Output
o of Output
Hoogle -> [Char]
"--hoogle"; Output
Html -> [Char]
"--html")
        ([Output] -> [[Char]])
-> (HaddockArgs -> [Output]) -> HaddockArgs -> [[Char]]
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 -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [([Char], Maybe [Char], Maybe [Char], Visibility)] -> [[Char]]
renderInterfaces ([([Char], Maybe [Char], Maybe [Char], Visibility)] -> [[Char]])
-> (HaddockArgs
    -> [([Char], Maybe [Char], Maybe [Char], Visibility)])
-> HaddockArgs
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> [([Char], Maybe [Char], Maybe [Char], Visibility)]
argInterfaces (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: []) ([Char] -> [[Char]])
-> (HaddockArgs -> [Char]) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"--odir=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (HaddockArgs -> [Char]) -> HaddockArgs -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg ('Dir Artifacts) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
u (SymbolicPath Pkg ('Dir Artifacts) -> [Char])
-> (HaddockArgs -> SymbolicPath Pkg ('Dir Artifacts))
-> HaddockArgs
-> [Char]
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 -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        []
        ( ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [])
            ([Char] -> [[Char]]) -> ShowS -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"--title=" [Char] -> 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
                  ([Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (internal documentation)")
                  (Any -> Bool
getAny (Any -> Bool) -> Any -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Any
argIgnoreExports HaddockArgs
args)
              )
        )
        (Maybe [Char] -> [[Char]])
-> (HaddockArgs -> Maybe [Char]) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag [Char] -> Maybe [Char]
forall a. Flag a -> Maybe a
flagToMaybe
        (Flag [Char] -> Maybe [Char])
-> (HaddockArgs -> Flag [Char]) -> HaddockArgs -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag [Char]
argTitle
        (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [ [Char]
"--optghc=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
opt | let opts :: GhcOptions
opts = HaddockArgs -> GhcOptions
argGhcOptions HaddockArgs
args, [Char]
opt <- Compiler -> Platform -> GhcOptions -> [[Char]]
renderGhcOptions Compiler
comp Platform
platform GhcOptions
opts
      ]
    , [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\[Char]
l -> [[Char]
"-B" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
l]) (Maybe [Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
        Flag [Char] -> Maybe [Char]
forall a. Flag a -> Maybe a
flagToMaybe (HaddockArgs -> Flag [Char]
argGhcLibDir HaddockArgs
args) -- error if Nothing?
    , -- https://github.com/haskell/haddock/pull/547
      [ [Char]
"--reexport=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ OpenModule -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow OpenModule
r
      | OpenModule
r <- HaddockArgs -> [OpenModule]
argReexports HaddockArgs
args
      , Int -> Int -> Bool
isVersion Int
2 Int
19
      ]
    , HaddockArgs -> [[Char]]
argTargets (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: []) ([Char] -> [[Char]]) -> ShowS -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
resourcesDirFlag [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe [Char] -> [[Char]])
-> (HaddockArgs -> Maybe [Char]) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag [Char] -> Maybe [Char]
forall a. Flag a -> Maybe a
flagToMaybe (Flag [Char] -> Maybe [Char])
-> (HaddockArgs -> Flag [Char]) -> HaddockArgs -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag [Char]
argResourcesDir (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
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]
      [[Char]
"--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]]
    , [[Char]] -> [[Char]] -> Bool -> [[Char]]
forall a. a -> a -> Bool -> a
bool [] [[Char]
"--use-unicode"] (Bool -> [[Char]])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Last Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Last Bool -> Bool)
-> (HaddockArgs -> Last Bool) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Last Bool
argUseUnicode (HaddockArgs -> [[Char]]) -> HaddockArgs -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    ]
  where
    -- See Note [Symbolic paths] in Distribution.Utils.Path
    u :: SymbolicPathX allowAbsolute from to -> [Char]
u = SymbolicPathX allowAbsolute from to -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPathCWD
    renderInterfaces :: [([Char], Maybe [Char], Maybe [Char], Visibility)] -> [[Char]]
renderInterfaces = (([Char], Maybe [Char], Maybe [Char], Visibility) -> [Char])
-> [([Char], Maybe [Char], Maybe [Char], Visibility)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Maybe [Char], Maybe [Char], Visibility) -> [Char]
renderInterface

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

                [ case (Maybe [Char]
html, Maybe [Char]
hypsrc) of
                    (Maybe [Char]
Nothing, Maybe [Char]
_) -> [Char]
""
                    (Maybe [Char]
_, Maybe [Char]
Nothing) -> [Char]
""
                    (Maybe [Char]
_, Just [Char]
x)
                      | Int -> Int -> Bool
isVersion Int
2 Int
17
                      , Bool -> Last Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Last Bool -> Bool)
-> (HaddockArgs -> Last Bool) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Last Bool
argLinkedSource (HaddockArgs -> Bool) -> HaddockArgs -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args ->
                          [Char]
x
                      | Bool
otherwise ->
                          [Char]
""
                ]
              , if Bool
haddockSupportsVisibility
                  then
                    [ case Visibility
visibility of
                        Visibility
Visible -> [Char]
"visible"
                        Visibility
Hidden -> [Char]
"hidden"
                    ]
                  else []
              , [[Char]
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 :: [Char]
verbosityFlag
      | Int -> Int -> Bool
isVersion Int
2 Int
5 = [Char]
"--verbosity=1"
      | Bool
otherwise = [Char]
"--verbose"
    resourcesDirFlag :: [Char]
resourcesDirFlag
      | Int -> Int -> Bool
isVersion Int
2 Int
29 = [Char]
"--resources-dir="
      | Bool
otherwise = [Char]
"--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 -> Last Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockArgs -> Last 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 -> [Char])
-> IO
     ([([Char], Maybe [Char], Maybe [Char], Visibility)], Maybe [Char])
haddockPackagePaths [InstalledPackageInfo]
ipkgs Maybe (InstalledPackageInfo -> [Char])
mkHtmlPath = do
  interfaces <-
    [IO
   (Either
      PackageIdentifier
      ([Char], Maybe [Char], Maybe [Char], Visibility))]
-> IO
     [Either
        PackageIdentifier ([Char], Maybe [Char], Maybe [Char], 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 ([Char], Maybe [Char])
interfaceAndHtmlPath InstalledPackageInfo
ipkg of
        Maybe ([Char], Maybe [Char])
Nothing -> do
          Either
  PackageIdentifier ([Char], Maybe [Char], Maybe [Char], Visibility)
-> IO
     (Either
        PackageIdentifier ([Char], Maybe [Char], Maybe [Char], Visibility))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageIdentifier
-> Either
     PackageIdentifier ([Char], Maybe [Char], Maybe [Char], Visibility)
forall a b. a -> Either a b
Left (InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId InstalledPackageInfo
ipkg))
        Just ([Char]
interface, Maybe [Char]
html) -> do
          (html', hypsrc') <-
            case Maybe [Char]
html of
              Just [Char]
htmlPath -> do
                let hypSrcPath :: [Char]
hypSrcPath = [Char]
htmlPath [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
defaultHyperlinkedSourceDirectory
                hypSrcExists <- [Char] -> IO Bool
doesDirectoryExist [Char]
hypSrcPath
                return $
                  ( Just (fixFileUrl htmlPath)
                  , if hypSrcExists
                      then Just (fixFileUrl hypSrcPath)
                      else Nothing
                  )
              Maybe [Char]
Nothing -> (Maybe [Char], Maybe [Char]) -> IO (Maybe [Char], Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char]
forall a. Maybe a
Nothing, Maybe [Char]
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 ([Char], Maybe [Char], Maybe [Char], Visibility)]
interfaces]
      warning =
        [Char]
"The following packages have no Haddock documentation "
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"installed. No links will be generated to these packages: "
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((PackageIdentifier -> [Char]) -> [PackageIdentifier] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow [PackageIdentifier]
missing)
      flags = [Either
   PackageIdentifier ([Char], Maybe [Char], Maybe [Char], Visibility)]
-> [([Char], Maybe [Char], Maybe [Char], Visibility)]
forall a b. [Either a b] -> [b]
rights [Either
   PackageIdentifier ([Char], Maybe [Char], Maybe [Char], 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 = ([Char] -> PackageName) -> [[Char]] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> PackageName
mkPackageName [[Char]
"rts"]

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

    -- 'src' is the default hyperlinked source directory ever since. It is
    -- not possible to configure that directory in any way in haddock.
    defaultHyperlinkedSourceDirectory :: [Char]
defaultHyperlinkedSourceDirectory = [Char]
"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
     ([([Char], Maybe [Char], Maybe [Char], Visibility)], Maybe [Char])
haddockPackageFlags Verbosity
verbosity LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate = do
  let allPkgs :: PackageIndex InstalledPackageInfo
allPkgs = LocalBuildInfo -> PackageIndex InstalledPackageInfo
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 PackageIndex InstalledPackageInfo
-> [UnitId]
-> Either
     (PackageIndex InstalledPackageInfo)
     [(InstalledPackageInfo, [UnitId])]
PackageIndex.dependencyClosure PackageIndex InstalledPackageInfo
allPkgs [UnitId]
directDeps of
    Left PackageIndex InstalledPackageInfo
x -> PackageIndex InstalledPackageInfo
-> IO (PackageIndex InstalledPackageInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PackageIndex InstalledPackageInfo
x
    Right [(InstalledPackageInfo, [UnitId])]
inf ->
      Verbosity
-> CabalException -> IO (PackageIndex InstalledPackageInfo)
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO (PackageIndex InstalledPackageInfo))
-> CabalException -> IO (PackageIndex InstalledPackageInfo)
forall a b. (a -> b) -> a -> b
$ [(InstalledPackageInfo, [UnitId])] -> CabalException
HaddockPackageFlags [(InstalledPackageInfo, [UnitId])]
inf

  haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath
  where
    mkHtmlPath :: Maybe (InstalledPackageInfo -> [Char])
mkHtmlPath = (PathTemplate -> InstalledPackageInfo -> [Char])
-> Maybe PathTemplate -> Maybe (InstalledPackageInfo -> [Char])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> InstalledPackageInfo -> [Char]
forall {pkg}. Package pkg => PathTemplate -> pkg -> [Char]
expandTemplateVars Maybe PathTemplate
htmlTemplate
    expandTemplateVars :: PathTemplate -> pkg -> [Char]
expandTemplateVars PathTemplate
tmpl pkg
pkg =
      PathTemplate -> [Char]
fromPathTemplate (PathTemplate -> [Char])
-> (PathTemplate -> PathTemplate) -> PathTemplate -> [Char]
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 -> [Char]) -> PathTemplate -> [Char]
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
-> ([Char] -> IO ())
-> HaddockTarget
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour' BuildHooks
setupHooks [Char] -> IO ()
forall a. [Char] -> 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
-> ([Char] -> IO ())
-> HaddockTarget
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour'
  (BuildHooks{preBuildComponentRules :: BuildHooks -> Maybe PreBuildComponentRules
preBuildComponentRules = Maybe PreBuildComponentRules
mbPbcRules})
  [Char] -> 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 -> [Char] -> IO ()
onNoHsColour ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ CabalException -> [Char]
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 -> [Char]
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> [Char]
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> [Char]
interpretSymbolicPathLBI LocalBuildInfo
lbi -- See Note [Symbolic paths] in Distribution.Utils.Path
      u :: SymbolicPath Pkg to -> FilePath
      u :: forall (to :: FileOrDir). SymbolicPath Pkg to -> [Char]
u = SymbolicPathX 'AllowAbsolute Pkg to -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPathCWD

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

        Verbosity -> [Char] -> PackageIdentifier -> IO ()
setupMessage Verbosity
verbosity [Char]
"Running hscolour for" (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)
        Verbosity -> Bool -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
          SymbolicPath Pkg ('Dir Artifacts) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i (SymbolicPath Pkg ('Dir Artifacts) -> [Char])
-> SymbolicPath Pkg ('Dir Artifacts) -> [Char]
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)
-> SymbolicPathX 'OnlyRelative Artifacts c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative Artifacts c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx (UnqualComponentName -> [Char]
unUnqualComponentName (Executable -> UnqualComponentName
exeName Executable
exe) [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
"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 -> [Char] -> IO ()
warn Verbosity
verbosity [Char]
"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)
-> SymbolicPathX 'OnlyRelative Artifacts c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative Artifacts c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
"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)
-> SymbolicPathX 'OnlyRelative Artifacts c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative Artifacts c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx
                        ( UnqualComponentName -> [Char]
unUnqualComponentName (ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib)
                            [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
"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 (Last Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Last 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 (Last Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Last 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 (Last Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Last Bool
hscolourBenchmarks HscolourFlags
flags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Component -> IO ()
doExe Component
comp

      stylesheet :: Maybe [Char]
stylesheet = Flag [Char] -> Maybe [Char]
forall a. Flag a -> Maybe a
flagToMaybe (HscolourFlags -> Flag [Char]
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 -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (SymbolicPath Pkg to -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPath Pkg to
outputDir)

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

haddockToHscolour :: HaddockFlags -> HscolourFlags
haddockToHscolour :: HaddockFlags -> HscolourFlags
haddockToHscolour HaddockFlags
flags =
  HscolourFlags
    { hscolourCommonFlags :: CommonSetupFlags
hscolourCommonFlags = HaddockFlags -> CommonSetupFlags
haddockCommonFlags HaddockFlags
flags
    , hscolourCSS :: Flag [Char]
hscolourCSS = HaddockFlags -> Flag [Char]
haddockHscolourCss HaddockFlags
flags
    , hscolourExecutables :: Last Bool
hscolourExecutables = HaddockFlags -> Last Bool
haddockExecutables HaddockFlags
flags
    , hscolourTestSuites :: Last Bool
hscolourTestSuites = HaddockFlags -> Last Bool
haddockTestSuites HaddockFlags
flags
    , hscolourBenchmarks :: Last Bool
hscolourBenchmarks = HaddockFlags -> Last Bool
haddockBenchmarks HaddockFlags
flags
    , hscolourForeignLibs :: Last Bool
hscolourForeignLibs = HaddockFlags -> Last 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 = [Char] -> Directory
Dir [Char]
"."
  mappend :: Directory -> Directory -> Directory
mappend = Directory -> Directory -> Directory
forall a. Semigroup a => a -> a -> a
(<>)

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