{-# 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. 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
$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]
(Int -> ReadS Directory)
-> ReadS [Directory]
-> ReadPrec Directory
-> ReadPrec [Directory]
-> Read 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
(Int -> Directory -> ShowS)
-> (Directory -> FilePath)
-> ([Directory] -> ShowS)
-> Show Directory
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
(Directory -> Directory -> Bool)
-> (Directory -> Directory -> Bool) -> Eq Directory
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
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
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
$cp1Ord :: Eq 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

-- ------------------------------------------------------------------------------
-- 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 (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 Bool
haddockHoogle       = Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True
            , haddockHtml :: Flag Bool
haddockHtml         = Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True
            , haddockHtmlLocation :: Flag FilePath
haddockHtmlLocation = FilePath -> Flag FilePath
forall a. a -> Flag a
Flag (FilePath
pkg_url FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"/docs")
            , haddockContents :: Flag PathTemplate
haddockContents     = PathTemplate -> Flag PathTemplate
forall a. a -> Flag a
Flag (FilePath -> PathTemplate
toPathTemplate FilePath
pkg_url)
            , haddockLinkedSource :: Flag Bool
haddockLinkedSource = Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True
            , haddockQuickJump :: Flag Bool
haddockQuickJump    = Bool -> Flag Bool
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        = 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 :: Bool
optKeepTempFiles = (HaddockFlags -> Flag Bool) -> Bool
forall a. (HaddockFlags -> Flag a) -> a
flag HaddockFlags -> Flag Bool
haddockKeepTempFiles }
        htmlTemplate :: Maybe PathTemplate
htmlTemplate  = (FilePath -> PathTemplate) -> Maybe FilePath -> Maybe PathTemplate
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')

    (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
    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
haddockHoogle 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 -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
"Haddock 2.0 and 2.1 do not support the --hoogle flag."


    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
haddockQuickJump 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
quickJmpFlag
        then Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
msg
        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 -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
"Could not get GHC version from Haddock"
      (Maybe Version
_, Maybe Version
Nothing) -> Verbosity -> FilePath -> IO ()
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 Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
ghcVersion -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise -> Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
               FilePath
"Haddock's internal GHC version must match the configured "
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"GHC version.\n"
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"The GHC version is " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Version
ghcVersion FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" but "
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"haddock is using GHC version " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
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'.
    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
haddockLinkedSource Bool -> Bool -> Bool
&& Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2,Int
17]) (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)

    HaddockArgs
libdirArgs <- Verbosity -> LocalBuildInfo -> IO HaddockArgs
getGhcLibDir  Verbosity
verbosity LocalBuildInfo
lbi
    let commonArgs :: HaddockArgs
commonArgs = [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 ]

    [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

      FilePath
-> PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Verbosity
-> IO ()
componentInitialBuildSteps ((HaddockFlags -> Flag FilePath) -> FilePath
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 PackageDBStack -> PackageDBStack -> PackageDBStack
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
            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
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
tmpFileOpts Compiler
comp Platform
platform
                  ConfiguredProgram
haddockProg 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 (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
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
tmpFileOpts Compiler
comp Platform
platform ConfiguredProgram
haddockProg 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 {
                  registerMultiInstance :: Bool
HcPkg.registerMultiInstance = Bool
True
                }

              InstalledPackageIndex -> IO InstalledPackageIndex
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) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
-> HaddockArgs
-> IO ()
runHaddock Verbosity
verbosity TempFileOptions
tmpFileOpts Compiler
comp Platform
platform ConfiguredProgram
haddockProg HaddockArgs
libArgs')

          IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
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 () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
smsg IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Component -> IO ()
doExe Component
component) IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
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 () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
smsg IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Component -> IO ()
doExe Component
component) IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
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 () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
smsg IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Component -> IO ()
doExe Component
component) IO () -> IO InstalledPackageIndex -> IO InstalledPackageIndex
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InstalledPackageIndex -> IO InstalledPackageIndex
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)

-- ------------------------------------------------------------------------------
-- 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 :: (All, [ModuleName])
argHideModules = (All -> (Bool -> All) -> Maybe Bool -> All
forall b a. b -> (a -> b) -> Maybe a -> b
maybe All
forall a. Monoid a => a
mempty (Bool -> All
All (Bool -> All) -> (Bool -> Bool) -> Bool -> All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not)
                        (Maybe Bool -> All) -> Maybe Bool -> All
forall a b. (a -> b) -> a -> b
$ Flag Bool -> Maybe Bool
forall a. Flag a -> Maybe a
flagToMaybe (HaddockFlags -> Flag Bool
haddockInternal HaddockFlags
flags), [ModuleName]
forall a. Monoid a => a
mempty),
      argLinkSource :: Flag (FilePath, FilePath, FilePath)
argLinkSource = if Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (HaddockFlags -> Flag Bool
haddockLinkedSource HaddockFlags
flags)
                               then (FilePath, FilePath, FilePath)
-> Flag (FilePath, FilePath, FilePath)
forall a. a -> Flag a
Flag (FilePath
"src/%{MODULE/./-}.html"
                                         ,FilePath
"src/%{MODULE/./-}.html#%{NAME}"
                                         ,FilePath
"src/%{MODULE/./-}.html#line-%{LINE}")
                               else Flag (FilePath, FilePath, FilePath)
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 = (PathTemplate -> FilePath) -> Flag PathTemplate -> Flag FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PathTemplate -> FilePath
fromPathTemplate (PathTemplate -> FilePath)
-> (PathTemplate -> PathTemplate) -> PathTemplate -> FilePath
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 = Any -> (Verbosity -> Any) -> Maybe Verbosity -> Any
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Any
forall a. Monoid a => a
mempty (Bool -> Any
Any (Bool -> Any) -> (Verbosity -> Bool) -> Verbosity -> Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening))
                   (Maybe Verbosity -> Any)
-> (Flag Verbosity -> Maybe Verbosity) -> Flag Verbosity -> Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag Verbosity -> Maybe Verbosity
forall a. Flag a -> Maybe a
flagToMaybe (Flag Verbosity -> Any) -> Flag Verbosity -> Any
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag Verbosity
haddockVerbosity HaddockFlags
flags,
      argOutput :: Flag [Output]
argOutput =
          [Output] -> Flag [Output]
forall a. a -> Flag a
Flag ([Output] -> Flag [Output]) -> [Output] -> Flag [Output]
forall a b. (a -> b) -> a -> b
$ case [ Output
Html | Flag Bool
True <- [HaddockFlags -> Flag Bool
haddockHtml HaddockFlags
flags] ] [Output] -> [Output] -> [Output]
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 = Directory -> (FilePath -> Directory) -> Maybe FilePath -> Directory
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Directory
forall a. Monoid a => a
mempty FilePath -> Directory
Dir (Maybe FilePath -> Directory)
-> (Flag FilePath -> Maybe FilePath) -> Flag FilePath -> Directory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Directory) -> Flag FilePath -> Directory
forall a b. (a -> b) -> a -> b
$ HaddockFlags -> Flag FilePath
haddockDistPref HaddockFlags
flags,

      argGhcOptions :: GhcOptions
argGhcOptions = GhcOptions
forall a. Monoid a => a
mempty { ghcOptExtra :: [FilePath]
ghcOptExtra = [FilePath]
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

fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs
fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs
fromPackageDescription HaddockTarget
haddockTarget PackageDescription
pkg_descr = HaddockArgs
forall a. Monoid a => a
mempty
    { argInterfaceFile :: Flag FilePath
argInterfaceFile = FilePath -> Flag FilePath
forall a. a -> Flag a
Flag (FilePath -> Flag FilePath) -> FilePath -> Flag FilePath
forall a b. (a -> b) -> a -> b
$ PackageDescription -> FilePath
haddockName PackageDescription
pkg_descr
    , argPackageName :: Flag PackageIdentifier
argPackageName = PackageIdentifier -> Flag PackageIdentifier
forall a. a -> Flag a
Flag (PackageIdentifier -> Flag PackageIdentifier)
-> PackageIdentifier -> Flag PackageIdentifier
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ PackageDescription
pkg_descr
    , argOutputDir :: Directory
argOutputDir = FilePath -> Directory
Dir (FilePath -> Directory) -> FilePath -> Directory
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 = FilePath -> Flag FilePath
forall a. a -> Flag a
Flag (FilePath -> Flag FilePath) -> FilePath -> Flag FilePath
forall a b. (a -> b) -> a -> b
$ ShortText -> FilePath
ShortText.fromShortText (ShortText -> FilePath) -> ShortText -> FilePath
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 = FilePath -> Flag FilePath
forall a. a -> Flag a
Flag (FilePath -> Flag FilePath) -> FilePath -> Flag FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
showPkg FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
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 :: Flag FilePath
ghcOptObjDir     = FilePath -> Flag FilePath
forall a. a -> Flag a
toFlag FilePath
tmp,
                          ghcOptHiDir :: Flag FilePath
ghcOptHiDir      = FilePath -> Flag FilePath
forall a. a -> Flag a
toFlag FilePath
tmp,
                          ghcOptStubDir :: Flag FilePath
ghcOptStubDir    = FilePath -> Flag FilePath
forall a. a -> Flag a
toFlag FilePath
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 :: Flag GhcDynLinkMode
ghcOptDynLinkMode = GhcDynLinkMode -> Flag GhcDynLinkMode
forall a. a -> Flag a
toFlag GhcDynLinkMode
GhcDynamicOnly,
                         ghcOptFPic :: Flag Bool
ghcOptFPic        = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
True,
                         ghcOptHiSuffix :: Flag FilePath
ghcOptHiSuffix    = FilePath -> Flag FilePath
forall a. a -> Flag a
toFlag FilePath
"dyn_hi",
                         ghcOptObjSuffix :: Flag FilePath
ghcOptObjSuffix   = FilePath -> Flag FilePath
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 GhcOptions -> IO GhcOptions
forall (m :: * -> *) a. Monad m => a -> m a
return GhcOptions
vanillaOpts
            else if LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi
            then GhcOptions -> IO GhcOptions
forall (m :: * -> *) a. Monad m => a -> m a
return GhcOptions
sharedOpts
            else Verbosity -> FilePath -> IO GhcOptions
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO GhcOptions) -> FilePath -> IO GhcOptions
forall a b. (a -> b) -> a -> b
$ FilePath
"Must have vanilla or shared libraries "
                       FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"enabled in order to run haddock"

    HaddockArgs -> IO HaddockArgs
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 <- ((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 (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 (m :: * -> *) a. Monad m => a -> m a
return HaddockArgs
args {
      argHideModules :: (All, [ModuleName])
argHideModules = (All
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 <- ((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 (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 (m :: * -> *) a. Monad m => a -> m a
return HaddockArgs
args {
      argOutputDir :: Directory
argOutputDir  = FilePath -> Directory
Dir  (FilePath -> Directory) -> FilePath -> Directory
forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ Executable -> UnqualComponentName
exeName Executable
exe,
      argTitle :: Flag FilePath
argTitle      = FilePath -> Flag FilePath
forall a. a -> Flag a
Flag (FilePath -> Flag FilePath) -> FilePath -> Flag FilePath
forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
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 <- ((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 (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 (m :: * -> *) a. Monad m => a -> m a
return HaddockArgs
args {
      argOutputDir :: Directory
argOutputDir  = FilePath -> Directory
Dir  (FilePath -> Directory) -> FilePath -> Directory
forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib,
      argTitle :: Flag FilePath
argTitle      = FilePath -> Flag FilePath
forall a. a -> Flag a
Flag (FilePath -> Flag FilePath) -> FilePath -> Flag FilePath
forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
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 } ->
      Executable -> Maybe Executable
forall a. a -> Maybe a
Just Executable :: UnqualComponentName
-> FilePath -> ExecutableScope -> BuildInfo -> Executable
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 :: UnqualComponentName
-> FilePath -> ExecutableScope -> BuildInfo -> Executable
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)]
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
    (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 (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 :: [(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 } =
    (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 :: NubListR Extension
ghcOptExtensions   = [Extension] -> NubListR Extension
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 Extension -> [Extension] -> 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 (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 FilePath
argGhcLibDir = FilePath -> Flag FilePath
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
  | [FilePath] -> 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 :: 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
  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 -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Flag FilePath -> FilePath
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag FilePath -> FilePath) -> Flag FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Flag FilePath
argPrologue HaddockArgs
args
             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)
    where
      outputDir :: FilePath
outputDir = (Directory -> FilePath
unDir (Directory -> FilePath) -> Directory -> FilePath
forall a b. (a -> b) -> a -> b
$ HaddockArgs -> Directory
argOutputDir HaddockArgs
args)
      result :: FilePath
result = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", "
             ([FilePath] -> FilePath)
-> ([Output] -> [FilePath]) -> [Output] -> 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 -> FilePath
"index.html"
                              Output
Hoogle -> FilePath
pkgstr FilePath -> ShowS
<.> FilePath
"txt")
             ([Output] -> FilePath) -> [Output] -> FilePath
forall a b. (a -> b) -> a -> b
$ (HaddockArgs -> Flag [Output]) -> [Output]
forall a. (HaddockArgs -> Flag a) -> a
arg HaddockArgs -> Flag [Output]
argOutput
            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
    [ (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
f -> FilePath
"--dump-interface="FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Directory -> FilePath
unDir (HaddockArgs -> Directory
argOutputDir HaddockArgs
args) FilePath -> ShowS
</> FilePath
f)
      ShowS -> (HaddockArgs -> FilePath) -> HaddockArgs -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> FilePath
forall a. WithCallStack (Flag a -> a)
fromFlag (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 Int -> Int -> Bool
isVersion Int
2 Int
16
        then (\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)
                      ])
             (PackageIdentifier -> [FilePath])
-> (HaddockArgs -> PackageIdentifier) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag PackageIdentifier -> PackageIdentifier
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag PackageIdentifier -> PackageIdentifier)
-> (HaddockArgs -> Flag PackageIdentifier)
-> HaddockArgs
-> 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
                      , Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (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" | Int -> Int -> Bool
isVersion Int
2 Int
17
                               , Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (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 ]

    , (\(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

    , [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
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
. Flag [Output] -> [Output]
forall a. WithCallStack (Flag a -> a)
fromFlag (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)] -> [FilePath]
renderInterfaces ([(FilePath, Maybe FilePath, Maybe FilePath)] -> [FilePath])
-> (HaddockArgs -> [(FilePath, Maybe FilePath, Maybe FilePath)])
-> HaddockArgs
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockArgs -> [(FilePath, Maybe FilePath, Maybe FilePath)]
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]
forall a. a -> [a] -> [a]
:[]) (FilePath -> [FilePath])
-> (HaddockArgs -> FilePath) -> HaddockArgs -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"--title="FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++)
      ShowS -> (HaddockArgs -> FilePath) -> HaddockArgs -> FilePath
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))
      ShowS -> (HaddockArgs -> FilePath) -> HaddockArgs -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag FilePath -> FilePath
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag FilePath -> FilePath)
-> (HaddockArgs -> Flag FilePath) -> HaddockArgs -> 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
    ]
    where
      renderInterfaces :: [(FilePath, Maybe FilePath, Maybe FilePath)] -> [FilePath]
renderInterfaces = ((FilePath, Maybe FilePath, Maybe FilePath) -> FilePath)
-> [(FilePath, Maybe FilePath, Maybe FilePath)] -> [FilePath]
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=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
        (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [[FilePath]] -> [FilePath]
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
                                        , Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (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
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"

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

-- | 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 <- [IO
   (Either
      PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath))]
-> IO
     [Either
        PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath)]
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 -> Either PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath)
-> IO
     (Either
        PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageIdentifier
-> Either
     PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath)
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 (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 (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)
-> IO
     (Either
        PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath, Maybe FilePath, Maybe FilePath)
-> Either
     PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath)
forall a b. b -> Either a b
Right (FilePath
interface, Maybe FilePath
html', Maybe FilePath
hypsrc'))
            else Either PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath)
-> IO
     (Either
        PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageIdentifier
-> Either
     PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath)
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)]
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)]
flags = [Either
   PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath)]
-> [(FilePath, Maybe FilePath, Maybe FilePath)]
forall a b. [Either a b] -> [b]
rights [Either
   PackageIdentifier (FilePath, Maybe FilePath, Maybe FilePath)]
interfaces

  ([(FilePath, Maybe FilePath, Maybe FilePath)], Maybe FilePath)
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath)], Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(FilePath, Maybe FilePath, Maybe FilePath)]
flags, if [PackageIdentifier] -> 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 (m :: * -> *) a. Monad m => a -> m a
return (FilePath
interface, if FilePath -> 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
                            )]
                          , 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 = ((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 (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageIndex
x
    Right [(InstalledPackageInfo, [UnitId])]
inf -> Verbosity -> FilePath -> IO InstalledPackageIndex
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO InstalledPackageIndex)
-> FilePath -> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$ FilePath
"internal error when calculating transitive "
                    FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"package dependencies.\nDebug info: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [(InstalledPackageInfo, [UnitId])] -> FilePath
forall a. Show a => a -> FilePath
show [(InstalledPackageInfo, [UnitId])]
inf
  [InstalledPackageInfo]
-> Maybe (InstalledPackageInfo -> FilePath)
-> IO
     ([(FilePath, Maybe FilePath, Maybe FilePath)], 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 (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 =
    (FilePath -> IO ())
-> ((ConfiguredProgram, Version, ProgramDb) -> IO ())
-> Either FilePath (ConfiguredProgram, Version, ProgramDb)
-> IO ()
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) (Either FilePath (ConfiguredProgram, Version, ProgramDb) -> IO ())
-> IO (Either FilePath (ConfiguredProgram, Version, ProgramDb))
-> IO ()
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 (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
        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"
              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 (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 (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 :: Flag FilePath
-> Flag Bool
-> Flag Bool
-> Flag Bool
-> Flag Bool
-> Flag FilePath
-> Flag Verbosity
-> Flag FilePath
-> HscolourFlags
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