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.

Author: fgaz

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.