{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.ConfigCmd
(ConfigCmdSet(..)
,configCmdSetParser
,cfgCmdSet
,cfgCmdSetName
,configCmdEnvParser
,cfgCmdEnv
,cfgCmdEnvName
,cfgCmdName) where
import Stack.Prelude
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import Data.Attoparsec.Text as P (Parser, parseOnly, skip, skipWhile,
string, takeText, takeWhile)
import qualified Data.Map.Merge.Strict as Map
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 (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 :: ConfigCmdSet -> CommandScope
configCmdSetScope (ConfigCmdSetResolver Unresolved AbstractResolver
_) = CommandScope
CommandScopeProject
configCmdSetScope (ConfigCmdSetSystemGhc CommandScope
scope Bool
_) = CommandScope
scope
configCmdSetScope (ConfigCmdSetInstallGhc CommandScope
scope Bool
_) = CommandScope
scope
cfgCmdSet
:: (HasConfig env, HasGHCVariant env)
=> ConfigCmdSet -> RIO env ()
cfgCmdSet :: forall env.
(HasConfig env, HasGHCVariant env) =>
ConfigCmdSet -> RIO env ()
cfgCmdSet ConfigCmdSet
cmd = do
Config
conf <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
Path Abs File
configFilePath <-
case ConfigCmdSet -> CommandScope
configCmdSetScope ConfigCmdSet
cmd of
CommandScope
CommandScopeProject -> do
StackYamlLoc
mstackYamlOption <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> StackYamlLoc
globalStackYaml
ProjectConfig (Path Abs File)
mstackYaml <- forall env.
HasLogFunc env =>
StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig StackYamlLoc
mstackYamlOption
case ProjectConfig (Path Abs File)
mstackYaml of
PCProject Path Abs File
stackYaml -> forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
stackYaml
ProjectConfig (Path Abs File)
PCGlobalProject -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml) (forall env. HasLogFunc env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
conf)
PCNoProject [PackageIdentifierRevision]
_extraDeps -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"config command used when no project configuration available"
CommandScope
CommandScopeGlobal -> forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> Path Abs File
configUserConfigPath Config
conf)
Text
rawConfig <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *). MonadIO m => String -> m Text
readFileUtf8 (forall b t. Path b t -> String
toFilePath Path Abs File
configFilePath))
KeyMap Value
config <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
rawConfig)
Value
newValue <- forall env.
(HasConfig env, HasGHCVariant env) =>
Path Abs Dir -> ConfigCmdSet -> RIO env Value
cfgCmdSetValue (forall b t. Path b t -> Path b Dir
parent Path Abs File
configFilePath) ConfigCmdSet
cmd
let yamlLines :: [Text]
yamlLines = Text -> [Text]
T.lines Text
rawConfig
cmdKey :: Text
cmdKey = ConfigCmdSet -> Text
cfgCmdSetOptionName ConfigCmdSet
cmd
cmdKey' :: Key
cmdKey' = Text -> Key
Key.fromText Text
cmdKey
newValue' :: Text
newValue' = Text -> Text
T.stripEnd forall a b. (a -> b) -> a -> b
$
OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
Yaml.encode Value
newValue
file :: String
file = forall b t. Path b t -> String
toFilePath Path Abs File
configFilePath
file' :: Utf8Builder
file' = forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
file
[Text]
newYamlLines <- case forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
cmdKey' KeyMap Value
config of
Maybe Value
Nothing -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
file' forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" has been extended."
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text]
yamlLines forall a. Semigroup a => a -> a -> a
<> [Text
cmdKey forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
newValue']
Just Value
oldValue -> if Value
oldValue forall a. Eq a => a -> a -> Bool
== Value
newValue
then do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
file' forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" already contained the intended \
\configuration and remains unchanged."
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
yamlLines
else forall {env} {m :: * -> *}.
(MonadReader env m, MonadIO m, HasLogFunc env) =>
Utf8Builder -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine Utf8Builder
file' Text
cmdKey Text
newValue' [] [Text]
yamlLines
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> Text -> m ()
writeFileUtf8 String
file ([Text] -> Text
T.unlines [Text]
newYamlLines)
where
switchLine :: Utf8Builder -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine Utf8Builder
file Text
cmdKey Text
_ [Text]
searched [] = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display Text
cmdKey forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" not found in YAML file " forall a. Semigroup a => a -> a -> a
<> Utf8Builder
file forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" as a single line. Multi-line key:value formats are not supported."
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Text]
searched
switchLine Utf8Builder
file Text
cmdKey Text
newValue [Text]
searched (Text
oldLine:[Text]
rest) =
case forall a. Parser a -> Text -> Either String a
parseOnly (Text -> Parser (KeyType, Text, Text, Text)
parseLine Text
cmdKey) Text
oldLine of
Left String
_ ->
Utf8Builder -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine Utf8Builder
file Text
cmdKey Text
newValue (Text
oldLineforall a. a -> [a] -> [a]
:[Text]
searched) [Text]
rest
Right (KeyType
kt, Text
spaces1, Text
spaces2, Text
comment) -> do
let newLine :: Text
newLine = Text -> KeyType -> Text
renderKey Text
cmdKey KeyType
kt forall a. Semigroup a => a -> a -> a
<> Text
spaces1 forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<>
Text
spaces2 forall a. Semigroup a => a -> a -> a
<> Text
newValue forall a. Semigroup a => a -> a -> a
<> Text
comment
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
file forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" has been updated."
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Text]
searched forall a. Semigroup a => a -> a -> a
<> (Text
newLineforall a. a -> [a] -> [a]
:[Text]
rest)
parseLine :: Text -> Parser (KeyType, Text, Text, Text)
parseLine :: Text -> Parser (KeyType, Text, Text, Text)
parseLine Text
key = do
KeyType
kt <- Text -> Parser KeyType
parseKey Text
key
Text
spaces1 <- (Char -> Bool) -> Parser Text
P.takeWhile (forall a. Eq a => a -> a -> Bool
== Char
' ')
(Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
== Char
':')
Text
spaces2 <- (Char -> Bool) -> Parser Text
P.takeWhile (forall a. Eq a => a -> a -> Bool
== Char
' ')
(Char -> Bool) -> Parser ()
skipWhile (forall a. Eq a => a -> a -> Bool
/= Char
' ')
Text
comment <- Parser Text
takeText
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyType
kt, Text
spaces1, Text
spaces2, Text
comment)
parseKey :: Text -> Parser KeyType
parseKey :: Text -> Parser KeyType
parseKey Text
k = Text -> Parser KeyType
parsePlainKey Text
k
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser KeyType
parseSingleQuotedKey Text
k
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser KeyType
parseDoubleQuotedKey Text
k
parsePlainKey :: Text -> Parser KeyType
parsePlainKey :: Text -> Parser KeyType
parsePlainKey Text
key = do
Text
_ <- Text -> Parser Text
string Text
key
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyType
PlainKey
parseSingleQuotedKey :: Text -> Parser KeyType
parseSingleQuotedKey :: Text -> Parser KeyType
parseSingleQuotedKey = KeyType -> Char -> Text -> Parser KeyType
parseQuotedKey KeyType
SingleQuotedKey Char
'\''
parseDoubleQuotedKey :: Text -> Parser KeyType
parseDoubleQuotedKey :: Text -> Parser KeyType
parseDoubleQuotedKey = KeyType -> Char -> Text -> Parser KeyType
parseQuotedKey KeyType
DoubleQuotedKey Char
'"'
parseQuotedKey :: KeyType -> Char -> Text -> Parser KeyType
parseQuotedKey :: KeyType -> Char -> Text -> Parser KeyType
parseQuotedKey KeyType
kt Char
c Text
key = do
(Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
==Char
c)
Text
_ <- Text -> Parser Text
string Text
key
(Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
==Char
c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyType
kt
renderKey :: Text -> KeyType -> Text
renderKey :: Text -> KeyType -> Text
renderKey Text
key KeyType
kt = case KeyType
kt of
KeyType
PlainKey -> Text
key
KeyType
SingleQuotedKey -> Char
'\'' Char -> Text -> Text
`T.cons` Text
key Text -> Char -> Text
`T.snoc` Char
'\''
KeyType
DoubleQuotedKey -> Char
'"' Char -> Text -> Text
`T.cons` Text
key Text -> Char -> Text
`T.snoc` Char
'"'
data KeyType
= PlainKey
| SingleQuotedKey
| DoubleQuotedKey
deriving (KeyType -> KeyType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyType -> KeyType -> Bool
$c/= :: KeyType -> KeyType -> Bool
== :: KeyType -> KeyType -> Bool
$c== :: KeyType -> KeyType -> Bool
Eq, Int -> KeyType -> ShowS
[KeyType] -> ShowS
KeyType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyType] -> ShowS
$cshowList :: [KeyType] -> ShowS
show :: KeyType -> String
$cshow :: KeyType -> String
showsPrec :: Int -> KeyType -> ShowS
$cshowsPrec :: Int -> KeyType -> ShowS
Show)
cfgCmdSetValue
:: (HasConfig env, HasGHCVariant env)
=> Path Abs Dir
-> ConfigCmdSet -> RIO env Yaml.Value
cfgCmdSetValue :: forall env.
(HasConfig env, HasGHCVariant env) =>
Path Abs Dir -> ConfigCmdSet -> RIO env Value
cfgCmdSetValue Path Abs Dir
root (ConfigCmdSetResolver Unresolved AbstractResolver
newResolver) = do
AbstractResolver
newResolver' <- forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (forall a. a -> Maybe a
Just Path Abs Dir
root) Unresolved AbstractResolver
newResolver
RawSnapshotLocation
concreteResolver <- forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver AbstractResolver
newResolver'
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
SnapshotLocation -> RIO env RawSnapshot
loadSnapshot forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation RawSnapshotLocation
concreteResolver
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
Yaml.toJSON RawSnapshotLocation
concreteResolver)
cfgCmdSetValue Path Abs Dir
_ (ConfigCmdSetSystemGhc CommandScope
_ Bool
bool') =
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Value
Yaml.Bool Bool
bool')
cfgCmdSetValue Path Abs Dir
_ (ConfigCmdSetInstallGhc CommandScope
_ Bool
bool') =
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Value
Yaml.Bool Bool
bool')
cfgCmdSetOptionName :: ConfigCmdSet -> Text
cfgCmdSetOptionName :: ConfigCmdSet -> Text
cfgCmdSetOptionName (ConfigCmdSetResolver Unresolved AbstractResolver
_) = Text
"resolver"
cfgCmdSetOptionName (ConfigCmdSetSystemGhc CommandScope
_ Bool
_) = Text
configMonoidSystemGHCName
cfgCmdSetOptionName (ConfigCmdSetInstallGhc CommandScope
_ Bool
_) = Text
configMonoidInstallGHCName
cfgCmdName :: String
cfgCmdName :: String
cfgCmdName = String
"config"
cfgCmdSetName :: String
cfgCmdSetName :: String
cfgCmdSetName = String
"set"
cfgCmdEnvName :: String
cfgCmdEnvName :: String
cfgCmdEnvName = String
"env"
configCmdSetParser :: OA.Parser ConfigCmdSet
configCmdSetParser :: Parser ConfigCmdSet
configCmdSetParser = forall a. Mod CommandFields a -> Parser a
OA.hsubparser forall a b. (a -> b) -> a -> b
$
forall a. Monoid a => [a] -> a
mconcat
[ forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"resolver"
( forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
(Unresolved AbstractResolver -> ConfigCmdSet
ConfigCmdSetResolver forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
OA.argument
ReadM (Unresolved AbstractResolver)
readAbstractResolver
(forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
OA.metavar String
"SNAPSHOT" forall a. Semigroup a => a -> a -> a
<>
forall (f :: * -> *) a. String -> Mod f a
OA.help String
"E.g. \"nightly\" or \"lts-7.2\""))
(forall a. String -> InfoMod a
OA.progDesc
String
"Change the resolver of the current project."))
, forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command (Text -> String
T.unpack Text
configMonoidSystemGHCName)
( forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
(CommandScope -> Bool -> ConfigCmdSet
ConfigCmdSetSystemGhc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser CommandScope
scopeFlag forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
boolArgument)
(forall a. String -> InfoMod a
OA.progDesc
String
"Configure whether Stack should use a system GHC installation \
\or not."))
, forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command (Text -> String
T.unpack Text
configMonoidInstallGHCName)
( forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
(CommandScope -> Bool -> ConfigCmdSet
ConfigCmdSetInstallGhc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser CommandScope
scopeFlag forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
boolArgument)
(forall a. String -> InfoMod a
OA.progDesc
String
"Configure whether Stack should automatically install GHC when \
\necessary."))
]
scopeFlag :: OA.Parser CommandScope
scopeFlag :: Parser CommandScope
scopeFlag = forall a. a -> a -> Mod FlagFields a -> Parser a
OA.flag
CommandScope
CommandScopeProject
CommandScope
CommandScopeGlobal
( forall (f :: * -> *) a. HasName f => String -> Mod f a
OA.long String
"global"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
OA.help
String
"Modify the user-specific global configuration file ('config.yaml') \
\instead of the project-level configuration file ('stack.yaml')."
)
readBool :: OA.ReadM Bool
readBool :: ReadM Bool
readBool = do
String
s <- ReadM String
OA.readerAsk
case String
s of
String
"true" -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
String
"false" -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
String
_ -> forall a. String -> ReadM a
OA.readerError (String
"Invalid value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s forall a. [a] -> [a] -> [a]
++
String
": Expected \"true\" or \"false\"")
boolArgument :: OA.Parser Bool
boolArgument :: Parser Bool
boolArgument = forall a. ReadM a -> Mod ArgumentFields a -> Parser a
OA.argument
ReadM Bool
readBool
( forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
OA.metavar String
"true|false"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasCompleter f => [String] -> Mod f a
OA.completeWith [String
"true", String
"false"]
)
configCmdEnvParser :: OA.Parser EnvSettings
configCmdEnvParser :: Parser EnvSettings
configCmdEnvParser = Bool -> Bool -> Bool -> Bool -> Bool -> EnvSettings
EnvSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
True String
"locals" String
"include local package information" forall a. Monoid a => a
mempty
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
True
String
"ghc-package-path" String
"set GHC_PACKAGE_PATH environment variable" forall a. Monoid a => a
mempty
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
True String
"stack-exe" String
"set STACK_EXE environment variable" forall a. Monoid a => a
mempty
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
False
String
"locale-utf8" String
"set the GHC_CHARENC environment variable to UTF-8" forall a. Monoid a => a
mempty
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
False
String
"keep-ghc-rts" String
"keep any GHCRTS environment variable" forall a. Monoid a => a
mempty
data EnvVarAction = EVASet !Text | EVAUnset
deriving Int -> EnvVarAction -> ShowS
[EnvVarAction] -> ShowS
EnvVarAction -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EnvVarAction] -> ShowS
$cshowList :: [EnvVarAction] -> ShowS
show :: EnvVarAction -> String
$cshow :: EnvVarAction -> String
showsPrec :: Int -> EnvVarAction -> ShowS
$cshowsPrec :: Int -> EnvVarAction -> ShowS
Show
cfgCmdEnv :: EnvSettings -> RIO EnvConfig ()
cfgCmdEnv :: EnvSettings -> RIO EnvConfig ()
cfgCmdEnv EnvSettings
es = do
Map Text String
origEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. IsString a => String -> a
fromString) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment
EnvSettings -> IO ProcessContext
mkPC <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings
ProcessContext
pc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ EnvSettings -> IO ProcessContext
mkPC EnvSettings
es
let newEnv :: EnvVars
newEnv = ProcessContext
pc forall s a. s -> Getting a s a -> a
^. forall env. HasProcessContext env => SimpleGetter env EnvVars
envVarsL
actions :: Map Text EnvVarAction
actions = forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
(forall (f :: * -> *) a. Applicative f => a -> f a
pure EnvVarAction
EVAUnset)
(forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f y) -> WhenMissing f k x y
Map.traverseMissing forall a b. (a -> b) -> a -> b
$ \Text
_k Text
new -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> EnvVarAction
EVASet Text
new))
(forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> f (Maybe z)) -> WhenMatched f k x y z
Map.zipWithMaybeAMatched forall a b. (a -> b) -> a -> b
$ \Text
_k String
old Text
new -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
if forall a. IsString a => String -> a
fromString String
old forall a. Eq a => a -> a -> Bool
== Text
new
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just (Text -> EnvVarAction
EVASet Text
new))
Map Text String
origEnv
EnvVars
newEnv
toLine :: Text -> EnvVarAction -> Builder
toLine Text
key EnvVarAction
EVAUnset = Builder
"unset " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeUtf8Builder Text
key forall a. Semigroup a => a -> a -> a
<> Builder
";\n"
toLine Text
key (EVASet Text
value) =
Text -> Builder
encodeUtf8Builder Text
key forall a. Semigroup a => a -> a -> a
<> Builder
"='" forall a. Semigroup a => a -> a -> a
<>
Text -> Builder
encodeUtf8Builder ((Char -> Text) -> Text -> Text
T.concatMap Char -> Text
escape Text
value) forall a. Semigroup a => a -> a -> a
<>
Builder
"'; export " forall a. Semigroup a => a -> a -> a
<>
Text -> Builder
encodeUtf8Builder Text
key forall a. Semigroup a => a -> a -> a
<> Builder
";\n"
escape :: Char -> Text
escape Char
'\'' = Text
"'\"'\"'"
escape Char
c = Char -> Text
T.singleton Char
c
forall (m :: * -> *). MonadIO m => Handle -> Builder -> m ()
hPutBuilder Handle
stdout forall a b. (a -> b) -> a -> b
$ forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey Text -> EnvVarAction -> Builder
toLine Map Text EnvVarAction
actions