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

-- | Make changes to project or global configuration.

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

import           Stack.Prelude
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import           Data.Attoparsec.Text as P (Parser, parseOnly, skip, skipWhile,
                                           string, takeText, takeWhile)
import qualified Data.Map.Merge.Strict as Map
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import qualified Options.Applicative as OA
import qualified Options.Applicative.Types as OA
import           Options.Applicative.Builder.Extra
import           Pantry (loadSnapshot)
import           Path
import qualified RIO.Map as Map
import           RIO.Process (envVarsL)
import           Stack.Config (makeConcreteResolver, getProjectConfig,
                              getImplicitGlobalProjectDir)
import           Stack.Constants
import           Stack.Types.Config
import           Stack.Types.Resolver
import           System.Environment (getEnvironment)

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

data CommandScope
    = CommandScopeGlobal
      -- ^ 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 :: forall env.
(HasConfig env, HasGHCVariant env) =>
ConfigCmdSet -> RIO env ()
cfgCmdSet ConfigCmdSet
cmd = do
    Config
conf <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    Path Abs File
configFilePath <-
             case ConfigCmdSet -> CommandScope
configCmdSetScope ConfigCmdSet
cmd of
                 CommandScope
CommandScopeProject -> do
                     StackYamlLoc
mstackYamlOption <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> StackYamlLoc
globalStackYaml
                     ProjectConfig (Path Abs File)
mstackYaml <- forall env.
HasLogFunc env =>
StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig StackYamlLoc
mstackYamlOption
                     case ProjectConfig (Path Abs File)
mstackYaml of
                         PCProject Path Abs File
stackYaml -> forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
stackYaml
                         ProjectConfig (Path Abs File)
PCGlobalProject -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml) (forall env. HasLogFunc env => Config -> RIO env (Path Abs Dir)
getImplicitGlobalProjectDir Config
conf)
                         PCNoProject [PackageIdentifierRevision]
_extraDeps -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"config command used when no project configuration available" -- maybe modify the ~/.stack/config.yaml file instead?

                 CommandScope
CommandScopeGlobal -> forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> Path Abs File
configUserConfigPath Config
conf)
    Text
rawConfig <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *). MonadIO m => String -> m Text
readFileUtf8 (forall b t. Path b t -> String
toFilePath Path Abs File
configFilePath))
    KeyMap Value
config <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
rawConfig)
    Value
newValue <- forall env.
(HasConfig env, HasGHCVariant env) =>
Path Abs Dir -> ConfigCmdSet -> RIO env Value
cfgCmdSetValue (forall b t. Path b t -> Path b Dir
parent Path Abs File
configFilePath) ConfigCmdSet
cmd
    let yamlLines :: [Text]
yamlLines = Text -> [Text]
T.lines Text
rawConfig
        cmdKey :: Text
cmdKey = ConfigCmdSet -> Text
cfgCmdSetOptionName ConfigCmdSet
cmd  -- Text

        cmdKey' :: Key
cmdKey' = Text -> Key
Key.fromText Text
cmdKey     -- Data.Aeson.Key.Key

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

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

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

    [Text]
newYamlLines <- case forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
cmdKey' KeyMap Value
config of
        Maybe Value
Nothing -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
file' forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" has been extended."
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text]
yamlLines forall a. Semigroup a => a -> a -> a
<> [Text
cmdKey forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
newValue']
        Just Value
oldValue -> if Value
oldValue forall a. Eq a => a -> a -> Bool
== Value
newValue
            then do
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
file' forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" already contained the intended \
                    \configuration and remains unchanged."
                forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
yamlLines
            else forall {env} {m :: * -> *}.
(MonadReader env m, MonadIO m, HasLogFunc env) =>
Utf8Builder -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine Utf8Builder
file' Text
cmdKey Text
newValue' [] [Text]
yamlLines
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> Text -> m ()
writeFileUtf8 String
file ([Text] -> Text
T.unlines [Text]
newYamlLines)
  where
    switchLine :: Utf8Builder -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine Utf8Builder
file Text
cmdKey Text
_ [Text]
searched [] = do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display Text
cmdKey forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" not found in YAML file " forall a. Semigroup a => a -> a -> a
<> Utf8Builder
file forall a. Semigroup a => a -> a -> a
<>
            Utf8Builder
" as a single line. Multi-line key:value formats are not supported."
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Text]
searched
    switchLine Utf8Builder
file Text
cmdKey Text
newValue [Text]
searched (Text
oldLine:[Text]
rest) =
        case forall a. Parser a -> Text -> Either String a
parseOnly (Text -> Parser (KeyType, Text, Text, Text)
parseLine Text
cmdKey) Text
oldLine of
            Left String
_ ->
                Utf8Builder -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine Utf8Builder
file Text
cmdKey Text
newValue (Text
oldLineforall a. a -> [a] -> [a]
:[Text]
searched) [Text]
rest
            Right (KeyType
kt, Text
spaces1, Text
spaces2, Text
comment) -> do
                let newLine :: Text
newLine = Text -> KeyType -> Text
renderKey Text
cmdKey KeyType
kt forall a. Semigroup a => a -> a -> a
<> Text
spaces1 forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<>
                        Text
spaces2 forall a. Semigroup a => a -> a -> a
<> Text
newValue forall a. Semigroup a => a -> a -> a
<> Text
comment
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
file forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" has been updated."
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Text]
searched forall a. Semigroup a => a -> a -> a
<> (Text
newLineforall a. a -> [a] -> [a]
:[Text]
rest)

    -- This assumes that a top-level key will not be indented in the YAML file.

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

    -- 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
               forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser KeyType
parseSingleQuotedKey Text
k
               forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser KeyType
parseDoubleQuotedKey Text
k

    parsePlainKey :: Text -> Parser KeyType
    parsePlainKey :: Text -> Parser KeyType
parsePlainKey Text
key = do
      Text
_ <- Text -> Parser Text
string Text
key
      forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyType
PlainKey

    parseSingleQuotedKey :: Text -> Parser KeyType
    parseSingleQuotedKey :: Text -> Parser KeyType
parseSingleQuotedKey = KeyType -> Char -> Text -> Parser KeyType
parseQuotedKey KeyType
SingleQuotedKey Char
'\''

    parseDoubleQuotedKey :: Text -> Parser KeyType
    parseDoubleQuotedKey :: Text -> Parser KeyType
parseDoubleQuotedKey = KeyType -> Char -> Text -> Parser KeyType
parseQuotedKey KeyType
DoubleQuotedKey Char
'"'

    parseQuotedKey :: KeyType -> Char -> Text -> Parser KeyType
    parseQuotedKey :: KeyType -> Char -> Text -> Parser KeyType
parseQuotedKey KeyType
kt Char
c Text
key = do
        (Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
==Char
c)
        Text
_ <- Text -> Parser Text
string Text
key
        (Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
==Char
c)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyType
kt

    renderKey :: Text -> KeyType -> Text
    renderKey :: Text -> KeyType -> Text
renderKey Text
key KeyType
kt = case KeyType
kt of
        KeyType
PlainKey -> Text
key
        KeyType
SingleQuotedKey -> Char
'\'' Char -> Text -> Text
`T.cons` Text
key Text -> Char -> Text
`T.snoc` Char
'\''
        KeyType
DoubleQuotedKey -> Char
'"' Char -> Text -> Text
`T.cons` Text
key Text -> Char -> Text
`T.snoc` Char
'"'

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

cfgCmdSetValue
    :: (HasConfig env, HasGHCVariant env)
    => Path Abs Dir -- ^ 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' <- forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (forall a. a -> Maybe a
Just Path Abs Dir
root) Unresolved AbstractResolver
newResolver
    RawSnapshotLocation
concreteResolver <- forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver AbstractResolver
newResolver'
    -- Check that the snapshot actually exists

    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
SnapshotLocation -> RIO env RawSnapshot
loadSnapshot forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation RawSnapshotLocation
concreteResolver
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
Yaml.toJSON RawSnapshotLocation
concreteResolver)
cfgCmdSetValue Path Abs Dir
_ (ConfigCmdSetSystemGhc CommandScope
_ Bool
bool') =
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Value
Yaml.Bool Bool
bool')
cfgCmdSetValue Path Abs Dir
_ (ConfigCmdSetInstallGhc CommandScope
_ Bool
bool') =
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Value
Yaml.Bool Bool
bool')

cfgCmdSetOptionName :: ConfigCmdSet -> Text
cfgCmdSetOptionName :: ConfigCmdSet -> Text
cfgCmdSetOptionName (ConfigCmdSetResolver Unresolved AbstractResolver
_) = Text
"resolver"
cfgCmdSetOptionName (ConfigCmdSetSystemGhc CommandScope
_ Bool
_) = Text
configMonoidSystemGHCName
cfgCmdSetOptionName (ConfigCmdSetInstallGhc CommandScope
_ Bool
_) = Text
configMonoidInstallGHCName

cfgCmdName :: String
cfgCmdName :: String
cfgCmdName = String
"config"

cfgCmdSetName :: String
cfgCmdSetName :: String
cfgCmdSetName = String
"set"

cfgCmdEnvName :: String
cfgCmdEnvName :: String
cfgCmdEnvName = String
"env"

configCmdSetParser :: OA.Parser ConfigCmdSet
configCmdSetParser :: Parser ConfigCmdSet
configCmdSetParser = forall a. Mod CommandFields a -> Parser a
OA.hsubparser forall a b. (a -> b) -> a -> b
$
  forall a. Monoid a => [a] -> a
mconcat
    [ forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"resolver"
        ( forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
            (Unresolved AbstractResolver -> ConfigCmdSet
ConfigCmdSetResolver forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
             forall a. ReadM a -> Mod ArgumentFields a -> Parser a
OA.argument
                 ReadM (Unresolved AbstractResolver)
readAbstractResolver
                 (forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
OA.metavar String
"SNAPSHOT" forall a. Semigroup a => a -> a -> a
<>
                  forall (f :: * -> *) a. String -> Mod f a
OA.help String
"E.g. \"nightly\" or \"lts-7.2\""))
            (forall a. String -> InfoMod a
OA.progDesc
               String
"Change the resolver of the current project."))
    , forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command (Text -> String
T.unpack Text
configMonoidSystemGHCName)
        ( forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
            (CommandScope -> Bool -> ConfigCmdSet
ConfigCmdSetSystemGhc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser CommandScope
scopeFlag forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
boolArgument)
            (forall a. String -> InfoMod a
OA.progDesc
               String
"Configure whether Stack should use a system GHC installation \
               \or not."))
    , forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command (Text -> String
T.unpack Text
configMonoidInstallGHCName)
        ( forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
            (CommandScope -> Bool -> ConfigCmdSet
ConfigCmdSetInstallGhc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser CommandScope
scopeFlag forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
boolArgument)
            (forall a. String -> InfoMod a
OA.progDesc
               String
"Configure whether Stack should automatically install GHC when \
               \necessary."))
    ]

scopeFlag :: OA.Parser CommandScope
scopeFlag :: Parser CommandScope
scopeFlag = forall a. a -> a -> Mod FlagFields a -> Parser a
OA.flag
  CommandScope
CommandScopeProject
  CommandScope
CommandScopeGlobal
  (  forall (f :: * -> *) a. HasName f => String -> Mod f a
OA.long String
"global"
  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
OA.help
       String
"Modify the user-specific global configuration file ('config.yaml') \
       \instead of the project-level configuration file ('stack.yaml')."
  )

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

boolArgument :: OA.Parser Bool
boolArgument :: Parser Bool
boolArgument = forall a. ReadM a -> Mod ArgumentFields a -> Parser a
OA.argument
  ReadM Bool
readBool
  (  forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
OA.metavar String
"true|false"
  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasCompleter f => [String] -> Mod f a
OA.completeWith [String
"true", String
"false"]
  )

configCmdEnvParser :: OA.Parser EnvSettings
configCmdEnvParser :: Parser EnvSettings
configCmdEnvParser = Bool -> Bool -> Bool -> Bool -> Bool -> EnvSettings
EnvSettings
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
True String
"locals" String
"include local package information" forall a. Monoid a => a
mempty
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
True
        String
"ghc-package-path" String
"set GHC_PACKAGE_PATH environment variable" forall a. Monoid a => a
mempty
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
True String
"stack-exe" String
"set STACK_EXE environment variable" forall a. Monoid a => a
mempty
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
False
        String
"locale-utf8" String
"set the GHC_CHARENC environment variable to UTF-8" forall a. Monoid a => a
mempty
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
False
        String
"keep-ghc-rts" String
"keep any GHCRTS environment variable" forall a. Monoid a => a
mempty

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

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

        Builder
"'; export " forall a. Semigroup a => a -> a -> a
<>
        Text -> Builder
encodeUtf8Builder Text
key forall a. Semigroup a => a -> a -> a
<> Builder
";\n"
      escape :: Char -> Text
escape Char
'\'' = Text
"'\"'\"'"
      escape Char
c = Char -> Text
T.singleton Char
c
  forall (m :: * -> *). MonadIO m => Handle -> Builder -> m ()
hPutBuilder Handle
stdout forall a b. (a -> b) -> a -> b
$ forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey Text -> EnvVarAction -> Builder
toLine Map Text EnvVarAction
actions