Merge pull request #4586 from fgaz/new-run-2

Completed the 'new-run' command (#4477). The functionality is the
same of the old 'run' command but using nix-style builds.
Additionally, it can run executables across packages in a project.

Cabal/doc/nix-local-build.rst

@@ -17,6 +17,12 @@ To open a GHCi shell with this package, use this command:
 
     $ cabal new-repl
 
+To run an executable defined in this package, use this command:
+
+::
+
+    $ cabal new-run <executable name> [executable args]
+
 Developing multiple packages
 ----------------------------
 
@@ -343,6 +349,26 @@ Currently, it is not supported to pass multiple targets to ``new-repl``
 (``new-repl`` will just successively open a separate GHCi session for
 each target.)
 
+cabal new-run
+-------------
+
+``cabal new-run [TARGET [ARGS]]`` runs the executable specified by the
+target, which can be a component, a package or can be left blank, as
+long as it can uniquely identify an executable within the project.
+
+See `the new-build section <#cabal-new-build>`__ for the target syntax.
+
+Except in the case of the empty target, the strings after it will be
+passed to the executable as arguments.
+
+If one of the arguments starts with ``-`` it will be interpreted as
+a cabal flag, so if you need to pass flags to the executable you
+have to separate them with ``--``.
+
+::
+
+    $ cabal new-run target -- -a -bcd --argument
+
 cabal new-freeze
 ----------------
 
@@ -382,10 +408,6 @@ The following commands are not currently supported:
     Workaround: run the benchmark executable directly (see `Where are my
     build products <#where-are-my-build-products>`__?)
 
-``cabal new-run`` (:issue:`3638`)
-    Workaround: run the executable directly (see `Where are my build
-    products <#where-are-my-build-products>`__?)
-
 ``cabal new-exec``
     Workaround: if you wanted to execute GHCi, consider using
     ``cabal new-repl`` instead. Otherwise, use ``-v`` to find the list

cabal-install/Distribution/Client/CmdRun.hs

@@ -13,6 +13,9 @@ module Distribution.Client.CmdRun (
     selectComponentTarget
   ) where
 
+import Prelude ()
+import Distribution.Client.Compat.Prelude
+
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.CmdErrorMessages
 
@@ -30,11 +33,34 @@ import Distribution.Text
 import Distribution.Verbosity
          ( Verbosity, normal )
 import Distribution.Simple.Utils
-         ( wrapText, die', ordNub )
+         ( wrapText, die', ordNub, info )
+import Distribution.Types.PackageName
+         ( unPackageName )
+import Distribution.Client.ProjectPlanning
+         ( ElaboratedConfiguredPackage(..)
+         , ElaboratedInstallPlan, binDirectoryFor )
+import Distribution.Client.InstallPlan
+         ( toList, foldPlanPackage )
+import Distribution.Client.ProjectPlanning.Types
+         ( ElaboratedPackageOrComponent(..)
+         , ElaboratedComponent(compComponentName) )
+import Distribution.Types.Executable
+         ( Executable(exeName) )
+import Distribution.Types.UnqualComponentName
+         ( UnqualComponentName, unUnqualComponentName )
+import Distribution.Types.PackageDescription
+         ( PackageDescription(executables) )
+import Distribution.Simple.Program.Run
+         ( runProgramInvocation, simpleProgramInvocation )
+import Distribution.Types.PackageId
+         ( PackageIdentifier(..) )
 
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import Control.Monad (when)
+import Data.Function
+         ( on )
+import System.FilePath
+         ( (</>) )
 
 
 runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
@@ -90,7 +116,8 @@ runAction (configFlags, configExFlags, installFlags, haddockFlags)
     baseCtx <- establishProjectBaseContext verbosity cliConfig
 
     targetSelectors <- either (reportTargetSelectorProblems verbosity) return
-                   =<< readTargetSelectors (localPackages baseCtx) targetStrings
+                   =<< readTargetSelectors (localPackages baseCtx)
+                         (take 1 targetStrings) -- Drop the exe's args.
 
     buildCtx <-
       runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
@@ -128,12 +155,181 @@ runAction (configFlags, configExFlags, installFlags, haddockFlags)
 
     buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
     runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
+
+    -- Get the selectors for the package and component.
+    -- These are wrapped in Maybes, because the user
+    -- might not specify them.
+    (selectedPackage, selectedComponent) <-
+       -- This should always match [x] anyway because
+       -- we already check for a single target in TargetSelector.hs
+       case selectorPackageAndComponent <$> targetSelectors
+         of [x] -> return x
+            [ ] -> die'
+                     verbosity
+                     "No targets given, but the run phase has been reached. This is a bug."
+            _   -> die'
+                     verbosity
+                     "Multiple targets given, but the run phase has been reached. This is a bug."
+
+    let elaboratedPlan = elaboratedPlanOriginal buildCtx
+        matchingElaboratedConfiguredPackages =
+          extractMatchingElaboratedConfiguredPackages
+            selectedPackage
+            selectedComponent
+            elaboratedPlan
+
+    -- The names to match. Used only for user feedback, as
+    -- later on we extract the real ones (whereas these are
+    -- wrapped in a Maybe) from the package itself.
+    let selectedPackageNameToMatch = getPackageName <$> selectedPackage
+        selectedComponentNameToMatch = getExeComponentName =<< selectedComponent
+
+    -- For each ElaboratedConfiguredPackage in the install plan, we
+    -- identify candidate executables. We only keep them if both the
+    -- package name and executable name match what the user asked for
+    -- (a missing specification matches everything).
+    --
+    -- In the common case, we expect this to pick out a single
+    -- ElaboratedConfiguredPackage that provides a single way of building
+    -- an appropriately-named executable. In that case we prune our
+    -- install plan to that UnitId and PackageTarget and continue.
+    --
+    -- However, multiple packages/components could provide that
+    -- executable, or it's possible we don't find the executable anywhere
+    -- in the build plan. I suppose in principle it's also possible that
+    -- a single package provides an executable in two different ways,
+    -- though that's probably a bug if. Anyway it's a good lint to report
+    -- an error in all of these cases, even if some seem like they
+    -- shouldn't happen.
+    (pkg,exe) <- case matchingElaboratedConfiguredPackages of
+      [] -> die' verbosity $ "Unknown executable"
+                          ++ case selectedComponentNameToMatch
+                             of Just x -> " " ++ x
+                                Nothing -> ""
+                          ++ case selectedPackageNameToMatch
+                             of Just x -> " in package " ++ x
+                                Nothing -> ""
+      [(elabPkg,exe)] -> do
+        info verbosity $ "Selecting " ++ display (elabUnitId elabPkg)
+                      ++ case selectedComponentNameToMatch
+                         of Just x -> " to supply " ++ x
+                            Nothing -> ""
+        return (elabPkg, unUnqualComponentName exe)
+      elabPkgs -> die' verbosity
+        $ "Multiple matching executables found"
+        ++ case selectedComponentNameToMatch
+           of Just x -> " matching " ++ x
+              Nothing -> ""
+        ++ ":\n"
+        ++ unlines (fmap (\(p,_) -> " - in package " ++ display (elabUnitId p)) elabPkgs)
+    let exePath = binDirectoryFor (distDirLayout baseCtx)
+                                  (elaboratedShared buildCtx)
+                                  pkg
+                                  exe
+               </> exe
+    let args = drop 1 targetStrings
+    runProgramInvocation
+      verbosity
+      (simpleProgramInvocation exePath args)
   where
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
     cliConfig = commandLineFlagsToProjectConfig
                   globalFlags configFlags configExFlags
                   installFlags haddockFlags
 
+-- Package selection
+------
+
+getPackageName :: PackageIdentifier -> String
+getPackageName (PackageIdentifier packageName _) =
+  unPackageName packageName
+
+getExeComponentName :: ComponentName -> Maybe String
+getExeComponentName (CExeName unqualComponentName) =
+  Just $ unUnqualComponentName unqualComponentName
+getExeComponentName _ = Nothing
+
+selectorPackageAndComponent :: TargetSelector PackageId
+                          -> (Maybe PackageId, Maybe ComponentName)
+selectorPackageAndComponent (TargetPackage _ pkg _) =
+  (Just pkg, Nothing)
+selectorPackageAndComponent (TargetAllPackages _) =
+  (Nothing, Nothing)
+selectorPackageAndComponent (TargetComponent pkg component _) =
+  (Just pkg, Just component)
+
+-- | Extract all 'ElaboratedConfiguredPackage's and executable names
+--  that match the user-provided component/package
+-- The component can be either:
+--  * specified by the user (both Just)
+--  * deduced from an user-specified package (the component is unspecified, Nothing)
+--  * deduced from the cwd (both the package and the component are unspecified)
+extractMatchingElaboratedConfiguredPackages
+  :: Maybe PackageId -- ^ the package to match
+  -> Maybe ComponentName -- ^ the component to match
+  -> ElaboratedInstallPlan -- ^ a plan in with to search for matching exes
+  -> [(ElaboratedConfiguredPackage, UnqualComponentName)] -- ^ the matching package and the exe name
+extractMatchingElaboratedConfiguredPackages
+  pkgId component = nubBy equalPackageIdAndExe
+                  . catMaybes
+                  . fmap sequenceA' -- get the Maybe outside the tuple
+                  . fmap (\p -> (p, matchingExecutable p))
+                  . catMaybes
+                  . fmap (foldPlanPackage
+                           (const Nothing)
+                           (\x -> if match x
+                                  then Just x
+                                  else Nothing))
+                  . toList
+  where
+    -- We need to support ghc 7.6, so we don't have
+    -- a sequenceA that works on tuples yet.
+    -- Once we drop support for pre-ftp ghc
+    -- it's safe to remove this.
+    sequenceA' (a, Just b) = Just (a, b)
+    sequenceA' _ = Nothing
+    match :: ElaboratedConfiguredPackage -> Bool
+    match p = matchPackage pkgId p && matchComponent component p
+    matchingExecutable p = exactlyOne
+                         $ filter (\x -> Just x == componentString
+                                      || isNothing componentString)
+                         $ executablesOfPackage p
+    componentString = componentNameString =<< component
+    exactlyOne [x] = Just x
+    exactlyOne _ = Nothing
+    equalPackageIdAndExe (p,c) (p',c') = c==c' && ((==) `on` elabPkgSourceId) p p'
+
+matchPackage :: Maybe PackageId
+             -> ElaboratedConfiguredPackage
+             -> Bool
+matchPackage pkgId pkg =
+  pkgId == Just (elabPkgSourceId pkg)
+  || isNothing pkgId --if the package is unspecified (Nothing), all packages match
+
+matchComponent :: Maybe ComponentName
+               -> ElaboratedConfiguredPackage
+               -> Bool
+matchComponent component pkg =
+  componentString `elem` (Just <$> executablesOfPackage pkg)
+  || isNothing componentString --if the component is unspecified (Nothing), all components match
+  where componentString = componentNameString =<< component
+
+executablesOfPackage :: ElaboratedConfiguredPackage
+                     -> [UnqualComponentName]
+executablesOfPackage p =
+  case exeFromComponent
+  of Just exe -> [exe]
+     Nothing -> exesFromPackage
+  where
+    exeFromComponent =
+      case elabPkgOrComp p
+      of ElabComponent comp -> case compComponentName comp
+                               of Just (CExeName exe) -> Just exe
+                                  _                   -> Nothing
+         _ -> Nothing
+    exesFromPackage = fmap exeName $ executables $ elabPkgDescription p
+
+
 -- | This defines what a 'TargetSelector' means for the @run@ command.
 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
 -- or otherwise classifies the problem.

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -56,6 +56,9 @@ module Distribution.Client.ProjectPlanning (
     setupHsHaddockFlags,
 
     packageHashInputs,
+
+    -- * Path construction
+    binDirectoryFor,
   ) where
 
 import Prelude ()
@@ -1129,7 +1132,7 @@ elaborateInstallPlan
   -> Map PackageName PackageConfig
   -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig)
 elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
-                     DistDirLayout{..}
+                     distDirLayout@DistDirLayout{..}
                      storeDirLayout@StoreDirLayout{storePackageDBStack}
                      solverPlan localPackages
                      sourcePackageHashes
@@ -1434,21 +1437,15 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
                   (compilerId compiler)
                   cid
 
-            -- NB: For inplace NOT InstallPaths.bindir installDirs; for an
-            -- inplace build those values are utter nonsense.  So we
-            -- have to guess where the directory is going to be.
-            -- Fortunately this is "stable" part of Cabal API.
-            -- But the way we get the build directory is A HORRIBLE
-            -- HACK.
-            inplace_bin_dir elab
-              | shouldBuildInplaceOnly spkg
-              = distBuildDirectory
-                    (elabDistDirParams elaboratedSharedConfig elab) </>
-                    "build" </> case Cabal.componentNameString cname of
-                                    Just n -> display n
-                                    Nothing -> ""
-              | otherwise
-              = InstallDirs.bindir (elabInstallDirs elab)
+            inplace_bin_dir elab =
+                binDirectoryFor
+                    distDirLayout
+                    elaboratedSharedConfig
+                    elab $
+                    case Cabal.componentNameString cname of
+                             Just n -> display n
+                             Nothing -> ""
+
 
     -- | Given a 'SolverId' referencing a dependency on a library, return
     -- the 'ElaboratedPlanPackage' corresponding to the library.  This
@@ -1463,20 +1460,18 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
     planPackageExePath =
         -- Pre-existing executables are assumed to be in PATH
         -- already.  In fact, this should be impossible.
-        -- Modest duplication with 'inplace_bin_dir'
         InstallPlan.foldPlanPackage (const Nothing) $ \elab -> Just $
-            if elabBuildStyle elab == BuildInplaceOnly
-              then distBuildDirectory
-                    (elabDistDirParams elaboratedSharedConfig elab) </>
-                    "build" </>
-                        case elabPkgOrComp elab of
-                            ElabPackage _ -> ""
-                            ElabComponent comp ->
-                                case fmap Cabal.componentNameString
-                                          (compComponentName comp) of
-                                    Just (Just n) -> display n
-                                    _ -> ""
-              else InstallDirs.bindir (elabInstallDirs elab)
+            binDirectoryFor
+                distDirLayout
+                elaboratedSharedConfig
+                elab $
+                    case elabPkgOrComp elab of
+                        ElabPackage _ -> ""
+                        ElabComponent comp ->
+                            case fmap Cabal.componentNameString
+                                      (compComponentName comp) of
+                                Just (Just n) -> display n
+                                _ -> ""
 
     elaborateSolverToPackage :: (SolverId -> [ElaboratedPlanPackage])
                              -> SolverPackage UnresolvedPkgLoc
@@ -3370,3 +3365,39 @@ improveInstallPlanWithInstalledPackages installedPkgIdSet =
 
     --TODO: decide what to do if we encounter broken installed packages,
     -- since overwriting is never safe.
+
+
+-- Path construction
+------
+
+-- | The path to the directory that contains a specific executable.
+-- NB: For inplace NOT InstallPaths.bindir installDirs; for an
+-- inplace build those values are utter nonsense.  So we
+-- have to guess where the directory is going to be.
+-- Fortunately this is "stable" part of Cabal API.
+-- But the way we get the build directory is A HORRIBLE
+-- HACK.
+binDirectoryFor
+  :: DistDirLayout
+  -> ElaboratedSharedConfig
+  -> ElaboratedConfiguredPackage
+  -> FilePath
+  -> FilePath
+binDirectoryFor layout config package exe = case elabBuildStyle package of
+  BuildAndInstall -> installedBinDirectory package
+  BuildInplaceOnly -> inplaceBinRoot layout config package </> exe
+
+-- package has been built and installed.
+installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath
+installedBinDirectory = InstallDirs.bindir . elabInstallDirs
+
+-- | The path to the @build@ directory for an inplace build.
+inplaceBinRoot
+  :: DistDirLayout
+  -> ElaboratedSharedConfig
+  -> ElaboratedConfiguredPackage
+  -> FilePath
+inplaceBinRoot layout config package
+  =  distBuildDirectory layout (elabDistDirParams config package)
+ </> "build"
+

cabal-install/changelog

@@ -5,6 +5,9 @@
 	roll back the index to an earlier state.
 	* 'cabal new-configure' now backs up the old 'cabal.project.local'
 	file if it exists (#4460).
+	* Completed the 'new-run' command (#4477). The functionality is the
+	same of the old 'run' command but using nix-style builds.
+	Additionally, it can run executables across packages in a project.
 	* '--allow-{newer,older}' syntax has been enhanced. Dependency
 	relaxation can be now limited to a specific release of a package,
 	plus there's a now syntax for relaxing only caret dependencies

cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/ExitCodePropagation.cabal

+name: ExitCodePropagation
+version: 1.0
+build-type: Simple
+cabal-version: >= 1.10
+
+executable foo
+    main-is: Main.hs
+    build-depends: base
+    default-language: Haskell2010

cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/Main.hs

+import System.Exit (exitWith, ExitCode(ExitFailure))
+
+main = exitWith $ ExitFailure 42
+

cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.out

+# cabal new-run
+Resolving dependencies...
+In order, the following will be built:
+ - ExitCodePropagation-1.0 (exe:foo) (first run)
+Configuring executable 'foo' for ExitCodePropagation-1.0..
+Preprocessing executable 'foo' for ExitCodePropagation-1.0..
+Building executable 'foo' for ExitCodePropagation-1.0..

cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.project

+packages: .

cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.test.hs

+import Test.Cabal.Prelude
+import Control.Monad ( (>=>) )
+import System.Exit (ExitCode(ExitFailure))
+main = cabalTest $
+    fails (cabal' "new-run" ["foo"]) >>= assertExitCode (ExitFailure 42)
+

cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/Bar.hs

+main = putStrLn "Hello Bar"

cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/Foo.hs

+main = putStrLn "Hello Foo"

cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/MultipleExes.cabal

+name: MultipleExes
+version: 1.0
+build-type: Simple
+cabal-version: >= 1.10
+
+executable foo
+    main-is: Foo.hs
+    build-depends: base
+    default-language: Haskell2010
+
+executable bar
+    main-is: Bar.hs
+    build-depends: base
+    default-language: Haskell2010
+

cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.out

+# cabal new-run
+Resolving dependencies...
+In order, the following will be built:
+ - MultipleExes-1.0 (exe:foo) (first run)
+Configuring executable 'foo' for MultipleExes-1.0..
+Preprocessing executable 'foo' for MultipleExes-1.0..
+Building executable 'foo' for MultipleExes-1.0..
+# cabal new-run
+In order, the following will be built:
+ - MultipleExes-1.0 (exe:bar) (first run)
+Configuring executable 'bar' for MultipleExes-1.0..
+Preprocessing executable 'bar' for MultipleExes-1.0..
+Building executable 'bar' for MultipleExes-1.0..
+# cabal new-run
+Up to date
+# cabal new-run
+cabal: The run command is for running a single executable at once. The target '' refers to the package MultipleExes-1.0 which includes the executables foo and bar.
+# cabal new-run
+cabal: The run command is for running a single executable at once. The target 'MultipleExes' refers to the package MultipleExes-1.0 which includes the executables foo and bar.

cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.project

+packages: .

cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.test.hs

+import Test.Cabal.Prelude
+
+main = cabalTest $ do
+    -- some ways of explicitly specifying an exe
+    cabal' "new-run" ["foo"] >>= assertOutputContains "Hello Foo"
+    cabal' "new-run" ["exe:bar"] >>= assertOutputContains "Hello Bar"
+    cabal' "new-run" ["MultipleExes:foo"] >>= assertOutputContains "Hello Foo"
+    -- there are multiple exes in ...
+    fails (cabal' "new-run" []) >>= assertOutputDoesNotContain "Hello" -- in the same project
+    fails (cabal' "new-run" ["MultipleExes"]) >>= assertOutputDoesNotContain "Hello" -- in the same package
+

cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/bar/Main1.hs

+main = putStrLn "Hello bar:foo-exe"

cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/bar/Main2.hs

+main = putStrLn "Hello bar:bar-exe"

cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/bar/bar.cabal

+name: bar
+version: 1.0
+build-type: Simple
+cabal-version: >= 1.10
+
+executable foo-exe
+    main-is: Main1.hs
+    build-depends: base
+    default-language: Haskell2010
+
+executable bar-exe
+    main-is: Main2.hs
+    build-depends: base
+    default-language: Haskell2010

cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.out

+# cabal new-run
+Resolving dependencies...
+In order, the following will be built:
+ - bar-1.0 (exe:bar-exe) (first run)
+Configuring executable 'bar-exe' for bar-1.0..
+Preprocessing executable 'bar-exe' for bar-1.0..
+Building executable 'bar-exe' for bar-1.0..
+# cabal new-run
+Up to date
+# cabal new-run
+In order, the following will be built:
+ - foo-1.0 (exe:foo-exe) (first run)
+Configuring executable 'foo-exe' for foo-1.0..
+Preprocessing executable 'foo-exe' for foo-1.0..
+Building executable 'foo-exe' for foo-1.0..
+# cabal new-run
+In order, the following will be built:
+ - bar-1.0 (exe:foo-exe) (first run)
+Configuring executable 'foo-exe' for bar-1.0..
+Preprocessing executable 'foo-exe' for bar-1.0..
+Building executable 'foo-exe' for bar-1.0..
+# cabal new-run
+cabal: No targets given and there is no package in the current directory. Use the target 'all' for all packages in the project or specify packages or components by name or location. See 'cabal build --help' for more details on target options.
+# cabal new-run
+cabal: The run command is for running a single executable at once. The target 'bar' refers to the package bar-1.0 which includes the executables foo-exe and bar-exe.
+# cabal new-run
+cabal: Ambiguous target 'foo-exe'. It could be:
+    bar:foo-exe (component)
+   foo:foo-exe (component)
+
+# cabal new-run
+cabal: Unknown target 'foo:bar-exe'.
+The package foo has no component 'bar-exe'.
+

cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.project

+packages:
+  foo
+  bar
+