{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigCmdException] -> ShowS
$cshowList :: [ConfigCmdException] -> ShowS
show :: ConfigCmdException -> String
$cshow :: ConfigCmdException -> String
showsPrec :: Int -> ConfigCmdException -> ShowS
$cshowsPrec :: Int -> ConfigCmdException -> ShowS
Show, Typeable)

instance Exception ConfigCmdException where
    displayException :: ConfigCmdException -> String
displayException ConfigCmdException
NoProjectConfigAvailable =
        String
"Error: [S-3136]\n"
        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 <- 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ConfigCmdException
NoProjectConfigAvailable
                         -- maybe modify the ~/.stack/config.yaml file instead?

                 CommandScope
CommandScopeGlobal -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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))
    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 (f :: * -> *) a. Applicative f => a -> f a
pure (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
        cmdKeys :: NonEmpty Text
cmdKeys = ConfigCmdSet -> NonEmpty Text
cfgCmdSetKeys ConfigCmdSet
cmd  -- Text

        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 Value -> NonEmpty Text -> Maybe Value
inConfig Value
config NonEmpty Text
cmdKeys 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
$ 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
"" NonEmpty Text
cmdKeys 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' (forall a. NonEmpty a -> a
NE.last NonEmpty Text
cmdKeys) 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
    -- 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 forall a. NonEmpty a -> [a]
NE.tail NonEmpty (Item t)
cmdKeys of
      [] -> t
yamlLines forall a. Semigroup a => a -> a -> a
<> [Item t
spaces forall a. Semigroup a => a -> a -> a
<> forall a. NonEmpty a -> a
NE.head NonEmpty (Item t)
cmdKeys forall a. Semigroup a => a -> a -> a
<> 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 forall a. Semigroup a => a -> a -> a
<> [Item t
spaces forall a. Semigroup a => a -> a -> a
<> forall a. NonEmpty a -> a
NE.head NonEmpty (Item t)
cmdKeys forall a. Semigroup a => a -> a -> a
<> Item t
":"])
                       (Item t
spaces forall a. Semigroup a => a -> a -> a
<> Item t
"  ")
                       (forall a. [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 forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText (forall a. NonEmpty a -> a
NE.head NonEmpty Text
cmdKeys)) Object
obj of
                Maybe Value
Nothing -> forall a. Maybe a
Nothing
                Just Value
v' -> case forall a. NonEmpty a -> [a]
NE.tail NonEmpty Text
cmdKeys of
                    [] -> forall a. a -> Maybe a
Just Value
v'
                    [Text]
ks -> Value -> NonEmpty Text -> Maybe Value
inConfig Value
v' (forall a. [a] -> NonEmpty a
NE.fromList [Text]
ks)
        Value
_ -> forall a. Maybe a
Nothing

    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, 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
spaces3, Text
comment) -> do
                let newLine :: Text
newLine = Text
spaces1 forall a. Semigroup a => a -> a -> a
<> Text -> KeyType -> Text
renderKey Text
cmdKey KeyType
kt forall a. Semigroup a => a -> a -> a
<> Text
spaces2 forall a. Semigroup a => a -> a -> a
<>
                        Text
":" forall a. Semigroup a => a -> a -> a
<> Text
spaces3 forall a. Semigroup a => a -> a -> a
<> Text
newValue forall a. Semigroup a => a -> a -> a
<> Text
comment
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
file forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" has been updated."
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Text]
searched forall a. Semigroup a => a -> a -> a
<> (Text
newLineforall a. a -> [a] -> [a]
:[Text]
rest)

    parseLine :: Text -> Parser (KeyType, Text, Text, Text, Text)
    parseLine :: Text -> Parser (KeyType, Text, Text, Text, Text)
parseLine Text
key = do
        Text
spaces1 <- (Char -> Bool) -> Parser Text
P.takeWhile (forall a. Eq a => a -> a -> Bool
== Char
' ')
        KeyType
kt <- Text -> Parser KeyType
parseKey Text
key
        Text
spaces2 <- (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
spaces3 <- (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
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
               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
P.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
P.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 (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. ToJSON a => a -> Value
Yaml.toJSON RawSnapshotLocation
concreteResolver)
cfgCmdSetValue Path Abs Dir
_ (ConfigCmdSetSystemGhc CommandScope
_ Bool
bool') = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> Value
Yaml.Bool Bool
bool'
cfgCmdSetValue Path Abs Dir
_ (ConfigCmdSetInstallGhc CommandScope
_ Bool
bool') = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> Value
Yaml.Bool Bool
bool'
cfgCmdSetValue Path Abs Dir
_ (ConfigCmdSetDownloadPrefix CommandScope
_ Text
url) = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
"resolver"]
cfgCmdSetKeys (ConfigCmdSetSystemGhc CommandScope
_ Bool
_) = [Text
configMonoidSystemGHCName]
cfgCmdSetKeys (ConfigCmdSetInstallGhc CommandScope
_ Bool
_) = [Text
configMonoidInstallGHCName]
cfgCmdSetKeys (ConfigCmdSetDownloadPrefix CommandScope
_ Text
_) =
    [Text
"package-index", 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 =
      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." ))
          , forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"package-index"
              ( forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
                  ( forall a. Mod CommandFields a -> Parser a
OA.hsubparser forall a b. (a -> b) -> a -> b
$
                      forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"download-prefix"
                        ( forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info
                            (   CommandScope -> Text -> ConfigCmdSet
ConfigCmdSetDownloadPrefix
                            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 Text
urlArgument )
                            ( forall a. String -> InfoMod a
OA.progDesc
                                String
"Configure download prefix for Stack's package \
                                \index." )))
                  ( forall a. String -> InfoMod a
OA.progDesc
                      String
"Configure Stack's package index" ))
          ]

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 (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    String
"false" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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"]
  )

urlArgument :: OA.Parser Text
urlArgument :: Parser Text
urlArgument = forall s. IsString s => Mod ArgumentFields s -> Parser s
OA.strArgument
  (  forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
OA.metavar String
"URL"
  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
OA.value Text
defaultDownloadPrefix
  forall a. Semigroup a => a -> a -> a
<> forall a (f :: * -> *). Show a => Mod f a
OA.showDefault
  forall a. Semigroup a => a -> a -> a
<> 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
  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