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

{-|
Module      : Stack.ConfigCmd
Description : Make changes to project or global configuration.
License     : BSD-3-Clause

Make changes to project or global configuration.
-}

module Stack.ConfigCmd
  ( cfgCmdSet
  , cfgCmdSetName
  , cfgCmdEnv
  , cfgCmdEnvName
  , cfgCmdBuildFiles
  , cfgCmdBuildFilesName
  , 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, string, takeText, takeWhile
                   , takeWhile1
                   )
import qualified Data.Map.Merge.Strict as Map
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import           Pantry ( loadSnapshot )
import           Path ( (</>), parent )
import qualified RIO.Map as Map
import           RIO.NonEmpty ( nonEmpty )
import qualified RIO.NonEmpty as NE
import           RIO.Process ( envVarsL )
import           Stack.Config
                   ( makeConcreteSnapshot, getProjectConfig
                   , getImplicitGlobalProjectDir
                   )
import           Stack.Constants ( stackDotYaml )
import           Stack.Prelude
import           Stack.Types.BuildConfig ( BuildConfig )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.ConfigMonoid
                   ( configMonoidInstallGHCName
                   , configMonoidInstallMsysName
                   , configMonoidRecommendStackUpgradeName
                   , configMonoidSystemGHCName
                   )
import           Stack.Types.ConfigSetOpts
                   ( CommandScope (..), ConfigCmdSet (..) ,configCmdSetScope )
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.Runner ( globalOptsL )
import           Stack.Types.Snapshot ( AbstractSnapshot )
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

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."

-- | Function underlying Stack's @config set@ command.

cfgCmdSet ::
     (HasConfig env, HasGHCVariant env)
  => ConfigCmdSet -> RIO env ()
cfgCmdSet :: forall env.
(HasConfig env, HasGHCVariant env) =>
ConfigCmdSet -> RIO env ()
cfgCmdSet ConfigCmdSet
cmd = do
  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
  configFilePath <-
    case configCmdSetScope cmd of
      CommandScope
CommandScopeProject -> do
        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 (.stackYaml)
        mstackYaml <- getProjectConfig mstackYamlOption
        case 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 -> RIO env (Path Abs Dir)
forall env. HasConfig env => RIO env (Path Abs Dir)
getImplicitGlobalProjectDir RIO env (Path Abs Dir)
-> (Path Abs Dir -> Path Abs File) -> RIO env (Path Abs File)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (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)
          PCNoProject [RawPackageLocationImmutable]
_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
conf.userGlobalConfigFile
  rawConfig <- liftIO (readFileUtf8 (toFilePath configFilePath))
  config <- either throwM pure (Yaml.decodeEither' $ encodeUtf8 rawConfig)
  newValue <- cfgCmdSetValue (parent configFilePath) cmd
  let yamlLines = Text -> [Text]
T.lines Text
rawConfig
      cmdKeys = ConfigCmdSet -> NonEmpty (NonEmpty Text)
cfgCmdSetKeys ConfigCmdSet
cmd  -- 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 = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
configFilePath  -- String

      hits = [Maybe (Text, Value)] -> [(Text, Value)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Text, Value)] -> [(Text, Value)])
-> [Maybe (Text, Value)] -> [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Maybe (Text, Value)) -> [Maybe (Text, Value)]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (Maybe (Text, Value)) -> [Maybe (Text, Value)])
-> NonEmpty (Maybe (Text, Value)) -> [Maybe (Text, Value)]
forall a b. (a -> b) -> a -> b
$ (NonEmpty Text -> Maybe (Text, Value))
-> NonEmpty (NonEmpty Text) -> NonEmpty (Maybe (Text, Value))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (Value -> NonEmpty Text -> Maybe (Text, Value)
inConfig Value
config) NonEmpty (NonEmpty Text)
cmdKeys
      primaryCmdKey = NonEmpty Text -> Text
forall a. NonEmpty a -> a
NE.last (NonEmpty Text -> Text) -> NonEmpty Text -> Text
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty Text) -> NonEmpty Text
forall a. NonEmpty a -> a
NE.head NonEmpty (NonEmpty Text)
cmdKeys
  newYamlLines <- case hits of
    [] -> 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 (NonEmpty Text) -> NonEmpty Text
forall a. NonEmpty a -> a
NE.head NonEmpty (NonEmpty Text)
cmdKeys) Text
Item [Text]
newValue'
    [(Text
cmdKey, Value
oldValue)] -> if Value
oldValue Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
newValue Bool -> Bool -> Bool
&& Text
cmdKey Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
primaryCmdKey
      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 do
        Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
cmdKey Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
primaryCmdKey) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
          StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               [StyleDoc] -> StyleDoc
fillSep
                 [ Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
configFilePath
                 , String -> StyleDoc
flow String
"contained a synonym for"
                 , Style -> StyleDoc -> StyleDoc
style Style
Target (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
primaryCmdKey)
                 , StyleDoc -> StyleDoc
parens (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
"which has been replaced."
                 ]
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        Path Abs File
-> Text -> Text -> Text -> [Text] -> [Text] -> RIO env [Text]
forall {m :: * -> *} {a} {env}.
(Pretty a, MonadIO m, MonadReader env m, HasTerm env) =>
a -> Text -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine Path Abs File
configFilePath Text
cmdKey Text
primaryCmdKey Text
newValue' [] [Text]
yamlLines
    [(Text, Value)]
_ -> do
      -- In practice, this warning should not be encountered because with

      -- snapshot and resolver present, Stack will not parse the YAML file.

      [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
        [ Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
configFilePath
        , String -> StyleDoc
flow String
"contains more than one possible existing configuration and, \
               \consequently, remains unchanged."
        ]
      [Text] -> RIO env [Text]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
yamlLines
  liftIO $ writeFileUtf8 file (T.unlines 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 [Item t] -> Maybe (NonEmpty (Item t))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Item t] -> Maybe (NonEmpty (Item t)))
-> [Item t] -> Maybe (NonEmpty (Item t))
forall a b. (a -> b) -> a -> b
$ NonEmpty (Item t) -> [Item t]
forall a. NonEmpty a -> [a]
NE.tail NonEmpty (Item t)
cmdKeys of
      Maybe (NonEmpty (Item t))
Nothing -> 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]
      Just NonEmpty (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
"  ")
                   NonEmpty (Item t)
ks
                   Item t
value

  inConfig :: Value -> NonEmpty Text -> Maybe (Text, Value)
inConfig Value
v NonEmpty Text
cmdKeys = case Value
v of
    Yaml.Object Object
obj ->
      let cmdKey :: Text
cmdKey = NonEmpty Text -> Text
forall a. NonEmpty a -> a
NE.head NonEmpty Text
cmdKeys
      in  case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
cmdKey) Object
obj of
            Maybe Value
Nothing -> Maybe (Text, Value)
forall a. Maybe a
Nothing
            Just Value
v' -> case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Text] -> Maybe (NonEmpty Text))
-> [Text] -> Maybe (NonEmpty Text)
forall a b. (a -> b) -> a -> b
$ NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.tail NonEmpty Text
cmdKeys of
              Maybe (NonEmpty Text)
Nothing -> (Text, Value) -> Maybe (Text, Value)
forall a. a -> Maybe a
Just (Text
cmdKey, Value
v')
              Just NonEmpty Text
ks -> Value -> NonEmpty Text -> Maybe (Text, Value)
inConfig Value
v' NonEmpty Text
ks
    Value
_ -> Maybe (Text, Value)
forall a. Maybe a
Nothing

  switchLine :: a -> Text -> Text -> Text -> [Text] -> [Text] -> m [Text]
switchLine a
file Text
cmdKey Text
_ 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
"was not found in YAML file"
      , a -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty a
file
      , String -> StyleDoc
flow String
"in the form"
      , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"key: value"
      , String -> StyleDoc
flow String
"on a single line. Multi-line formats for existing keys are not \
             \supported by the"
      , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"config set"
      , String -> StyleDoc
flow String
"commands. The file's contents have not been changed."
      ]
    [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
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] -> [Text] -> m [Text]
switchLine a
file Text
cmdKey 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
    spaces1 <- (Char -> Bool) -> Parser Text
P.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
    kt <- parseKey key
    spaces2 <- P.takeWhile (== ' ')
    skip (== ':')
    spaces3 <- P.takeWhile1 (== ' ')
    -- This assumes that the existing value contains no space characters, which

    -- is tolerable for current purposes.

    void $ takeWhile1 (/= ' ')
    -- This assumes that anything that follows the existing value is a comment,

    -- which is tolerable for current purposes.

    comment <- takeText
    pure (kt, spaces1, spaces2, spaces3, 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 -> Parser Text
P.string Text
key
    pure 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 -> Parser Text
P.string Text
key
    skip (==c)
    pure 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 (ConfigCmdSetSnapshot Unresolved AbstractSnapshot
newSnapshot) =
  Path Abs Dir -> Unresolved AbstractSnapshot -> RIO env Value
forall env.
HasConfig env =>
Path Abs Dir -> Unresolved AbstractSnapshot -> RIO env Value
snapshotValue Path Abs Dir
root Unresolved AbstractSnapshot
newSnapshot
cfgCmdSetValue Path Abs Dir
root (ConfigCmdSetResolver Unresolved AbstractSnapshot
newSnapshot) =
  Path Abs Dir -> Unresolved AbstractSnapshot -> RIO env Value
forall env.
HasConfig env =>
Path Abs Dir -> Unresolved AbstractSnapshot -> RIO env Value
snapshotValue Path Abs Dir
root Unresolved AbstractSnapshot
newSnapshot
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
_ (ConfigCmdSetInstallMsys 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
_ (ConfigCmdSetRecommendStackUpgrade 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

snapshotValue ::
     HasConfig env
  => Path Abs Dir -- ^ root directory of project

  -> Unresolved AbstractSnapshot
  -> RIO env Yaml.Value
snapshotValue :: forall env.
HasConfig env =>
Path Abs Dir -> Unresolved AbstractSnapshot -> RIO env Value
snapshotValue Path Abs Dir
root Unresolved AbstractSnapshot
snapshot = do
  snapshot' <- Maybe (Path Abs Dir)
-> Unresolved AbstractSnapshot -> RIO env AbstractSnapshot
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 AbstractSnapshot
snapshot
  concreteSnapshot <- makeConcreteSnapshot snapshot'
  -- Check that the snapshot actually exists

  void $ loadSnapshot =<< completeSnapshotLocation concreteSnapshot
  pure (Yaml.toJSON concreteSnapshot)

cfgCmdSetKeys :: ConfigCmdSet -> NonEmpty (NonEmpty Text)
cfgCmdSetKeys :: ConfigCmdSet -> NonEmpty (NonEmpty Text)
cfgCmdSetKeys (ConfigCmdSetSnapshot Unresolved AbstractSnapshot
_) = [[Text
Item (NonEmpty Text)
"snapshot"], [Text
Item (NonEmpty Text)
"resolver"]]
cfgCmdSetKeys (ConfigCmdSetResolver Unresolved AbstractSnapshot
_) = [[Text
Item (NonEmpty Text)
"resolver"], [Text
Item (NonEmpty Text)
"snapshot"]]
cfgCmdSetKeys (ConfigCmdSetSystemGhc CommandScope
_ Bool
_) = [[Text
Item (NonEmpty Text)
configMonoidSystemGHCName]]
cfgCmdSetKeys (ConfigCmdSetInstallGhc CommandScope
_ Bool
_) = [[Text
Item (NonEmpty Text)
configMonoidInstallGHCName]]
cfgCmdSetKeys (ConfigCmdSetInstallMsys CommandScope
_ Bool
_) = [[Text
Item (NonEmpty Text)
configMonoidInstallMsysName]]
cfgCmdSetKeys (ConfigCmdSetRecommendStackUpgrade CommandScope
_ Bool
_) =
  [[Text
Item (NonEmpty Text)
configMonoidRecommendStackUpgradeName]]
cfgCmdSetKeys (ConfigCmdSetDownloadPrefix CommandScope
_ Text
_) =
  [[Text
Item (NonEmpty Text)
"package-index", Text
Item (NonEmpty Text)
"download-prefix"]]

-- | The name of Stack's @config@ command.

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

-- | The name of Stack's @config@ command's @set@ subcommand.

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

-- | The name of Stack's @config@ command's @env@ subcommand.

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

-- | The name of Stack's @config@ command's @build-files@ subcommand.

cfgCmdBuildFilesName :: String
cfgCmdBuildFilesName :: String
cfgCmdBuildFilesName = String
"build-files"

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

-- | Function underlying Stack's @config env@ command.

cfgCmdEnv :: EnvSettings -> RIO EnvConfig ()
cfgCmdEnv :: EnvSettings -> RIO EnvConfig ()
cfgCmdEnv EnvSettings
es = do
  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
  mkPC <- view $ configL . to (.processContextSettings)
  pc <- liftIO $ mkPC es
  let 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 = 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
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
c = Char -> Text
T.singleton Char
c
  putBuilder $ Map.foldMapWithKey toLine actions

-- | This function takes no settings and yields no action of interest. It is

-- 'Stack.Config.withBuildConfig' that yields the desired actions.

cfgCmdBuildFiles :: () -> RIO BuildConfig ()
cfgCmdBuildFiles :: () -> RIO BuildConfig ()
cfgCmdBuildFiles () = () -> RIO BuildConfig ()
forall a. a -> RIO BuildConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()