From 6d9267d78b35c5075171309170825d42e4fd16e6 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Mon, 26 Feb 2024 09:56:19 -0500 Subject: [PATCH] Add a cabal target command --- cabal-install/cabal-install.cabal | 1 + .../src/Distribution/Client/CmdTarget.hs | 155 ++++++++++++++++++ cabal-install/src/Distribution/Client/Main.hs | 2 + .../Client/ProjectOrchestration.hs | 58 ++++++- .../src/Distribution/Client/Setup.hs | 6 +- 5 files changed, 220 insertions(+), 2 deletions(-) create mode 100644 cabal-install/src/Distribution/Client/CmdTarget.hs diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 38401ed7adb..74dce38255f 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -100,6 +100,7 @@ library Distribution.Client.CmdRepl Distribution.Client.CmdRun Distribution.Client.CmdSdist + Distribution.Client.CmdTarget Distribution.Client.CmdTest Distribution.Client.CmdUpdate Distribution.Client.Compat.Directory diff --git a/cabal-install/src/Distribution/Client/CmdTarget.hs b/cabal-install/src/Distribution/Client/CmdTarget.hs new file mode 100644 index 00000000000..c59e20957ce --- /dev/null +++ b/cabal-install/src/Distribution/Client/CmdTarget.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Distribution.Client.CmdTarget + ( targetCommand + , targetAction + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Data.Map as Map +import Distribution.Client.CmdBuild (selectComponentTarget, selectPackageTargets) +import Distribution.Client.CmdErrorMessages +import Distribution.Client.Errors +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..) + , defaultNixStyleFlags + ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ScriptUtils + ( AcceptNoTargets (..) + , TargetContext (..) + , updateContextAndWriteProjectFile + , withContextAndSelectors + ) +import Distribution.Client.Setup + ( ConfigFlags (..) + , GlobalFlags + ) +import Distribution.Client.TargetProblem + ( TargetProblem' + ) +import Distribution.Simple.Command + ( CommandUI (..) + , usageAlternatives + ) +import Distribution.Simple.Flag (fromFlagOrDefault) +import Distribution.Simple.Utils + ( dieWithException + , wrapText + ) +import Distribution.Verbosity + ( normal + ) + +------------------------------------------------------------------------------- +-- Command +------------------------------------------------------------------------------- + +targetCommand :: CommandUI (NixStyleFlags ()) +targetCommand = + CommandUI + { commandName = "v2-target" + , commandSynopsis = "List target forms within the project." + , commandUsage = usageAlternatives "v2-target" ["[TARGETS]"] + , commandDescription = Just $ \_ -> + wrapText $ + "List targets within a build plan. " + ++ "If no [TARGETS] are given 'all' will be used for selecting a build plan.\n\n" + ++ "The given target can be;\n" + ++ "- a package target (e.g. [pkg:]package)\n" + ++ "- a component target (e.g. [package:][ctype:]component)\n" + ++ "- all packages (e.g. all)\n" + ++ "- components of a particular type (e.g. package:ctypes or all:ctypes)\n" + ++ "- a module target: (e.g. [package:][ctype:]module)\n" + ++ "- a filepath target: (e.g. [package:][ctype:]filepath)\n" + ++ "- a script target: (e.g. path/to/script)\n\n" + ++ "The ctypes can be one of: " + ++ "libs or libraries, " + ++ "exes or executables, " + ++ "tests, " + ++ "benches or benchmarks, " + ++ " and flibs or foreign-libraries." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " v2-target all\n" + ++ " List all targets of the package in the current directory " + ++ "or all packages in the project\n" + ++ " " + ++ pname + ++ " v2-target pkgname\n" + ++ " List targets of the package named pkgname in the project\n" + ++ " " + ++ pname + ++ " v2-target ./pkgfoo\n" + ++ " List targets of the package in the ./pkgfoo directory\n" + ++ " " + ++ pname + ++ " v2-target cname\n" + ++ " List targets of the component named cname in the project\n" + ++ " " + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = const [] + } + +------------------------------------------------------------------------------- +-- Action +------------------------------------------------------------------------------- + +targetAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () +targetAction flags@NixStyleFlags{..} ts globalFlags = do + let targetStrings = if null ts then ["all"] else ts + withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags BuildCommand $ \targetCtx ctx targetSelectors -> do + baseCtx <- case targetCtx of + ProjectContext -> return ctx + GlobalContext -> return ctx + ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- + either (reportBuildTargetProblems verbosity) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionConfigure + targets + elaboratedPlan + elaboratedPlan'' <- + if buildSettingOnlyDeps (buildSettings baseCtx) + then + either (reportCannotPruneDependencies verbosity) return $ + pruneInstallPlanToDependencies + (Map.keysSet targets) + elaboratedPlan' + else return elaboratedPlan' + + return (elaboratedPlan'', targets) + + printPlanTargetForms verbosity buildCtx + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + +reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a +reportBuildTargetProblems verbosity problems = + reportTargetProblems verbosity "target" problems + +reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a +reportCannotPruneDependencies verbosity = + dieWithException verbosity . ReportCannotPruneDependencies . renderCannotPruneDependencies diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 6ef0a673717..afd1f8902ee 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -140,6 +140,7 @@ import qualified Distribution.Client.CmdOutdated as CmdOutdated import qualified Distribution.Client.CmdRepl as CmdRepl import qualified Distribution.Client.CmdRun as CmdRun import qualified Distribution.Client.CmdSdist as CmdSdist +import qualified Distribution.Client.CmdTarget as CmdTarget import qualified Distribution.Client.CmdTest as CmdTest import qualified Distribution.Client.CmdUpdate as CmdUpdate @@ -460,6 +461,7 @@ mainWorker args = do , newCmd CmdExec.execCommand CmdExec.execAction , newCmd CmdClean.cleanCommand CmdClean.cleanAction , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction + , newCmd CmdTarget.targetCommand CmdTarget.targetAction , legacyCmd configureExCommand configureAction , legacyCmd buildCommand buildAction , legacyCmd replCommand replAction diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index c3fa259b41e..08719c90a19 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -90,6 +90,7 @@ module Distribution.Client.ProjectOrchestration , pruneInstallPlanToDependencies , CannotPruneDependencies (..) , printPlan + , printPlanTargetForms -- * Build phase: now do it. , runProjectBuildPhase @@ -933,7 +934,62 @@ distinctTargetComponents targetsMap = ------------------------------------------------------------------------------ -- Displaying what we plan to do --- + +-- | Print available target forms. +printPlanTargetForms + :: Verbosity + -> ProjectBuildContext + -> IO () +printPlanTargetForms + verbosity + ProjectBuildContext{elaboratedPlanToExecute = elaboratedPlan} + | not (null pkgs) = noticeNoWrap verbosity . unlines $ map showPkgAndReason pkgs + | otherwise = return () + where + pkgs :: [GenericReadyPackage ElaboratedConfiguredPackage] + pkgs = + sortBy + (compare `on` showPkgAndReason) + (InstallPlan.executionOrder elaboratedPlan) + + showPkgAndReason :: ElaboratedReadyPackage -> String + showPkgAndReason (ReadyPackage elab) = + unwords $ + filter (not . null) $ + [ " -" + , concat . filter (not . null) $ + [ prettyShow $ packageName (packageId elab) + , case elabPkgOrComp elab of + ElabPackage _ -> showTargets elab + ElabComponent comp -> ":" ++ showComp elab comp + ] + ] + + showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String + showComp elab comp = + maybe "custom" prettyShow (compComponentName comp) + ++ if Map.null (elabInstantiatedWith elab) + then "" + else + " with " + ++ intercalate + ", " + -- TODO: Abbreviate the UnitIds + [ prettyShow k ++ "=" ++ prettyShow v + | (k, v) <- Map.toList (elabInstantiatedWith elab) + ] + + showTargets :: ElaboratedConfiguredPackage -> String + showTargets elab + | null (elabBuildTargets elab) = "" + | otherwise = + "(" + ++ intercalate + ", " + [ showComponentTarget (packageId elab) t + | t <- elabBuildTargets elab + ] + ++ ")" -- | Print a user-oriented presentation of the install plan, indicating what -- will be built. diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 85cc7665647..9fdb47fbffa 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -275,6 +275,7 @@ globalCommand commands = , "unpack" , "init" , "configure" + , "target" , "build" , "clean" , "run" @@ -327,7 +328,8 @@ globalCommand commands = , "v1-register" , "v1-reconfigure" , -- v2 commands, nix-style - "v2-build" + "v2-target" + , "v2-build" , "v2-configure" , "v2-repl" , "v2-freeze" @@ -381,6 +383,7 @@ globalCommand commands = , addCmd "clean" , par , startGroup "running and testing" + , addCmd "target" , addCmd "list-bin" , addCmd "repl" , addCmd "run" @@ -399,6 +402,7 @@ globalCommand commands = , addCmd "hscolour" , par , startGroup "new-style projects (forwards-compatible aliases)" + , addCmd "v2-target" , addCmd "v2-build" , addCmd "v2-configure" , addCmd "v2-repl"