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

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

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

import 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.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.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.Haddock
import Distribution.Simple.Setup.Hscolour
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 qualified Distribution.Utils.ShortText as ShortText
import Distribution.Version

import Distribution.Verbosity
import Language.Haskell.Extension

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

import Control.Monad
import Data.Either (rights)

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

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

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

type Template = String

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

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

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

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

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

  FilePath
haddockGhcVersionStr <-
    Verbosity -> ConfiguredProgram -> [FilePath] -> IO FilePath
getProgramOutput
      Verbosity
verbosity
      ConfiguredProgram
haddockProg
      [FilePath
"--ghc-version"]
  case (FilePath -> Maybe Version
forall a. Parsec a => FilePath -> Maybe a
simpleParsec FilePath
haddockGhcVersionStr, CompilerFlavor -> Compiler -> Maybe Version
compilerCompatVersion CompilerFlavor
GHC Compiler
comp) of
    (Maybe Version
Nothing, Maybe Version
_) -> Verbosity -> 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_descr LocalBuildInfo
_ [PPSuffixHandler]
_ HaddockFlags
haddockFlags
  | Bool -> Bool
not (PackageDescription -> Bool
hasLibs PackageDescription
pkg_descr)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockExecutables HaddockFlags
haddockFlags)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockTestSuites HaddockFlags
haddockFlags)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockBenchmarks HaddockFlags
haddockFlags)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockForeignLibs HaddockFlags
haddockFlags) =
      Verbosity -> FilePath -> IO ()
warn (Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Verbosity
haddockVerbosity HaddockFlags
haddockFlags) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"No documentation was generated as this package does not contain "
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"a library. Perhaps you want to use the --executables, --tests,"
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" --benchmarks or --foreign-libraries flags."
haddock PackageDescription
pkg_descr LocalBuildInfo
lbi [PPSuffixHandler]
suffixes HaddockFlags
flags' = do
  let verbosity :: Verbosity
verbosity = (HaddockFlags -> Flag Verbosity) -> Verbosity
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Verbosity
haddockVerbosity
      comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
      platform :: Platform
platform = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi

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

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

  HaddockArgs
libdirArgs <- Verbosity -> LocalBuildInfo -> IO HaddockArgs
getGhcLibDir Verbosity
verbosity LocalBuildInfo
lbi
  -- 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 FilePath
haddockOutputDir HaddockFlags
flags of
        Flag FilePath
NoFlag -> HaddockArgs
args
        Flag FilePath
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
$
    (FilePath -> IO ())
-> HaddockTarget
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour'
      (Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity)
      HaddockTarget
haddockTarget
      PackageDescription
pkg_descr
      LocalBuildInfo
lbi
      [PPSuffixHandler]
suffixes
      (HscolourFlags
defaultHscolourFlags HscolourFlags -> HscolourFlags -> HscolourFlags
forall a. Monoid a => a -> a -> a
`mappend` HaddockFlags -> HscolourFlags
haddockToHscolour HaddockFlags
flags)

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

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

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

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

    Verbosity -> LocalBuildInfo -> TargetInfo -> IO ()
preBuildComponent Verbosity
verbosity LocalBuildInfo
lbi TargetInfo
target

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

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

            FilePath
pwd <- IO FilePath
getCurrentDirectory

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

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

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

            InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageIndex -> IO InstalledPackageIndex)
-> InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo
-> InstalledPackageIndex -> InstalledPackageIndex
PackageIndex.insert InstalledPackageInfo
ipi InstalledPackageIndex
index
      CFLib ForeignLib
flib ->
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
          ((HaddockFlags -> Flag Bool) -> Bool
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockForeignLibs)
          ( do
              Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO a)
-> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
tmpFileOpts (LocalBuildInfo -> FilePath
buildDir LocalBuildInfo
lbi') FilePath
"tmp" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                \FilePath
tmp -> do
                  IO ()
smsg
                  HaddockArgs
flibArgs <-
                    Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> Version
-> ForeignLib
-> IO HaddockArgs
fromForeignLib
                      Verbosity
verbosity
                      FilePath
tmp
                      LocalBuildInfo
lbi'
                      ComponentLocalBuildInfo
clbi
                      Maybe PathTemplate
htmlTemplate
                      Version
version
                      ForeignLib
flib
                  let libArgs' :: HaddockArgs
libArgs' = HaddockArgs
commonArgs HaddockArgs -> HaddockArgs -> HaddockArgs
forall a. Monoid a => a -> a -> a
`mappend` HaddockArgs
flibArgs
                  Verbosity
-> TempFileOptions
-> Compiler
-> Platform
-> ConfiguredProgram
-> Bool
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
tmpFileOpts Compiler
comp Platform
platform ConfiguredProgram
haddockProg Bool
True HaddockArgs
libArgs'
          )
          IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
index
      CExe Executable
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((HaddockFlags -> Flag Bool) -> Bool
forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockExecutables) (IO ()
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

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

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

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

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

fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs
fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs
fromHaddockProjectFlags HaddockProjectFlags
flags =
  HaddockArgs
forall a. Monoid a => a
mempty
    { argOutputDir = Dir (fromFlag $ haddockProjectDir flags)
    , argQuickJump = 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 :: FilePath
showPkg = PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)
    subtitle :: FilePath
subtitle
      | ShortText -> Bool
ShortText.null (PackageDescription -> ShortText
synopsis PackageDescription
pkg_descr) = FilePath
""
      | Bool
otherwise = FilePath
": " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShortText -> FilePath
ShortText.fromShortText (PackageDescription -> ShortText
synopsis PackageDescription
pkg_descr)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String]
renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [FilePath]
renderPureArgs Version
version Compiler
comp Platform
platform HaddockArgs
args =
  [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
f -> FilePath
"--dump-interface=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Directory -> FilePath
unDir (HaddockArgs -> Directory
argOutputDir HaddockArgs
args) FilePath -> ShowS
</> FilePath
f)
        ([FilePath] -> [FilePath])
-> (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> [FilePath]
forall a. Flag a -> [a]
flagToList
        (Flag FilePath -> [FilePath])
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argInterfaceFile
        (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , if Bool
haddockSupportsPackageName
        then
          [FilePath]
-> (PackageIdentifier -> [FilePath])
-> Maybe PackageIdentifier
-> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            []
            ( \PackageIdentifier
pkg ->
                [ FilePath
"--package-name=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkg)
                , FilePath
"--package-version=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> Version
pkgVersion PackageIdentifier
pkg)
                ]
            )
            (Maybe PackageIdentifier -> [FilePath])
-> (HaddockArgs -> Maybe PackageIdentifier)
-> HaddockArgs
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag PackageIdentifier -> Maybe PackageIdentifier
forall a. Flag a -> Maybe a
flagToMaybe
            (Flag PackageIdentifier -> Maybe PackageIdentifier)
-> (HaddockArgs -> Flag PackageIdentifier)
-> HaddockArgs
-> Maybe PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag PackageIdentifier
argPackageName
            (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
        else []
    , [FilePath
"--since-qual=external" | Int -> Int -> Bool
isVersion Int
2 Int
20]
    , [ FilePath
"--quickjump" | Int -> Int -> Bool
isVersion Int
2 Int
19, Bool
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
      ]
    , [FilePath
"--hyperlinked-source" | Bool
isHyperlinkedSource]
    , (\(All Bool
b, [ModuleName]
xs) -> [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall {p}. p -> p -> Bool -> p
bool ((ModuleName -> FilePath) -> [ModuleName] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
"--hide=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (ModuleName -> FilePath) -> ModuleName -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow) [ModuleName]
xs) [] Bool
b)
        ((All, [ModuleName]) -> [FilePath])
-> (HaddockArgs -> (All, [ModuleName]))
-> HaddockArgs
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> (All, [ModuleName])
argHideModules
        (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall {p}. p -> p -> Bool -> p
bool [FilePath
"--ignore-all-exports"] [] (Bool -> [FilePath])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Bool
getAny (Any -> Bool) -> (HaddockArgs -> Any) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Any
argIgnoreExports (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , -- 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
          [FilePath]
-> ((FilePath, FilePath, FilePath) -> [FilePath])
-> Maybe (FilePath, FilePath, FilePath)
-> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            []
            ( \(FilePath
m, FilePath
e, FilePath
l) ->
                [ FilePath
"--source-module=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
m
                , FilePath
"--source-entity=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
e
                ]
                  [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ if Int -> Int -> Bool
isVersion Int
2 Int
14
                    then [FilePath
"--source-entity-line=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
l]
                    else []
            )
            (Maybe (FilePath, FilePath, FilePath) -> [FilePath])
-> (HaddockArgs -> Maybe (FilePath, FilePath, FilePath))
-> HaddockArgs
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag (FilePath, FilePath, FilePath)
-> Maybe (FilePath, FilePath, FilePath)
forall a. Flag a -> Maybe a
flagToMaybe
            (Flag (FilePath, FilePath, FilePath)
 -> Maybe (FilePath, FilePath, FilePath))
-> (HaddockArgs -> Flag (FilePath, FilePath, FilePath))
-> HaddockArgs
-> Maybe (FilePath, FilePath, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag (FilePath, FilePath, FilePath)
argLinkSource
            (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: []) (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--css=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe FilePath -> [FilePath])
-> (HaddockArgs -> Maybe FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argCssFile (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: []) (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--use-contents=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe FilePath -> [FilePath])
-> (HaddockArgs -> Maybe FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argContents (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall {p}. p -> p -> Bool -> p
bool [FilePath
"--gen-contents"] [] (Bool -> [FilePath])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool)
-> (HaddockArgs -> Flag Bool) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag Bool
argGenContents (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: []) (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--use-index=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe FilePath -> [FilePath])
-> (HaddockArgs -> Maybe FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argIndex (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall {p}. p -> p -> Bool -> p
bool [FilePath
"--gen-index"] [] (Bool -> [FilePath])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool)
-> (HaddockArgs -> Flag Bool) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag Bool
argGenIndex (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: []) (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--base-url=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe FilePath -> [FilePath])
-> (HaddockArgs -> Maybe FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argBaseUrl (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall {p}. p -> p -> Bool -> p
bool [] [FilePath
verbosityFlag] (Bool -> [FilePath])
-> (HaddockArgs -> Bool) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Bool
getAny (Any -> Bool) -> (HaddockArgs -> Any) -> HaddockArgs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Any
argVerbose (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , (Output -> FilePath) -> [Output] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\Output
o -> case Output
o of Output
Hoogle -> FilePath
"--hoogle"; Output
Html -> FilePath
"--html")
        ([Output] -> [FilePath])
-> (HaddockArgs -> [Output]) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Output] -> Flag [Output] -> [Output]
forall a. a -> Flag a -> a
fromFlagOrDefault []
        (Flag [Output] -> [Output])
-> (HaddockArgs -> Flag [Output]) -> HaddockArgs -> [Output]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag [Output]
argOutput
        (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
-> [FilePath]
renderInterfaces ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
 -> [FilePath])
-> (HaddockArgs
    -> [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)])
-> HaddockArgs
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs
-> [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
argInterfaces (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , (FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: []) (FilePath -> [FilePath])
-> (HaddockArgs -> FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--odir=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (HaddockArgs -> FilePath) -> HaddockArgs -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directory -> FilePath
unDir (Directory -> FilePath)
-> (HaddockArgs -> Directory) -> HaddockArgs -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Directory
argOutputDir (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        []
        ( (FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [])
            (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--title=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( ShowS -> ShowS -> Bool -> ShowS
forall {p}. p -> p -> Bool -> p
bool
                  (FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" (internal documentation)")
                  ShowS
forall a. a -> a
id
                  (Any -> Bool
getAny (Any -> Bool) -> Any -> Bool
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Any
argIgnoreExports HaddockArgs
args)
              )
        )
        (Maybe FilePath -> [FilePath])
-> (HaddockArgs -> Maybe FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe
        (Flag FilePath -> Maybe FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argTitle
        (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [ FilePath
"--optghc=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
opt | let opts :: GhcOptions
opts = HaddockArgs -> GhcOptions
argGhcOptions HaddockArgs
args, FilePath
opt <- Compiler -> Platform -> GhcOptions -> [FilePath]
renderGhcOptions Compiler
comp Platform
platform GhcOptions
opts
      ]
    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
l -> [FilePath
"-B" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
l]) (Maybe FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$
        Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (HaddockArgs -> Flag FilePath
argGhcLibDir HaddockArgs
args) -- error if Nothing?
    , -- https://github.com/haskell/haddock/pull/547
      [ FilePath
"--reexport=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ OpenModule -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow OpenModule
r
      | OpenModule
r <- HaddockArgs -> [OpenModule]
argReexports HaddockArgs
args
      , Int -> Int -> Bool
isVersion Int
2 Int
19
      ]
    , HaddockArgs -> [FilePath]
argTargets (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: []) (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--lib=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Maybe FilePath -> [FilePath])
-> (HaddockArgs -> Maybe FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argLib (HaddockArgs -> [FilePath]) -> HaddockArgs -> [FilePath]
forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    ]
  where
    renderInterfaces :: [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
-> [FilePath]
renderInterfaces = ((FilePath, Maybe FilePath, Maybe FilePath, Visibility)
 -> FilePath)
-> [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
-> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> FilePath
renderInterface

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

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

    bool :: p -> p -> Bool -> p
bool p
a p
b Bool
c = if Bool
c then p
a else p
b
    isVersion :: Int -> Int -> Bool
isVersion Int
major Int
minor = Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
major, Int
minor]
    verbosityFlag :: FilePath
verbosityFlag
      | Int -> Int -> Bool
isVersion Int
2 Int
5 = FilePath
"--verbosity=1"
      | Bool
otherwise = FilePath
"--verbose"
    haddockSupportsVisibility :: Bool
haddockSupportsVisibility = Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
2, Int
26, Int
1]
    haddockSupportsPackageName :: Bool
haddockSupportsPackageName = Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> [Int] -> Version
mkVersion [Int
2, Int
16]
    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 -> FilePath)
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)],
      Maybe FilePath)
haddockPackagePaths [InstalledPackageInfo]
ipkgs Maybe (InstalledPackageInfo -> FilePath)
mkHtmlPath = do
  [Either
   PackageIdentifier
   (FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
interfaces <-
    [IO
   (Either
      PackageIdentifier
      (FilePath, Maybe FilePath, Maybe FilePath, Visibility))]
-> IO
     [Either
        PackageIdentifier
        (FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
      [ case InstalledPackageInfo -> Maybe (FilePath, Maybe FilePath)
interfaceAndHtmlPath InstalledPackageInfo
ipkg of
        Maybe (FilePath, Maybe FilePath)
Nothing -> Either
  PackageIdentifier
  (FilePath, Maybe FilePath, Maybe FilePath, Visibility)
-> IO
     (Either
        PackageIdentifier
        (FilePath, Maybe FilePath, Maybe FilePath, Visibility))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageIdentifier
-> Either
     PackageIdentifier
     (FilePath, Maybe FilePath, Maybe FilePath, Visibility)
forall a b. a -> Either a b
Left (InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId InstalledPackageInfo
ipkg))
        Just (FilePath
interface, Maybe FilePath
html) -> do
          (Maybe FilePath
html', Maybe FilePath
hypsrc') <-
            case Maybe FilePath
html of
              Just FilePath
htmlPath -> do
                let hypSrcPath :: FilePath
hypSrcPath = FilePath
htmlPath FilePath -> ShowS
</> FilePath
defaultHyperlinkedSourceDirectory
                Bool
hypSrcExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
hypSrcPath
                (Maybe FilePath, Maybe FilePath)
-> IO (Maybe FilePath, Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe FilePath, Maybe FilePath)
 -> IO (Maybe FilePath, Maybe FilePath))
-> (Maybe FilePath, Maybe FilePath)
-> IO (Maybe FilePath, Maybe FilePath)
forall a b. (a -> b) -> a -> b
$
                  ( FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (ShowS
fixFileUrl FilePath
htmlPath)
                  , if Bool
hypSrcExists
                      then FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (ShowS
fixFileUrl FilePath
hypSrcPath)
                      else Maybe FilePath
forall a. Maybe a
Nothing
                  )
              Maybe FilePath
Nothing -> (Maybe FilePath, Maybe FilePath)
-> IO (Maybe FilePath, Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath
forall a. Maybe a
Nothing, Maybe FilePath
forall a. Maybe a
Nothing)

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

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

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

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

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

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

haddockPackageFlags
  :: Verbosity
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> Maybe PathTemplate
  -> IO
      ( [ ( FilePath -- path to interface
      -- file
          , Maybe FilePath -- url to html
          -- documentation
          , Maybe FilePath -- url to hyperlinked
          -- source
          , Visibility
          )
        ]
      , Maybe String -- warning about
      -- missing documentation
      )
haddockPackageFlags :: Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)],
      Maybe FilePath)
haddockPackageFlags Verbosity
verbosity LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate = do
  let allPkgs :: InstalledPackageIndex
allPkgs = LocalBuildInfo -> InstalledPackageIndex
installedPkgs LocalBuildInfo
lbi
      directDeps :: [UnitId]
directDeps = ((UnitId, MungedPackageId) -> UnitId)
-> [(UnitId, MungedPackageId)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, MungedPackageId) -> UnitId
forall a b. (a, b) -> a
fst (ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
componentPackageDeps ComponentLocalBuildInfo
clbi)
  InstalledPackageIndex
transitiveDeps <- case InstalledPackageIndex
-> [UnitId]
-> Either InstalledPackageIndex [(InstalledPackageInfo, [UnitId])]
PackageIndex.dependencyClosure InstalledPackageIndex
allPkgs [UnitId]
directDeps of
    Left InstalledPackageIndex
x -> InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
x
    Right [(InstalledPackageInfo, [UnitId])]
inf ->
      Verbosity -> 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 -> FilePath)
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath, Visibility)],
      Maybe FilePath)
haddockPackagePaths (InstalledPackageIndex -> [InstalledPackageInfo]
forall a. PackageIndex a -> [a]
PackageIndex.allPackages InstalledPackageIndex
transitiveDeps) Maybe (InstalledPackageInfo -> FilePath)
mkHtmlPath
  where
    mkHtmlPath :: Maybe (InstalledPackageInfo -> FilePath)
mkHtmlPath = (PathTemplate -> InstalledPackageInfo -> FilePath)
-> Maybe PathTemplate -> Maybe (InstalledPackageInfo -> FilePath)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> InstalledPackageInfo -> FilePath
forall {pkg}. Package pkg => PathTemplate -> pkg -> FilePath
expandTemplateVars Maybe PathTemplate
htmlTemplate
    expandTemplateVars :: PathTemplate -> pkg -> FilePath
expandTemplateVars PathTemplate
tmpl pkg
pkg =
      PathTemplate -> FilePath
fromPathTemplate (PathTemplate -> FilePath)
-> (PathTemplate -> PathTemplate) -> PathTemplate -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate (pkg -> PathTemplateEnv
forall {pkg}. Package pkg => pkg -> PathTemplateEnv
env pkg
pkg) (PathTemplate -> FilePath) -> PathTemplate -> FilePath
forall a b. (a -> b) -> a -> b
$ PathTemplate
tmpl
    env :: pkg -> PathTemplateEnv
env pkg
pkg = LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
haddockTemplateEnv LocalBuildInfo
lbi (pkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId pkg
pkg)

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

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

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

hscolour'
  :: (String -> IO ())
  -- ^ Called when the 'hscolour' exe is not found.
  -> HaddockTarget
  -> PackageDescription
  -> LocalBuildInfo
  -> [PPSuffixHandler]
  -> HscolourFlags
  -> IO ()
hscolour' :: (FilePath -> IO ())
-> HaddockTarget
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
hscolour' FilePath -> IO ()
onNoHsColour HaddockTarget
haddockTarget PackageDescription
pkg_descr LocalBuildInfo
lbi [PPSuffixHandler]
suffixes HscolourFlags
flags =
  (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 -> FilePath -> IO ()
onNoHsColour (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ CabalException -> FilePath
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
    go :: ConfiguredProgram -> IO ()
    go :: ConfiguredProgram -> IO ()
go ConfiguredProgram
hscolourProg = do
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"the 'cabal hscolour' command is deprecated in favour of 'cabal "
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"haddock --hyperlink-source' and will be removed in the next major "
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"release."

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

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

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

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

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

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

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

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

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

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

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

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