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

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

-- |
-- Module      :  Distribution.Simple.Haddock
-- Copyright   :  Isaac Jones 2003-2005
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module deals with the @haddock@ and @hscolour@ commands.
-- It uses information about installed packages (from @ghc-pkg@) to find the
-- locations of documentation for dependent packages, so it can create links.
--
-- The @hscolour@ support allows generating HTML versions of the original
-- source, with coloured syntax highlighting.
module Distribution.Simple.Haddock
  ( haddock
  , haddock_setupHooks
  , createHaddockIndex
  , hscolour
  , hscolour_setupHooks
  , haddockPackagePaths
  , Visibility (..)
  ) where

import Distribution.Compat.Prelude
import Prelude ()

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

-- local

import Distribution.Backpack (OpenModule)
import Distribution.Backpack.DescribeUnitId
import Distribution.Compat.Semigroup (All (..), Any (..))
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import qualified Distribution.ModuleName as ModuleName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Parsec (simpleParsec)
import Distribution.Pretty
import Distribution.Simple.Build
import Distribution.Simple.BuildPaths
import Distribution.Simple.BuildTarget
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.FileMonitor.Types
  ( MonitorFilePath
  )
import Distribution.Simple.Flag
import Distribution.Simple.Glob (matchDirFileGlob)
import Distribution.Simple.InstallDirs
import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PreProcess
import Distribution.Simple.Program
import Distribution.Simple.Program.GHC
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import Distribution.Simple.Program.ResponseFile
import Distribution.Simple.Register
import Distribution.Simple.Setup.Common
import Distribution.Simple.Setup.Haddock
import Distribution.Simple.Setup.Hscolour
import Distribution.Simple.SetupHooks.Internal
  ( BuildingWhat (..)
  )
import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks
  ( PreBuildComponentInputs (..)
  )
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.NubList
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 Language.Haskell.Extension

import Data.Either (rights)
import System.Directory (doesDirectoryExist, doesFileExist)
import System.FilePath (isAbsolute, normalise)
import System.IO (hClose, hPutStrLn, hSetEncoding, utf8)

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

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

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

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

type Template = String

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

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

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

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

  -- various sanity checks
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hoogle Bool -> Bool -> Bool
&& Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2, Int
2]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
NoSupportForHoogle

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

  String
haddockGhcVersionStr <-
    Verbosity -> ConfiguredProgram -> [String] -> IO String
getProgramOutput
      Verbosity
verbosity
      ConfiguredProgram
haddockProg
      [String
"--ghc-version"]
  case (String -> Maybe Version
forall a. Parsec a => String -> Maybe a
simpleParsec String
haddockGhcVersionStr, CompilerFlavor -> Compiler -> Maybe Version
compilerCompatVersion CompilerFlavor
GHC Compiler
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

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

haddock
  :: PackageDescription
  -> LocalBuildInfo
  -> [PPSuffixHandler]
  -> HaddockFlags
  -> IO ()
haddock :: PackageDescription
-> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO ()
haddock PackageDescription
pkg LocalBuildInfo
lbi [PPSuffixHandler]
suffixHandlers HaddockFlags
flags =
  IO [MonitorFilePath] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [MonitorFilePath] -> IO ()) -> IO [MonitorFilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$ (PreBuildComponentInputs -> IO [MonitorFilePath])
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HaddockFlags
-> IO [MonitorFilePath]
haddock_setupHooks (IO [MonitorFilePath]
-> PreBuildComponentInputs -> IO [MonitorFilePath]
forall a b. a -> b -> a
const (IO [MonitorFilePath]
 -> PreBuildComponentInputs -> IO [MonitorFilePath])
-> IO [MonitorFilePath]
-> PreBuildComponentInputs
-> IO [MonitorFilePath]
forall a b. (a -> b) -> a -> b
$ [MonitorFilePath] -> IO [MonitorFilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []) PackageDescription
pkg LocalBuildInfo
lbi [PPSuffixHandler]
suffixHandlers HaddockFlags
flags

haddock_setupHooks
  :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath])
  -- ^ pre-build hook
  -> PackageDescription
  -> LocalBuildInfo
  -> [PPSuffixHandler]
  -> HaddockFlags
  -> IO [MonitorFilePath]
haddock_setupHooks :: (PreBuildComponentInputs -> IO [MonitorFilePath])
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HaddockFlags
-> IO [MonitorFilePath]
haddock_setupHooks
  PreBuildComponentInputs -> IO [MonitorFilePath]
_
  PackageDescription
pkg_descr
  LocalBuildInfo
_
  [PPSuffixHandler]
_
  HaddockFlags
haddockFlags
    | Bool -> Bool
not (PackageDescription -> Bool
hasLibs PackageDescription
pkg_descr)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockExecutables HaddockFlags
haddockFlags)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockTestSuites HaddockFlags
haddockFlags)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockBenchmarks HaddockFlags
haddockFlags)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockForeignLibs HaddockFlags
haddockFlags) = do
        Verbosity -> String -> IO ()
warn (Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Verbosity
haddockVerbosity HaddockFlags
haddockFlags) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"No documentation was generated as this package does not contain "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"a library. Perhaps you want to use the --executables, --tests,"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" --benchmarks or --foreign-libraries flags."
        [MonitorFilePath] -> IO [MonitorFilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
haddock_setupHooks
  PreBuildComponentInputs -> IO [MonitorFilePath]
preBuildHook
  PackageDescription
pkg_descr
  LocalBuildInfo
lbi
  [PPSuffixHandler]
suffixes
  HaddockFlags
flags' = do
    let verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Verbosity
haddockVerbosity HaddockFlags
flags
        mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a -> Maybe a
flagToMaybe (Flag (SymbolicPath CWD ('Dir Pkg))
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
haddockWorkingDir HaddockFlags
flags
        comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
        platform :: Platform
platform = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi

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

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

    HaddockArgs
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 -> HaddockArgs
overrideWithOutputDir HaddockArgs
args = case HaddockFlags -> Flag String
haddockOutputDir HaddockFlags
flags of
          Flag String
NoFlag -> HaddockArgs
args
          Flag String
dir -> HaddockArgs
args{argOutputDir = Dir dir}
    let commonArgs :: HaddockArgs
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
              ]

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

    -- We fall back to using HsColour only for versions of Haddock which don't
    -- support '--hyperlinked-sources'.
    let using_hscolour :: Bool
using_hscolour = (HaddockFlags -> Flag Bool) -> Bool
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockLinkedSource Bool -> Bool -> Bool
&& Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2, Int
17]
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
using_hscolour (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      (PreBuildComponentInputs -> IO [MonitorFilePath])
-> (String -> IO ())
-> HaddockTarget
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour'
        (IO [MonitorFilePath]
-> PreBuildComponentInputs -> IO [MonitorFilePath]
forall a b. a -> b -> a
const (IO [MonitorFilePath]
 -> PreBuildComponentInputs -> IO [MonitorFilePath])
-> IO [MonitorFilePath]
-> PreBuildComponentInputs
-> IO [MonitorFilePath]
forall a b. (a -> b) -> a -> b
$ [MonitorFilePath] -> IO [MonitorFilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
        -- NB: we are not passing the user BuildHooks here,
        -- because we are already running the pre/post build hooks
        -- for Haddock.
        (Verbosity -> String -> IO ()
warn Verbosity
verbosity)
        HaddockTarget
haddockTarget
        PackageDescription
pkg_descr
        LocalBuildInfo
lbi
        [PPSuffixHandler]
suffixes
        (HscolourFlags
defaultHscolourFlags HscolourFlags -> HscolourFlags -> HscolourFlags
forall a. Monoid a => a -> a -> a
`mappend` HaddockFlags -> HscolourFlags
haddockToHscolour HaddockFlags
flags)

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

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

    PackageDB
internalPackageDB <-
      Verbosity
-> LocalBuildInfo -> SymbolicPath Pkg ('Dir Dist) -> IO PackageDB
createInternalPackageDB Verbosity
verbosity LocalBuildInfo
lbi ((HaddockFlags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> SymbolicPath Pkg ('Dir Dist)
forall {a}. (HaddockFlags -> Flag a) -> a
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)

    ([MonitorFilePath]
mons, InstalledPackageIndex
_mbIPI) <- (\([MonitorFilePath], InstalledPackageIndex)
-> TargetInfo -> IO ([MonitorFilePath], InstalledPackageIndex)
f -> (([MonitorFilePath], InstalledPackageIndex)
 -> TargetInfo -> IO ([MonitorFilePath], InstalledPackageIndex))
-> ([MonitorFilePath], InstalledPackageIndex)
-> [TargetInfo]
-> IO ([MonitorFilePath], InstalledPackageIndex)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([MonitorFilePath], InstalledPackageIndex)
-> TargetInfo -> IO ([MonitorFilePath], InstalledPackageIndex)
f ([], LocalBuildInfo -> InstalledPackageIndex
installedPkgs LocalBuildInfo
lbi) [TargetInfo]
targets') ((([MonitorFilePath], InstalledPackageIndex)
  -> TargetInfo -> IO ([MonitorFilePath], InstalledPackageIndex))
 -> IO ([MonitorFilePath], InstalledPackageIndex))
-> (([MonitorFilePath], InstalledPackageIndex)
    -> TargetInfo -> IO ([MonitorFilePath], InstalledPackageIndex))
-> IO ([MonitorFilePath], InstalledPackageIndex)
forall a b. (a -> b) -> a -> b
$ \([MonitorFilePath]
monsAcc, InstalledPackageIndex
index) TargetInfo
target -> do
      let
        component :: Component
component = TargetInfo -> Component
targetComponent TargetInfo
target
        clbi :: ComponentLocalBuildInfo
clbi = TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
target
        bi :: BuildInfo
bi = Component -> BuildInfo
componentBuildInfo Component
component
        -- Include any build-tool-depends on build tools internal to the current package.
        progs' :: ProgramDb
progs' = PackageDescription
-> LocalBuildInfo -> BuildInfo -> ProgramDb -> ProgramDb
addInternalBuildTools PackageDescription
pkg_descr LocalBuildInfo
lbi BuildInfo
bi (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
        lbi' :: LocalBuildInfo
lbi' =
          LocalBuildInfo
lbi
            { withPrograms = progs'
            , withPackageDB = withPackageDB lbi ++ [internalPackageDB]
            , installedPkgs = index
            }
        pbci :: PreBuildComponentInputs
pbci = BuildingWhat
-> LocalBuildInfo -> TargetInfo -> PreBuildComponentInputs
SetupHooks.PreBuildComponentInputs (HaddockFlags -> BuildingWhat
BuildHaddock HaddockFlags
flags) LocalBuildInfo
lbi' TargetInfo
target
      [MonitorFilePath]
mons <- IO [MonitorFilePath]
-> Verbosity
-> LocalBuildInfo
-> TargetInfo
-> IO [MonitorFilePath]
forall r. IO r -> Verbosity -> LocalBuildInfo -> TargetInfo -> IO r
preBuildComponent (PreBuildComponentInputs -> IO [MonitorFilePath]
preBuildHook PreBuildComponentInputs
pbci) 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
            Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Build)
-> String
-> (SymbolicPath Pkg ('Dir Tmp) -> IO ())
-> IO ()
forall a tmpDir1 tmpDir2.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> String
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
withTempDirectoryCwdEx Verbosity
verbosity TempFileOptions
tmpFileOpts Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi') String
"tmp" ((SymbolicPath Pkg ('Dir Tmp) -> IO ()) -> IO ())
-> (SymbolicPath Pkg ('Dir Tmp) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
              \SymbolicPath Pkg ('Dir Tmp)
tmp -> do
                HaddockArgs
exeArgs <-
                  Verbosity
-> SymbolicPath Pkg ('Dir Tmp)
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> Executable
-> IO HaddockArgs
fromExecutable
                    Verbosity
verbosity
                    SymbolicPath Pkg ('Dir Tmp)
tmp
                    LocalBuildInfo
lbi'
                    ComponentLocalBuildInfo
clbi
                    Maybe PathTemplate
htmlTemplate
                    Version
version
                    Executable
exe
                let exeArgs' :: HaddockArgs
exeArgs' = HaddockArgs
commonArgs HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Monoid a => a -> a -> a
`mappend` HaddockArgs
exeArgs
                Verbosity
-> 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
True
                  HaddockArgs
exeArgs'
          Maybe Executable
Nothing -> do
            Verbosity -> String -> IO ()
warn
              Verbosity
verbosity
              String
"Unsupported component, skipping..."
            () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- We define 'smsg' once and then reuse it inside the case, so that
        -- we don't say we are running Haddock when we actually aren't
        -- (e.g., Haddock is not run on non-libraries)
        smsg :: IO ()
        smsg :: IO ()
smsg =
          Verbosity
-> String
-> PackageIdentifier
-> ComponentName
-> Maybe [(ModuleName, OpenModule)]
-> IO ()
forall a.
Pretty a =>
Verbosity
-> String
-> PackageIdentifier
-> ComponentName
-> Maybe [(ModuleName, a)]
-> IO ()
setupMessage'
            Verbosity
verbosity
            String
"Running Haddock on"
            (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)
            (ComponentLocalBuildInfo -> ComponentName
componentLocalName ComponentLocalBuildInfo
clbi)
            (ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)]
maybeComponentInstantiatedWith ComponentLocalBuildInfo
clbi)
      InstalledPackageIndex
ipi <- case Component
component of
        CLib Library
lib -> do
          Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Build)
-> String
-> (SymbolicPath Pkg ('Dir Tmp) -> IO InstalledPackageIndex)
-> IO InstalledPackageIndex
forall a tmpDir1 tmpDir2.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> String
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
withTempDirectoryCwdEx Verbosity
verbosity TempFileOptions
tmpFileOpts Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi) String
"tmp" ((SymbolicPath Pkg ('Dir Tmp) -> IO InstalledPackageIndex)
 -> IO InstalledPackageIndex)
-> (SymbolicPath Pkg ('Dir Tmp) -> IO InstalledPackageIndex)
-> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$
            \SymbolicPath Pkg ('Dir Tmp)
tmp -> do
              IO ()
smsg
              HaddockArgs
libArgs <-
                Verbosity
-> SymbolicPath Pkg ('Dir Tmp)
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> Library
-> IO HaddockArgs
fromLibrary
                  Verbosity
verbosity
                  SymbolicPath Pkg ('Dir Tmp)
tmp
                  LocalBuildInfo
lbi'
                  ComponentLocalBuildInfo
clbi
                  Maybe PathTemplate
htmlTemplate
                  Version
version
                  Library
lib
              let libArgs' :: HaddockArgs
libArgs' = HaddockArgs
commonArgs HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Monoid a => a -> a -> a
`mappend` HaddockArgs
libArgs
              Verbosity
-> 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
True HaddockArgs
libArgs'
              String
inplaceDir <- LocalBuildInfo -> IO String
absoluteWorkingDirLBI LocalBuildInfo
lbi

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

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

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

              InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageIndex -> IO InstalledPackageIndex)
-> InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo
-> InstalledPackageIndex -> InstalledPackageIndex
PackageIndex.insert InstalledPackageInfo
ipi InstalledPackageIndex
index
        CFLib ForeignLib
flib ->
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
            ((HaddockFlags -> Flag Bool) -> Bool
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockForeignLibs)
            ( do
                Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Build)
-> String
-> (SymbolicPath Pkg ('Dir Tmp) -> IO ())
-> IO ()
forall a tmpDir1 tmpDir2.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> String
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
withTempDirectoryCwdEx Verbosity
verbosity TempFileOptions
tmpFileOpts Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi') String
"tmp" ((SymbolicPath Pkg ('Dir Tmp) -> IO ()) -> IO ())
-> (SymbolicPath Pkg ('Dir Tmp) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                  \SymbolicPath Pkg ('Dir Tmp)
tmp -> do
                    IO ()
smsg
                    HaddockArgs
flibArgs <-
                      Verbosity
-> SymbolicPath Pkg ('Dir Tmp)
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> ForeignLib
-> IO HaddockArgs
fromForeignLib
                        Verbosity
verbosity
                        SymbolicPath Pkg ('Dir Tmp)
tmp
                        LocalBuildInfo
lbi'
                        ComponentLocalBuildInfo
clbi
                        Maybe PathTemplate
htmlTemplate
                        Version
version
                        ForeignLib
flib
                    let libArgs' :: HaddockArgs
libArgs' = HaddockArgs
commonArgs HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Monoid a => a -> a -> a
`mappend` HaddockArgs
flibArgs
                    Verbosity
-> 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
True HaddockArgs
libArgs'
            )
            IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
index
        CExe Executable
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Flag Bool) -> Bool
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockExecutables) (IO ()
smsg IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Component -> IO ()
doExe Component
component) IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
index
        CTest TestSuite
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Flag Bool) -> Bool
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockTestSuites) (IO ()
smsg IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Component -> IO ()
doExe Component
component) IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
index
        CBench Benchmark
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Flag Bool) -> Bool
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockBenchmarks) (IO ()
smsg IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Component -> IO ()
doExe Component
component) IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
index

      ([MonitorFilePath], InstalledPackageIndex)
-> IO ([MonitorFilePath], InstalledPackageIndex)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([MonitorFilePath]
monsAcc [MonitorFilePath] -> [MonitorFilePath] -> [MonitorFilePath]
forall a. [a] -> [a] -> [a]
++ [MonitorFilePath]
mons, InstalledPackageIndex
ipi)

    [RelativePath Pkg 'File]
-> (RelativePath Pkg 'File -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (PackageDescription -> [RelativePath Pkg 'File]
extraDocFiles PackageDescription
pkg_descr) ((RelativePath Pkg 'File -> IO ()) -> IO ())
-> (RelativePath Pkg 'File -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RelativePath Pkg 'File
fpath -> do
      [RelativePath Pkg 'File]
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
      [RelativePath Pkg 'File]
-> (RelativePath Pkg 'File -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [RelativePath Pkg 'File]
files ((RelativePath Pkg 'File -> IO ()) -> IO ())
-> (RelativePath Pkg 'File -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Artifacts)
-> RelativePath Pkg 'File
-> IO ()
forall target.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir target)
-> RelativePath Pkg 'File
-> IO ()
copyFileToCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (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
commonArgs)

    [MonitorFilePath] -> IO [MonitorFilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [MonitorFilePath]
mons

-- | 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
  (ConfiguredProgram
haddockProg, Version
_version) <-
    Verbosity
-> ProgramDb
-> Compiler
-> HaddockArgs
-> Flag Bool
-> IO (ConfiguredProgram, Version)
getHaddockProg Verbosity
verbosity ProgramDb
programDb Compiler
comp HaddockArgs
args (Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True)
  Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> TempFileOptions
-> Compiler
-> Platform
-> ConfiguredProgram
-> Bool
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir TempFileOptions
defaultTempFileOptions Compiler
comp Platform
platform ConfiguredProgram
haddockProg Bool
False HaddockArgs
args

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

fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags PathTemplateEnv
env HaddockFlags
flags =
  HaddockArgs
forall a. Monoid a => a
mempty
    { argHideModules =
        ( maybe mempty (All . not) $
            flagToMaybe (haddockInternal flags)
        , mempty
        )
    , argLinkSource =
        if fromFlag (haddockLinkedSource flags)
          then
            Flag
              ( "src/%{MODULE/./-}.html"
              , "src/%{MODULE/./-}.html#%{NAME}"
              , "src/%{MODULE/./-}.html#line-%{LINE}"
              )
          else NoFlag
    , argLinkedSource = haddockLinkedSource flags
    , argQuickJump = haddockQuickJump flags
    , argCssFile = haddockCss flags
    , argContents =
        fmap
          (fromPathTemplate . substPathTemplate env)
          (haddockContents flags)
    , argGenContents = Flag False
    , argIndex =
        fmap
          (fromPathTemplate . substPathTemplate env)
          (haddockIndex flags)
    , argGenIndex = Flag False
    , argBaseUrl = haddockBaseUrl flags
    , argLib = haddockLib flags
    , argVerbose =
        maybe mempty (Any . (>= deafening))
          . flagToMaybe
          $ 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}
    }
  where
    ghcArgs :: [String]
ghcArgs = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [String] -> [String])
-> (HaddockFlags -> Maybe [String]) -> HaddockFlags -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, [String])] -> Maybe [String]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"ghc" ([(String, [String])] -> Maybe [String])
-> (HaddockFlags -> [(String, [String])])
-> HaddockFlags
-> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockFlags -> [(String, [String])]
haddockProgramArgs (HaddockFlags -> [String]) -> HaddockFlags -> [String]
forall a b. (a -> b) -> a -> b
$ HaddockFlags
flags
    commonFlags :: CommonSetupFlags
commonFlags = HaddockFlags -> CommonSetupFlags
haddockCommonFlags HaddockFlags
flags

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

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

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

mkHaddockArgs
  :: Verbosity
  -> SymbolicPath Pkg (Path.Dir Tmp)
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Maybe PathTemplate
  -- ^ template for HTML location
  -> Version
  -> [SymbolicPath Pkg File]
  -> BuildInfo
  -> IO HaddockArgs
mkHaddockArgs :: Verbosity
-> SymbolicPath Pkg ('Dir Tmp)
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> [SymbolicPath Pkg 'File]
-> BuildInfo
-> IO HaddockArgs
mkHaddockArgs Verbosity
verbosity SymbolicPath Pkg ('Dir Tmp)
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate Version
haddockVersion [SymbolicPath Pkg 'File]
inFiles BuildInfo
bi = do
  HaddockArgs
ifaceArgs <- Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO HaddockArgs
getInterfaces Verbosity
verbosity LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate
  let vanillaOpts :: GhcOptions
vanillaOpts =
        (Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> 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))
          { -- Noooooooooo!!!!!111
            -- haddock stomps on our precious .hi
            -- and .o files. Workaround by telling
            -- haddock to write them elsewhere.
            ghcOptObjDir = toFlag $ coerceSymbolicPath tmp
          , ghcOptHiDir = toFlag $ coerceSymbolicPath tmp
          , ghcOptStubDir = toFlag $ coerceSymbolicPath tmp
          }
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` Version -> BuildInfo -> GhcOptions
getGhcCppOpts Version
haddockVersion BuildInfo
bi
      sharedOpts :: GhcOptions
sharedOpts =
        GhcOptions
vanillaOpts
          { ghcOptDynLinkMode = toFlag GhcDynamicOnly
          , ghcOptFPic = toFlag True
          , ghcOptHiSuffix = toFlag "dyn_hi"
          , ghcOptObjSuffix = toFlag "dyn_o"
          , ghcOptExtra = hcSharedOptions GHC bi
          }
  GhcOptions
opts <-
    if LocalBuildInfo -> Bool
withVanillaLib LocalBuildInfo
lbi
      then GhcOptions -> IO GhcOptions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GhcOptions
vanillaOpts
      else
        if LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi
          then GhcOptions -> IO GhcOptions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GhcOptions
sharedOpts
          else Verbosity -> CabalException -> IO GhcOptions
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
MustHaveSharedLibraries

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

fromLibrary
  :: Verbosity
  -> SymbolicPath Pkg (Path.Dir Tmp)
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Maybe PathTemplate
  -- ^ template for HTML location
  -> Version
  -> Library
  -> IO HaddockArgs
fromLibrary :: Verbosity
-> SymbolicPath Pkg ('Dir Tmp)
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> Library
-> IO HaddockArgs
fromLibrary Verbosity
verbosity SymbolicPath Pkg ('Dir Tmp)
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate Version
haddockVersion Library
lib = do
  [SymbolicPath Pkg 'File]
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
  HaddockArgs
args <-
    Verbosity
-> SymbolicPath Pkg ('Dir Tmp)
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> [SymbolicPath Pkg 'File]
-> BuildInfo
-> IO HaddockArgs
mkHaddockArgs
      Verbosity
verbosity
      SymbolicPath Pkg ('Dir Tmp)
tmp
      LocalBuildInfo
lbi
      ComponentLocalBuildInfo
clbi
      Maybe PathTemplate
htmlTemplate
      Version
haddockVersion
      [SymbolicPath Pkg 'File]
inFiles
      (Library -> BuildInfo
libBuildInfo Library
lib)
  HaddockArgs -> IO HaddockArgs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    HaddockArgs
args
      { argHideModules = (mempty, otherModules (libBuildInfo lib))
      }

fromExecutable
  :: Verbosity
  -> SymbolicPath Pkg (Path.Dir Tmp)
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Maybe PathTemplate
  -- ^ template for HTML location
  -> Version
  -> Executable
  -> IO HaddockArgs
fromExecutable :: Verbosity
-> SymbolicPath Pkg ('Dir Tmp)
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> Executable
-> IO HaddockArgs
fromExecutable Verbosity
verbosity SymbolicPath Pkg ('Dir Tmp)
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate Version
haddockVersion Executable
exe = do
  [SymbolicPath Pkg 'File]
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
  HaddockArgs
args <-
    Verbosity
-> SymbolicPath Pkg ('Dir Tmp)
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> [SymbolicPath Pkg 'File]
-> BuildInfo
-> IO HaddockArgs
mkHaddockArgs
      Verbosity
verbosity
      SymbolicPath Pkg ('Dir Tmp)
tmp
      LocalBuildInfo
lbi
      ComponentLocalBuildInfo
clbi
      Maybe PathTemplate
htmlTemplate
      Version
haddockVersion
      [SymbolicPath Pkg 'File]
inFiles
      (Executable -> BuildInfo
buildInfo Executable
exe)
  HaddockArgs -> IO HaddockArgs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    HaddockArgs
args
      { argOutputDir = Dir $ unUnqualComponentName $ exeName exe
      , argTitle = Flag $ unUnqualComponentName $ exeName exe
      }

fromForeignLib
  :: Verbosity
  -> SymbolicPath Pkg (Path.Dir Tmp)
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Maybe PathTemplate
  -- ^ template for HTML location
  -> Version
  -> ForeignLib
  -> IO HaddockArgs
fromForeignLib :: Verbosity
-> SymbolicPath Pkg ('Dir Tmp)
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> ForeignLib
-> IO HaddockArgs
fromForeignLib Verbosity
verbosity SymbolicPath Pkg ('Dir Tmp)
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate Version
haddockVersion ForeignLib
flib = do
  [SymbolicPath Pkg 'File]
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
  HaddockArgs
args <-
    Verbosity
-> SymbolicPath Pkg ('Dir Tmp)
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> [SymbolicPath Pkg 'File]
-> BuildInfo
-> IO HaddockArgs
mkHaddockArgs
      Verbosity
verbosity
      SymbolicPath Pkg ('Dir Tmp)
tmp
      LocalBuildInfo
lbi
      ComponentLocalBuildInfo
clbi
      Maybe PathTemplate
htmlTemplate
      Version
haddockVersion
      [SymbolicPath Pkg 'File]
inFiles
      (ForeignLib -> BuildInfo
foreignLibBuildInfo ForeignLib
flib)
  HaddockArgs -> IO HaddockArgs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    HaddockArgs
args
      { argOutputDir = Dir $ unUnqualComponentName $ foreignLibName flib
      , argTitle = Flag $ unUnqualComponentName $ foreignLibName flib
      }

compToExe :: Component -> Maybe Executable
compToExe :: Component -> Maybe Executable
compToExe Component
comp =
  case Component
comp of
    CTest test :: TestSuite
test@TestSuite{testInterface :: TestSuite -> TestSuiteInterface
testInterface = TestSuiteExeV10 Version
_ 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
  ([(String, Maybe String, Maybe String, Visibility)]
packageFlags, Maybe String
warnings) <- Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO
     ([(String, Maybe String, Maybe String, Visibility)], Maybe String)
haddockPackageFlags Verbosity
verbosity LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate
  (String -> IO ()) -> Maybe String -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> String -> IO ()
warn (Verbosity -> Verbosity
verboseUnmarkOutput Verbosity
verbosity)) Maybe String
warnings
  HaddockArgs -> IO HaddockArgs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockArgs -> IO HaddockArgs) -> HaddockArgs -> IO HaddockArgs
forall a b. (a -> b) -> a -> b
$
    HaddockArgs
forall a. Monoid a => a
mempty
      { argInterfaces = packageFlags
      }

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

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

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

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

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

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

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

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

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

                [ case (Maybe String
html, Maybe String
hypsrc) of
                    (Maybe String
Nothing, Maybe String
_) -> String
""
                    (Maybe String
_, Maybe String
Nothing) -> String
""
                    (Maybe String
_, Just String
x)
                      | Int -> Int -> Bool
isVersion Int
2 Int
17
                      , Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool)
-> (HaddockArgs -> Flag Bool) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag Bool
argLinkedSource (HaddockArgs -> Bool) -> HaddockArgs -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args ->
                          String
x
                      | Bool
otherwise ->
                          String
""
                ]
              , if Bool
haddockSupportsVisibility
                  then
                    [ case Visibility
visibility of
                        Visibility
Visible -> String
"visible"
                        Visibility
Hidden -> String
"hidden"
                    ]
                  else []
              , [String
i]
              ]
          )

    bool :: p -> p -> Bool -> p
bool p
a p
b Bool
c = if Bool
c then p
a else p
b
    isVersion :: Int -> Int -> Bool
isVersion Int
major Int
minor = Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
major, Int
minor]
    verbosityFlag :: String
verbosityFlag
      | Int -> Int -> Bool
isVersion Int
2 Int
5 = String
"--verbosity=1"
      | Bool
otherwise = String
"--verbose"
    haddockSupportsVisibility :: Bool
haddockSupportsVisibility = Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
2, Int
26, Int
1]
    haddockSupportsPackageName :: Bool
haddockSupportsPackageName = Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> [Int] -> Version
mkVersion [Int
2, Int
16]
    haddockSupportsHyperlinkedSource :: Bool
haddockSupportsHyperlinkedSource = Int -> Int -> Bool
isVersion Int
2 Int
17
    isHyperlinkedSource :: Bool
isHyperlinkedSource =
      Bool
haddockSupportsHyperlinkedSource
        Bool -> Bool -> Bool
&& Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockArgs -> Flag Bool
argLinkedSource HaddockArgs
args)

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

-- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and
-- HTML paths, and an optional warning for packages with missing documentation.
haddockPackagePaths
  :: [InstalledPackageInfo]
  -> Maybe (InstalledPackageInfo -> FilePath)
  -> IO
      ( [ ( FilePath -- path to interface
      -- file
          , Maybe FilePath -- url to html
          -- documentation
          , Maybe FilePath -- url to hyperlinked
          -- source
          , Visibility
          )
        ]
      , Maybe String -- warning about
      -- missing documentation
      )
haddockPackagePaths :: [InstalledPackageInfo]
-> Maybe (InstalledPackageInfo -> String)
-> IO
     ([(String, Maybe String, Maybe String, Visibility)], Maybe String)
haddockPackagePaths [InstalledPackageInfo]
ipkgs Maybe (InstalledPackageInfo -> String)
mkHtmlPath = do
  [Either
   PackageIdentifier (String, Maybe String, Maybe String, Visibility)]
interfaces <-
    [IO
   (Either
      PackageIdentifier
      (String, Maybe String, Maybe String, Visibility))]
-> IO
     [Either
        PackageIdentifier (String, Maybe String, Maybe String, Visibility)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
      [ case InstalledPackageInfo -> Maybe (String, Maybe String)
interfaceAndHtmlPath InstalledPackageInfo
ipkg of
        Maybe (String, Maybe String)
Nothing -> Either
  PackageIdentifier (String, Maybe String, Maybe String, Visibility)
-> IO
     (Either
        PackageIdentifier (String, Maybe String, Maybe String, Visibility))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageIdentifier
-> Either
     PackageIdentifier (String, Maybe String, Maybe String, Visibility)
forall a b. a -> Either a b
Left (InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId InstalledPackageInfo
ipkg))
        Just (String
interface, Maybe String
html) -> do
          (Maybe String
html', Maybe String
hypsrc') <-
            case Maybe String
html of
              Just String
htmlPath -> do
                let hypSrcPath :: String
hypSrcPath = String
htmlPath String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
defaultHyperlinkedSourceDirectory
                Bool
hypSrcExists <- String -> IO Bool
doesDirectoryExist String
hypSrcPath
                (Maybe String, Maybe String) -> IO (Maybe String, Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe String, Maybe String) -> IO (Maybe String, Maybe String))
-> (Maybe String, Maybe String) -> IO (Maybe String, Maybe String)
forall a b. (a -> b) -> a -> b
$
                  ( String -> Maybe String
forall a. a -> Maybe a
Just (ShowS
fixFileUrl String
htmlPath)
                  , if Bool
hypSrcExists
                      then String -> Maybe String
forall a. a -> Maybe a
Just (ShowS
fixFileUrl String
hypSrcPath)
                      else Maybe String
forall a. Maybe a
Nothing
                  )
              Maybe String
Nothing -> (Maybe String, Maybe String) -> IO (Maybe String, Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
forall a. Maybe a
Nothing, Maybe String
forall a. Maybe a
Nothing)

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

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

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

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

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

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

haddockPackageFlags
  :: Verbosity
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Maybe PathTemplate
  -> IO
      ( [ ( FilePath -- path to interface
      -- file
          , Maybe FilePath -- url to html
          -- documentation
          , Maybe FilePath -- url to hyperlinked
          -- source
          , Visibility
          )
        ]
      , Maybe String -- warning about
      -- missing documentation
      )
haddockPackageFlags :: Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO
     ([(String, Maybe String, Maybe String, Visibility)], Maybe String)
haddockPackageFlags Verbosity
verbosity LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate = do
  let allPkgs :: InstalledPackageIndex
allPkgs = LocalBuildInfo -> InstalledPackageIndex
installedPkgs LocalBuildInfo
lbi
      directDeps :: [UnitId]
directDeps = ((UnitId, MungedPackageId) -> UnitId)
-> [(UnitId, MungedPackageId)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, MungedPackageId) -> UnitId
forall a b. (a, b) -> a
fst (ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
componentPackageDeps ComponentLocalBuildInfo
clbi)
  InstalledPackageIndex
transitiveDeps <- case InstalledPackageIndex
-> [UnitId]
-> Either InstalledPackageIndex [(InstalledPackageInfo, [UnitId])]
PackageIndex.dependencyClosure InstalledPackageIndex
allPkgs [UnitId]
directDeps of
    Left InstalledPackageIndex
x -> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
x
    Right [(InstalledPackageInfo, [UnitId])]
inf ->
      Verbosity -> CabalException -> IO InstalledPackageIndex
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO InstalledPackageIndex)
-> CabalException -> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$ [(InstalledPackageInfo, [UnitId])] -> CabalException
HaddockPackageFlags [(InstalledPackageInfo, [UnitId])]
inf

  [InstalledPackageInfo]
-> Maybe (InstalledPackageInfo -> String)
-> IO
     ([(String, Maybe String, Maybe String, Visibility)], Maybe String)
haddockPackagePaths (InstalledPackageIndex -> [InstalledPackageInfo]
forall a. PackageIndex a -> [a]
PackageIndex.allPackages InstalledPackageIndex
transitiveDeps) Maybe (InstalledPackageInfo -> String)
mkHtmlPath
  where
    mkHtmlPath :: Maybe (InstalledPackageInfo -> String)
mkHtmlPath = (PathTemplate -> InstalledPackageInfo -> String)
-> Maybe PathTemplate -> Maybe (InstalledPackageInfo -> String)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> InstalledPackageInfo -> String
forall {pkg}. Package pkg => PathTemplate -> pkg -> String
expandTemplateVars Maybe PathTemplate
htmlTemplate
    expandTemplateVars :: PathTemplate -> pkg -> String
expandTemplateVars PathTemplate
tmpl pkg
pkg =
      PathTemplate -> String
fromPathTemplate (PathTemplate -> String)
-> (PathTemplate -> PathTemplate) -> PathTemplate -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate (pkg -> PathTemplateEnv
forall {pkg}. Package pkg => pkg -> PathTemplateEnv
env pkg
pkg) (PathTemplate -> String) -> PathTemplate -> String
forall a b. (a -> b) -> a -> b
$ PathTemplate
tmpl
    env :: pkg -> PathTemplateEnv
env pkg
pkg = LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
haddockTemplateEnv LocalBuildInfo
lbi (pkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId pkg
pkg)

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

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

hscolour
  :: PackageDescription
  -> LocalBuildInfo
  -> [PPSuffixHandler]
  -> HscolourFlags
  -> IO ()
hscolour :: PackageDescription
-> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO ()
hscolour = (PreBuildComponentInputs -> IO [MonitorFilePath])
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour_setupHooks (IO [MonitorFilePath]
-> PreBuildComponentInputs -> IO [MonitorFilePath]
forall a b. a -> b -> a
const (IO [MonitorFilePath]
 -> PreBuildComponentInputs -> IO [MonitorFilePath])
-> IO [MonitorFilePath]
-> PreBuildComponentInputs
-> IO [MonitorFilePath]
forall a b. (a -> b) -> a -> b
$ [MonitorFilePath] -> IO [MonitorFilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [])

hscolour_setupHooks
  :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath])
  -- ^ pre-build hook
  -> PackageDescription
  -> LocalBuildInfo
  -> [PPSuffixHandler]
  -> HscolourFlags
  -> IO ()
hscolour_setupHooks :: (PreBuildComponentInputs -> IO [MonitorFilePath])
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour_setupHooks PreBuildComponentInputs -> IO [MonitorFilePath]
preBuildHook =
  (PreBuildComponentInputs -> IO [MonitorFilePath])
-> (String -> IO ())
-> HaddockTarget
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour' PreBuildComponentInputs -> IO [MonitorFilePath]
preBuildHook String -> IO ()
forall a. String -> IO a
dieNoVerbosity HaddockTarget
ForDevelopment

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

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

        Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage Verbosity
verbosity String
"Running hscolour for" (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)
        Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          SymbolicPath Pkg ('Dir Artifacts) -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i (SymbolicPath Pkg ('Dir Artifacts) -> String)
-> SymbolicPath Pkg ('Dir Artifacts) -> String
forall a b. (a -> b) -> a -> b
$
            HaddockTarget
-> SymbolicPath Pkg ('Dir Dist)
-> PackageDescription
-> SymbolicPath Pkg ('Dir Artifacts)
forall root.
HaddockTarget
-> SymbolicPath root ('Dir Dist)
-> PackageDescription
-> SymbolicPath root ('Dir Artifacts)
hscolourPref HaddockTarget
haddockTarget SymbolicPath Pkg ('Dir Dist)
distPref PackageDescription
pkg_descr

        PackageDescription
-> LocalBuildInfo
-> (Component -> ComponentLocalBuildInfo -> IO ())
-> IO ()
withAllComponentsInBuildOrder PackageDescription
pkg_descr LocalBuildInfo
lbi ((Component -> ComponentLocalBuildInfo -> IO ()) -> IO ())
-> (Component -> ComponentLocalBuildInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Component
comp ComponentLocalBuildInfo
clbi -> do
          let
            target :: TargetInfo
target = ComponentLocalBuildInfo -> Component -> TargetInfo
TargetInfo ComponentLocalBuildInfo
clbi Component
comp
            pbci :: PreBuildComponentInputs
pbci = BuildingWhat
-> LocalBuildInfo -> TargetInfo -> PreBuildComponentInputs
SetupHooks.PreBuildComponentInputs (HscolourFlags -> BuildingWhat
BuildHscolour HscolourFlags
flags) LocalBuildInfo
lbi TargetInfo
target
          [MonitorFilePath]
_monitors <- IO [MonitorFilePath]
-> Verbosity
-> LocalBuildInfo
-> TargetInfo
-> IO [MonitorFilePath]
forall r. IO r -> Verbosity -> LocalBuildInfo -> TargetInfo -> IO r
preBuildComponent (PreBuildComponentInputs -> IO [MonitorFilePath]
preBuildHook PreBuildComponentInputs
pbci) Verbosity
verbosity LocalBuildInfo
lbi TargetInfo
target
          PackageDescription
-> Component
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Bool
-> Verbosity
-> [PPSuffixHandler]
-> IO ()
preprocessComponent PackageDescription
pkg_descr Component
comp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Bool
False Verbosity
verbosity [PPSuffixHandler]
suffixes
          let
            doExe :: Component -> IO ()
doExe Component
com = case (Component -> Maybe Executable
compToExe Component
com) of
              Just Executable
exe -> do
                let outputDir :: SymbolicPathX 'AllowAbsolute Pkg c3
outputDir =
                      HaddockTarget
-> SymbolicPath Pkg ('Dir Dist)
-> PackageDescription
-> SymbolicPath Pkg ('Dir Artifacts)
forall root.
HaddockTarget
-> SymbolicPath root ('Dir Dist)
-> PackageDescription
-> SymbolicPath root ('Dir Artifacts)
hscolourPref HaddockTarget
haddockTarget SymbolicPath Pkg ('Dir Dist)
distPref PackageDescription
pkg_descr
                        SymbolicPath Pkg ('Dir Artifacts)
-> RelativePath Artifacts c3 -> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Artifacts c3
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx (UnqualComponentName -> String
unUnqualComponentName (Executable -> UnqualComponentName
exeName Executable
exe) String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
"src")
                ConfiguredProgram
-> SymbolicPathX 'AllowAbsolute Pkg Any
-> [(ModuleName, SymbolicPath Pkg 'File)]
-> IO ()
forall (to :: FileOrDir) (to1 :: FileOrDir).
ConfiguredProgram
-> SymbolicPath Pkg to
-> [(ModuleName, SymbolicPath Pkg to1)]
-> IO ()
runHsColour ConfiguredProgram
hscolourProg SymbolicPathX 'AllowAbsolute Pkg Any
forall {to2 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg to2
outputDir ([(ModuleName, SymbolicPath Pkg 'File)] -> IO ())
-> IO [(ModuleName, SymbolicPath Pkg 'File)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
getExeSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Executable
exe ComponentLocalBuildInfo
clbi
              Maybe Executable
Nothing -> do
                Verbosity -> String -> IO ()
warn Verbosity
verbosity String
"Unsupported component, skipping..."
                () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          case Component
comp of
            CLib Library
lib -> do
              let outputDir :: SymbolicPathX 'AllowAbsolute Pkg c3
outputDir = HaddockTarget
-> SymbolicPath Pkg ('Dir Dist)
-> PackageDescription
-> SymbolicPath Pkg ('Dir Artifacts)
forall root.
HaddockTarget
-> SymbolicPath root ('Dir Dist)
-> PackageDescription
-> SymbolicPath root ('Dir Artifacts)
hscolourPref HaddockTarget
haddockTarget SymbolicPath Pkg ('Dir Dist)
distPref PackageDescription
pkg_descr SymbolicPath Pkg ('Dir Artifacts)
-> RelativePath Artifacts c3 -> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Artifacts c3
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx String
"src"
              ConfiguredProgram
-> SymbolicPathX 'AllowAbsolute Pkg Any
-> [(ModuleName, SymbolicPath Pkg 'File)]
-> IO ()
forall (to :: FileOrDir) (to1 :: FileOrDir).
ConfiguredProgram
-> SymbolicPath Pkg to
-> [(ModuleName, SymbolicPath Pkg to1)]
-> IO ()
runHsColour ConfiguredProgram
hscolourProg SymbolicPathX 'AllowAbsolute Pkg Any
forall {to2 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg to2
outputDir ([(ModuleName, SymbolicPath Pkg 'File)] -> IO ())
-> IO [(ModuleName, SymbolicPath Pkg 'File)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
getLibSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi
            CFLib ForeignLib
flib -> do
              let outputDir :: SymbolicPathX 'AllowAbsolute Pkg c3
outputDir =
                    HaddockTarget
-> SymbolicPath Pkg ('Dir Dist)
-> PackageDescription
-> SymbolicPath Pkg ('Dir Artifacts)
forall root.
HaddockTarget
-> SymbolicPath root ('Dir Dist)
-> PackageDescription
-> SymbolicPath root ('Dir Artifacts)
hscolourPref HaddockTarget
haddockTarget SymbolicPath Pkg ('Dir Dist)
distPref PackageDescription
pkg_descr
                      SymbolicPath Pkg ('Dir Artifacts)
-> RelativePath Artifacts c3 -> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Artifacts c3
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx
                        ( UnqualComponentName -> String
unUnqualComponentName (ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib)
                            String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
"src"
                        )
              ConfiguredProgram
-> SymbolicPathX 'AllowAbsolute Pkg Any
-> [(ModuleName, SymbolicPath Pkg 'File)]
-> IO ()
forall (to :: FileOrDir) (to1 :: FileOrDir).
ConfiguredProgram
-> SymbolicPath Pkg to
-> [(ModuleName, SymbolicPath Pkg to1)]
-> IO ()
runHsColour ConfiguredProgram
hscolourProg SymbolicPathX 'AllowAbsolute Pkg Any
forall {to2 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg to2
outputDir ([(ModuleName, SymbolicPath Pkg 'File)] -> IO ())
-> IO [(ModuleName, SymbolicPath Pkg 'File)] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity
-> LocalBuildInfo
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO [(ModuleName, SymbolicPath Pkg 'File)]
getFLibSourceFiles Verbosity
verbosity LocalBuildInfo
lbi ForeignLib
flib ComponentLocalBuildInfo
clbi
            CExe Executable
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Flag Bool
hscolourExecutables HscolourFlags
flags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Component -> IO ()
doExe Component
comp
            CTest TestSuite
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Flag Bool
hscolourTestSuites HscolourFlags
flags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Component -> IO ()
doExe Component
comp
            CBench Benchmark
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Flag Bool
hscolourBenchmarks HscolourFlags
flags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Component -> IO ()
doExe Component
comp

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

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

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

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

haddockToHscolour :: HaddockFlags -> HscolourFlags
haddockToHscolour :: HaddockFlags -> HscolourFlags
haddockToHscolour HaddockFlags
flags =
  HscolourFlags
    { hscolourCommonFlags :: CommonSetupFlags
hscolourCommonFlags = HaddockFlags -> CommonSetupFlags
haddockCommonFlags HaddockFlags
flags
    , hscolourCSS :: Flag String
hscolourCSS = HaddockFlags -> Flag String
haddockHscolourCss HaddockFlags
flags
    , hscolourExecutables :: Flag Bool
hscolourExecutables = HaddockFlags -> Flag Bool
haddockExecutables HaddockFlags
flags
    , hscolourTestSuites :: Flag Bool
hscolourTestSuites = HaddockFlags -> Flag Bool
haddockTestSuites HaddockFlags
flags
    , hscolourBenchmarks :: Flag Bool
hscolourBenchmarks = HaddockFlags -> Flag Bool
haddockBenchmarks HaddockFlags
flags
    , hscolourForeignLibs :: Flag Bool
hscolourForeignLibs = HaddockFlags -> Flag Bool
haddockForeignLibs HaddockFlags
flags
    }

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

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

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

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