Commit b7f726ca authored by Francesco Gazzetta's avatar Francesco Gazzetta
Browse files

Merge branch 'master' of github.com:dmwit/cabal into new-exec/1

parents f7c2b18f 108ab93b
......@@ -526,13 +526,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
......
-------------------------------------------------------------------------------
-- |
-- 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
, installCommand
)
import Distribution.Client.ProjectOrchestration
( ProjectBuildContext(..)
, PreBuildHooks(..)
, runProjectPreBuildPhase
)
import Distribution.Client.ProjectPlanOutput
( updatePostBuildProjectStatus
, createPackageEnvironment
)
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
)
import Distribution.Simple.Program.Find
( ProgramSearchPathEntry(..)
)
import Distribution.Simple.Program.Run
( programInvocation
, runProgramInvocation
)
import Distribution.Simple.Program.Types
( programOverrideEnv
, simpleProgram
)
import Distribution.Simple.Setup
( HaddockFlags
, fromFlagOrDefault
)
import Distribution.Simple.Utils
( die
, info
, withTempDirectory
, wrapText
)
import Distribution.Verbosity
( Verbosity
, normal
)
import Prelude ()
import Distribution.Client.Compat.Prelude
import Data.Set (Set)
import qualified Data.Set as S
execCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
execCommand = installCommand
{ 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
}
execAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
-> [String] -> GlobalFlags -> IO ()
execAction (configFlags, configExFlags, installFlags, haddockFlags)
extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
-- 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
(globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
PreBuildHooks
{ hookPrePlanning = \_ _ _ -> return ()
, hookSelectPlanSubset = \_ -> return
}
-- 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 buildCtx)
(elaboratedPlanToExecute buildCtx)
(pkgsBuildStatus buildCtx)
mempty
-- 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.
withTempDirectory
verbosity
(distTempDirectory (distDirLayout buildCtx))
"environment."
$ \tmpDir -> do
envOverrides <- createPackageEnvironment
verbosity
tmpDir
(elaboratedPlanToExecute buildCtx)
(elaboratedShared buildCtx)
buildStatus
-- Some dependencies may have executables. Let's put those on the PATH.
extraPaths <- pathAdditions verbosity buildCtx
let programDb = modifyProgramSearchPath
(map ProgramSearchPathDir extraPaths ++)
. pkgConfigCompilerProgs
. elaboratedShared
$ buildCtx
case extraArgs of
exe:args -> do
(program, _) <- requireProgram verbosity (simpleProgram exe) programDb
let program' = withOverrides envOverrides program
invocation = programInvocation program' args
runProgramInvocation verbosity invocation
[] -> die "Please specify an executable to run"
where
withOverrides env program = program
{ programOverrideEnv = programOverrideEnv program ++ env }
pathAdditions :: Verbosity -> ProjectBuildContext -> IO [FilePath]
pathAdditions verbosity 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
......@@ -334,7 +334,7 @@ runProjectPostBuildPhase verbosity
-- - delete stale lib registrations
-- - delete stale package dirs
postBuildStatus <- updatePostBuildProjectStatus
_postBuildStatus <- updatePostBuildProjectStatus
verbosity
distDirLayout
elaboratedPlanOriginal
......
......@@ -10,6 +10,7 @@ module Distribution.Client.ProjectPlanOutput (
-- | Several outputs rely on having a general overview of
PostBuildProjectStatus(..),
updatePostBuildProjectStatus,
createPackageEnvironment,
writePlanGhcEnvironment,
) where
......@@ -655,6 +656,43 @@ 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
tmpDir
elaboratedPlan
elaboratedShared
buildStatus
| compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC
= do
envFileM <- writePlanGhcEnvironment
tmpDir
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
--
......@@ -662,7 +700,7 @@ writePlanGhcEnvironment :: DistDirLayout
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> PostBuildProjectStatus
-> IO ()
-> IO (Maybe FilePath)
writePlanGhcEnvironment DistDirLayout{distProjectRootDirectory}
elaboratedInstallPlan
ElaboratedSharedConfig {
......@@ -673,24 +711,24 @@ writePlanGhcEnvironment DistDirLayout{distProjectRootDirectory}
| compilerFlavor compiler == GHC
, supportsPkgEnvFiles (getImplInfo compiler)
--TODO: check ghcjs compat
= writeGhcEnvironmentFile
= fmap Just $ writeGhcEnvironmentFile
distProjectRootDirectory
platform (compilerVersion compiler)
(renderGhcEnviromentFile distProjectRootDirectory
elaboratedInstallPlan
postBuildStatus)
(renderGhcEnvironmentFile distProjectRootDirectory
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 +739,9 @@ 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 $
selectGhcEnviromentFilePackageDbs elaboratedInstallPlan
selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan
-- We're producing an environment for users to use in ghci, so of course
......@@ -738,10 +776,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 +797,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 +811,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,9 @@ module Distribution.Client.ProjectPlanning (
-- * Path construction
binDirectoryFor,
-- TODO: [code cleanup] utils that should live in some shared place?
createPackageDBIfMissing,
binDirectories
) where
import Prelude ()
......@@ -1922,6 +1925,79 @@ mkShapeMapping dpkg =
IndefFullUnitId dcid
(Map.fromList [ (req, OpenModuleVar req)
| req <- Set.toList (modShapeRequires shape)])
-- TODO: Delete this and binDirectory.
-- | Get the bin\/ directory that executables should reside in, assuming that
-- they are the result of an in-place build.
--
-- For packages that get built inplace, the executable named @foo@ goes in
-- @bin/foo/foo@, and this function will return just @bin@. The more general
-- 'inplaceBinDirectories' will return @bin/foo@ (and @bin/bar@, etc., one such
-- directory for each executable in the package).
inplaceBinDirectory
:: DistDirLayout
-> ElaboratedSharedConfig
-> ElaboratedConfiguredPackage
-> FilePath
inplaceBinDirectory layout config package
= distBuildDirectory layout (elabDistDirParams config package)
</> "build"
</> case elabPkgOrComp package of
ElabPackage _ -> ""
ElabComponent comp -> case compComponentName comp >>=
Cabal.componentNameString of
Just n -> display n
_ -> ""
-- | Get the bin\/ directory that executables should reside in after the
-- package has been built and installed.
installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath
installedBinDirectory = InstallDirs.bindir . elabInstallDirs
-- TODO: Probably calling this is a mistake. We should check each caller and
-- make sure it shouldn't be transitioned to binDirectories instead, then
-- delete this function.
-- | Get the bin\/ directory that a package's executables should reside in.
--
-- See also the more general 'binDirectories', which handles packages built
-- inplace more gracefully.
binDirectory
:: DistDirLayout
-> ElaboratedSharedConfig
-> ElaboratedConfiguredPackage
-> FilePath
binDirectory layout config package =
if elabBuildStyle package == BuildInplaceOnly
then inplaceBinDirectory layout config package
else installedBinDirectory package
-- | 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
......
......@@ -45,7 +45,7 @@ module Distribution.Client.Setup
, win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
, actAsSetupCommand, ActAsSetupFlags(..)
, sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
, execCommand, ExecFlags(..)
, execCommand, ExecFlags(..), defaultExecFlags
, userConfigCommand, UserConfigFlags(..)
, manpageCommand
......
......@@ -159,6 +159,7 @@ library
Distribution.Client.CmdBench
Distribution.Client.CmdBuild
Distribution.Client.CmdConfigure
Distribution.Client.CmdExec
Distribution.Client.CmdFreeze
Distribution.Client.CmdHaddock
Distribution.Client.CmdRepl
......
......@@ -83,6 +83,7 @@ import qualified Distribution.Client.CmdHaddock as CmdHaddock
import qualified Distribution.Client.CmdRun as CmdRun
import qualified Distribution.Client.CmdTest as CmdTest
import qualified Distribution.Client.CmdBench as CmdBench
import qualified Distribution.Client.CmdExec as CmdExec
import Distribution.Client.Install (install)
import Distribution.Client.Configure (configure, writeConfigFlags)
......@@ -321,6 +322,7 @@ mainWorker args = topHandler $
, regularCmd CmdRun.runCommand CmdRun.runAction
, regularCmd CmdTest.testCommand CmdTest.testAction
, regularCmd CmdBench.benchCommand CmdBench.benchAction
, regularCmd CmdExec.execCommand CmdExec.execAction
]
type Action = GlobalFlags -> IO ()
......
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