{-# LANGUAGE RecordWildCards #-}
module Hoogle.Cabal.Command.Common
( GlobalOptions (..),
globalOptionsParser,
hoogleDatabaseArg,
Context (..),
readContext,
)
where
import qualified Data.Map.Strict as Map
import Distribution.Client.CmdBuild (BuildFlags, defaultBuildFlags, selectComponentTarget, selectPackageTargets)
import Distribution.Client.CmdErrorMessages (renderCannotPruneDependencies, reportTargetProblems)
import Distribution.Client.DistDirLayout (distDirectory)
import Distribution.Client.NixStyleOptions
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ScriptUtils
import Distribution.Client.Setup (GlobalFlags, InstallFlags (..), defaultGlobalFlags)
import Distribution.Simple (OptimisationLevel (NoOptimisation))
import Distribution.Simple.Setup (ConfigFlags (..), Flag (..), HaddockFlags (..))
import Distribution.Simple.Utils (die')
import qualified Distribution.Verbosity as Verbosity
import Options.Applicative
import System.FilePath ((</>))
data GlobalOptions = GlobalOptions
{ GlobalOptions -> FilePath
_globalOptions_builddir :: FilePath,
GlobalOptions -> Bool
_globalOptions_version :: Bool
}
deriving (Int -> GlobalOptions -> ShowS
[GlobalOptions] -> ShowS
GlobalOptions -> FilePath
(Int -> GlobalOptions -> ShowS)
-> (GlobalOptions -> FilePath)
-> ([GlobalOptions] -> ShowS)
-> Show GlobalOptions
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GlobalOptions -> ShowS
showsPrec :: Int -> GlobalOptions -> ShowS
$cshow :: GlobalOptions -> FilePath
show :: GlobalOptions -> FilePath
$cshowList :: [GlobalOptions] -> ShowS
showList :: [GlobalOptions] -> ShowS
Show, GlobalOptions -> GlobalOptions -> Bool
(GlobalOptions -> GlobalOptions -> Bool)
-> (GlobalOptions -> GlobalOptions -> Bool) -> Eq GlobalOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlobalOptions -> GlobalOptions -> Bool
== :: GlobalOptions -> GlobalOptions -> Bool
$c/= :: GlobalOptions -> GlobalOptions -> Bool
/= :: GlobalOptions -> GlobalOptions -> Bool
Eq)
globalOptionsParser :: Parser GlobalOptions
globalOptionsParser :: Parser GlobalOptions
globalOptionsParser =
FilePath -> Bool -> GlobalOptions
GlobalOptions
(FilePath -> Bool -> GlobalOptions)
-> Parser FilePath -> Parser (Bool -> GlobalOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"builddir"
Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value FilePath
"dist-newstyle/hoogle"
Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Cabal project build dir"
)
Parser (Bool -> GlobalOptions)
-> Parser Bool -> Parser GlobalOptions
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"version"
Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Print version"
)
hoogleDatabaseArg :: String
hoogleDatabaseArg :: FilePath
hoogleDatabaseArg = FilePath
"--database=all.hoo"
data Context = Context
{ Context -> ProjectBaseContext
_context_baseCtx :: ProjectBaseContext,
Context -> ProjectBuildContext
_context_buildCtx :: ProjectBuildContext,
Context -> FilePath
_context_hoogleDir :: FilePath,
Context -> [FilePath]
_context_targetStrings :: [String],
Context -> NixStyleFlags BuildFlags
_context_flags :: NixStyleFlags BuildFlags,
Context -> GlobalFlags
_context_globalFlags :: GlobalFlags
}
readContext ::
GlobalOptions ->
[String] ->
IO Context
readContext :: GlobalOptions -> [FilePath] -> IO Context
readContext GlobalOptions {Bool
FilePath
_globalOptions_builddir :: GlobalOptions -> FilePath
_globalOptions_version :: GlobalOptions -> Bool
_globalOptions_builddir :: FilePath
_globalOptions_version :: Bool
..} [FilePath]
targetStrings =
AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags BuildFlags
-> [FilePath]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
-> ProjectBaseContext -> [TargetSelector] -> IO Context)
-> IO Context
forall a b.
AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> [FilePath]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
-> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors AcceptNoTargets
RejectNoTargets Maybe ComponentKind
forall a. Maybe a
Nothing NixStyleFlags BuildFlags
flags [FilePath]
targetStrings' GlobalFlags
globalFlags CurrentCommand
HaddockCommand ((TargetContext
-> ProjectBaseContext -> [TargetSelector] -> IO Context)
-> IO Context)
-> (TargetContext
-> ProjectBaseContext -> [TargetSelector] -> IO Context)
-> IO Context
forall a b. (a -> b) -> a -> b
$ \TargetContext
targetCtx ProjectBaseContext
ctx [TargetSelector]
targetSelectors -> do
let targetAction :: TargetAction
targetAction = TargetAction
TargetActionBuild
ProjectBaseContext
baseCtx <- case TargetContext
targetCtx of
TargetContext
ProjectContext -> ProjectBaseContext -> IO ProjectBaseContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
TargetContext
GlobalContext -> ProjectBaseContext -> IO ProjectBaseContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
ScriptContext FilePath
path Executable
exemeta -> ProjectBaseContext
-> FilePath -> Executable -> IO ProjectBaseContext
updateContextAndWriteProjectFile ProjectBaseContext
ctx FilePath
path Executable
exemeta
let verbosity :: Verbosity
verbosity = Verbosity
Verbosity.normal
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
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 -> FilePath -> [TargetProblem'] -> IO TargetsMap
forall a. Verbosity -> FilePath -> [TargetProblem'] -> IO a
reportTargetProblems Verbosity
verbosity FilePath
"build") 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
TargetSelector -> [AvailableTarget k] -> Either TargetProblem' [k]
forall k.
TargetSelector -> [AvailableTarget k] -> Either TargetProblem' [k]
selectPackageTargets
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
targetAction
TargetsMap
targets
ElaboratedInstallPlan
elaboratedPlan
ElaboratedInstallPlan
elaboratedPlan'' <-
if BuildTimeSettings -> Bool
buildSettingOnlyDeps (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)
then
(CannotPruneDependencies -> IO ElaboratedInstallPlan)
-> (ElaboratedInstallPlan -> IO ElaboratedInstallPlan)
-> Either CannotPruneDependencies ElaboratedInstallPlan
-> IO ElaboratedInstallPlan
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> FilePath -> IO ElaboratedInstallPlan
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ElaboratedInstallPlan)
-> (CannotPruneDependencies -> FilePath)
-> CannotPruneDependencies
-> IO ElaboratedInstallPlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CannotPruneDependencies -> FilePath
renderCannotPruneDependencies) ElaboratedInstallPlan -> IO ElaboratedInstallPlan
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CannotPruneDependencies ElaboratedInstallPlan
-> IO ElaboratedInstallPlan)
-> Either CannotPruneDependencies ElaboratedInstallPlan
-> IO ElaboratedInstallPlan
forall a b. (a -> b) -> a -> b
$
Set UnitId
-> ElaboratedInstallPlan
-> Either CannotPruneDependencies ElaboratedInstallPlan
pruneInstallPlanToDependencies
(TargetsMap -> Set UnitId
forall k a. Map k a -> Set k
Map.keysSet TargetsMap
targets)
ElaboratedInstallPlan
elaboratedPlan'
else ElaboratedInstallPlan -> IO ElaboratedInstallPlan
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return 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)
Context -> IO Context
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> IO Context) -> Context -> IO Context
forall a b. (a -> b) -> a -> b
$
ProjectBaseContext
-> ProjectBuildContext
-> FilePath
-> [FilePath]
-> NixStyleFlags BuildFlags
-> GlobalFlags
-> Context
Context
ProjectBaseContext
baseCtx
ProjectBuildContext
buildCtx
(DistDirLayout -> FilePath
distDirectory (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx) FilePath -> ShowS
</> FilePath
".hoogle")
[FilePath]
targetStrings'
NixStyleFlags BuildFlags
flags
GlobalFlags
globalFlags
where
defaultFlags :: NixStyleFlags BuildFlags
defaultFlags = BuildFlags -> NixStyleFlags BuildFlags
forall a. a -> NixStyleFlags a
defaultNixStyleFlags BuildFlags
defaultBuildFlags
flags :: NixStyleFlags BuildFlags
flags =
NixStyleFlags BuildFlags
defaultFlags
{ configFlags =
(configFlags defaultFlags)
{ configOptimization = Flag NoOptimisation,
configDistPref = Flag _globalOptions_builddir
},
haddockFlags =
(haddockFlags defaultFlags)
{ haddockHoogle = Flag True,
haddockHtml = Flag True,
haddockLinkedSource = Flag True,
haddockQuickJump = Flag True
},
installFlags =
(installFlags defaultFlags)
{ installDocumentation = Flag True
}
}
targetStrings' :: [String]
targetStrings' :: [FilePath]
targetStrings' = if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
targetStrings then [FilePath
"all"] else [FilePath]
targetStrings
globalFlags :: GlobalFlags
globalFlags = GlobalFlags
defaultGlobalFlags