Commit 87a9dfaa authored by Mikhail Glushenkov's avatar Mikhail Glushenkov Committed by GitHub
Browse files

Merge pull request #4722 from fgaz/new-exec/1

new-exec
parents 37300936 28c9fd81
......@@ -520,13 +520,15 @@ simpleGhcEnvironmentFile packageDBs pkgids =
--
-- The 'Platform' and GHC 'Version' are needed as part of the file name.
--
-- Returns the name of the file written.
writeGhcEnvironmentFile :: FilePath -- ^ directory in which to put it
-> Platform -- ^ the GHC target platform
-> Version -- ^ the GHC version
-> [GhcEnvironmentFileEntry] -- ^ the content
-> NoCallStackIO ()
writeGhcEnvironmentFile directory platform ghcversion =
writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile
-> NoCallStackIO FilePath
writeGhcEnvironmentFile directory platform ghcversion entries = do
writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries
return envfile
where
envfile = directory </> ghcEnvironmentFileName platform ghcversion
......
......@@ -14,6 +14,8 @@ module Distribution.Simple.Program.GHC (
runGHC,
packageDbArgsDb,
) where
import Prelude ()
......
......@@ -421,16 +421,18 @@ cabal new-haddock
``cabal new-haddock [FLAGS] TARGET`` builds Haddock documentation for
the specified packages within the project.
cabal new-exec
---------------
``cabal new-exec [FLAGS] [--] COMMAND [--] [ARGS]`` runs the specified command
using the project's environment. That is, passing the right flags to compiler
invocations and bringing the project's executables into scope.
Unsupported commands
--------------------
The following commands are not currently supported:
``cabal new-exec`` (:issue:`4722`)
Workaround: if you wanted to execute GHCi, consider using
``cabal new-repl`` instead. Otherwise, use ``-v`` to find the list
of flags GHC is being invoked with and pass it manually.
``cabal new-install`` (:issue:`3737` and :issue:`3332`)
Workaround: no good workaround at the moment. (But note that you no
longer need to install libraries before building!)
......
-------------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Exec
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Implementation of the 'new-exec' command for running an arbitrary executable
-- in an environment suited to the part of the store built for a project.
-------------------------------------------------------------------------------
{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.CmdExec
( execAction
, execCommand
) where
import Distribution.Client.DistDirLayout
( DistDirLayout(..)
)
import Distribution.Client.InstallPlan
( GenericPlanPackage(..)
, toGraph
)
import Distribution.Client.Setup
( ConfigExFlags
, ConfigFlags(configVerbosity)
, GlobalFlags
, InstallFlags
)
import Distribution.Client.ProjectOrchestration
( ProjectBuildContext(..)
, runProjectPreBuildPhase
, establishProjectBaseContext
, distDirLayout
, commandLineFlagsToProjectConfig
, ProjectBaseContext(..)
)
import Distribution.Client.ProjectPlanOutput
( updatePostBuildProjectStatus
, createPackageEnvironment
, argsEquivalentOfGhcEnvironmentFile
, PostBuildProjectStatus
)
import qualified Distribution.Client.ProjectPlanning as Planning
import Distribution.Client.ProjectPlanning
( ElaboratedInstallPlan
, ElaboratedSharedConfig(..)
)
import Distribution.Simple.Command
( CommandUI(..)
)
import Distribution.Simple.Program.Db
( modifyProgramSearchPath
, requireProgram
, configuredPrograms
)
import Distribution.Simple.Program.Find
( ProgramSearchPathEntry(..)
)
import Distribution.Simple.Program.Run
( programInvocation
, runProgramInvocation
)
import Distribution.Simple.Program.Types
( programOverrideEnv
, programDefaultArgs
, programPath
, simpleProgram
, ConfiguredProgram
)
import Distribution.Simple.GHC
( getImplInfo
, GhcImplInfo(supportsPkgEnvFiles) )
import Distribution.Simple.Setup
( HaddockFlags
, fromFlagOrDefault
)
import Distribution.Simple.Utils
( die'
, info
, withTempDirectory
, wrapText
)
import Distribution.Verbosity
( Verbosity
, normal
)
import qualified Distribution.Client.CmdBuild as CmdBuild
import Prelude ()
import Distribution.Client.Compat.Prelude
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Map as M
execCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
execCommand = CommandUI
{ commandName = "new-exec"
, commandSynopsis = "Give a command access to the store."
, commandUsage = \pname ->
"Usage: " ++ pname ++ " new-exec [FLAGS] [--] COMMAND [--] [ARGS]\n"
, commandDescription = Just $ \pname -> wrapText $
"During development it is often useful to run build tasks and perform"
++ " one-off program executions to experiment with the behavior of build"
++ " tools. It is convenient to run these tools in the same way " ++ pname
++ " itself would. The `" ++ pname ++ " new-exec` command provides a way to"
++ " do so.\n"
++ "\n"
++ "Compiler tools will be configured to see the same subset of the store"
++ " that builds would see. The PATH is modified to make all executables in"
++ " the dependency tree available (provided they have been built already)."
++ " Commands are also rewritten in the way cabal itself would. For"
++ " example, `" ++ pname ++ " new-exec ghc` will consult the configuration"
++ " to choose an appropriate version of ghc and to include any"
++ " ghc-specific flags requested."
, commandNotes = Nothing
, commandOptions = commandOptions CmdBuild.buildCommand
, commandDefaultFlags = commandDefaultFlags CmdBuild.buildCommand
}
execAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
-> [String] -> GlobalFlags -> IO ()
execAction (configFlags, configExFlags, installFlags, haddockFlags)
extraArgs globalFlags = do
baseCtx <- establishProjectBaseContext verbosity cliConfig
-- To set up the environment, we'd like to select the libraries in our
-- dependency tree that we've already built. So first we set up an install
-- plan, but we walk the dependency tree without first executing the plan.
buildCtx <- runProjectPreBuildPhase
verbosity
baseCtx
(\plan -> return (plan, M.empty))
-- We use the build status below to decide what libraries to include in the
-- compiler environment, but we don't want to actually build anything. So we
-- pass mempty to indicate that nothing happened and we just want the current
-- status.
buildStatus <- updatePostBuildProjectStatus
verbosity
(distDirLayout baseCtx)
(elaboratedPlanOriginal buildCtx)
(pkgsBuildStatus buildCtx)
mempty
-- Some dependencies may have executables. Let's put those on the PATH.
extraPaths <- pathAdditions verbosity baseCtx buildCtx
let programDb = modifyProgramSearchPath
(map ProgramSearchPathDir extraPaths ++)
. pkgConfigCompilerProgs
. elaboratedShared
$ buildCtx
-- Now that we have the packages, set up the environment. We accomplish this
-- by creating an environment file that selects the databases and packages we
-- computed in the previous step, and setting an environment variable to
-- point at the file.
-- In case ghc is too old to support environment files,
-- we pass the same info as arguments
let compiler = pkgConfigCompiler $ elaboratedShared buildCtx
envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler)
case extraArgs of
[] -> die' verbosity "Please specify an executable to run"
exe:args -> do
(program, _) <- requireProgram verbosity (simpleProgram exe) programDb
let argOverrides =
argsEquivalentOfGhcEnvironmentFile
compiler
(distDirLayout baseCtx)
(elaboratedPlanOriginal buildCtx)
buildStatus
programIsConfiguredCompiler = matchCompilerPath
(elaboratedShared buildCtx)
program
argOverrides' =
if envFilesSupported
|| not programIsConfiguredCompiler
then []
else argOverrides
(if envFilesSupported
then withTempEnvFile verbosity baseCtx buildCtx buildStatus
else \f -> f []) $ \envOverrides -> do
let program' = withOverrides
envOverrides
argOverrides'
program
invocation = programInvocation program' args
runProgramInvocation verbosity invocation
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags
installFlags haddockFlags
withOverrides env args program = program
{ programOverrideEnv = programOverrideEnv program ++ env
, programDefaultArgs = programDefaultArgs program ++ args}
matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool
matchCompilerPath elaboratedShared program =
programPath program
`elem`
(programPath <$> configuredCompilers)
where
configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared
-- | Execute an action with a temporary .ghc.environment file reflecting the
-- current environment. The action takes an environment containing the env
-- variable which points ghc to the file.
withTempEnvFile :: Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> PostBuildProjectStatus
-> ([(String, Maybe String)] -> IO a)
-> IO a
withTempEnvFile verbosity
baseCtx
buildCtx
buildStatus
action =
withTempDirectory
verbosity
(distTempDirectory (distDirLayout baseCtx))
"environment."
(\tmpDir -> do
envOverrides <- createPackageEnvironment
verbosity
tmpDir
(elaboratedPlanToExecute buildCtx)
(elaboratedShared buildCtx)
buildStatus
action envOverrides)
pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath]
pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do
info verbosity . unlines $ "Including the following directories in PATH:"
: paths
return paths
where
paths = S.toList
$ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute
binDirectories
:: DistDirLayout
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> Set FilePath
binDirectories layout config = fromElaboratedInstallPlan where
fromElaboratedInstallPlan = fromGraph . toGraph
fromGraph = foldMap fromPlan
fromSrcPkg = S.fromList . Planning.binDirectories layout config
fromPlan (PreExisting _) = mempty
fromPlan (Configured pkg) = fromSrcPkg pkg
fromPlan (Installed pkg) = fromSrcPkg pkg
......@@ -140,6 +140,7 @@ import Data.Map (Map)
import Data.List
import Data.Maybe
import Data.Either
import Control.Monad (void)
import Control.Exception (Exception(..), throwIO, assert)
import System.Exit (ExitCode(..), exitFailure)
#ifdef MIN_VERSION_unix
......@@ -349,10 +350,11 @@ runProjectPostBuildPhase verbosity
pkgsBuildStatus
buildOutcomes
writePlanGhcEnvironment distDirLayout
elaboratedPlanOriginal
elaboratedShared
postBuildStatus
void $ writePlanGhcEnvironment (distProjectRootDirectory
distDirLayout)
elaboratedPlanOriginal
elaboratedShared
postBuildStatus
-- Finally if there were any build failures then report them and throw
-- an exception to terminate the program
......
......@@ -10,7 +10,9 @@ module Distribution.Client.ProjectPlanOutput (
-- | Several outputs rely on having a general overview of
PostBuildProjectStatus(..),
updatePostBuildProjectStatus,
createPackageEnvironment,
writePlanGhcEnvironment,
argsEquivalentOfGhcEnvironmentFile,
) where
import Distribution.Client.ProjectPlanning.Types
......@@ -29,10 +31,11 @@ import Distribution.Package
import Distribution.System
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.PackageDescription as PD
import Distribution.Compiler (CompilerFlavor(GHC))
import Distribution.Compiler (CompilerFlavor(GHC, GHCJS))
import Distribution.Simple.Compiler
( PackageDBStack, PackageDB(..)
, compilerVersion, compilerFlavor, showCompilerId )
, compilerVersion, compilerFlavor, showCompilerId
, compilerId, CompilerId(..), Compiler )
import Distribution.Simple.GHC
( getImplInfo, GhcImplInfo(supportsPkgEnvFiles)
, GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile
......@@ -45,8 +48,9 @@ import Distribution.Simple.Utils
import Distribution.Verbosity
import qualified Paths_cabal_install as Our (version)
import Data.Maybe (maybeToList, fromMaybe)
import Data.Monoid
import Prelude ()
import Distribution.Client.Compat.Prelude
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
......@@ -56,6 +60,7 @@ import qualified Data.ByteString.Builder as BB
import System.FilePath
import System.IO
import Distribution.Simple.Program.GHC (packageDbArgsDb)
-----------------------------------------------------------------------------
-- Writing plan.json files
......@@ -655,15 +660,52 @@ writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate =
writeFileAtomic (distProjectCacheFile "up-to-date") $
Binary.encode upToDate
-- | Prepare a package environment that includes all the library dependencies
-- for a plan.
--
-- When running cabal new-exec, we want to set things up so that the compiler
-- can find all the right packages (and nothing else). This function is
-- intended to do that work. It takes a location where it can write files
-- temporarily, in case the compiler wants to learn this information via the
-- filesystem, and returns any environment variable overrides the compiler
-- needs.
createPackageEnvironment :: Verbosity
-> FilePath
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> PostBuildProjectStatus
-> IO [(String, Maybe String)]
createPackageEnvironment verbosity
path
elaboratedPlan
elaboratedShared
buildStatus
| compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC
= do
envFileM <- writePlanGhcEnvironment
path
elaboratedPlan
elaboratedShared
buildStatus
case envFileM of
Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)]
Nothing -> do
warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail"
return []
| otherwise
= do
warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail"
return []
-- Writing .ghc.environment files
--
writePlanGhcEnvironment :: DistDirLayout
writePlanGhcEnvironment :: FilePath
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> PostBuildProjectStatus
-> IO ()
writePlanGhcEnvironment DistDirLayout{distProjectRootDirectory}
-> IO (Maybe FilePath)
writePlanGhcEnvironment path
elaboratedInstallPlan
ElaboratedSharedConfig {
pkgConfigCompiler = compiler,
......@@ -673,24 +715,24 @@ writePlanGhcEnvironment DistDirLayout{distProjectRootDirectory}
| compilerFlavor compiler == GHC
, supportsPkgEnvFiles (getImplInfo compiler)
--TODO: check ghcjs compat
= writeGhcEnvironmentFile
distProjectRootDirectory
= fmap Just $ writeGhcEnvironmentFile
path
platform (compilerVersion compiler)
(renderGhcEnviromentFile distProjectRootDirectory
elaboratedInstallPlan
postBuildStatus)
(renderGhcEnvironmentFile path
elaboratedInstallPlan
postBuildStatus)
--TODO: [required eventually] support for writing user-wide package
-- environments, e.g. like a global project, but we would not put the
-- env file in the home dir, rather it lives under ~/.ghc/
writePlanGhcEnvironment _ _ _ _ = return ()
writePlanGhcEnvironment _ _ _ _ = return Nothing
renderGhcEnviromentFile :: FilePath
-> ElaboratedInstallPlan
-> PostBuildProjectStatus
-> [GhcEnvironmentFileEntry]
renderGhcEnviromentFile projectRootDir elaboratedInstallPlan
postBuildStatus =
renderGhcEnvironmentFile :: FilePath
-> ElaboratedInstallPlan
-> PostBuildProjectStatus
-> [GhcEnvironmentFileEntry]
renderGhcEnvironmentFile projectRootDir elaboratedInstallPlan
postBuildStatus =
headerComment
: simpleGhcEnvironmentFile packageDBs unitIds
where
......@@ -701,9 +743,44 @@ renderGhcEnviromentFile projectRootDir elaboratedInstallPlan
++ "But you still need to use cabal repl $target to get the environment\n"
++ "of specific components (libs, exes, tests etc) because each one can\n"
++ "have its own source dirs, cpp flags etc.\n\n"
unitIds = selectGhcEnviromentFileLibraries postBuildStatus
unitIds = selectGhcEnvironmentFileLibraries postBuildStatus
packageDBs = relativePackageDBPaths projectRootDir $
selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan
argsEquivalentOfGhcEnvironmentFile
:: Compiler
-> DistDirLayout
-> ElaboratedInstallPlan
-> PostBuildProjectStatus
-> [String]
argsEquivalentOfGhcEnvironmentFile compiler =
case compilerId compiler
of CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc
CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc
CompilerId _ _ -> error "Only GHC and GHCJS are supported"
-- TODO remove this when we drop support for non-.ghc.env ghc
argsEquivalentOfGhcEnvironmentFileGhc
:: DistDirLayout
-> ElaboratedInstallPlan
-> PostBuildProjectStatus
-> [String]
argsEquivalentOfGhcEnvironmentFileGhc
distDirLayout
elaboratedInstallPlan
postBuildStatus =
clearPackageDbStackFlag
++ packageDbArgsDb packageDBs
++ foldMap packageIdFlag packageIds
where
projectRootDir = distProjectRootDirectory distDirLayout
packageIds = selectGhcEnvironmentFileLibraries postBuildStatus
packageDBs = relativePackageDBPaths projectRootDir $
selectGhcEnviromentFilePackageDbs elaboratedInstallPlan
selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan
-- TODO use proper flags? but packageDbArgsDb is private
clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"]
packageIdFlag uid = ["-package-id", display uid]
-- We're producing an environment for users to use in ghci, so of course
......@@ -738,10 +815,10 @@ renderGhcEnviromentFile projectRootDir elaboratedInstallPlan
-- to find the libs) then those exes still end up in our list so we have
-- to filter them out at the end.
--
selectGhcEnviromentFileLibraries :: PostBuildProjectStatus -> [UnitId]
selectGhcEnviromentFileLibraries PostBuildProjectStatus{..} =
selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId]
selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} =
case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of
Nothing -> error "renderGhcEnviromentFile: broken dep closure"
Nothing -> error "renderGhcEnvironmentFile: broken dep closure"
Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes
, hasUpToDateLib pkg ]
where
......@@ -759,8 +836,8 @@ selectGhcEnviromentFileLibraries PostBuildProjectStatus{..} =
&& installedUnitId pkg `Set.member` packagesProbablyUpToDate
selectGhcEnviromentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack
selectGhcEnviromentFilePackageDbs elaboratedInstallPlan =
selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack
selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan =
-- If we have any inplace packages then their package db stack is the
-- one we should use since it'll include the store + the local db but
-- it's certainly possible to have no local inplace packages
......@@ -773,7 +850,7 @@ selectGhcEnviromentFilePackageDbs elaboratedInstallPlan =
case ordNub (map elabBuildPackageDBStack pkgs) of
[packageDbs] -> packageDbs
[] -> []
_ -> error $ "renderGhcEnviromentFile: packages with "
_ -> error $ "renderGhcEnvironmentFile: packages with "
++ "different package db stacks"
-- This should not happen at the moment but will happen as soon
-- as we support projects where we build packages with different
......
......@@ -61,6 +61,7 @@ module Distribution.Client.ProjectPlanning (
-- * Path construction
binDirectoryFor,
binDirectories
) where
import Prelude ()
......@@ -1928,6 +1929,35 @@ mkShapeMapping dpkg =
(Map.fromList [ (req, OpenModuleVar req)
| req <- Set.toList (modShapeRequires shape)])
-- | Get the bin\/ directories that a package's executables should reside in.
--
-- The result may be empty if the package does not build any executables.
--
-- The result may have several entries if this is an inplace build of a package
-- with multiple executables.
binDirectories
:: DistDirLayout
-> ElaboratedSharedConfig
-> ElaboratedConfiguredPackage
-> [FilePath]
binDirectories layout config package = case elabBuildStyle package of
-- quick sanity check: no sense returning a bin directory if we're not going
-- to put any executables in it, that will just clog up the PATH
_ | noExecutables -> []
BuildAndInstall -> [installedBinDirectory package]
BuildInplaceOnly -> map (root</>) $ case elabPkgOrComp package of
ElabComponent comp -> case compSolverName comp of
CD.ComponentExe n -> [display n]
_ -> []
ElabPackage _ -> map (display . PD.exeName)
. PD.executables
. elabPkgDescription
$ package
where
noExecutables = null . PD.executables . elabPkgDescription $ package
root = distBuildDirectory layout (elabDistDirParams config package)
</> "build"
-- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the
-- dependency graph considers only dependencies on libraries which are
-- NOT from setup dependencies. Used to compute the set
......
......@@ -45,7 +45,7 @@ module Distribution.Client.Setup
, win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
, actAsSetupCommand, ActAsSetupFlags(..)
, sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
, execCommand, ExecFlags(..)
, execCommand, ExecFlags(..), defaultExecFlags
, userConfigCommand, UserConfigFlags(..)
,