{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.CmdHaddock (
haddockCommand,
haddockAction,
selectPackageTargets,
selectComponentTarget
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages
import Distribution.Client.TargetProblem
( TargetProblem (..), TargetProblem' )
import Distribution.Client.NixStyleOptions
( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..) )
import Distribution.Simple.Setup
( HaddockFlags(..), fromFlagOrDefault, trueArg )
import Distribution.Simple.Command
( CommandUI(..), usageAlternatives, ShowOrParseArgs, OptionField, option )
import Distribution.Verbosity
( normal )
import Distribution.Simple.Utils
( wrapText, die', notice )
import Distribution.Simple.Flag (Flag(..))
import qualified System.Exit (exitSuccess)
newtype ClientHaddockFlags = ClientHaddockFlags { ClientHaddockFlags -> Flag Bool
openInBrowser :: Flag Bool }
haddockCommand :: CommandUI (NixStyleFlags ClientHaddockFlags)
haddockCommand :: CommandUI (NixStyleFlags ClientHaddockFlags)
haddockCommand = CommandUI :: forall flags.
String
-> String
-> (String -> String)
-> Maybe (String -> String)
-> Maybe (String -> String)
-> flags
-> (ShowOrParseArgs -> [OptionField flags])
-> CommandUI flags
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))
}
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 :: Flag Bool
openInBrowser = Flag Bool
v}) MkOptDescr
(ClientHaddockFlags -> Flag Bool)
(Flag Bool -> ClientHaddockFlags -> ClientHaddockFlags)
ClientHaddockFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
]
haddockAction :: NixStyleFlags ClientHaddockFlags -> [String] -> GlobalFlags -> IO ()
haddockAction :: NixStyleFlags ClientHaddockFlags
-> [String] -> GlobalFlags -> IO ()
haddockAction flags :: NixStyleFlags ClientHaddockFlags
flags@NixStyleFlags {ConfigFlags
HaddockFlags
TestFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
ClientHaddockFlags
extraFlags :: forall a. NixStyleFlags a -> a
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
extraFlags :: ClientHaddockFlags
projectFlags :: ProjectFlags
benchmarkFlags :: BenchmarkFlags
testFlags :: TestFlags
haddockFlags :: HaddockFlags
installFlags :: InstallFlags
configExFlags :: ConfigExFlags
configFlags :: ConfigFlags
..} [String]
targetStrings GlobalFlags
globalFlags = do
ProjectBaseContext
projCtx <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
cliConfig CurrentCommand
HaddockCommand
let baseCtx :: ProjectBaseContext
baseCtx
| Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ClientHaddockFlags -> Flag Bool
openInBrowser ClientHaddockFlags
extraFlags)
= ProjectBaseContext
projCtx { buildSettings :: BuildTimeSettings
buildSettings = (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
projCtx) { buildSettingHaddockOpen :: Bool
buildSettingHaddockOpen = Bool
True } }
| Bool
otherwise
= ProjectBaseContext
projCtx
[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 (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 -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity
String
"The haddock command does not support '--only-dependencies'."
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 (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)
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 (m :: * -> *) a. Monad m => a -> m a
return (ElaboratedInstallPlan
elaboratedPlan', TargetsMap
targets)
Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO ()
printPlan Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx
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
where
verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)
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
selectPackageTargets :: HaddockFlags -> TargetSelector
-> [AvailableTarget k] -> Either TargetProblem' [k]
selectPackageTargets :: HaddockFlags
-> TargetSelector
-> [AvailableTarget k]
-> Either TargetProblem' [k]
selectPackageTargets HaddockFlags
haddockFlags TargetSelector
targetSelector [AvailableTarget k]
targets
| Bool -> Bool
not ([k] -> 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
| Bool -> Bool
not ([AvailableTarget k] -> 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')
| 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)
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 :: AvailableTargetStatus k
availableTargetStatus = AvailableTargetStatus k
forall k. AvailableTargetStatus k
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 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)
selectComponentTarget :: SubComponentTarget
-> AvailableTarget k -> Either TargetProblem' k
selectComponentTarget :: 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 :: 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