{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedLists     #-}
{-# LANGUAGE OverloadedStrings   #-}

-- | 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 ( (</>), parent )
import qualified RIO.Map as Map
import           RIO.Process ( envVarsL )
import           Stack.Config
                   ( makeConcreteResolver, getProjectConfig
                   , getImplicitGlobalProjectDir
                   )
import           Stack.Constants ( stackDotYaml )
import           Stack.Prelude
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.ConfigMonoid
                   ( configMonoidInstallGHCName, configMonoidSystemGHCName )
import           Stack.Types.EnvConfig ( EnvConfig )
import           Stack.Types.EnvSettings ( EnvSettings (..) )
import           Stack.Types.GHCVariant ( HasGHCVariant )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.ProjectConfig ( ProjectConfig (..) )
import           Stack.Types.Resolver ( AbstractResolver, readAbstractResolver )
import           Stack.Types.Runner ( globalOptsL )
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.
HasTerm 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 a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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. HasTerm 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

  [Text]
newYamlLines <- case Value -> NonEmpty Text -> Maybe Value
inConfig Value
config NonEmpty Text
cmdKeys of
    Maybe Value
Nothing -> do
      [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
        [ Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
configFilePath
        , String -> StyleDoc
flow String
"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
        [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
          [ Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
configFilePath
          , String -> StyleDoc
flow String
"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 Path Abs File -> Text -> Text -> [Text] -> [Text] -> RIO env [Text]
forall {m :: * -> *} {a} {env}.
(Pretty a, MonadIO m, HasTerm env, MonadReader env m) =>
a -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine Path Abs File
configFilePath (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 :: a -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine a
file Text
cmdKey Text
_ [Text]
searched [] = do
    [StyleDoc] -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
      [ Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
cmdKey)
      , String -> StyleDoc
flow String
"not found in YAML file"
      , a -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty a
file
      , String -> StyleDoc
flow String
"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 a
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
_ -> a -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine a
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
        [StyleDoc] -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
          [ a -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty a
file
          , String -> StyleDoc
flow String
"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
  Builder -> RIO EnvConfig ()
forall (m :: * -> *). MonadIO m => Builder -> m ()
putBuilder (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