{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}

-- | Make changes to project or global configuration.
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 (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
      -- ^ Apply changes to the global configuration,
      --   typically at @~/.stack/config.yaml@.
    | CommandScopeProject
      -- ^ Apply changes to the project @stack.yaml@.

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 :: ConfigCmdSet -> RIO env ()
cfgCmdSet ConfigCmdSet
cmd = do
    Config
conf <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
configL
    Path Abs File
configFilePath <-
             case ConfigCmdSet -> CommandScope
configCmdSetScope ConfigCmdSet
cmd of
                 CommandScope
CommandScopeProject -> do
                     StackYamlLoc
mstackYamlOption <- Getting StackYamlLoc env StackYamlLoc -> RIO env StackYamlLoc
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting StackYamlLoc env StackYamlLoc -> RIO env StackYamlLoc)
-> Getting StackYamlLoc env StackYamlLoc -> RIO env StackYamlLoc
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const StackYamlLoc GlobalOpts)
-> env -> Const StackYamlLoc env
forall env. HasRunner env => Lens' env GlobalOpts
globalOptsL((GlobalOpts -> Const StackYamlLoc GlobalOpts)
 -> env -> Const StackYamlLoc env)
-> ((StackYamlLoc -> Const StackYamlLoc StackYamlLoc)
    -> GlobalOpts -> Const StackYamlLoc GlobalOpts)
-> Getting StackYamlLoc env StackYamlLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GlobalOpts -> StackYamlLoc)
-> SimpleGetter GlobalOpts StackYamlLoc
forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> StackYamlLoc
globalStackYaml
                     ProjectConfig (Path Abs File)
mstackYaml <- StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
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 -> Path Abs File -> RIO env (Path Abs File)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
stackYaml
                         ProjectConfig (Path Abs File)
PCGlobalProject -> (Path Abs Dir -> Path Abs File)
-> RIO env (Path Abs Dir) -> RIO env (Path Abs File)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml) (Config -> RIO env (Path Abs Dir)
forall env. HasLogFunc env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
conf)
                         PCNoProject [PackageIdentifierRevision]
_extraDeps -> String -> RIO env (Path Abs File)
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"config command used when no project configuration available" -- maybe modify the ~/.stack/config.yaml file instead?
                 CommandScope
CommandScopeGlobal -> Path Abs File -> RIO env (Path Abs File)
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> Path Abs File
configUserConfigPath Config
conf)
    -- We don't need to worry about checking for a valid yaml here
    (Object
config :: Yaml.Object) <-
        IO (Either ParseException Object)
-> RIO env (Either ParseException Object)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Either ParseException Object)
forall a. FromJSON a => String -> IO (Either ParseException a)
Yaml.decodeFileEither (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
configFilePath)) RIO env (Either ParseException Object)
-> (Either ParseException Object -> RIO env Object)
-> RIO env Object
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ParseException -> RIO env Object)
-> (Object -> RIO env Object)
-> Either ParseException Object
-> RIO env Object
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseException -> RIO env Object
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Object -> RIO env Object
forall (m :: * -> *) a. Monad m => a -> m a
return
    Value
newValue <- Path Abs Dir -> ConfigCmdSet -> RIO env Value
forall env.
(HasConfig env, HasGHCVariant env) =>
Path Abs Dir -> ConfigCmdSet -> RIO env Value
cfgCmdSetValue (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
configFilePath) ConfigCmdSet
cmd
    let cmdKey :: Text
cmdKey = ConfigCmdSet -> Text
cfgCmdSetOptionName ConfigCmdSet
cmd
        config' :: Object
config' = Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert Text
cmdKey Value
newValue Object
config
    if Object
config' Object -> Object -> Bool
forall a. Eq a => a -> a -> Bool
== Object
config
        then Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo
                 (String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
configFilePath) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
" already contained the intended configuration and remains unchanged.")
        else do
            Path Abs File -> Builder -> RIO env ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
configFilePath (ByteString -> Builder
byteString (Object -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode Object
config'))
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
configFilePath) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" has been updated.")

cfgCmdSetValue
    :: (HasConfig env, HasGHCVariant env)
    => Path Abs Dir -- ^ root directory of project
    -> ConfigCmdSet -> RIO env Yaml.Value
cfgCmdSetValue :: Path Abs Dir -> ConfigCmdSet -> RIO env Value
cfgCmdSetValue Path Abs Dir
root (ConfigCmdSetResolver Unresolved AbstractResolver
newResolver) = do
    AbstractResolver
newResolver' <- Maybe (Path Abs Dir)
-> Unresolved AbstractResolver -> RIO env AbstractResolver
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just Path Abs Dir
root) Unresolved AbstractResolver
newResolver
    RawSnapshotLocation
concreteResolver <- AbstractResolver -> RIO env RawSnapshotLocation
forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver AbstractResolver
newResolver'
    -- Check that the snapshot actually exists
    RIO env RawSnapshot -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env RawSnapshot -> RIO env ())
-> RIO env RawSnapshot -> RIO env ()
forall a b. (a -> b) -> a -> b
$ SnapshotLocation -> RIO env RawSnapshot
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
SnapshotLocation -> RIO env RawSnapshot
loadSnapshot (SnapshotLocation -> RIO env RawSnapshot)
-> RIO env SnapshotLocation -> RIO env RawSnapshot
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RawSnapshotLocation -> RIO env SnapshotLocation
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation RawSnapshotLocation
concreteResolver
    Value -> RIO env Value
forall (m :: * -> *) a. Monad m => a -> m a
return (RawSnapshotLocation -> Value
forall a. ToJSON a => a -> Value
Yaml.toJSON RawSnapshotLocation
concreteResolver)
cfgCmdSetValue Path Abs Dir
_ (ConfigCmdSetSystemGhc CommandScope
_ Bool
bool') =
    Value -> RIO env Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Value
Yaml.Bool Bool
bool')
cfgCmdSetValue Path Abs Dir
_ (ConfigCmdSetInstallGhc CommandScope
_ Bool
bool') =
    Value -> RIO env Value
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 =
    Mod CommandFields ConfigCmdSet -> Parser ConfigCmdSet
forall a. Mod CommandFields a -> Parser a
OA.hsubparser (Mod CommandFields ConfigCmdSet -> Parser ConfigCmdSet)
-> Mod CommandFields ConfigCmdSet -> Parser ConfigCmdSet
forall a b. (a -> b) -> a -> b
$
    [Mod CommandFields ConfigCmdSet] -> Mod CommandFields ConfigCmdSet
forall a. Monoid a => [a] -> a
mconcat
        [ String -> ParserInfo ConfigCmdSet -> Mod CommandFields ConfigCmdSet
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command
              String
"resolver"
              (Parser ConfigCmdSet
-> InfoMod ConfigCmdSet -> ParserInfo ConfigCmdSet
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
                   (Unresolved AbstractResolver -> ConfigCmdSet
ConfigCmdSetResolver (Unresolved AbstractResolver -> ConfigCmdSet)
-> Parser (Unresolved AbstractResolver) -> Parser ConfigCmdSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    ReadM (Unresolved AbstractResolver)
-> Mod ArgumentFields (Unresolved AbstractResolver)
-> Parser (Unresolved AbstractResolver)
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
OA.argument
                        ReadM (Unresolved AbstractResolver)
readAbstractResolver
                        (String -> Mod ArgumentFields (Unresolved AbstractResolver)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
OA.metavar String
"RESOLVER" Mod ArgumentFields (Unresolved AbstractResolver)
-> Mod ArgumentFields (Unresolved AbstractResolver)
-> Mod ArgumentFields (Unresolved AbstractResolver)
forall a. Semigroup a => a -> a -> a
<>
                         String -> Mod ArgumentFields (Unresolved AbstractResolver)
forall (f :: * -> *) a. String -> Mod f a
OA.help String
"E.g. \"nightly\" or \"lts-7.2\""))
                   (String -> InfoMod ConfigCmdSet
forall a. String -> InfoMod a
OA.progDesc
                        String
"Change the resolver of the current project. See https://docs.haskellstack.org/en/stable/yaml_configuration/#resolver for more info."))
        , String -> ParserInfo ConfigCmdSet -> Mod CommandFields ConfigCmdSet
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command
              (Text -> String
T.unpack Text
configMonoidSystemGHCName)
              (Parser ConfigCmdSet
-> InfoMod ConfigCmdSet -> ParserInfo ConfigCmdSet
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
                   (CommandScope -> Bool -> ConfigCmdSet
ConfigCmdSetSystemGhc (CommandScope -> Bool -> ConfigCmdSet)
-> Parser CommandScope -> Parser (Bool -> ConfigCmdSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser CommandScope
scopeFlag Parser (Bool -> ConfigCmdSet) -> Parser Bool -> Parser ConfigCmdSet
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
boolArgument)
                   (String -> InfoMod ConfigCmdSet
forall a. String -> InfoMod a
OA.progDesc
                        String
"Configure whether stack should use a system GHC installation or not."))
        , String -> ParserInfo ConfigCmdSet -> Mod CommandFields ConfigCmdSet
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command
              (Text -> String
T.unpack Text
configMonoidInstallGHCName)
              (Parser ConfigCmdSet
-> InfoMod ConfigCmdSet -> ParserInfo ConfigCmdSet
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
                   (CommandScope -> Bool -> ConfigCmdSet
ConfigCmdSetInstallGhc (CommandScope -> Bool -> ConfigCmdSet)
-> Parser CommandScope -> Parser (Bool -> ConfigCmdSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser CommandScope
scopeFlag Parser (Bool -> ConfigCmdSet) -> Parser Bool -> Parser ConfigCmdSet
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
boolArgument)
                   (String -> InfoMod ConfigCmdSet
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 =
    CommandScope
-> CommandScope
-> Mod FlagFields CommandScope
-> Parser CommandScope
forall a. a -> a -> Mod FlagFields a -> Parser a
OA.flag
        CommandScope
CommandScopeProject
        CommandScope
CommandScopeGlobal
        (String -> Mod FlagFields CommandScope
forall (f :: * -> *) a. HasName f => String -> Mod f a
OA.long String
"global" Mod FlagFields CommandScope
-> Mod FlagFields CommandScope -> Mod FlagFields CommandScope
forall a. Semigroup a => a -> a -> a
<>
         String -> Mod FlagFields CommandScope
forall (f :: * -> *) a. String -> Mod f a
OA.help
             String
"Modify the global configuration (typically at \"~/.stack/config.yaml\") instead of the project stack.yaml.")

readBool :: OA.ReadM Bool
readBool :: ReadM Bool
readBool = do
    String
s <- ReadM String
OA.readerAsk
    case String
s of
        String
"true" -> Bool -> ReadM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        String
"false" -> Bool -> ReadM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        String
_ -> String -> ReadM Bool
forall a. String -> ReadM a
OA.readerError (String
"Invalid value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": Expected \"true\" or \"false\"")

boolArgument :: OA.Parser Bool
boolArgument :: Parser Bool
boolArgument = ReadM Bool -> Mod ArgumentFields Bool -> Parser Bool
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
OA.argument ReadM Bool
readBool (String -> Mod ArgumentFields Bool
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
OA.metavar String
"true|false" Mod ArgumentFields Bool
-> Mod ArgumentFields Bool -> Mod ArgumentFields Bool
forall a. Semigroup a => a -> a -> a
<> [String] -> Mod ArgumentFields Bool
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
  (Bool -> Bool -> Bool -> Bool -> Bool -> EnvSettings)
-> Parser Bool
-> Parser (Bool -> Bool -> Bool -> Bool -> 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" Mod FlagFields Bool
forall a. Monoid a => a
mempty
  Parser (Bool -> Bool -> Bool -> Bool -> EnvSettings)
-> Parser Bool -> Parser (Bool -> Bool -> Bool -> EnvSettings)
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 variable" Mod FlagFields Bool
forall a. Monoid a => a
mempty
  Parser (Bool -> Bool -> Bool -> EnvSettings)
-> Parser Bool -> Parser (Bool -> Bool -> EnvSettings)
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" Mod FlagFields Bool
forall a. Monoid a => a
mempty
  Parser (Bool -> Bool -> EnvSettings)
-> Parser Bool -> Parser (Bool -> EnvSettings)
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 UTF8" Mod FlagFields Bool
forall a. Monoid a => a
mempty
  Parser (Bool -> EnvSettings) -> Parser Bool -> Parser EnvSettings
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 GHC_RTS environment variables" Mod FlagFields Bool
forall a. Monoid a => a
mempty

data EnvVarAction = EVASet !Text | EVAUnset
  deriving Int -> EnvVarAction -> String -> String
[EnvVarAction] -> String -> String
EnvVarAction -> String
(Int -> EnvVarAction -> String -> String)
-> (EnvVarAction -> String)
-> ([EnvVarAction] -> String -> String)
-> Show EnvVarAction
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [EnvVarAction] -> String -> String
$cshowList :: [EnvVarAction] -> String -> String
show :: EnvVarAction -> String
$cshow :: EnvVarAction -> String
showsPrec :: Int -> EnvVarAction -> String -> String
$cshowsPrec :: Int -> EnvVarAction -> String -> String
Show

cfgCmdEnv :: EnvSettings -> RIO EnvConfig ()
cfgCmdEnv :: EnvSettings -> RIO EnvConfig ()
cfgCmdEnv EnvSettings
es = do
  Map Text String
origEnv <- IO (Map Text String) -> RIO EnvConfig (Map Text String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Text String) -> RIO EnvConfig (Map Text String))
-> IO (Map Text String) -> RIO EnvConfig (Map Text String)
forall a b. (a -> b) -> a -> b
$ [(Text, String)] -> Map Text String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, String)] -> Map Text String)
-> ([(String, String)] -> [(Text, String)])
-> [(String, String)]
-> Map Text String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> (Text, String))
-> [(String, String)] -> [(Text, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Text) -> (String, String) -> (Text, String)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
forall a. IsString a => String -> a
fromString) ([(String, String)] -> Map Text String)
-> IO [(String, String)] -> IO (Map Text String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment
  EnvSettings -> IO ProcessContext
mkPC <- Getting
  (EnvSettings -> IO ProcessContext)
  EnvConfig
  (EnvSettings -> IO ProcessContext)
-> RIO EnvConfig (EnvSettings -> IO ProcessContext)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (EnvSettings -> IO ProcessContext)
   EnvConfig
   (EnvSettings -> IO ProcessContext)
 -> RIO EnvConfig (EnvSettings -> IO ProcessContext))
-> Getting
     (EnvSettings -> IO ProcessContext)
     EnvConfig
     (EnvSettings -> IO ProcessContext)
-> RIO EnvConfig (EnvSettings -> IO ProcessContext)
forall a b. (a -> b) -> a -> b
$ (Config -> Const (EnvSettings -> IO ProcessContext) Config)
-> EnvConfig -> Const (EnvSettings -> IO ProcessContext) EnvConfig
forall env. HasConfig env => Lens' env Config
configL((Config -> Const (EnvSettings -> IO ProcessContext) Config)
 -> EnvConfig -> Const (EnvSettings -> IO ProcessContext) EnvConfig)
-> (((EnvSettings -> IO ProcessContext)
     -> Const
          (EnvSettings -> IO ProcessContext)
          (EnvSettings -> IO ProcessContext))
    -> Config -> Const (EnvSettings -> IO ProcessContext) Config)
-> Getting
     (EnvSettings -> IO ProcessContext)
     EnvConfig
     (EnvSettings -> IO ProcessContext)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> EnvSettings -> IO ProcessContext)
-> SimpleGetter Config (EnvSettings -> IO ProcessContext)
forall s a. (s -> a) -> SimpleGetter s a
to Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings
  ProcessContext
pc <- IO ProcessContext -> RIO EnvConfig ProcessContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO EnvConfig ProcessContext)
-> IO ProcessContext -> RIO EnvConfig ProcessContext
forall a b. (a -> b) -> a -> b
$ EnvSettings -> IO ProcessContext
mkPC EnvSettings
es
  let newEnv :: EnvVars
newEnv = ProcessContext
pc ProcessContext -> Getting EnvVars ProcessContext EnvVars -> EnvVars
forall s a. s -> Getting a s a -> a
^. Getting EnvVars ProcessContext EnvVars
forall env. HasProcessContext env => SimpleGetter env EnvVars
envVarsL
      actions :: Map Text EnvVarAction
actions = SimpleWhenMissing Text String EnvVarAction
-> SimpleWhenMissing Text Text EnvVarAction
-> SimpleWhenMatched Text String Text EnvVarAction
-> Map Text String
-> EnvVars
-> Map Text EnvVarAction
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
        (EnvVarAction -> SimpleWhenMissing Text String EnvVarAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnvVarAction
EVAUnset)
        ((Text -> Text -> Identity EnvVarAction)
-> SimpleWhenMissing Text Text EnvVarAction
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f y) -> WhenMissing f k x y
Map.traverseMissing ((Text -> Text -> Identity EnvVarAction)
 -> SimpleWhenMissing Text Text EnvVarAction)
-> (Text -> Text -> Identity EnvVarAction)
-> SimpleWhenMissing Text Text EnvVarAction
forall a b. (a -> b) -> a -> b
$ \Text
_k Text
new -> EnvVarAction -> Identity EnvVarAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> EnvVarAction
EVASet Text
new))
        ((Text -> String -> Text -> Identity (Maybe EnvVarAction))
-> SimpleWhenMatched Text String Text EnvVarAction
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> f (Maybe z)) -> WhenMatched f k x y z
Map.zipWithMaybeAMatched ((Text -> String -> Text -> Identity (Maybe EnvVarAction))
 -> SimpleWhenMatched Text String Text EnvVarAction)
-> (Text -> String -> Text -> Identity (Maybe EnvVarAction))
-> SimpleWhenMatched Text String Text EnvVarAction
forall a b. (a -> b) -> a -> b
$ \Text
_k String
old Text
new -> Maybe EnvVarAction -> Identity (Maybe EnvVarAction)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe EnvVarAction -> Identity (Maybe EnvVarAction))
-> Maybe EnvVarAction -> Identity (Maybe EnvVarAction)
forall a b. (a -> b) -> a -> b
$
            if String -> Text
forall a. IsString a => String -> a
fromString String
old Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
new
              then Maybe EnvVarAction
forall a. Maybe a
Nothing
              else EnvVarAction -> Maybe EnvVarAction
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 " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeUtf8Builder Text
key Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
";\n"
      toLine Text
key (EVASet Text
value) =
        Text -> Builder
encodeUtf8Builder Text
key Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"='" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Text -> Builder
encodeUtf8Builder ((Char -> Text) -> Text -> Text
T.concatMap Char -> Text
escape Text
value) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> -- TODO more efficient to use encodeUtf8BuilderEscaped
        Builder
"'; export " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Text -> Builder
encodeUtf8Builder Text
key Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
";\n"
      escape :: Char -> Text
escape Char
'\'' = Text
"'\"'\"'"
      escape Char
c = Char -> Text
T.singleton Char
c
  Handle -> Builder -> RIO EnvConfig ()
forall (m :: * -> *). MonadIO m => Handle -> Builder -> m ()
hPutBuilder Handle
stdout (Builder -> RIO EnvConfig ()) -> Builder -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ (Text -> EnvVarAction -> Builder)
-> Map Text EnvVarAction -> Builder
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey Text -> EnvVarAction -> Builder
toLine Map Text EnvVarAction
actions