{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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, hscolour,

  haddockPackagePaths
  ) where

import Prelude ()
import Distribution.Compat.Prelude

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

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

import Distribution.Verbosity
import Language.Haskell.Extension

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

import Control.Monad
import Data.Either      ( rights )

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

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

-- | A record that represents the arguments to the haddock executable, a product
-- monoid.
data HaddockArgs = HaddockArgs {
 HaddockArgs -> Flag FilePath
argInterfaceFile :: Flag FilePath,
 -- ^ Path to the interface file, relative to argOutputDir, required.
 HaddockArgs -> Flag PackageIdentifier
argPackageName :: Flag PackageIdentifier,
 -- ^ Package name, required.
 HaddockArgs -> (All, [ModuleName])
argHideModules :: (All,[ModuleName.ModuleName]),
 -- ^ (Hide modules ?, modules to hide)
 HaddockArgs -> Any
argIgnoreExports :: Any,
 -- ^ Ignore export lists in modules?
 HaddockArgs -> Flag (FilePath, FilePath, FilePath)
argLinkSource :: Flag (Template,Template,Template),
 -- ^ (Template for modules, template for symbols, template for lines).
 HaddockArgs -> Flag Bool
argLinkedSource :: Flag Bool,
 -- ^ Generate hyperlinked sources
 HaddockArgs -> Flag Bool
argQuickJump :: Flag Bool,
 -- ^ Generate quickjump index
 HaddockArgs -> Flag FilePath
argCssFile :: Flag FilePath,
 -- ^ Optional custom CSS file.
 HaddockArgs -> Flag FilePath
argContents :: Flag String,
 -- ^ Optional URL to contents page.
 HaddockArgs -> Any
argVerbose :: Any,
 HaddockArgs -> Flag [Output]
argOutput :: Flag [Output],
 -- ^ HTML or Hoogle doc or both? Required.
 HaddockArgs -> [(FilePath, Maybe FilePath, Maybe FilePath)]
argInterfaces :: [(FilePath, Maybe String, Maybe String)],
 -- ^ [(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.
 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.
} deriving 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
$cto :: forall x. Rep HaddockArgs x -> HaddockArgs
$cfrom :: forall x. HaddockArgs -> Rep HaddockArgs x
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]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Directory]
$creadListPrec :: ReadPrec [Directory]
readPrec :: ReadPrec Directory
$creadPrec :: ReadPrec Directory
readList :: ReadS [Directory]
$creadList :: ReadS [Directory]
readsPrec :: Int -> ReadS Directory
$creadsPrec :: Int -> ReadS Directory
Read,Int -> Directory -> ShowS
[Directory] -> ShowS
Directory -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Directory] -> ShowS
$cshowList :: [Directory] -> ShowS
show :: Directory -> FilePath
$cshow :: Directory -> FilePath
showsPrec :: Int -> Directory -> ShowS
$cshowsPrec :: Int -> Directory -> ShowS
Show,Directory -> Directory -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Directory -> Directory -> Bool
$c/= :: Directory -> Directory -> Bool
== :: Directory -> Directory -> Bool
$c== :: Directory -> Directory -> Bool
Eq,Eq 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
min :: Directory -> Directory -> Directory
$cmin :: Directory -> Directory -> Directory
max :: Directory -> Directory -> Directory
$cmax :: Directory -> Directory -> Directory
>= :: Directory -> Directory -> Bool
$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
compare :: Directory -> Directory -> Ordering
$ccompare :: Directory -> Directory -> Ordering
Ord)

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

type Template = String

data Output = Html | Hoogle

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

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 (forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockExecutables HaddockFlags
haddockFlags)
    Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockTestSuites  HaddockFlags
haddockFlags)
    Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockBenchmarks  HaddockFlags
haddockFlags)
    Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Bool
haddockForeignLibs HaddockFlags
haddockFlags)
    =
      Verbosity -> FilePath -> IO ()
warn (forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Verbosity
haddockVerbosity HaddockFlags
haddockFlags) forall a b. (a -> b) -> a -> b
$
           FilePath
"No documentation was generated as this package does not contain "
        forall a. [a] -> [a] -> [a]
++ FilePath
"a library. Perhaps you want to use the --executables, --tests,"
        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     = 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 Bool
haddockHoogle       = forall a. a -> Flag a
Flag Bool
True
            , haddockHtml :: Flag Bool
haddockHtml         = forall a. a -> Flag a
Flag Bool
True
            , haddockHtmlLocation :: Flag FilePath
haddockHtmlLocation = forall a. a -> Flag a
Flag (FilePath
pkg_url forall a. [a] -> [a] -> [a]
++ FilePath
"/docs")
            , haddockContents :: Flag PathTemplate
haddockContents     = forall a. a -> Flag a
Flag (FilePath -> PathTemplate
toPathTemplate FilePath
pkg_url)
            , haddockLinkedSource :: Flag Bool
haddockLinkedSource = forall a. a -> Flag a
Flag Bool
True
            , haddockQuickJump :: Flag Bool
haddockQuickJump    = forall a. a -> Flag a
Flag Bool
True
            }
        pkg_url :: FilePath
pkg_url       = FilePath
"/package/$pkg-$version"
        flag :: (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag a
f        = forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag a
f HaddockFlags
flags

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

    (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])) (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)

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


    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockQuickJump Bool -> Bool -> Bool
&& Version
version forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2,Int
19]) 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 forall a. a -> Flag a
Flag Bool
True forall a. Eq a => a -> a -> Bool
== Flag Bool
quickJmpFlag
        then forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
msg
        else Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath
msg forall a. [a] -> [a] -> [a]
++ FilePath
"\n" forall a. [a] -> [a] -> [a]
++ FilePath
alt)

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

    -- the tools match the requests, we can proceed

    -- We fall back to using HsColour only for versions of Haddock which don't
    -- support '--hyperlinked-sources'.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockLinkedSource Bool -> Bool -> Bool
&& Version
version forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2,Int
17]) 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 forall a. Monoid a => a -> a -> a
`mappend` HaddockFlags -> HscolourFlags
haddockToHscolour HaddockFlags
flags)

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

    [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 (forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag FilePath
haddockDistPref)

    (\InstalledPackageIndex -> TargetInfo -> IO InstalledPackageIndex
f -> 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') forall a b. (a -> b) -> a -> b
$ \InstalledPackageIndex
index TargetInfo
target -> do

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

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

      let
        lbi' :: LocalBuildInfo
lbi' = LocalBuildInfo
lbi {
          withPackageDB :: PackageDBStack
withPackageDB = LocalBuildInfo -> PackageDBStack
withPackageDB LocalBuildInfo
lbi forall a. [a] -> [a] -> [a]
++ [PackageDB
internalPackageDB],
          installedPkgs :: InstalledPackageIndex
installedPkgs = InstalledPackageIndex
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
            forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO a)
-> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
tmpFileOpts (LocalBuildInfo -> FilePath
buildDir LocalBuildInfo
lbi') FilePath
"tmp" 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 forall a. Monoid a => a -> a -> a
`mappend` HaddockArgs
exeArgs
                Verbosity
-> TempFileOptions
-> Compiler
-> Platform
-> ConfiguredProgram
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
tmpFileOpts Compiler
comp Platform
platform
                  ConfiguredProgram
haddockProg HaddockArgs
exeArgs'
          Maybe Executable
Nothing -> do
           Verbosity -> FilePath -> IO ()
warn (forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Verbosity
haddockVerbosity HaddockFlags
flags)
             FilePath
"Unsupported component, skipping..."
           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 = forall a.
Pretty a =>
Verbosity
-> FilePath
-> PackageIdentifier
-> ComponentName
-> Maybe [(ModuleName, a)]
-> IO ()
setupMessage' Verbosity
verbosity FilePath
"Running Haddock on" (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
          forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO a)
-> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
tmpFileOpts (LocalBuildInfo -> FilePath
buildDir LocalBuildInfo
lbi) FilePath
"tmp" 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 forall a. Monoid a => a -> a -> a
`mappend` HaddockArgs
libArgs
              Verbosity
-> TempFileOptions
-> Compiler
-> Platform
-> ConfiguredProgram
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
tmpFileOpts Compiler
comp Platform
platform ConfiguredProgram
haddockProg HaddockArgs
libArgs'

              case Library -> LibraryName
libName Library
lib of
                LibraryName
LMainLibName ->
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure InstalledPackageIndex
index
                LSubLibName UnqualComponentName
_ -> do
                  FilePath
pwd <- IO FilePath
getCurrentDirectory

                  let
                    ipi :: InstalledPackageInfo
ipi = FilePath
-> FilePath
-> PackageDescription
-> AbiHash
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstalledPackageInfo
inplaceInstalledPackageInfo
                            FilePath
pwd (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 forall a b. (a -> b) -> a -> b
$ FilePath
"Registering inplace:\n"
                    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 {
                      registerMultiInstance :: Bool
HcPkg.registerMultiInstance = Bool
True
                    }

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

        CFLib ForeignLib
flib -> (forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {a}. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockForeignLibs) forall a b. (a -> b) -> a -> b
$ do
          forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO a)
-> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
tmpFileOpts (LocalBuildInfo -> FilePath
buildDir LocalBuildInfo
lbi') FilePath
"tmp" 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 forall a. Monoid a => a -> a -> a
`mappend` HaddockArgs
flibArgs
              Verbosity
-> TempFileOptions
-> Compiler
-> Platform
-> ConfiguredProgram
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
tmpFileOpts Compiler
comp Platform
platform ConfiguredProgram
haddockProg HaddockArgs
libArgs')

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

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

    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (PackageDescription -> [FilePath]
extraDocFiles PackageDescription
pkg_descr) 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
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [FilePath]
files forall a b. (a -> b) -> a -> b
$ Verbosity -> FilePath -> FilePath -> IO ()
copyFileTo Verbosity
verbosity (Directory -> FilePath
unDir forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Directory
argOutputDir HaddockArgs
commonArgs)

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

fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags PathTemplateEnv
env HaddockFlags
flags =
    forall a. Monoid a => a
mempty {
      argHideModules :: (All, [ModuleName])
argHideModules = (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (Bool -> All
All forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not)
                        forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Maybe a
flagToMaybe (HaddockFlags -> Flag Bool
haddockInternal HaddockFlags
flags), forall a. Monoid a => a
mempty),
      argLinkSource :: Flag (FilePath, FilePath, FilePath)
argLinkSource = if forall a. WithCallStack (Flag a -> a)
fromFlag (HaddockFlags -> Flag Bool
haddockLinkedSource HaddockFlags
flags)
                               then forall a. a -> Flag a
Flag (FilePath
"src/%{MODULE/./-}.html"
                                         ,FilePath
"src/%{MODULE/./-}.html#%{NAME}"
                                         ,FilePath
"src/%{MODULE/./-}.html#line-%{LINE}")
                               else forall a. Flag a
NoFlag,
      argLinkedSource :: Flag Bool
argLinkedSource = HaddockFlags -> Flag Bool
haddockLinkedSource HaddockFlags
flags,
      argQuickJump :: Flag Bool
argQuickJump = HaddockFlags -> Flag Bool
haddockQuickJump HaddockFlags
flags,
      argCssFile :: Flag FilePath
argCssFile = HaddockFlags -> Flag FilePath
haddockCss HaddockFlags
flags,
      argContents :: Flag FilePath
argContents = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PathTemplate -> FilePath
fromPathTemplate forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env)
                    (HaddockFlags -> Flag PathTemplate
haddockContents HaddockFlags
flags),
      argVerbose :: Any
argVerbose = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (Bool -> Any
Any forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening))
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Flag a -> Maybe a
flagToMaybe forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Verbosity
haddockVerbosity HaddockFlags
flags,
      argOutput :: Flag [Output]
argOutput =
          forall a. a -> Flag a
Flag forall a b. (a -> b) -> a -> b
$ case [ Output
Html | Flag Bool
True <- [HaddockFlags -> Flag Bool
haddockHtml HaddockFlags
flags] ] forall a. [a] -> [a] -> [a]
++
                      [ Output
Hoogle | Flag Bool
True <- [HaddockFlags -> Flag Bool
haddockHoogle HaddockFlags
flags] ]
                 of [] -> [ Output
Html ]
                    [Output]
os -> [Output]
os,
      argOutputDir :: Directory
argOutputDir = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty FilePath -> Directory
Dir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Flag a -> Maybe a
flagToMaybe forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag FilePath
haddockDistPref HaddockFlags
flags,

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

fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs
fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs
fromPackageDescription HaddockTarget
haddockTarget PackageDescription
pkg_descr = forall a. Monoid a => a
mempty
    { argInterfaceFile :: Flag FilePath
argInterfaceFile = forall a. a -> Flag a
Flag forall a b. (a -> b) -> a -> b
$ PackageDescription -> FilePath
haddockName PackageDescription
pkg_descr
    , argPackageName :: Flag PackageIdentifier
argPackageName = forall a. a -> Flag a
Flag forall a b. (a -> b) -> a -> b
$ forall pkg. Package pkg => pkg -> PackageIdentifier
packageId forall a b. (a -> b) -> a -> b
$ PackageDescription
pkg_descr
    , argOutputDir :: Directory
argOutputDir = FilePath -> Directory
Dir forall a b. (a -> b) -> a -> b
$
        FilePath
"doc" FilePath -> ShowS
</> FilePath
"html" FilePath -> ShowS
</> HaddockTarget -> PackageDescription -> FilePath
haddockDirName HaddockTarget
haddockTarget PackageDescription
pkg_descr
    , argPrologue :: Flag FilePath
argPrologue = forall a. a -> Flag a
Flag forall a b. (a -> b) -> a -> b
$ ShortText -> FilePath
ShortText.fromShortText forall a b. (a -> b) -> a -> b
$
        if ShortText -> Bool
ShortText.null ShortText
desc
        then PackageDescription -> ShortText
synopsis PackageDescription
pkg_descr
        else ShortText
desc
    , argTitle :: Flag FilePath
argTitle = forall a. a -> Flag a
Flag forall a b. (a -> b) -> a -> b
$ FilePath
showPkg forall a. [a] -> [a] -> [a]
++ FilePath
subtitle
    }
  where
    desc :: ShortText
desc = PackageDescription -> ShortText
description PackageDescription
pkg_descr
    showPkg :: FilePath
showPkg = forall a. Pretty a => a -> FilePath
prettyShow (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
": " 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
_     -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$
                       FilePath
"Distribution.Simple.Haddock.componentGhcOptions:" 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 :: Flag FilePath
ghcOptObjDir     = forall a. a -> Flag a
toFlag FilePath
tmp,
                          ghcOptHiDir :: Flag FilePath
ghcOptHiDir      = forall a. a -> Flag a
toFlag FilePath
tmp,
                          ghcOptStubDir :: Flag FilePath
ghcOptStubDir    = forall a. a -> Flag a
toFlag FilePath
tmp
                      } forall a. Monoid a => a -> a -> a
`mappend` Version -> BuildInfo -> GhcOptions
getGhcCppOpts Version
haddockVersion BuildInfo
bi
        sharedOpts :: GhcOptions
sharedOpts = GhcOptions
vanillaOpts {
                         ghcOptDynLinkMode :: Flag GhcDynLinkMode
ghcOptDynLinkMode = forall a. a -> Flag a
toFlag GhcDynLinkMode
GhcDynamicOnly,
                         ghcOptFPic :: Flag Bool
ghcOptFPic        = forall a. a -> Flag a
toFlag Bool
True,
                         ghcOptHiSuffix :: Flag FilePath
ghcOptHiSuffix    = forall a. a -> Flag a
toFlag FilePath
"dyn_hi",
                         ghcOptObjSuffix :: Flag FilePath
ghcOptObjSuffix   = forall a. a -> Flag a
toFlag FilePath
"dyn_o",
                         ghcOptExtra :: [FilePath]
ghcOptExtra       = CompilerFlavor -> BuildInfo -> [FilePath]
hcSharedOptions CompilerFlavor
GHC BuildInfo
bi

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

    forall (m :: * -> *) a. Monad m => a -> m a
return HaddockArgs
ifaceArgs
      { argGhcOptions :: GhcOptions
argGhcOptions  = GhcOptions
opts
      , argTargets :: [FilePath]
argTargets     = [FilePath]
inFiles
      , argReexports :: [OpenModule]
argReexports   = ComponentLocalBuildInfo -> [OpenModule]
getReexports ComponentLocalBuildInfo
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 <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd 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)
    forall (m :: * -> *) a. Monad m => a -> m a
return HaddockArgs
args {
      argHideModules :: (All, [ModuleName])
argHideModules = (forall a. Monoid a => a
mempty, BuildInfo -> [ModuleName]
otherModules (Library -> BuildInfo
libBuildInfo Library
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 <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd 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)
    forall (m :: * -> *) a. Monad m => a -> m a
return HaddockArgs
args {
      argOutputDir :: Directory
argOutputDir  = FilePath -> Directory
Dir  forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName forall a b. (a -> b) -> a -> b
$ Executable -> UnqualComponentName
exeName Executable
exe,
      argTitle :: Flag FilePath
argTitle      = forall a. a -> Flag a
Flag forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName forall a b. (a -> b) -> a -> b
$ Executable -> UnqualComponentName
exeName Executable
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 <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd 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)
    forall (m :: * -> *) a. Monad m => a -> m a
return HaddockArgs
args {
      argOutputDir :: Directory
argOutputDir  = FilePath -> Directory
Dir  forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName forall a b. (a -> b) -> a -> b
$ ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib,
      argTitle :: Flag FilePath
argTitle      = forall a. a -> Flag a
Flag forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName forall a b. (a -> b) -> a -> b
$ ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
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 } ->
      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 } ->
      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 -> forall a. a -> Maybe a
Just Executable
exe
    Component
_ -> 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)]
packageFlags, Maybe FilePath
warnings) <- Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath)], Maybe FilePath)
haddockPackageFlags Verbosity
verbosity LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Maybe PathTemplate
htmlTemplate
    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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty {
                 argInterfaces :: [(FilePath, Maybe FilePath, Maybe FilePath)]
argInterfaces = [(FilePath, Maybe FilePath, Maybe FilePath)]
packageFlags
               }

getReexports :: ComponentLocalBuildInfo -> [OpenModule]
getReexports :: ComponentLocalBuildInfo -> [OpenModule]
getReexports LibComponentLocalBuildInfo {componentExposedModules :: ComponentLocalBuildInfo -> [ExposedModule]
componentExposedModules = [ExposedModule]
mods } =
    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 =
    forall a. Monoid a => a
mempty {
        ghcOptExtensions :: NubListR Extension
ghcOptExtensions   = forall a. Ord a => [a] -> NubListR a
toNubListR [KnownExtension -> Extension
EnableExtension KnownExtension
CPP | Bool
needsCpp],
        ghcOptCppOptions :: [FilePath]
ghcOptCppOptions   = [FilePath]
defines
    }
  where
    needsCpp :: Bool
needsCpp             = KnownExtension -> Extension
EnableExtension KnownExtension
CPP 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__="
                           forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (Int
v1 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
+ Int
v2 forall a. Num a => a -> a -> a
* Int
10 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
_     -> forall a. HasCallStack => FilePath -> a
error FilePath
"haddock only supports GHC and GHCJS"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty { argGhcLibDir :: Flag FilePath
argGhcLibDir = forall a. a -> Flag a
Flag FilePath
l }

-- ------------------------------------------------------------------------------
-- | Call haddock with the specified arguments.
runHaddock :: Verbosity
              -> TempFileOptions
              -> Compiler
              -> Platform
              -> ConfiguredProgram
              -> HaddockArgs
              -> IO ()
runHaddock :: Verbosity
-> TempFileOptions
-> Compiler
-> Platform
-> ConfiguredProgram
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
tmpFileOpts Compiler
comp Platform
platform ConfiguredProgram
haddockProg HaddockArgs
args
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HaddockArgs -> [FilePath]
argTargets HaddockArgs
args) = Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
       FilePath
"Haddocks are being requested, but there aren't any modules given "
    forall a. [a] -> [a] -> [a]
++ FilePath
"to create documentation for."
  | Bool
otherwise = do
    let haddockVersion :: Version
haddockVersion = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => FilePath -> a
error FilePath
"unable to determine haddock version")
                        (ConfiguredProgram -> Maybe Version
programVersion ConfiguredProgram
haddockProg)
    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 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 forall a b. (a -> b) -> a -> b
$ FilePath
"Documentation created: " 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 forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
2,Int
14,Int
4]
      haddockSupportsResponseFiles :: Bool
haddockSupportsResponseFiles = Version
version 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
  forall a.
TempFileOptions
-> FilePath -> FilePath -> (FilePath -> Handle -> IO a) -> IO a
withTempFileEx TempFileOptions
tmpFileOpts FilePath
outputDir FilePath
"haddock-prologue.txt" forall a b. (a -> b) -> a -> b
$
    \FilePath
prologueFileName Handle
h -> do
          do
             forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
haddockSupportsUTF8 (Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8)
             Handle -> FilePath -> IO ()
hPutStrLn Handle
h forall a b. (a -> b) -> a -> b
$ forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Flag FilePath
argPrologue HaddockArgs
args
             Handle -> IO ()
hClose Handle
h
             let pflag :: FilePath
pflag = FilePath
"--prologue=" forall a. [a] -> [a] -> [a]
++ FilePath
prologueFileName
                 renderedArgs :: [FilePath]
renderedArgs = FilePath
pflag forall a. a -> [a] -> [a]
: Version -> Compiler -> Platform -> HaddockArgs -> [FilePath]
renderPureArgs Version
version Compiler
comp Platform
platform HaddockArgs
args
             if Bool
haddockSupportsResponseFiles
               then
                 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 forall a. a -> Maybe a
Just TextEncoding
utf8 else forall a. Maybe a
Nothing)
                   [FilePath]
renderedArgs
                   (\FilePath
responseFileName -> ([FilePath], FilePath) -> IO a
k ([FilePath
"@" 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 forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Directory
argOutputDir HaddockArgs
args)
      result :: FilePath
result = forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", "
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Output
o -> FilePath
outputDir FilePath -> ShowS
</>
                            case Output
o of
                              Output
Html -> FilePath
"index.html"
                              Output
Hoogle -> FilePath
pkgstr FilePath -> ShowS
<.> FilePath
"txt")
             forall a b. (a -> b) -> a -> b
$ forall {a}. (HaddockArgs -> Flag a) -> a
arg HaddockArgs -> Flag [Output]
argOutput
            where
              pkgstr :: FilePath
pkgstr = forall a. Pretty a => a -> FilePath
prettyShow forall a b. (a -> b) -> a -> b
$ forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid
              pkgid :: PackageIdentifier
pkgid = forall {a}. (HaddockArgs -> Flag a) -> a
arg HaddockArgs -> Flag PackageIdentifier
argPackageName
      arg :: (HaddockArgs -> Flag a) -> a
arg HaddockArgs -> Flag a
f = forall a. WithCallStack (Flag a -> a)
fromFlag 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\FilePath
f -> FilePath
"--dump-interface="forall a. [a] -> [a] -> [a]
++ Directory -> FilePath
unDir (HaddockArgs -> Directory
argOutputDir HaddockArgs
args) FilePath -> ShowS
</> FilePath
f)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithCallStack (Flag a -> a)
fromFlag forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag FilePath
argInterfaceFile forall a b. (a -> b) -> a -> b
$ HaddockArgs
args

    , if Int -> Int -> Bool
isVersion Int
2 Int
16
        then (\PackageIdentifier
pkg -> [ FilePath
"--package-name=" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkg)
                      , FilePath
"--package-version=" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> Version
pkgVersion PackageIdentifier
pkg)
                      ])
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithCallStack (Flag a -> a)
fromFlag forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag PackageIdentifier
argPackageName 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
                      , forall a. WithCallStack (Flag a -> a)
fromFlag forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag Bool
argQuickJump forall a b. (a -> b) -> a -> b
$ HaddockArgs
args ]

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

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

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

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

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

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

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

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

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

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

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

    , [ FilePath
"--optghc=" 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 ]

    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
l -> [FilePath
"-B"forall a. [a] -> [a] -> [a]
++FilePath
l]) forall a b. (a -> b) -> a -> b
$
      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=" forall a. [a] -> [a] -> [a]
++ 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 forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
    ]
    where
      renderInterfaces :: [(FilePath, Maybe FilePath, Maybe FilePath)] -> [FilePath]
renderInterfaces = forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Maybe FilePath, Maybe FilePath) -> FilePath
renderInterface

      renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath) -> String
      renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath) -> FilePath
renderInterface (FilePath
i, Maybe FilePath
html, Maybe FilePath
hypsrc) = FilePath
"--read-interface=" forall a. [a] -> [a] -> [a]
++
        (forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [ FilePath
x | Just FilePath
x <- [Maybe FilePath
html] ]
                                  , [ FilePath
x | Just FilePath
_ <- [Maybe FilePath
html]
                                        -- only render hypsrc path if html path
                                        -- is given and hyperlinked-source is
                                        -- enabled
                                        , Just FilePath
x <- [Maybe FilePath
hypsrc]
                                        , Int -> Int -> Bool
isVersion Int
2 Int
17
                                        , forall a. WithCallStack (Flag a -> a)
fromFlag forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> Flag Bool
argLinkedSource forall a b. (a -> b) -> a -> b
$ HaddockArgs
args
                                        ]
                                  , [ 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 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"

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

-- | 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
                                       )]
                                     , Maybe String      -- warning about
                                                         -- missing documentation
                                     )
haddockPackagePaths :: [InstalledPackageInfo]
-> Maybe (InstalledPackageInfo -> FilePath)
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath)], Maybe FilePath)
haddockPackagePaths [InstalledPackageInfo]
ipkgs Maybe (InstalledPackageInfo -> FilePath)
mkHtmlPath = do
  [Either
   PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath)]
interfaces <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
    [ case InstalledPackageInfo -> Maybe (FilePath, Maybe FilePath)
interfaceAndHtmlPath InstalledPackageInfo
ipkg of
        Maybe (FilePath, Maybe FilePath)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (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
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ( forall a. a -> Maybe a
Just (ShowS
fixFileUrl FilePath
htmlPath)
                         , if Bool
hypSrcExists
                           then forall a. a -> Maybe a
Just (ShowS
fixFileUrl FilePath
hypSrcPath)
                           else forall a. Maybe a
Nothing
                         )
              Maybe FilePath
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)

          Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
interface
          if Bool
exists
            then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (FilePath
interface, Maybe FilePath
html', Maybe FilePath
hypsrc'))
            else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left PackageIdentifier
pkgid)
    | InstalledPackageInfo
ipkg <- [InstalledPackageInfo]
ipkgs, let pkgid :: PackageIdentifier
pkgid = forall pkg. Package pkg => pkg -> PackageIdentifier
packageId InstalledPackageInfo
ipkg
    , PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgid 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)]
interfaces ]
      warning :: FilePath
warning = FilePath
"The documentation for the following packages are not "
             forall a. [a] -> [a] -> [a]
++ FilePath
"installed. No links will be generated to these packages: "
             forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> FilePath
prettyShow [PackageIdentifier]
missing)
      flags :: [(FilePath, Maybe FilePath, Maybe FilePath)]
flags = forall a b. [Either a b] -> [b]
rights [Either
   PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath)]
interfaces

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

  where
    -- Don't warn about missing documentation for these packages. See #1231.
    noHaddockWhitelist :: [PackageName]
noHaddockWhitelist = 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 <- forall a. [a] -> Maybe a
listToMaybe (InstalledPackageInfo -> [FilePath]
InstalledPackageInfo.haddockInterfaces InstalledPackageInfo
pkg)
      FilePath
html <- case Maybe (InstalledPackageInfo -> FilePath)
mkHtmlPath of
        Maybe (InstalledPackageInfo -> FilePath)
Nothing     -> forall a. [a] -> Maybe a
listToMaybe (InstalledPackageInfo -> [FilePath]
InstalledPackageInfo.haddockHTMLs InstalledPackageInfo
pkg)
        Just InstalledPackageInfo -> FilePath
mkPath -> forall a. a -> Maybe a
Just (InstalledPackageInfo -> FilePath
mkPath InstalledPackageInfo
pkg)
      forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
interface, if forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
html then forall a. Maybe a
Nothing else 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://" 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
                            )]
                          , Maybe String      -- warning about
                                              -- missing documentation
                          )
haddockPackageFlags :: Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath)], 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 = forall a b. (a -> b) -> [a] -> [b]
map 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    -> forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
x
    Right [(InstalledPackageInfo, [UnitId])]
inf -> forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"internal error when calculating transitive "
                    forall a. [a] -> [a] -> [a]
++ FilePath
"package dependencies.\nDebug info: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show [(InstalledPackageInfo, [UnitId])]
inf
  [InstalledPackageInfo]
-> Maybe (InstalledPackageInfo -> FilePath)
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath)], Maybe FilePath)
haddockPackagePaths (forall a. PackageIndex a -> [a]
PackageIndex.allPackages InstalledPackageIndex
transitiveDeps) Maybe (InstalledPackageInfo -> FilePath)
mkHtmlPath
    where
      mkHtmlPath :: Maybe (InstalledPackageInfo -> FilePath)
mkHtmlPath                  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {pkg}. Package pkg => PathTemplate -> pkg -> FilePath
expandTemplateVars Maybe PathTemplate
htmlTemplate
      expandTemplateVars :: PathTemplate -> pkg -> FilePath
expandTemplateVars PathTemplate
tmpl pkg
pkg =
        PathTemplate -> FilePath
fromPathTemplate forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate (forall {pkg}. Package pkg => pkg -> PathTemplateEnv
env pkg
pkg) forall a b. (a -> b) -> a -> b
$ PathTemplate
tmpl
      env :: pkg -> PathTemplateEnv
env pkg
pkg                     = LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
haddockTemplateEnv LocalBuildInfo
lbi (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, forall dir. InstallDirs dir -> dir
prefix (LocalBuildInfo -> InstallDirTemplates
installDirTemplates LocalBuildInfo
lbi))
  -- We want the legacy unit ID here, because it gives us nice paths
  -- (Haddock people don't care about the dependencies)
  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' 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 =
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO ()
onNoHsColour (\(ConfiguredProgram
hscolourProg, Version
_, ProgramDb
_) -> ConfiguredProgram -> IO ()
go ConfiguredProgram
hscolourProg) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (Either FilePath (ConfiguredProgram, Version, ProgramDb))
lookupProgramVersion Verbosity
verbosity Program
hscolourProgram
      (Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
1,Int
8])) (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
  where
    go :: ConfiguredProgram -> IO ()
    go :: ConfiguredProgram -> IO ()
go ConfiguredProgram
hscolourProg = do
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
        FilePath
"the 'cabal hscolour' command is deprecated in favour of 'cabal " forall a. [a] -> [a] -> [a]
++
        FilePath
"haddock --hyperlink-source' and will be removed in the next major " forall a. [a] -> [a] -> [a]
++
        FilePath
"release."

      Verbosity -> FilePath -> PackageIdentifier -> IO ()
setupMessage Verbosity
verbosity FilePath
"Running hscolour for" (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)
      Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True 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 forall a b. (a -> b) -> a -> b
$ \Component
comp ComponentLocalBuildInfo
clbi -> do
        FilePath
-> PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Verbosity
-> IO ()
componentInitialBuildSteps FilePath
distPref PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Verbosity
verbosity
        PackageDescription
-> Component
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Bool
-> Verbosity
-> [PPSuffixHandler]
-> IO ()
preprocessComponent PackageDescription
pkg_descr Component
comp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Bool
False Verbosity
verbosity [PPSuffixHandler]
suffixes
        let
          doExe :: Component -> IO ()
doExe Component
com = case (Component -> Maybe Executable
compToExe Component
com) of
            Just Executable
exe -> do
              let outputDir :: FilePath
outputDir = HaddockTarget -> FilePath -> PackageDescription -> FilePath
hscolourPref HaddockTarget
haddockTarget FilePath
distPref PackageDescription
pkg_descr
                              FilePath -> ShowS
</> UnqualComponentName -> FilePath
unUnqualComponentName (Executable -> UnqualComponentName
exeName Executable
exe) FilePath -> ShowS
</> FilePath
"src"
              forall {t :: * -> *}.
Foldable t =>
ConfiguredProgram -> FilePath -> t (ModuleName, FilePath) -> IO ()
runHsColour ConfiguredProgram
hscolourProg FilePath
outputDir 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 (forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ HscolourFlags -> Flag Verbosity
hscolourVerbosity HscolourFlags
flags)
                FilePath
"Unsupported component, skipping..."
              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"
            forall {t :: * -> *}.
Foldable t =>
ConfiguredProgram -> FilePath -> t (ModuleName, FilePath) -> IO ()
runHsColour ConfiguredProgram
hscolourProg FilePath
outputDir 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"
            forall {t :: * -> *}.
Foldable t =>
ConfiguredProgram -> FilePath -> t (ModuleName, FilePath) -> IO ()
runHsColour ConfiguredProgram
hscolourProg FilePath
outputDir 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
_ -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Flag Bool
hscolourExecutables HscolourFlags
flags)) forall a b. (a -> b) -> a -> b
$ Component -> IO ()
doExe Component
comp
          CTest  TestSuite
_ -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Flag Bool
hscolourTestSuites  HscolourFlags
flags)) forall a b. (a -> b) -> a -> b
$ Component -> IO ()
doExe Component
comp
          CBench Benchmark
_ -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Flag Bool
hscolourBenchmarks  HscolourFlags
flags)) forall a b. (a -> b) -> a -> b
$ Component -> IO ()
doExe Component
comp

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

    verbosity :: Verbosity
verbosity  = forall a. WithCallStack (Flag a -> a)
fromFlag (HscolourFlags -> Flag Verbosity
hscolourVerbosity HscolourFlags
flags)
    distPref :: FilePath
distPref   = 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 forall a. Ord a => a -> a -> Bool
>= 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" forall a. [a] -> [a] -> [a]
++ FilePath
outputDir FilePath -> ShowS
</> FilePath
"hscolour.css"]
                   | Bool
otherwise -> 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")

         forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ t (ModuleName, FilePath)
moduleFiles 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" forall a. [a] -> [a] -> [a]
++ ModuleName -> FilePath
outFile ModuleName
m, FilePath
inFile]
        where
          outFile :: ModuleName -> FilePath
outFile ModuleName
m = FilePath
outputDir FilePath -> ShowS
</>
                      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 = forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
    mappend :: HaddockArgs -> HaddockArgs -> HaddockArgs
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup HaddockArgs where
    <> :: 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 = forall a. Semigroup a => a -> a -> a
(<>)

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