{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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 )
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
| CommandScopeProject
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
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
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
file :: String
file = forall b t. Path b t -> String
toFilePath Path Abs File
configFilePath
file' :: Utf8Builder
file' = forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
file
[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
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)
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
'"'
data KeyType
= PlainKey
| SingleQuotedKey
| DoubleQuotedKey
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
-> 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'
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
<>
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