new-run

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,39 @@ 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 )
+import Distribution.Client.InstallPlan
+         ( toList, foldPlanPackage )
+import Distribution.Client.ProjectPlanning.Types
+         ( ElaboratedPackageOrComponent(..)
+         , ElaboratedComponent(compComponentName)
+         , BuildStyle(BuildInplaceOnly, BuildAndInstall)
+         , ElaboratedSharedConfig, elabDistDirParams )
+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 Distribution.Client.DistDirLayout
+         ( DistDirLayout, distBuildDirectory )
+import qualified Distribution.Simple.InstallDirs as InstallDirs
 
 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 +121,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) -- we drop the exe's args
 
     buildCtx <-
       runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
@@ -128,12 +160,209 @@ runAction (configFlags, configExFlags, installFlags, haddockFlags)
 
     buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
     runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
+
+    -- We 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"
+            _   -> die'
+                     verbosity
+                     "Multiple targets given"
+
+    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 = atMostOne
+                         $ filter (\x -> Just x == componentString
+                                      || isNothing componentString)
+                         $ executablesOfPackage p
+    componentString = componentNameString =<< component
+    atMostOne [x] = Just x
+    atMostOne _ = 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
+
+-- Path construction
+------
+
+-- | 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"
+
+-- | The path to the directory that contains a specific executable.
+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
+
+
 -- | 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-testsuite/PackageTests/NewBuild/T4477/cabal.out

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

cabal-testsuite/PackageTests/NewBuild/T4477/cabal.test.hs

@@ -1,4 +1,3 @@
 import Test.Cabal.Prelude
 main = cabalTest $ do
-    expectBroken 4477 $ do
-        cabal' "new-run" ["foo"] >>= assertOutputContains "Hello World"
+    cabal' "new-run" ["foo"] >>= assertOutputContains "Hello World"