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

-- | Make changes to project or global configuration.

module Stack.ConfigCmd
  ( ConfigCmdSet (..)
  , configCmdSetParser
  , cfgCmdSet
  , cfgCmdSetName
  , configCmdEnvParser
  , cfgCmdEnv
  , cfgCmdEnvName
  , cfgCmdName
  ) where

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.List.NonEmpty as NE
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import qualified Options.Applicative as OA
import           Options.Applicative.Builder.Extra
import qualified Options.Applicative.Types as OA
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.Prelude
import           Stack.Types.Config
import           Stack.Types.Resolver
import           System.Environment ( getEnvironment )

-- | Type repesenting exceptions thrown by functions exported by the

-- "Stack.ConfigCmd" module.

data ConfigCmdException
    = NoProjectConfigAvailable
    deriving (Int -> ConfigCmdException -> ShowS
[ConfigCmdException] -> ShowS
ConfigCmdException -> String
(Int -> ConfigCmdException -> ShowS)
-> (ConfigCmdException -> String)
-> ([ConfigCmdException] -> ShowS)
-> Show ConfigCmdException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigCmdException -> ShowS
showsPrec :: Int -> ConfigCmdException -> ShowS
$cshow :: ConfigCmdException -> String
show :: ConfigCmdException -> String
$cshowList :: [ConfigCmdException] -> ShowS
showList :: [ConfigCmdException] -> ShowS
Show, Typeable)

instance Exception ConfigCmdException where
    displayException :: ConfigCmdException -> String
displayException ConfigCmdException
NoProjectConfigAvailable =
        String
"Error: [S-3136]\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'config' command used when no project configuration available."

data ConfigCmdSet
    = ConfigCmdSetResolver !(Unresolved AbstractResolver)
    | ConfigCmdSetSystemGhc !CommandScope !Bool
    | ConfigCmdSetInstallGhc !CommandScope !Bool
    | ConfigCmdSetDownloadPrefix !CommandScope !Text

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
configCmdSetScope (ConfigCmdSetDownloadPrefix CommandScope
scope Text
_) = 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 <- 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
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
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 -> ConfigCmdException -> RIO env (Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ConfigCmdException
NoProjectConfigAvailable
                         -- maybe modify the ~/.stack/config.yaml file instead?

                 CommandScope
CommandScopeGlobal -> Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Config -> Path Abs File
configUserConfigPath Config
conf)
    Text
rawConfig <- IO Text -> RIO env Text
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Text
forall (m :: * -> *). MonadIO m => String -> m Text
readFileUtf8 (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
configFilePath))
    Value
config <- (ParseException -> RIO env Value)
-> (Value -> RIO env Value)
-> Either ParseException Value
-> RIO env Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseException -> RIO env Value
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Value -> RIO env Value
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either ParseException Value
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' (ByteString -> Either ParseException Value)
-> ByteString -> Either ParseException Value
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
rawConfig)
    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 yamlLines :: [Text]
yamlLines = Text -> [Text]
T.lines Text
rawConfig
        cmdKeys :: NonEmpty Text
cmdKeys = ConfigCmdSet -> NonEmpty Text
cfgCmdSetKeys ConfigCmdSet
cmd  -- Text

        newValue' :: Text
newValue' = Text -> Text
T.stripEnd (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
            OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode Value
newValue  -- Text

        file :: String
file = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
configFilePath  -- String

        file' :: Utf8Builder
file' = Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
file     -- Utf8Builder

    [Text]
newYamlLines <- case Value -> NonEmpty Text -> Maybe Value
inConfig Value
config NonEmpty Text
cmdKeys of
        Maybe Value
Nothing -> do
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
file' Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" has been extended."
            [Text] -> RIO env [Text]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> RIO env [Text]) -> [Text] -> RIO env [Text]
forall a b. (a -> b) -> a -> b
$ [Text]
-> Item [Text] -> NonEmpty (Item [Text]) -> Item [Text] -> [Text]
forall {t}.
(IsList t, Semigroup t, Semigroup (Item t), IsString (Item t)) =>
t -> Item t -> NonEmpty (Item t) -> Item t -> t
writeLines [Text]
yamlLines Text
Item [Text]
"" NonEmpty Text
NonEmpty (Item [Text])
cmdKeys Text
Item [Text]
newValue'
        Just Value
oldValue -> if Value
oldValue Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
newValue
            then do
                Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
file' Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" already contained the intended \
                    \configuration and remains unchanged."
                [Text] -> RIO env [Text]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
yamlLines
            else Utf8Builder -> Text -> Text -> [Text] -> [Text] -> RIO env [Text]
forall {m :: * -> *} {env}.
(MonadIO m, HasLogFunc env, MonadReader env m) =>
Utf8Builder -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine Utf8Builder
file' (NonEmpty Text -> Text
forall a. NonEmpty a -> a
NE.last NonEmpty Text
cmdKeys) Text
newValue' [] [Text]
yamlLines
    IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
forall (m :: * -> *). MonadIO m => String -> Text -> m ()
writeFileUtf8 String
file ([Text] -> Text
T.unlines [Text]
newYamlLines)
  where
    -- This assumes that if the key does not exist, the lines that can be

    -- appended to include it are of a form like:

    --

    -- key1:

    --   key2:

    --     key3: value

    --

    writeLines :: t -> Item t -> NonEmpty (Item t) -> Item t -> t
writeLines t
yamlLines Item t
spaces NonEmpty (Item t)
cmdKeys Item t
value = case NonEmpty (Item t) -> [Item t]
forall a. NonEmpty a -> [a]
NE.tail NonEmpty (Item t)
cmdKeys of
      [] -> t
yamlLines t -> t -> t
forall a. Semigroup a => a -> a -> a
<> [Item t
spaces Item t -> Item t -> Item t
forall a. Semigroup a => a -> a -> a
<> NonEmpty (Item t) -> Item t
forall a. NonEmpty a -> a
NE.head NonEmpty (Item t)
cmdKeys Item t -> Item t -> Item t
forall a. Semigroup a => a -> a -> a
<> Item t
": " Item t -> Item t -> Item t
forall a. Semigroup a => a -> a -> a
<> Item t
value]
      [Item t]
ks -> t -> Item t -> NonEmpty (Item t) -> Item t -> t
writeLines (t
yamlLines t -> t -> t
forall a. Semigroup a => a -> a -> a
<> [Item t
spaces Item t -> Item t -> Item t
forall a. Semigroup a => a -> a -> a
<> NonEmpty (Item t) -> Item t
forall a. NonEmpty a -> a
NE.head NonEmpty (Item t)
cmdKeys Item t -> Item t -> Item t
forall a. Semigroup a => a -> a -> a
<> Item t
":"])
                       (Item t
spaces Item t -> Item t -> Item t
forall a. Semigroup a => a -> a -> a
<> Item t
"  ")
                       ([Item t] -> NonEmpty (Item t)
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [Item t]
ks)
                       Item t
value

    inConfig :: Value -> NonEmpty Text -> Maybe Value
inConfig Value
v NonEmpty Text
cmdKeys = case Value
v of
        Yaml.Object Object
obj ->
            case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText (NonEmpty Text -> Text
forall a. NonEmpty a -> a
NE.head NonEmpty Text
cmdKeys)) Object
obj of
                Maybe Value
Nothing -> Maybe Value
forall a. Maybe a
Nothing
                Just Value
v' -> case NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.tail NonEmpty Text
cmdKeys of
                    [] -> Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v'
                    [Text]
ks -> Value -> NonEmpty Text -> Maybe Value
inConfig Value
v' ([Text] -> NonEmpty Text
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [Text]
ks)
        Value
_ -> Maybe Value
forall a. Maybe a
Nothing

    switchLine :: Utf8Builder -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine Utf8Builder
file Text
cmdKey Text
_ [Text]
searched [] = do
        Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
cmdKey Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" not found in YAML file " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
file Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
            Utf8Builder
" as a single line. Multi-line key:value formats are not supported."
        [Text] -> m [Text]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> m [Text]) -> [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
searched
    switchLine Utf8Builder
file Text
cmdKey Text
newValue [Text]
searched (Text
oldLine:[Text]
rest) =
        case Parser (KeyType, Text, Text, Text, Text)
-> Text -> Either String (KeyType, Text, Text, Text, Text)
forall a. Parser a -> Text -> Either String a
parseOnly (Text -> Parser (KeyType, Text, 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
oldLineText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
searched) [Text]
rest
            Right (KeyType
kt, Text
spaces1, Text
spaces2, Text
spaces3, Text
comment) -> do
                let newLine :: Text
newLine = Text
spaces1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> KeyType -> Text
renderKey Text
cmdKey KeyType
kt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
spaces2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                        Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
spaces3 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
newValue Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
comment
                Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
file Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" has been updated."
                [Text] -> m [Text]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> m [Text]) -> [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
searched [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text
newLineText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
rest)

    parseLine :: Text -> Parser (KeyType, Text, Text, Text, Text)
    parseLine :: Text -> Parser (KeyType, Text, Text, Text, Text)
parseLine Text
key = do
        Text
spaces1 <- (Char -> Bool) -> Parser Text
P.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
        KeyType
kt <- Text -> Parser KeyType
parseKey Text
key
        Text
spaces2 <- (Char -> Bool) -> Parser Text
P.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
        (Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':')
        Text
spaces3 <- (Char -> Bool) -> Parser Text
P.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
        (Char -> Bool) -> Parser ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
        Text
comment <- Parser Text
takeText
        (KeyType, Text, Text, Text, Text)
-> Parser (KeyType, Text, Text, Text, Text)
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyType
kt, Text
spaces1, Text
spaces2, Text
spaces3, Text
comment)

    -- If the key is, for example, install-ghc, this recognises install-ghc,

    -- 'install-ghc' or "install-ghc".

    parseKey :: Text -> Parser KeyType
    parseKey :: Text -> Parser KeyType
parseKey Text
k =   Text -> Parser KeyType
parsePlainKey Text
k
               Parser KeyType -> Parser KeyType -> Parser KeyType
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser KeyType
parseSingleQuotedKey Text
k
               Parser KeyType -> Parser KeyType -> Parser KeyType
forall a. Parser Text a -> Parser Text a -> Parser Text a
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
P.string Text
key
      KeyType -> Parser KeyType
forall a. a -> Parser Text a
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c)
        Text
_ <- Text -> Parser Text
P.string Text
key
        (Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c)
        KeyType -> Parser KeyType
forall a. a -> Parser Text a
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
'"'

-- |Type representing types of representations of keys in YAML files.

data KeyType
    = PlainKey  -- ^ For example: install-ghc

    | SingleQuotedKey  -- ^ For example: 'install-ghc'

    | DoubleQuotedKey  -- ^ For example: "install-ghc"

    deriving (KeyType -> KeyType -> Bool
(KeyType -> KeyType -> Bool)
-> (KeyType -> KeyType -> Bool) -> Eq KeyType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyType -> KeyType -> Bool
== :: KeyType -> KeyType -> Bool
$c/= :: KeyType -> KeyType -> Bool
/= :: KeyType -> KeyType -> Bool
Eq, Int -> KeyType -> ShowS
[KeyType] -> ShowS
KeyType -> String
(Int -> KeyType -> ShowS)
-> (KeyType -> String) -> ([KeyType] -> ShowS) -> Show KeyType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyType -> ShowS
showsPrec :: Int -> KeyType -> ShowS
$cshow :: KeyType -> String
show :: KeyType -> String
$cshowList :: [KeyType] -> ShowS
showList :: [KeyType] -> ShowS
Show)

cfgCmdSetValue
    :: (HasConfig env, HasGHCVariant env)
    => Path Abs Dir -- ^ root directory of project

    -> 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' <- 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> RIO env Value) -> Value -> RIO env Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
Yaml.Bool Bool
bool'
cfgCmdSetValue Path Abs Dir
_ (ConfigCmdSetInstallGhc CommandScope
_ Bool
bool') = Value -> RIO env Value
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> RIO env Value) -> Value -> RIO env Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
Yaml.Bool Bool
bool'
cfgCmdSetValue Path Abs Dir
_ (ConfigCmdSetDownloadPrefix CommandScope
_ Text
url) = Value -> RIO env Value
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> RIO env Value) -> Value -> RIO env Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
Yaml.String Text
url


cfgCmdSetKeys :: ConfigCmdSet -> NonEmpty Text
cfgCmdSetKeys :: ConfigCmdSet -> NonEmpty Text
cfgCmdSetKeys (ConfigCmdSetResolver Unresolved AbstractResolver
_) = [Text
Item (NonEmpty Text)
"resolver"]
cfgCmdSetKeys (ConfigCmdSetSystemGhc CommandScope
_ Bool
_) = [Text
Item (NonEmpty Text)
configMonoidSystemGHCName]
cfgCmdSetKeys (ConfigCmdSetInstallGhc CommandScope
_ Bool
_) = [Text
Item (NonEmpty Text)
configMonoidInstallGHCName]
cfgCmdSetKeys (ConfigCmdSetDownloadPrefix CommandScope
_ Text
_) =
    [Text
Item (NonEmpty Text)
"package-index", Text
Item (NonEmpty Text)
"download-prefix"]

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
"SNAPSHOT"
                        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." ))
          , 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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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." ))
          , String -> ParserInfo ConfigCmdSet -> Mod CommandFields ConfigCmdSet
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"package-index"
              ( Parser ConfigCmdSet
-> InfoMod ConfigCmdSet -> ParserInfo ConfigCmdSet
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
                  ( 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
$
                      String -> ParserInfo ConfigCmdSet -> Mod CommandFields ConfigCmdSet
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"download-prefix"
                        ( Parser ConfigCmdSet
-> InfoMod ConfigCmdSet -> ParserInfo ConfigCmdSet
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
                            (   CommandScope -> Text -> ConfigCmdSet
ConfigCmdSetDownloadPrefix
                            (CommandScope -> Text -> ConfigCmdSet)
-> Parser CommandScope -> Parser (Text -> ConfigCmdSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser CommandScope
scopeFlag
                            Parser (Text -> ConfigCmdSet) -> Parser Text -> Parser ConfigCmdSet
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
urlArgument )
                            ( String -> InfoMod ConfigCmdSet
forall a. String -> InfoMod a
OA.progDesc
                                String
"Configure download prefix for Stack's package \
                                \index." )))
                  ( String -> InfoMod ConfigCmdSet
forall a. String -> InfoMod a
OA.progDesc
                      String
"Configure Stack's package index" ))
          ]

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 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" -> Bool -> ReadM Bool
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    String
"false" -> Bool -> ReadM Bool
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    String
_ -> String -> ReadM Bool
forall a. String -> ReadM a
OA.readerError (String
"Invalid value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s String -> ShowS
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
Item [String]
"true", String
Item [String]
"false"]
  )

urlArgument :: OA.Parser Text
urlArgument :: Parser Text
urlArgument = Mod ArgumentFields Text -> Parser Text
forall s. IsString s => Mod ArgumentFields s -> Parser s
OA.strArgument
  (  String -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
OA.metavar String
"URL"
  Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> Text -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasValue f => a -> Mod f a
OA.value Text
defaultDownloadPrefix
  Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> Mod ArgumentFields Text
forall a (f :: * -> *). Show a => Mod f a
OA.showDefault
  Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields Text
forall (f :: * -> *) a. String -> Mod f a
OA.help
       String
"Location of package index. It is highly recommended to use only the \
       \official Hackage server or a mirror."
  )

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 a b. Parser (a -> b) -> Parser a -> Parser b
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" Mod FlagFields Bool
forall a. Monoid a => a
mempty
  Parser (Bool -> Bool -> Bool -> EnvSettings)
-> Parser Bool -> Parser (Bool -> Bool -> EnvSettings)
forall a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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" Mod FlagFields Bool
forall a. Monoid a => a
mempty
  Parser (Bool -> EnvSettings) -> Parser Bool -> Parser EnvSettings
forall a b. Parser (a -> b) -> Parser a -> Parser b
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" Mod FlagFields Bool
forall a. Monoid a => a
mempty

data EnvVarAction = EVASet !Text | EVAUnset
  deriving Int -> EnvVarAction -> ShowS
[EnvVarAction] -> ShowS
EnvVarAction -> String
(Int -> EnvVarAction -> ShowS)
-> (EnvVarAction -> String)
-> ([EnvVarAction] -> ShowS)
-> Show EnvVarAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EnvVarAction -> ShowS
showsPrec :: Int -> EnvVarAction -> ShowS
$cshow :: EnvVarAction -> String
show :: EnvVarAction -> String
$cshowList :: [EnvVarAction] -> ShowS
showList :: [EnvVarAction] -> ShowS
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 a. IO a -> RIO EnvConfig a
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 a b c. (a -> b) -> (a, c) -> (b, c)
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
Lens' EnvConfig 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 a. IO a -> RIO EnvConfig a
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
SimpleGetter ProcessContext 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 a. a -> WhenMissing Identity Text String a
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 a. a -> Identity a
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 a. a -> Identity a
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