{-# LANGUAGE RecordWildCards #-}

-- | cabal-install CLI command: haddock
module Distribution.Client.CmdHaddock
  ( -- * The @haddock@ CLI and action
    haddockCommand
  , haddockAction
  , ClientHaddockFlags (..)

    -- * Internals exposed for testing
  , selectPackageTargets
  , selectComponentTarget
  ) where

import Distribution.Client.Compat.Prelude
import System.Directory (makeAbsolute)
import Prelude ()

import Distribution.Client.CmdErrorMessages
import Distribution.Client.NixStyleOptions
  ( NixStyleFlags (..)
  , defaultNixStyleFlags
  , nixStyleOptions
  )
import Distribution.Client.ProjectConfig.Types
  ( PackageConfig (..)
  , ProjectConfig (..)
  )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
  ( ElaboratedSharedConfig (..)
  )
import Distribution.Client.Setup
  ( CommonSetupFlags (..)
  , ConfigFlags (..)
  , GlobalFlags
  , InstallFlags (..)
  )
import Distribution.Client.TargetProblem
  ( TargetProblem (..)
  , TargetProblem'
  )
import Distribution.Simple.Command
  ( CommandUI (..)
  , OptionField
  , ShowOrParseArgs
  , option
  , usageAlternatives
  )
import Distribution.Simple.Flag (Flag (..))
import Distribution.Simple.Program.Builtin
  ( haddockProgram
  )
import Distribution.Simple.Program.Db
  ( addKnownProgram
  , reconfigurePrograms
  )
import Distribution.Simple.Setup
  ( HaddockFlags (..)
  , fromFlagOrDefault
  , trueArg
  )
import Distribution.Simple.Utils
  ( dieWithException
  , notice
  , wrapText
  )
import Distribution.Verbosity
  ( normal
  )

import Distribution.Client.Errors
import qualified System.Exit (exitSuccess)

newtype ClientHaddockFlags = ClientHaddockFlags {ClientHaddockFlags -> Flag Bool
openInBrowser :: Flag Bool}

haddockCommand :: CommandUI (NixStyleFlags ClientHaddockFlags)
haddockCommand :: CommandUI (NixStyleFlags ClientHaddockFlags)
haddockCommand =
  CommandUI
    { commandName :: String
commandName = String
"v2-haddock"
    , commandSynopsis :: String
commandSynopsis = String
"Build Haddock documentation."
    , commandUsage :: String -> String
commandUsage = String -> [String] -> String -> String
usageAlternatives String
"v2-haddock" [String
"[FLAGS] TARGET"]
    , commandDescription :: Maybe (String -> String)
commandDescription = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
_ ->
        String -> String
wrapText (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
          String
"Build Haddock documentation for the specified packages within the "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"project.\n\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Any package in the project can be specified. If no package is "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"specified, the default is to build the documentation for the package "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"in the current directory. The default behaviour is to build "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"documentation for the exposed modules of the library component (if "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"any). This can be changed with the '--internal', '--executables', "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'--tests', '--benchmarks' or '--all' flags.\n\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Currently, documentation for dependencies is NOT built. This "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"behavior may change in future.\n\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Additional configuration flags can be specified on the command line "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"and these extend the project configuration from the 'cabal.project', "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'cabal.project.local' and other files."
    , commandNotes :: Maybe (String -> String)
commandNotes = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
pname ->
        String
"Examples:\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-haddock pkgname"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Build documentation for the package named pkgname\n"
    , commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ClientHaddockFlags)]
commandOptions = (ShowOrParseArgs -> [OptionField ClientHaddockFlags])
-> ShowOrParseArgs
-> [OptionField (NixStyleFlags ClientHaddockFlags)]
forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ShowOrParseArgs -> [OptionField ClientHaddockFlags]
haddockOptions
    , commandDefaultFlags :: NixStyleFlags ClientHaddockFlags
commandDefaultFlags = ClientHaddockFlags -> NixStyleFlags ClientHaddockFlags
forall a. a -> NixStyleFlags a
defaultNixStyleFlags (Flag Bool -> ClientHaddockFlags
ClientHaddockFlags (Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
False))
    }

-- TODO: [nice to have] support haddock on specific components, not just
-- whole packages and the silly --executables etc modifiers.

haddockOptions :: ShowOrParseArgs -> [OptionField ClientHaddockFlags]
haddockOptions :: ShowOrParseArgs -> [OptionField ClientHaddockFlags]
haddockOptions ShowOrParseArgs
_ =
  [ String
-> [String]
-> String
-> (ClientHaddockFlags -> Flag Bool)
-> (Flag Bool -> ClientHaddockFlags -> ClientHaddockFlags)
-> MkOptDescr
     (ClientHaddockFlags -> Flag Bool)
     (Flag Bool -> ClientHaddockFlags -> ClientHaddockFlags)
     ClientHaddockFlags
-> OptionField ClientHaddockFlags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      []
      [String
"open"]
      String
"Open generated documentation in the browser"
      ClientHaddockFlags -> Flag Bool
openInBrowser
      (\Flag Bool
v ClientHaddockFlags
f -> ClientHaddockFlags
f{openInBrowser = v})
      MkOptDescr
  (ClientHaddockFlags -> Flag Bool)
  (Flag Bool -> ClientHaddockFlags -> ClientHaddockFlags)
  ClientHaddockFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
  ]

mkConfigAbsolute :: ProjectConfig -> IO ProjectConfig
mkConfigAbsolute :: ProjectConfig -> IO ProjectConfig
mkConfigAbsolute ProjectConfig
relConfig = do
  let relPackageConfig :: PackageConfig
relPackageConfig = ProjectConfig -> PackageConfig
projectConfigLocalPackages ProjectConfig
relConfig
  Flag String
absHaddockOutputDir <- (String -> IO String) -> Flag String -> IO (Flag String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Flag a -> f (Flag b)
traverse String -> IO String
makeAbsolute (PackageConfig -> Flag String
packageConfigHaddockOutputDir PackageConfig
relPackageConfig)
  ProjectConfig -> IO ProjectConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( ProjectConfig
relConfig
        { projectConfigLocalPackages =
            relPackageConfig
              { packageConfigHaddockOutputDir = absHaddockOutputDir
              }
        }
    )

mkFlagsAbsolute :: NixStyleFlags ClientHaddockFlags -> IO (NixStyleFlags ClientHaddockFlags)
mkFlagsAbsolute :: NixStyleFlags ClientHaddockFlags
-> IO (NixStyleFlags ClientHaddockFlags)
mkFlagsAbsolute NixStyleFlags ClientHaddockFlags
relFlags = do
  let relHaddockFlags :: HaddockFlags
relHaddockFlags = NixStyleFlags ClientHaddockFlags -> HaddockFlags
forall a. NixStyleFlags a -> HaddockFlags
haddockFlags NixStyleFlags ClientHaddockFlags
relFlags
  Flag String
absHaddockOutputDir <- (String -> IO String) -> Flag String -> IO (Flag String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Flag a -> f (Flag b)
traverse String -> IO String
makeAbsolute (HaddockFlags -> Flag String
haddockOutputDir HaddockFlags
relHaddockFlags)
  NixStyleFlags ClientHaddockFlags
-> IO (NixStyleFlags ClientHaddockFlags)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NixStyleFlags ClientHaddockFlags
relFlags{haddockFlags = relHaddockFlags{haddockOutputDir = absHaddockOutputDir}})

-- | The @haddock@ command is TODO.
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
haddockAction :: NixStyleFlags ClientHaddockFlags -> [String] -> GlobalFlags -> IO ()
haddockAction :: NixStyleFlags ClientHaddockFlags
-> [String] -> GlobalFlags -> IO ()
haddockAction NixStyleFlags ClientHaddockFlags
relFlags [String]
targetStrings GlobalFlags
globalFlags = do
  -- It's important to make --haddock-output-dir absolute since we change the working directory later.
  flags :: NixStyleFlags ClientHaddockFlags
flags@NixStyleFlags{TestFlags
HaddockFlags
ConfigFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
ClientHaddockFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
extraFlags :: ClientHaddockFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
extraFlags :: forall a. NixStyleFlags a -> a
..} <- NixStyleFlags ClientHaddockFlags
-> IO (NixStyleFlags ClientHaddockFlags)
mkFlagsAbsolute NixStyleFlags ClientHaddockFlags
relFlags

  let
    verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (CommonSetupFlags -> Flag Verbosity
setupVerbosity (CommonSetupFlags -> Flag Verbosity)
-> CommonSetupFlags -> Flag Verbosity
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags)
    installDoc :: Bool
installDoc = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
True (InstallFlags -> Flag Bool
installDocumentation InstallFlags
installFlags)
    flags' :: NixStyleFlags ClientHaddockFlags
flags' = NixStyleFlags ClientHaddockFlags
flags{installFlags = installFlags{installDocumentation = Flag installDoc}}
    cliConfig :: ProjectConfig
cliConfig = GlobalFlags
-> NixStyleFlags ClientHaddockFlags
-> ClientInstallFlags
-> ProjectConfig
forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig GlobalFlags
globalFlags NixStyleFlags ClientHaddockFlags
flags' ClientInstallFlags
forall a. Monoid a => a
mempty -- ClientInstallFlags, not needed here
  ProjectBaseContext
projCtx <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
cliConfig CurrentCommand
HaddockCommand

  let relBaseCtx :: ProjectBaseContext
relBaseCtx@ProjectBaseContext{projectConfig :: ProjectBaseContext -> ProjectConfig
projectConfig = ProjectConfig
relProjectConfig}
        | Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ClientHaddockFlags -> Flag Bool
openInBrowser ClientHaddockFlags
extraFlags) =
            ProjectBaseContext
projCtx{buildSettings = (buildSettings projCtx){buildSettingHaddockOpen = True}}
        | Bool
otherwise =
            ProjectBaseContext
projCtx
  ProjectConfig
absProjectConfig <- ProjectConfig -> IO ProjectConfig
mkConfigAbsolute ProjectConfig
relProjectConfig
  let baseCtx :: ProjectBaseContext
baseCtx = ProjectBaseContext
relBaseCtx{projectConfig = absProjectConfig}

  [TargetSelector]
targetSelectors <-
    ([TargetSelectorProblem] -> IO [TargetSelector])
-> ([TargetSelector] -> IO [TargetSelector])
-> Either [TargetSelectorProblem] [TargetSelector]
-> IO [TargetSelector]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> [TargetSelectorProblem] -> IO [TargetSelector]
forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity) [TargetSelector] -> IO [TargetSelector]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
      (Either [TargetSelectorProblem] [TargetSelector]
 -> IO [TargetSelector])
-> IO (Either [TargetSelectorProblem] [TargetSelector])
-> IO [TargetSelector]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [PackageSpecifier (SourcePackage (PackageLocation (Maybe String)))]
-> Maybe ComponentKindFilter
-> [String]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
forall a.
[PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKindFilter
-> [String]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors (ProjectBaseContext
-> [PackageSpecifier
      (SourcePackage (PackageLocation (Maybe String)))]
localPackages ProjectBaseContext
baseCtx) Maybe ComponentKindFilter
forall a. Maybe a
Nothing [String]
targetStrings

  ProjectBuildContext
buildCtx <-
    Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
runProjectPreBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ((ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))
 -> IO ProjectBuildContext)
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
forall a b. (a -> b) -> a -> b
$ \ElaboratedInstallPlan
elaboratedPlan -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BuildTimeSettings -> Bool
buildSettingOnlyDeps (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
HaddockCommandDoesn'tSupport

      -- When we interpret the targets on the command line, interpret them as
      -- haddock targets
      TargetsMap
targets <-
        ([TargetProblem'] -> IO TargetsMap)
-> (TargetsMap -> IO TargetsMap)
-> Either [TargetProblem'] TargetsMap
-> IO TargetsMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> [TargetProblem'] -> IO TargetsMap
forall a. Verbosity -> [TargetProblem'] -> IO a
reportBuildDocumentationTargetProblems Verbosity
verbosity) TargetsMap -> IO TargetsMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TargetProblem'] TargetsMap -> IO TargetsMap)
-> Either [TargetProblem'] TargetsMap -> IO TargetsMap
forall a b. (a -> b) -> a -> b
$
          (forall k.
 TargetSelector -> [AvailableTarget k] -> Either TargetProblem' [k])
-> (forall k.
    SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem'] TargetsMap
forall err.
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets
            (HaddockFlags
-> TargetSelector
-> [AvailableTarget k]
-> Either TargetProblem' [k]
forall k.
HaddockFlags
-> TargetSelector
-> [AvailableTarget k]
-> Either TargetProblem' [k]
selectPackageTargets HaddockFlags
haddockFlags)
            SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k
forall k.
SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k
selectComponentTarget
            ElaboratedInstallPlan
elaboratedPlan
            Maybe SourcePackageDb
forall a. Maybe a
Nothing
            [TargetSelector]
targetSelectors

      let elaboratedPlan' :: ElaboratedInstallPlan
elaboratedPlan' =
            TargetAction
-> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets
              TargetAction
TargetActionHaddock
              TargetsMap
targets
              ElaboratedInstallPlan
elaboratedPlan
      (ElaboratedInstallPlan, TargetsMap)
-> IO (ElaboratedInstallPlan, TargetsMap)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElaboratedInstallPlan
elaboratedPlan', TargetsMap
targets)

  Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO ()
printPlan Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx

  ProgramDb
progs <-
    Verbosity
-> [(String, String)]
-> [(String, [String])]
-> ProgramDb
-> IO ProgramDb
reconfigurePrograms
      Verbosity
verbosity
      (HaddockFlags -> [(String, String)]
haddockProgramPaths HaddockFlags
haddockFlags)
      (HaddockFlags -> [(String, [String])]
haddockProgramArgs HaddockFlags
haddockFlags)
      -- we need to insert 'haddockProgram' before we reconfigure it,
      -- otherwise 'set
      (ProgramDb -> IO ProgramDb)
-> (ProjectBuildContext -> ProgramDb)
-> ProjectBuildContext
-> IO ProgramDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> ProgramDb -> ProgramDb
addKnownProgram Program
haddockProgram
      (ProgramDb -> ProgramDb)
-> (ProjectBuildContext -> ProgramDb)
-> ProjectBuildContext
-> ProgramDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedSharedConfig -> ProgramDb
pkgConfigCompilerProgs
      (ElaboratedSharedConfig -> ProgramDb)
-> (ProjectBuildContext -> ElaboratedSharedConfig)
-> ProjectBuildContext
-> ProgramDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared
      (ProjectBuildContext -> IO ProgramDb)
-> ProjectBuildContext -> IO ProgramDb
forall a b. (a -> b) -> a -> b
$ ProjectBuildContext
buildCtx
  let buildCtx' :: ProjectBuildContext
buildCtx' =
        ProjectBuildContext
buildCtx
          { elaboratedShared =
              (elaboratedShared buildCtx)
                { pkgConfigCompilerProgs = progs
                }
          }

  BuildOutcomes
buildOutcomes <- Verbosity
-> ProjectBaseContext -> ProjectBuildContext -> IO BuildOutcomes
runProjectBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx'
  Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> BuildOutcomes
-> IO ()
runProjectPostBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx' BuildOutcomes
buildOutcomes

-- | This defines what a 'TargetSelector' means for the @haddock@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
-- or otherwise classifies the problem.
--
-- For the @haddock@ command we select all buildable libraries. Additionally,
-- depending on the @--executables@ flag we also select all the buildable exes.
-- We do similarly for test-suites, benchmarks and foreign libs.
selectPackageTargets
  :: HaddockFlags
  -> TargetSelector
  -> [AvailableTarget k]
  -> Either TargetProblem' [k]
selectPackageTargets :: forall k.
HaddockFlags
-> TargetSelector
-> [AvailableTarget k]
-> Either TargetProblem' [k]
selectPackageTargets HaddockFlags
haddockFlags TargetSelector
targetSelector [AvailableTarget k]
targets
  -- If there are any buildable targets then we select those
  | Bool -> Bool
not ([k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsBuildable) =
      [k] -> Either TargetProblem' [k]
forall a b. b -> Either a b
Right [k]
targetsBuildable
  -- If there are targets but none are buildable then we report those
  | Bool -> Bool
not ([AvailableTarget k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget k]
targets) =
      TargetProblem' -> Either TargetProblem' [k]
forall a b. a -> Either a b
Left (TargetSelector -> [AvailableTarget ()] -> TargetProblem'
forall a. TargetSelector -> [AvailableTarget ()] -> TargetProblem a
TargetProblemNoneEnabled TargetSelector
targetSelector [AvailableTarget ()]
targets')
  -- If there are no targets at all then we report that
  | Bool
otherwise =
      TargetProblem' -> Either TargetProblem' [k]
forall a b. a -> Either a b
Left (TargetSelector -> TargetProblem'
forall a. TargetSelector -> TargetProblem a
TargetProblemNoTargets TargetSelector
targetSelector)
  where
    targets' :: [AvailableTarget ()]
targets' = [AvailableTarget k] -> [AvailableTarget ()]
forall k. [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail ((AvailableTarget k -> AvailableTarget k)
-> [AvailableTarget k] -> [AvailableTarget k]
forall a b. (a -> b) -> [a] -> [b]
map AvailableTarget k -> AvailableTarget k
forall {k}. AvailableTarget k -> AvailableTarget k
disableNotRequested [AvailableTarget k]
targets)
    targetsBuildable :: [k]
targetsBuildable = [AvailableTarget k] -> [k]
forall k. [AvailableTarget k] -> [k]
selectBuildableTargets ((AvailableTarget k -> AvailableTarget k)
-> [AvailableTarget k] -> [AvailableTarget k]
forall a b. (a -> b) -> [a] -> [b]
map AvailableTarget k -> AvailableTarget k
forall {k}. AvailableTarget k -> AvailableTarget k
disableNotRequested [AvailableTarget k]
targets)

    -- When there's a target filter like "pkg:exes" then we do select exes,
    -- but if it's just a target like "pkg" then we don't build docs for exes
    -- unless they are requested by default (i.e. by using --executables)
    disableNotRequested :: AvailableTarget k -> AvailableTarget k
disableNotRequested t :: AvailableTarget k
t@(AvailableTarget PackageId
_ ComponentName
cname (TargetBuildable k
_ TargetRequested
_) Bool
_)
      | Bool -> Bool
not (TargetSelector -> ComponentKindFilter -> Bool
isRequested TargetSelector
targetSelector (ComponentName -> ComponentKindFilter
componentKind ComponentName
cname)) =
          AvailableTarget k
t{availableTargetStatus = TargetDisabledByUser}
    disableNotRequested AvailableTarget k
t = AvailableTarget k
t

    isRequested :: TargetSelector -> ComponentKindFilter -> Bool
isRequested (TargetPackage TargetImplicitCwd
_ [PackageId]
_ (Just ComponentKindFilter
_)) ComponentKindFilter
_ = Bool
True
    isRequested (TargetAllPackages (Just ComponentKindFilter
_)) ComponentKindFilter
_ = Bool
True
    isRequested TargetSelector
_ ComponentKindFilter
LibKind = Bool
True
    --  isRequested _ SubLibKind = True --TODO: what about sublibs?

    -- TODO/HACK, we encode some defaults here as v2-haddock's logic;
    -- make sure this matches the defaults applied in
    -- "Distribution.Client.ProjectPlanning"; this may need more work
    -- to be done properly
    --
    -- See also https://github.com/haskell/cabal/pull/4886
    isRequested TargetSelector
_ ComponentKindFilter
FLibKind = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockFlags -> Flag Bool
haddockForeignLibs HaddockFlags
haddockFlags)
    isRequested TargetSelector
_ ComponentKindFilter
ExeKind = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockFlags -> Flag Bool
haddockExecutables HaddockFlags
haddockFlags)
    isRequested TargetSelector
_ ComponentKindFilter
TestKind = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockFlags -> Flag Bool
haddockTestSuites HaddockFlags
haddockFlags)
    isRequested TargetSelector
_ ComponentKindFilter
BenchKind = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockFlags -> Flag Bool
haddockBenchmarks HaddockFlags
haddockFlags)

-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @haddock@ command we just need the basic checks on being buildable
-- etc.
selectComponentTarget
  :: SubComponentTarget
  -> AvailableTarget k
  -> Either TargetProblem' k
selectComponentTarget :: forall k.
SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k
selectComponentTarget = SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k
forall k a.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic

reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
reportBuildDocumentationTargetProblems :: forall a. Verbosity -> [TargetProblem'] -> IO a
reportBuildDocumentationTargetProblems Verbosity
verbosity [TargetProblem']
problems =
  case [TargetProblem']
problems of
    [TargetProblemNoneEnabled TargetSelector
_ [AvailableTarget ()]
_] -> do
      Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        [String] -> String
unwords
          [ String
"No documentation was generated as this package does not contain a library."
          , String
"Perhaps you want to use the --haddock-all flag, or one or more of the"
          , String
"--haddock-executables, --haddock-tests, --haddock-benchmarks or"
          , String
"--haddock-internal flags."
          ]
      IO a
forall a. IO a
System.Exit.exitSuccess
    [TargetProblem']
_ -> Verbosity -> String -> [TargetProblem'] -> IO a
forall a. Verbosity -> String -> [TargetProblem'] -> IO a
reportTargetProblems Verbosity
verbosity String
"build documentation for" [TargetProblem']
problems