Commit 585fe3a4 authored by Daniel Wagner's avatar Daniel Wagner

bare-bones new-exec support

This implements a bare-bones skeleton for cabal new-exec.

The old cabal exec gave programs access to a sandbox's package database.
By analogy, cabal new-exec should give programs access to the store's
package database; however, this database will be cluttered with many
non-project-related packages that may confuse issues. Therefore new-exec
selects just the packages that are in the current project's dependency
tree and makes them available to compiler tools. Currently only very new
GHCs are supported, via the GHC_ENVIRONMENT mechanism for selecting a
subset of some package databases.

Eventually we should probably also modify the PATH so that dependencies'
executables are available.
parent 599120e3
......@@ -531,13 +531,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 StandaloneDeriving #-}
module Distribution.Client.CmdExec
( execAction
, execCommand
) where
import Distribution.Client.DistDirLayout
( distTempDirectory
)
import Distribution.Client.Setup
( GlobalFlags(..)
, ExecFlags(..)
, defaultExecFlags
)
import Distribution.Client.ProjectOrchestration
( ProjectBuildContext(..)
, PreBuildHooks(..)
, runProjectPreBuildPhase
)
import Distribution.Client.ProjectPlanOutput
( updatePostBuildProjectStatus
, createPackageEnvironment
)
import Distribution.Simple.Command
( CommandUI(..)
)
import Distribution.Simple.Program.Run
( ProgramInvocation(..)
, runProgramInvocation
, simpleProgramInvocation
)
import Distribution.Simple.Setup
( fromFlag
, optionDistPref, optionVerbosity
, configDistPref, configVerbosity
, haddockDistPref, haddockVerbosity
)
import Distribution.Simple.Utils
( die
, withTempDirectory
, wrapText
)
execCommand :: CommandUI ExecFlags
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 $
"TODO"
, commandNotes = Nothing
, commandDefaultFlags = defaultExecFlags
, commandOptions = \showOrParseArgs ->
[ optionVerbosity execVerbosity (\v flags -> flags { execVerbosity = v })
, optionDistPref
execDistPref (\v flags -> flags { execDistPref = v })
showOrParseArgs
]
}
execAction :: ExecFlags -> [String] -> GlobalFlags -> IO ()
execAction execFlags extraArgs globalFlags = do
let verbosity = fromFlag (execVerbosity execFlags)
-- 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.
--
-- TODO: We set a lot of default settings here (with mempty). It might be
-- worth walking through each of the settings we default and making sure they
-- shouldn't become ExecFlags.
buildCtx <- runProjectPreBuildPhase
verbosity
( globalFlags
, mempty
{ configDistPref = execDistPref execFlags
, configVerbosity = execVerbosity execFlags
}
, mempty
, mempty
, mempty
{ haddockDistPref = execDistPref execFlags
, haddockVerbosity = execVerbosity execFlags
}
)
PreBuildHooks
{ hookPrePlanning = \_ _ _ -> return ()
, hookSelectPlanSubset = \_ -> return
}
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
-- TODO: discuss PATH munging with #hackage
case extraArgs of
exe:args -> runProgramInvocation
verbosity
(simpleProgramInvocation exe args)
{ progInvokeEnv = envOverrides
}
[] -> die "Please specify an executable to run"
......@@ -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 :: FilePath
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> PostBuildProjectStatus
-> IO ()
-> IO (Maybe FilePath)
writePlanGhcEnvironment projectRootDir
elaboratedInstallPlan
ElaboratedSharedConfig {
......@@ -673,7 +711,7 @@ writePlanGhcEnvironment projectRootDir
| compilerFlavor compiler == GHC
, supportsPkgEnvFiles (getImplInfo compiler)
--TODO: check ghcjs compat
= writeGhcEnvironmentFile
= fmap Just $ writeGhcEnvironmentFile
projectRootDir
platform (compilerVersion compiler)
(renderGhcEnvironmentFile projectRootDir
......@@ -683,7 +721,7 @@ writePlanGhcEnvironment projectRootDir
-- 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
renderGhcEnvironmentFile :: FilePath
-> ElaboratedInstallPlan
......
......@@ -45,7 +45,7 @@ module Distribution.Client.Setup
, win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
, actAsSetupCommand, ActAsSetupFlags(..)
, sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
, execCommand, ExecFlags(..)
, execCommand, ExecFlags(..), defaultExecFlags
, userConfigCommand, UserConfigFlags(..)
, manpageCommand
......
......@@ -234,6 +234,7 @@ library
Distribution.Client.CmdHaddock
Distribution.Client.CmdTest
Distribution.Client.CmdRepl
Distribution.Client.CmdExec
Distribution.Client.Config
Distribution.Client.Configure
Distribution.Client.Dependency
......
......@@ -80,6 +80,7 @@ import qualified Distribution.Client.CmdFreeze as CmdFreeze
import qualified Distribution.Client.CmdHaddock as CmdHaddock
import qualified Distribution.Client.CmdRepl as CmdRepl
import qualified Distribution.Client.CmdTest as CmdTest
import qualified Distribution.Client.CmdExec as CmdExec
import Distribution.Client.Install (install)
import Distribution.Client.Configure (configure, writeConfigFlags)
......@@ -292,6 +293,7 @@ mainWorker args = topHandler $
, hiddenCmd CmdTest.testCommand CmdTest.testAction
, regularCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction
, regularCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction
, 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