diff --git a/ChangeLog.md b/ChangeLog.md index 3cb5da8d95..064593df7f 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -127,6 +127,8 @@ Other enhancements: * Both `stack dot` and `stack ls dependencies` accept a `--global-hints` flag to bypass the need for an installed GHC. See [#4390](https://github.com/commercialhaskell/stack/issues/4390). +* Add the `stack config env` command for getting shell script environment + variables. See [#620](https://github.com/commercialhaskell/stack/issues/620). Bug fixes: diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index d71ae815d7..be3c9ddf74 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -11,21 +11,29 @@ module Stack.ConfigCmd ,configCmdSetParser ,cfgCmdSet ,cfgCmdSetName + ,configCmdEnvParser + ,cfgCmdEnv + ,cfgCmdEnvName ,cfgCmdName) where import Stack.Prelude import qualified Data.ByteString as S +import qualified Data.Map.Merge.Strict as Map import qualified Data.HashMap.Strict as HMap import qualified Data.Text as T import qualified Data.Yaml as Yaml import qualified Options.Applicative as OA import qualified Options.Applicative.Types as OA +import Options.Applicative.Builder.Extra import Path +import qualified RIO.Map as Map +import RIO.Process (envVarsL) import Stack.Config (makeConcreteResolver, getProjectConfig, getImplicitGlobalProjectDir) import Stack.Constants import Stack.Snapshot (loadResolver) import Stack.Types.Config import Stack.Types.Resolver +import System.Environment (getEnvironment) data ConfigCmdSet = ConfigCmdSetResolver (Unresolved AbstractResolver) @@ -101,6 +109,9 @@ cfgCmdName = "config" cfgCmdSetName :: String cfgCmdSetName = "set" +cfgCmdEnvName :: String +cfgCmdEnvName = "env" + configCmdSetParser :: OA.Parser ConfigCmdSet configCmdSetParser = OA.hsubparser $ @@ -148,3 +159,39 @@ readBool = do boolArgument :: OA.Parser Bool boolArgument = OA.argument readBool (OA.metavar "true|false" <> OA.completeWith ["true", "false"]) + +configCmdEnvParser :: OA.Parser EnvSettings +configCmdEnvParser = EnvSettings + <$> boolFlags True "locals" "include local package information" mempty + <*> boolFlags True "ghc-package-path" "set GHC_PACKAGE_PATH variable" mempty + <*> boolFlags True "stack-exe" "set STACK_EXE environment variable" mempty + <*> boolFlags False "locale-utf8" "set the GHC_CHARENC environment variable to UTF8" mempty + <*> boolFlags False "keep-ghc-rts" "keep any GHC_RTS environment variables" mempty + +data EnvVarAction = EVASet !Text | EVAUnset + deriving Show + +cfgCmdEnv :: EnvSettings -> RIO EnvConfig () +cfgCmdEnv es = do + origEnv <- liftIO $ Map.fromList . map (first fromString) <$> getEnvironment + mkPC <- view $ configL.to configProcessContextSettings + pc <- liftIO $ mkPC es + let newEnv = pc ^. envVarsL + actions = Map.merge + (pure EVAUnset) + (Map.traverseMissing $ \_k new -> pure (EVASet new)) + (Map.zipWithMaybeAMatched $ \_k old new -> pure $ + if fromString old == new + then Nothing + else Just (EVASet new)) + origEnv + newEnv + toLine key EVAUnset = "unset " <> encodeUtf8Builder key <> ";\n" + toLine key (EVASet value) = + encodeUtf8Builder key <> "='" <> + encodeUtf8Builder (T.concatMap escape value) <> -- TODO more efficient to use encodeUtf8BuilderEscaped + "'; export " <> + encodeUtf8Builder key <> ";\n" + escape '\'' = "'\"'\"'" + escape c = T.singleton c + hPutBuilder stdout $ Map.foldMapWithKey toLine actions diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 6e66064545..357fd62ec2 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -297,7 +297,7 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do extras <- runReaderT packageDatabaseExtra envConfig0 let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb - distDir <- runReaderT distRelativeDir envConfig0 + distDir <- runReaderT distRelativeDir envConfig0 >>= canonicalizePath executablePath <- liftIO getExecutablePath diff --git a/src/main/Main.hs b/src/main/Main.hs index cc8ef94181..cbdd00f8c0 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -465,10 +465,15 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions addSubCommands' ConfigCmd.cfgCmdName "Subcommands specific to modifying stack.yaml files" - (addCommand' ConfigCmd.cfgCmdSetName - "Sets a field in the project's stack.yaml to value" - (withConfig . cfgCmdSet) - configCmdSetParser) + (do + addCommand' ConfigCmd.cfgCmdSetName + "Sets a field in the project's stack.yaml to value" + (withConfig . cfgCmdSet) + configCmdSetParser + addCommand' ConfigCmd.cfgCmdEnvName + "Print environment variables for use in a shell" + (withConfig . withDefaultEnvConfig . cfgCmdEnv) + configCmdEnvParser) addSubCommands' "hpc" "Subcommands specific to Haskell Program Coverage" diff --git a/test/integration/tests/620-env-command/Main.hs b/test/integration/tests/620-env-command/Main.hs new file mode 100644 index 0000000000..f22d0f95e7 --- /dev/null +++ b/test/integration/tests/620-env-command/Main.hs @@ -0,0 +1,6 @@ +import StackTest +import System.Process +import Control.Exception (throwIO) + +main :: IO () +main = rawSystem "bash" ["run.sh"] >>= throwIO diff --git a/test/integration/tests/620-env-command/files/.gitignore b/test/integration/tests/620-env-command/files/.gitignore new file mode 100644 index 0000000000..f406f9be9a --- /dev/null +++ b/test/integration/tests/620-env-command/files/.gitignore @@ -0,0 +1,2 @@ +Main +Main.exe diff --git a/test/integration/tests/620-env-command/files/Main.hs b/test/integration/tests/620-env-command/files/Main.hs new file mode 100644 index 0000000000..bd555bc39d --- /dev/null +++ b/test/integration/tests/620-env-command/files/Main.hs @@ -0,0 +1,4 @@ +import Control.Concurrent.Async () + +main :: IO () +main = pure () diff --git a/test/integration/tests/620-env-command/files/run.sh b/test/integration/tests/620-env-command/files/run.sh new file mode 100644 index 0000000000..89f2015219 --- /dev/null +++ b/test/integration/tests/620-env-command/files/run.sh @@ -0,0 +1,7 @@ +#!/usr/bin/env bash + +set -euxo pipefail + +stack build --resolver lts-11.22 async +eval `stack config env --resolver lts-11.22` +ghc Main.hs