{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
module Stack.ConfigCmd
(ConfigCmdSet(..)
,configCmdSetParser
,cfgCmdSet
,cfgCmdSetName
,configCmdEnvParser
,cfgCmdEnv
,cfgCmdEnvName
,cfgCmdName) where
import Stack.Prelude
import Data.ByteString.Builder (byteString)
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 Pantry (completeSnapshotLocation, loadSnapshot)
import Path
import qualified RIO.Map as Map
import RIO.Process (envVarsL)
import Stack.Config (makeConcreteResolver, getProjectConfig, getImplicitGlobalProjectDir)
import Stack.Constants
import Stack.Types.Config
import Stack.Types.Resolver
import System.Environment (getEnvironment)
data ConfigCmdSet
= ConfigCmdSetResolver (Unresolved AbstractResolver)
| ConfigCmdSetSystemGhc CommandScope
Bool
| ConfigCmdSetInstallGhc CommandScope
Bool
data CommandScope
= CommandScopeGlobal
| CommandScopeProject
configCmdSetScope :: ConfigCmdSet -> CommandScope
configCmdSetScope (ConfigCmdSetResolver _) = CommandScopeProject
configCmdSetScope (ConfigCmdSetSystemGhc scope _) = scope
configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope
cfgCmdSet
:: (HasConfig env, HasGHCVariant env)
=> ConfigCmdSet -> RIO env ()
cfgCmdSet cmd = do
conf <- view configL
configFilePath <-
case configCmdSetScope cmd of
CommandScopeProject -> do
mstackYamlOption <- view $ globalOptsL.to globalStackYaml
mstackYaml <- getProjectConfig mstackYamlOption
case mstackYaml of
PCProject stackYaml -> return stackYaml
PCGlobalProject -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir conf)
PCNoProject _extraDeps -> throwString "config command used when no project configuration available"
CommandScopeGlobal -> return (configUserConfigPath conf)
(config :: Yaml.Object) <-
liftIO (Yaml.decodeFileEither (toFilePath configFilePath)) >>= either throwM return
newValue <- cfgCmdSetValue (parent configFilePath) cmd
let cmdKey = cfgCmdSetOptionName cmd
config' = HMap.insert cmdKey newValue config
if config' == config
then logInfo
(fromString (toFilePath configFilePath) <>
" already contained the intended configuration and remains unchanged.")
else do
writeBinaryFileAtomic configFilePath (byteString (Yaml.encode config'))
logInfo (fromString (toFilePath configFilePath) <> " has been updated.")
cfgCmdSetValue
:: (HasConfig env, HasGHCVariant env)
=> Path Abs Dir
-> ConfigCmdSet -> RIO env Yaml.Value
cfgCmdSetValue root (ConfigCmdSetResolver newResolver) = do
newResolver' <- resolvePaths (Just root) newResolver
concreteResolver <- makeConcreteResolver newResolver'
void $ loadSnapshot =<< completeSnapshotLocation concreteResolver
return (Yaml.toJSON concreteResolver)
cfgCmdSetValue _ (ConfigCmdSetSystemGhc _ bool') =
return (Yaml.Bool bool')
cfgCmdSetValue _ (ConfigCmdSetInstallGhc _ bool') =
return (Yaml.Bool bool')
cfgCmdSetOptionName :: ConfigCmdSet -> Text
cfgCmdSetOptionName (ConfigCmdSetResolver _) = "resolver"
cfgCmdSetOptionName (ConfigCmdSetSystemGhc _ _) = configMonoidSystemGHCName
cfgCmdSetOptionName (ConfigCmdSetInstallGhc _ _) = configMonoidInstallGHCName
cfgCmdName :: String
cfgCmdName = "config"
cfgCmdSetName :: String
cfgCmdSetName = "set"
cfgCmdEnvName :: String
cfgCmdEnvName = "env"
configCmdSetParser :: OA.Parser ConfigCmdSet
configCmdSetParser =
OA.hsubparser $
mconcat
[ OA.command
"resolver"
(OA.info
(ConfigCmdSetResolver <$>
OA.argument
readAbstractResolver
(OA.metavar "RESOLVER" <>
OA.help "E.g. \"nightly\" or \"lts-7.2\""))
(OA.progDesc
"Change the resolver of the current project. See https://docs.haskellstack.org/en/stable/yaml_configuration/#resolver for more info."))
, OA.command
(T.unpack configMonoidSystemGHCName)
(OA.info
(ConfigCmdSetSystemGhc <$> scopeFlag <*> boolArgument)
(OA.progDesc
"Configure whether stack should use a system GHC installation or not."))
, OA.command
(T.unpack configMonoidInstallGHCName)
(OA.info
(ConfigCmdSetInstallGhc <$> scopeFlag <*> boolArgument)
(OA.progDesc
"Configure whether stack should automatically install GHC when necessary."))
]
scopeFlag :: OA.Parser CommandScope
scopeFlag =
OA.flag
CommandScopeProject
CommandScopeGlobal
(OA.long "global" <>
OA.help
"Modify the global configuration (typically at \"~/.stack/config.yaml\") instead of the project stack.yaml.")
readBool :: OA.ReadM Bool
readBool = do
s <- OA.readerAsk
case s of
"true" -> return True
"false" -> return False
_ -> OA.readerError ("Invalid value " ++ show s ++ ": Expected \"true\" or \"false\"")
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) <>
"'; export " <>
encodeUtf8Builder key <> ";\n"
escape '\'' = "'\"'\"'"
escape c = T.singleton c
hPutBuilder stdout $ Map.foldMapWithKey toLine actions