Commit f551e919 authored by refold's avatar refold

Implement the 'run' command.

See the discussion in #1088.
parent 5f51b62c
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Run
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Implementation of the 'run' command.
-----------------------------------------------------------------------------
module Distribution.Client.Run ( run )
where
import Distribution.Client.Setup (BuildFlags (..))
import Distribution.Client.SetupWrapper (SetupScriptOptions (..),
defaultSetupScriptOptions)
import Distribution.PackageDescription (Executable (..),
PackageDescription (..))
import Distribution.Simple.Build.PathsModule (pkgPathEnvVar)
import Distribution.Simple.BuildPaths (exeExtension)
import Distribution.Simple.Configure (getPersistBuildConfig)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))
import Distribution.Simple.Setup (fromFlagOrDefault)
import Distribution.Simple.Utils (die, rawSystemExitWithEnv)
import Distribution.Verbosity (Verbosity)
import Data.Functor ((<$>))
import Data.List (find)
import System.Directory (canonicalizePath,
getCurrentDirectory)
import System.Environment (getEnvironment)
import System.FilePath ((<.>), (</>))
run :: Verbosity -> BuildFlags -> [String] -> IO ()
run verbosity buildFlags args = do
let distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
(buildDistPref buildFlags)
-- The package must have been configured by now.
lbi <- getPersistBuildConfig distPref
curDir <- getCurrentDirectory
let buildPref = buildDir lbi
pkg_descr = localPkgDescr lbi
exes = executables pkg_descr
dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir",
curDir </> dataDir pkg_descr)
exePath :: Executable -> FilePath
exePath exe = buildPref </> exeName exe </> (exeName exe <.> exeExtension)
doRun :: Executable -> [String] -> IO ()
doRun exe exeArgs = do
path <- canonicalizePath $ exePath exe
env <- (dataDirEnvVar:) <$> getEnvironment
rawSystemExitWithEnv verbosity path exeArgs env
case exes of
[] -> die "Couldn't find any executables."
[exe] -> case args of
[] -> doRun exe []
(x:xs) | x == exeName exe -> doRun exe xs
| otherwise -> doRun exe args
_ -> case args of
[] -> die $ "This package contains multiple executables. "
++ "You must pass the executable name as the first argument "
++ "to run."
(x:xs) -> case find (\exe -> exeName exe == x) exes of
Nothing -> die $ "No executable named '" ++ x ++ "'."
Just exe -> doRun exe xs
......@@ -25,6 +25,7 @@ module Distribution.Client.Setup
, checkCommand
, uploadCommand, UploadFlags(..)
, reportCommand, ReportFlags(..)
, runCommand
, unpackCommand, UnpackFlags(..)
, initCommand, IT.InitFlags(..)
, sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
......@@ -430,6 +431,21 @@ checkCommand = CommandUI {
commandOptions = \_ -> []
}
runCommand :: CommandUI BuildFlags
runCommand = CommandUI {
commandName = "run",
commandSynopsis = "Runs the compiled executable.",
commandDescription = Nothing,
commandUsage =
(\pname -> "Usage: " ++ pname
++ " run [FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]\n\n"
++ "Flags for run:"),
commandDefaultFlags = mempty,
commandOptions = Cabal.buildOptions progConf
}
where
progConf = defaultProgramConfiguration
-- ------------------------------------------------------------
-- * Report flags
-- ------------------------------------------------------------
......
......@@ -27,6 +27,7 @@ import Distribution.Client.Setup
, InfoFlags(..), infoCommand
, UploadFlags(..), uploadCommand
, ReportFlags(..), reportCommand
, runCommand
, InitFlags(initVerbosity), initCommand
, SDistFlags(..), SDistExFlags(..), sdistCommand
, Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand
......@@ -62,6 +63,7 @@ import Distribution.Client.Fetch (fetch)
import Distribution.Client.Check as Check (check)
--import Distribution.Client.Clean (clean)
import Distribution.Client.Upload as Upload (upload, check, report)
import Distribution.Client.Run (run)
import Distribution.Client.SrcDist (sdist)
import Distribution.Client.Unpack (unpack)
import Distribution.Client.Index (index)
......@@ -150,6 +152,7 @@ mainWorker args = topHandler $
,sdistCommand `commandAddAction` sdistAction
,uploadCommand `commandAddAction` uploadAction
,reportCommand `commandAddAction` reportAction
,runCommand `commandAddAction` runAction
,initCommand `commandAddAction` initAction
,configureExCommand `commandAddAction` configureAction
,buildCommand `commandAddAction` buildAction
......@@ -555,6 +558,17 @@ reportAction reportFlags extraArgs globalFlags = do
(flagToMaybe $ reportUsername reportFlags')
(flagToMaybe $ reportPassword reportFlags')
runAction :: BuildFlags -> [String] -> GlobalFlags -> IO ()
runAction buildFlags extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
(buildDistPref buildFlags)
reconfigure verbosity distPref mempty [] globalFlags (const Nothing)
build verbosity distPref mempty []
run verbosity buildFlags extraArgs
unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()
unpackAction unpackFlags extraArgs globalFlags = do
let verbosity = fromFlag (unpackVerbosity unpackFlags)
......
......@@ -93,6 +93,7 @@ Executable cabal
Distribution.Client.PackageIndex
Distribution.Client.PackageUtils
Distribution.Client.ParseUtils
Distribution.Client.Run
Distribution.Client.Sandbox
Distribution.Client.Setup
Distribution.Client.SetupWrapper
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment