Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

implement a new-exec command #4304

Closed
wants to merge 12 commits into from
8 changes: 5 additions & 3 deletions Cabal/Distribution/Simple/GHC/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

If I wanted to be picky, I'd create a pure function to compute the envfile name, and then have writeGhcEnvironmentFile take the final filename to write it out to. You don't have to do this.

where
envfile = directory </> ghcEnvironmentFileName platform ghcversion

Expand Down
191 changes: 191 additions & 0 deletions cabal-install/Distribution/Client/CmdExec.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,191 @@
-------------------------------------------------------------------------------
-- |
-- 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
4 changes: 3 additions & 1 deletion cabal-install/Distribution/Client/ProjectOrchestration.hs
Original file line number Diff line number Diff line change
Expand Up @@ -277,17 +277,19 @@ runProjectPostBuildPhase verbosity ProjectBuildContext {..} buildOutcomes = do
-- - delete stale lib registrations
-- - delete stale package dirs

postBuildStatus <- updatePostBuildProjectStatus
_postBuildStatus <- updatePostBuildProjectStatus
verbosity
distDirLayout
elaboratedPlanOriginal
pkgsBuildStatus
buildOutcomes

{-TODO: This feature is temporarily disabled due to #4010
writePlanGhcEnvironment projectRootDir
elaboratedPlanOriginal
elaboratedShared
postBuildStatus
-}

-- Finally if there were any build failures then report them and throw
-- an exception to terminate the program
Expand Down
80 changes: 58 additions & 22 deletions cabal-install/Distribution/Client/ProjectPlanOutput.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@ module Distribution.Client.ProjectPlanOutput (
-- | Several outputs rely on having a general overview of
PostBuildProjectStatus(..),
updatePostBuildProjectStatus,
createPackageEnvironment,
writePlanGhcEnvironment,
) where

Expand Down Expand Up @@ -655,14 +656,51 @@ 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
--

writePlanGhcEnvironment :: FilePath
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> PostBuildProjectStatus
-> IO ()
-> IO (Maybe FilePath)
writePlanGhcEnvironment projectRootDir
elaboratedInstallPlan
ElaboratedSharedConfig {
Expand All @@ -673,26 +711,24 @@ writePlanGhcEnvironment projectRootDir
| compilerFlavor compiler == GHC
, supportsPkgEnvFiles (getImplInfo compiler)
--TODO: check ghcjs compat
--TODO: This feature is temporarily disabled due to #4010
, False
= writeGhcEnvironmentFile
= fmap Just $ writeGhcEnvironmentFile
projectRootDir
platform (compilerVersion compiler)
(renderGhcEnviromentFile projectRootDir
elaboratedInstallPlan
postBuildStatus)
(renderGhcEnvironmentFile projectRootDir
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
Expand All @@ -703,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
Expand Down Expand Up @@ -740,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
Expand All @@ -761,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
Expand All @@ -775,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
Expand Down
Loading