Add/command target backup

cabal-install/cabal-install.cabal

@@ -105,6 +105,7 @@ library
         Distribution.Client.CmdRepl
         Distribution.Client.CmdRun
         Distribution.Client.CmdSdist
+        Distribution.Client.CmdTarget
         Distribution.Client.CmdTest
         Distribution.Client.CmdUpdate
         Distribution.Client.Compat.Directory

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 = "Target disclosure."
+    , commandUsage = usageAlternatives "v2-target" ["[TARGETS]"]
+    , commandDescription = Just $ \_ ->
+        wrapText $
+          "Reveal the targets of build plan. "
+            ++ "If no [TARGETS] are given 'all' will be used for selecting a build plan.\n\n"
+            ++ "A [TARGETS] item can be one of these target forms;\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"
+          ++ "    Targets of the package in the current directory "
+          ++ "or all packages in the project\n"
+          ++ "  "
+          ++ pname
+          ++ " v2-target pkgname\n"
+          ++ "    Targets of the package named pkgname in the project\n"
+          ++ "  "
+          ++ pname
+          ++ " v2-target ./pkgfoo\n"
+          ++ "    Targets of the package in the ./pkgfoo directory\n"
+          ++ "  "
+          ++ pname
+          ++ " v2-target cname\n"
+          ++ "    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

cabal-install/src/Distribution/Client/Main.hs

@@ -135,6 +135,7 @@ import qualified Distribution.Client.CmdPath as CmdPath
 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
 
@@ -455,6 +456,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

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
@@ -934,7 +935,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.

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"
@@ -374,6 +376,7 @@ globalCommand commands =
                 , addCmd "path"
                 , par
                 , startGroup "project building and installing"
+                , addCmd "target"
                 , addCmd "build"
                 , addCmd "install"
                 , addCmd "haddock"
@@ -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"