diff --git a/doc/GUIDE_advanced.md b/doc/GUIDE_advanced.md index bdf6e65c48..78bde95a71 100644 --- a/doc/GUIDE_advanced.md +++ b/doc/GUIDE_advanced.md @@ -78,36 +78,52 @@ the command, see the [build command](build_command.md) documentation. ## The `stack config` commands -The `stack config` commands provide assistence with accessing or modifying +The `stack config` commands provide assistance with accessing or modifying Stack's configuration. See `stack config` for the available commands. -## The `stack config env` command +## The `stack config dump-*` commands -`stack config env` outputs a script that sets or unsets environment variables -for a Stack environment. Flags modify the script that is output: +These commands dump YAML but can dump JSON with an added `--json` flag. -* `--[no-]locals` (enabled by default) include/exclude local package information -* `--[no-]ghc-package-path` (enabled by default) set `GHC_PACKAGE_PATH` - environment variable or not -* `--[no-]stack-exe` (enabled by default) set `STACK_EXE` environment variable - or not -* `--[no-]locale-utf8` (disabled by default) set the `GHC_CHARENC` - environment variable to `UTF-8` or not -* `--[no-]keep-ghc-rts` (disabled by default) keep/discard any `GHCRTS` - environment variable +## The `stack config dump-project` command + +The `stack config dump-project` command dumps project-only configuration. Any +non-project configuration in the project is removed. + +## The `stack config dump-stack` command + +The `stack config dump-stack` command dumps configuration related to the +operation of stack itself. This is non-project configuration. With `--lens` we +can look at the configuration coming from the global settings, from stack +settings within the project or the effective combination from those two +locations. + +## The `stack config get` commands + +The `stack config get` commands gets values of keys in YAML configuration +files but only those that can also be set. + +## The `stack config get resolver` command + +Gets the effective resolver. + +## The `stack config get *-ghc` commands + +The `--global` option will get these settings' global value. + +## The `stack config get system-ghc` commands + +Gets whether stack should use the system GHC installation. + +## The `stack config get install-ghc` command + +Gets whether stack should install GHC by itself. ## The `stack config set` commands The `stack config set` commands allow the values of keys in YAML configuration files to be set. See `stack config set` for the available keys. -## The `stack config set install-ghc` command - -`stack config set install-ghc true` or `false` sets the `install-ghc` key in a -YAML configuration file, accordingly. By default, the project-level -configuration file (`stack.yaml`) is altered. The `--global` flag specifies the -user-specific global configuration file (`config.yaml`). - ## The `stack config set resolver` command `stack config set resolver ` sets the `resolver` key in the @@ -128,6 +144,28 @@ YAML configuration file, accordingly. By default, the project-level configuration file (`stack.yaml`) is altered. The `--global` flag specifies the user-specific global configuration file (`config.yaml`). +## The `stack config set install-ghc` command + +`stack config set install-ghc true` or `false` sets the `install-ghc` key in a +YAML configuration file, accordingly. By default, the project-level +configuration file (`stack.yaml`) is altered. The `--global` flag specifies the +user-specific global configuration file (`config.yaml`). + +## The `stack config env` command + +`stack config env` outputs a script that sets or unsets environment variables +for a Stack environment. Flags modify the script that is output: + +* `--[no-]locals` (enabled by default) include/exclude local package information +* `--[no-]ghc-package-path` (enabled by default) set `GHC_PACKAGE_PATH` + environment variable or not +* `--[no-]stack-exe` (enabled by default) set `STACK_EXE` environment variable + or not +* `--[no-]locale-utf8` (disabled by default) set the `GHC_CHARENC` + environment variable to `UTF-8` or not +* `--[no-]keep-ghc-rts` (disabled by default) keep/discard any `GHCRTS` + environment variable + ## The `stack dot` command If you'd like to get some insight into the dependency tree of your packages, you diff --git a/package.yaml b/package.yaml index 750ca894d7..1f84ee9fee 100644 --- a/package.yaml +++ b/package.yaml @@ -52,6 +52,7 @@ dependencies: - base >= 4.16.3.0 && < 5 - Cabal >= 3.6.3.0 - aeson >= 2.0.3.0 +- aeson-pretty - annotated-wl-pprint - ansi-terminal - array diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index b5d45d51fb..47cebcc951 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -1,24 +1,57 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} -- | Make changes to project or global configuration. module Stack.ConfigCmd - (ConfigCmdSet(..) + (cfgCmdName + + -- * config dump project + ,ConfigCmdDumpProject(..) + ,configCmdDumpProjectParser + ,cfgCmdDumpProject + ,cfgCmdDumpProjectName + + -- * config dump stack + ,ConfigCmdDumpStack(..) + ,configCmdDumpStackParser + ,cfgCmdDumpStack + ,cfgCmdDumpStackName + + -- * config get + ,ConfigCmdGet(..) + ,configCmdGetParser + ,cfgCmdGet + ,cfgCmdGetName + + -- * config set + ,ConfigCmdSet(..) ,configCmdSetParser ,cfgCmdSet ,cfgCmdSetName + + -- * config env ,configCmdEnvParser ,cfgCmdEnv ,cfgCmdEnvName - ,cfgCmdName) where + ) where import Stack.Prelude import Data.Coerce (coerce) +import Pantry.Internal.AesonExtended + (ToJSON(..), FromJSON, (.=), WithJSONWarnings (WithJSONWarnings), object) +import Data.Aeson.Encode.Pretty (encodePretty, encodePretty', confCompare) +import qualified Data.Aeson.Encode.Pretty as Aeson (defConfig) import qualified Data.Aeson.Key as Key +import Data.Aeson.KeyMap (KeyMap) import qualified Data.Aeson.KeyMap as KeyMap import Data.ByteString.Builder (byteString) import qualified Data.Map.Merge.Strict as Map @@ -39,63 +72,229 @@ import Stack.Types.Resolver import System.Environment (getEnvironment) import Stack.YamlUpdate +data ConfigDumpFormat = ConfigDumpYaml | ConfigDumpJson + +-- | Dump project configuration settings. +newtype ConfigCmdDumpProject = ConfigCmdDumpProject ConfigDumpFormat + +-- | Dump stack's own settings. Configuration related to its own opertion. This +-- can be defaulted or stored in a global location or project location or both, +-- in @~\/.stack\/config.yaml@ or @stack.yaml@. +data ConfigCmdDumpStack = ConfigCmdDumpStack DumpStackScope ConfigDumpFormat + +-- | Get configuration items that can be individually set by `stack config set`. +data ConfigCmdGet + = ConfigCmdGetResolver + | ConfigCmdGetSystemGhc CommandScope + | ConfigCmdGetInstallGhc CommandScope + +-- | Set the resolver for the project or set compiler-related configuration at +-- project or global scope. data ConfigCmdSet = ConfigCmdSetResolver (Unresolved AbstractResolver) - | ConfigCmdSetSystemGhc CommandScope - Bool - | ConfigCmdSetInstallGhc CommandScope - Bool + | ConfigCmdSetSystemGhc CommandScope Bool + | ConfigCmdSetInstallGhc CommandScope Bool +-- | Where to get the configuration settings from. data CommandScope = CommandScopeGlobal - -- ^ Apply changes to the global configuration, - -- typically at @~/.stack/config.yaml@. + -- ^ Apply changes to or get settings from the global configuration, + -- typically at @~\/.stack\/config.yaml@. | CommandScopeProject - -- ^ Apply changes to the project @stack.yaml@. + -- ^ Apply changes to or get settings from the project @stack.yaml@. + +-- | Where to get the configuration settings from. +data DumpStackScope + = DumpStackScopeEffective + -- ^ A view of settings where those settings in the project but related to + -- stack's own operation override settings in the global location. + | DumpStackScopeGlobal + -- ^ Apply changes to or get settings from the global configuration, + -- typically at @~\/.stack\/config.yaml@. + | DumpStackScopeProject + -- ^ Apply changes to or get settings from the project @stack.yaml@. + +instance Display CommandScope where + display CommandScopeProject = "project" + display CommandScopeGlobal = "global" + +configCmdGetScope :: ConfigCmdGet -> CommandScope +configCmdGetScope ConfigCmdGetResolver = CommandScopeProject +configCmdGetScope (ConfigCmdGetSystemGhc scope) = scope +configCmdGetScope (ConfigCmdGetInstallGhc scope) = scope configCmdSetScope :: ConfigCmdSet -> CommandScope configCmdSetScope (ConfigCmdSetResolver _) = CommandScopeProject configCmdSetScope (ConfigCmdSetSystemGhc scope _) = scope configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope -cfgCmdSet - :: (HasConfig env, HasGHCVariant env) - => ConfigCmdSet -> RIO env () -cfgCmdSet cmd = do +encodeDumpProject :: RawYaml -> ConfigDumpFormat -> Project -> ByteString +encodeDumpProject rawConfig format p + | ConfigDumpYaml <- format = dumpProject (\e d -> + either (const e) encodeUtf8 (cfgRedress rawConfig d "")) + | ConfigDumpJson <- format = dumpProject (\_ d -> + toStrictBytes $ encodePretty' (cfgPretty d) d) + where + -- REVIEW: Is there a way to encode straight to keymap? + -- encode project to bytestring then decode to keymap. + dumpProject f = let e = Yaml.encode p in Yaml.decodeEither' e & + either (const e) (\(d :: KeyMap Yaml.Value) -> f e d) + + cfgPretty d = Aeson.defConfig{confCompare = cfgKeyCompare rawConfig d ""} + +cfgKeyCompare :: RawYaml -> KeyMap Yaml.Value -> Text -> (Text -> Text -> Ordering) +cfgKeyCompare (yamlLines -> configLines) (fmap Key.toText . KeyMap.keys -> keys) cmdKey = + compareInOrder configLines (coerce keys) (coerce cmdKey) + +encodeDumpBy :: ToJSON a => (Config -> a) -> ConfigDumpFormat -> (Config -> ByteString) +encodeDumpBy f ConfigDumpYaml = Yaml.encode . f +encodeDumpBy f ConfigDumpJson = toStrictBytes . encodePretty . f + +encodeDumpStack :: ConfigDumpFormat -> (DumpStack -> ByteString) +encodeDumpStack ConfigDumpYaml = Yaml.encode +encodeDumpStack ConfigDumpJson = toStrictBytes . encodePretty + +cfgReadProject :: (HasConfig env, HasLogFunc env) => CommandScope -> RIO env (Maybe Project) +cfgReadProject scope = do + (configFilePath, yamlConfig) <- cfgRead scope + let parser = parseProjectAndConfigMonoid (parent configFilePath) + case Yaml.parseEither parser yamlConfig of + Left err -> logError (display $ T.pack err) >> return Nothing + Right (WithJSONWarnings res _warnings) -> liftIO res >>= + \(ProjectAndConfigMonoid project _) -> return $ Just project + +cfgCmdDumpProject :: (HasConfig env, HasLogFunc env) => ConfigCmdDumpProject -> RIO env () +cfgCmdDumpProject (ConfigCmdDumpProject dumpFormat) = do + configFilePath <- cfgLocation CommandScopeProject + rawConfig <- mkRaw <$> liftIO (readFileUtf8 (toFilePath configFilePath)) + project <- cfgReadProject CommandScopeProject + project & maybe (logError "Couldn't find project") (\p -> + encodeDumpProject rawConfig dumpFormat p + & decodeUtf8' + & either throwM (logInfo . display)) + +-- | The subset of stack's configuration that we dump. +data DumpStack = + DumpStack + { dsInstallGHC :: !(Maybe Bool) + , dsSystemGHC :: !(Maybe Bool) + } + +instance ToJSON DumpStack where + toJSON DumpStack{..} = object + [ "install-GHC" .= toJSON dsInstallGHC + , "system-GHC" .= toJSON dsSystemGHC + ] + +cfgCmdDumpStack :: (HasConfig env, HasLogFunc env) => ConfigCmdDumpStack -> RIO env () +cfgCmdDumpStack (ConfigCmdDumpStack scope dumpFormat) = dumpFormat & case scope of + DumpStackScopeEffective -> cfgCmdDumpStackEffective + DumpStackScopeProject -> cfgDumpStack CommandScopeProject + DumpStackScopeGlobal -> cfgDumpStack CommandScopeGlobal + +cfgDumpStack + :: (HasConfig env, HasLogFunc env) + => CommandScope -> ConfigDumpFormat -> RIO env () +cfgDumpStack scope dumpFormat = do + (configFilePath, yamlConfig) <- cfgRead scope + let parser = parseConfigMonoid (parent configFilePath) + case Yaml.parseEither parser yamlConfig of + Left err -> logError . display $ T.pack err + Right (WithJSONWarnings config _warnings) -> do + let dsSystemGHC = getFirst $ configMonoidSystemGHC config + let dsInstallGHC = getFirstTrue $ configMonoidInstallGHC config + + DumpStack{..} + & encodeDumpStack dumpFormat + & decodeUtf8' + & either throwM (logInfo . display) + +cfgCmdDumpStackEffective :: (HasConfig env, HasLogFunc env) => ConfigDumpFormat -> RIO env () +cfgCmdDumpStackEffective dumpFormat = do + conf <- view configL + let f Config{..} = + DumpStack + { dsInstallGHC = Just configInstallGHC + , dsSystemGHC = Just configSystemGHC + } + conf + & encodeDumpBy f dumpFormat + & decodeUtf8' + & either throwM (logInfo . display) + +cfgCmdGet :: (HasConfig env, HasLogFunc env) => ConfigCmdGet -> RIO env () +cfgCmdGet cmd = do + let logBool maybeValue = logInfo $ + maybe "default" (display . T.toLower . T.pack . show) maybeValue + + (configFilePath, yamlConfig) <- cfgRead (configCmdGetScope cmd) + let parser = parseProjectAndConfigMonoid (parent configFilePath) + case Yaml.parseEither parser yamlConfig of + Left err -> logError . display $ T.pack err + Right (WithJSONWarnings res _warnings) -> do + ProjectAndConfigMonoid project config <- liftIO res + cmd & \case + ConfigCmdGetResolver -> + logInfo . display $ projectResolver project + ConfigCmdGetSystemGhc{} -> + logBool (getFirst $ configMonoidSystemGHC config) + ConfigCmdGetInstallGhc{} -> + logBool (getFirstTrue $ configMonoidInstallGHC config) + +-- | Configuration location for a scope. Typically: +-- * at @~\/.stack\/config.yaml@ for global scope. +-- * at @.\/stack.yaml@ by default or from the @--stack-yaml@ option for project scope. +cfgLocation :: HasConfig s => CommandScope -> RIO s (Path Abs File) +cfgLocation scope = do conf <- view configL - configFilePath <- - case configCmdSetScope cmd of - CommandScopeProject -> do - mstackYamlOption <- view $ globalOptsL.to globalStackYaml - mstackYaml <- getProjectConfig mstackYamlOption - case mstackYaml of - PCProject stackYaml -> return stackYaml - PCGlobalProject -> liftM ( stackDotYaml) (getImplicitGlobalProjectDir conf) - PCNoProject _extraDeps -> throwString "config command used when no project configuration available" -- maybe modify the ~/.stack/config.yaml file instead? - CommandScopeGlobal -> return (configUserConfigPath conf) + case scope of + CommandScopeProject -> do + mstackYamlOption <- view $ globalOptsL.to globalStackYaml + mstackYaml <- getProjectConfig mstackYamlOption + case mstackYaml of + PCProject stackYaml -> return stackYaml + PCGlobalProject -> liftM ( stackDotYaml) (getImplicitGlobalProjectDir conf) + PCNoProject _extraDeps -> + -- REVIEW: Maybe modify the ~/.stack/config.yaml file instead? + throwString "config command used when no project configuration available" + CommandScopeGlobal -> return (configUserConfigPath conf) + +cfgRead :: (HasConfig s, FromJSON a) => CommandScope -> RIO s (Path Abs File, a) +cfgRead scope = do + configFilePath <- cfgLocation scope + + -- We don't need to worry about checking for a valid yaml here + liftIO (Yaml.decodeFileEither (toFilePath configFilePath)) >>= + either throwM (return . (configFilePath,)) + +cfgRedress :: RawYaml -> KeyMap Yaml.Value -> Text -> Either UnicodeException Text +cfgRedress (yamlLines -> configLines) config@(fmap Key.toText . KeyMap.keys -> keys) cmdKey = + unmkRaw . redress configLines <$> + encodeInOrder configLines (coerce keys) (coerce cmdKey) config + +cfgRedressWrite :: RawYaml -> KeyMap Yaml.Value -> Text -> (Text -> RIO env ()) -> RIO env () +cfgRedressWrite rawConfig config cmdKey write = + either throwM write (cfgRedress rawConfig config cmdKey) + +cfgCmdSet :: (HasConfig env, HasGHCVariant env) => ConfigCmdSet -> RIO env () +cfgCmdSet cmd = do -- We don't need to worry about checking for a valid yaml here + configFilePath <- cfgLocation $ configCmdSetScope cmd rawConfig <- mkRaw <$> liftIO (readFileUtf8 (toFilePath configFilePath)) (config :: Yaml.Object) <- either throwM return (Yaml.decodeEither' . encodeUtf8 $ coerce rawConfig) newValue <- cfgCmdSetValue (parent configFilePath) cmd let cmdKey = cfgCmdSetOptionName cmd config' = KeyMap.insert (Key.fromText cmdKey) newValue config - yamlKeys = Key.toText <$> KeyMap.keys config if config' == config then logInfo (fromString (toFilePath configFilePath) <> " already contained the intended configuration and remains \ \unchanged.") - else do - let configLines = yamlLines rawConfig - either - throwM - (\updated -> do - let redressed = unmkRaw $ redress configLines updated - writeBinaryFileAtomic configFilePath . byteString $ encodeUtf8 redressed - - let file = fromString $ toFilePath configFilePath - logInfo (file <> " has been updated.")) - (encodeInOrder configLines (coerce yamlKeys) (coerce cmdKey) config') + else cfgRedressWrite rawConfig config' cmdKey (\redressed -> do + writeBinaryFileAtomic configFilePath . byteString $ encodeUtf8 redressed + + let file = fromString $ toFilePath configFilePath + logInfo (file <> " has been updated.")) cfgCmdSetValue :: (HasConfig env, HasGHCVariant env) @@ -117,15 +316,51 @@ cfgCmdSetOptionName (ConfigCmdSetResolver _) = "resolver" cfgCmdSetOptionName (ConfigCmdSetSystemGhc _ _) = configMonoidSystemGHCName cfgCmdSetOptionName (ConfigCmdSetInstallGhc _ _) = configMonoidInstallGHCName -cfgCmdName :: String +cfgCmdName, cfgCmdGetName, cfgCmdSetName, cfgCmdEnvName :: String +cfgCmdDumpProjectName, cfgCmdDumpStackName :: String cfgCmdName = "config" - -cfgCmdSetName :: String +cfgCmdDumpProjectName = "dump-project" +cfgCmdDumpStackName = "dump-stack" +cfgCmdGetName = "get" cfgCmdSetName = "set" - -cfgCmdEnvName :: String cfgCmdEnvName = "env" +configCmdDumpProjectParser :: OA.Parser ConfigCmdDumpProject +configCmdDumpProjectParser = ConfigCmdDumpProject <$> dumpFormatFlag + +configCmdDumpStackParser :: OA.Parser ConfigCmdDumpStack +configCmdDumpStackParser = ConfigCmdDumpStack <$> getDumpStackScope <*> dumpFormatFlag + +dumpFormatFlag :: OA.Parser ConfigDumpFormat +dumpFormatFlag = + OA.flag + ConfigDumpYaml + ConfigDumpJson + (OA.long "json" <> OA.help "Dump the configuration as JSON instead of as YAML") + +configCmdGetParser :: OA.Parser ConfigCmdGet +configCmdGetParser = + OA.hsubparser $ + mconcat + [ OA.command + "resolver" + (OA.info + (OA.pure ConfigCmdGetResolver) + (OA.progDesc "Gets the configured resolver.")) + , OA.command + (T.unpack configMonoidSystemGHCName) + (OA.info + (ConfigCmdGetSystemGhc <$> getScopeFlag) + (OA.progDesc + "Gets whether stack should use a system GHC installation or not.")) + , OA.command + (T.unpack configMonoidInstallGHCName) + (OA.info + (ConfigCmdGetInstallGhc <$> getScopeFlag) + (OA.progDesc + "Gets whether stack should automatically install GHC when necessary.")) + ] + configCmdSetParser :: OA.Parser ConfigCmdSet configCmdSetParser = OA.hsubparser $ mconcat @@ -140,36 +375,51 @@ configCmdSetParser = OA.hsubparser $ "Change the resolver of the current project.")) , OA.command (T.unpack configMonoidSystemGHCName) ( OA.info - (ConfigCmdSetSystemGhc <$> scopeFlag <*> boolArgument) + (ConfigCmdSetSystemGhc <$> setScopeFlag <*> boolArgument) (OA.progDesc "Configure whether Stack should use a system GHC installation \ \or not.")) , OA.command (T.unpack configMonoidInstallGHCName) ( OA.info - (ConfigCmdSetInstallGhc <$> scopeFlag <*> boolArgument) + (ConfigCmdSetInstallGhc <$> setScopeFlag <*> boolArgument) (OA.progDesc "Configure whether Stack should automatically install GHC when \ \necessary.")) ] -scopeFlag :: OA.Parser CommandScope -scopeFlag = OA.flag - CommandScopeProject - CommandScopeGlobal - ( OA.long "global" - <> OA.help - "Modify the user-specific global configuration file ('config.yaml') \ - \instead of the project-level configuration file ('stack.yaml')." - ) +getScopeFlag, setScopeFlag :: OA.Parser CommandScope +getScopeFlag = scopeFlag "From" +setScopeFlag = scopeFlag "Modify" + +getDumpStackScope :: OA.Parser DumpStackScope +getDumpStackScope = OA.option readDumpStackScope + $ OA.long "lens" + <> OA.help "Which configuration to look at, project or global or effective (global with project overrides)." + <> OA.metavar "[project|global|effective]" + +scopeFlag :: String -> OA.Parser CommandScope +scopeFlag action = + OA.flag + CommandScopeProject + CommandScopeGlobal + (OA.long "global" <> + OA.help + (action <> + " the user-specific global configuration file ('config.yaml') \ + \instead of the project-level configuration file ('stack.yaml').")) + +readDumpStackScope :: OA.ReadM DumpStackScope +readDumpStackScope = OA.str >>= \case + ("effective" :: String) -> return DumpStackScopeEffective + "project" -> return DumpStackScopeProject + "global" -> return DumpStackScopeGlobal + _ -> OA.readerError "Accepted scopes are 'effective', 'project' and 'global'." readBool :: OA.ReadM Bool -readBool = do - s <- OA.readerAsk - case s of +readBool = OA.readerAsk >>= \case "true" -> return True "false" -> return False - _ -> OA.readerError ("Invalid value " ++ show s ++ - ": Expected \"true\" or \"false\"") + s -> OA.readerError ("Invalid value " ++ show s ++ ": Expected \"true\" or \"false\"") boolArgument :: OA.Parser Bool boolArgument = OA.argument diff --git a/src/Stack/YamlUpdate.hs b/src/Stack/YamlUpdate.hs index 131ae24045..9f28b17141 100644 --- a/src/Stack/YamlUpdate.hs +++ b/src/Stack/YamlUpdate.hs @@ -14,7 +14,8 @@ -- -- Use yamlLines to transform 'RawYaml' to ['RawYamlLine']. module Stack.YamlUpdate - ( encodeInOrder + ( compareInOrder + , encodeInOrder , redress , mkRaw , unmkRaw @@ -131,6 +132,27 @@ fetchInRange YamlLines{blanks, wholeLineComments, partLineComments} p = ps = filterLineNumber partLineComments in (ps, L.sortOn commentLineNumber $ ls ++ cs) +-- | From an ordered list of keys constructs a comparison respecting that order. +preservingCompare :: Ord a => Map Text a -> [Text] -> Text -> Text -> Text -> Ordering +preservingCompare ixMap keysFound k x y = + -- If updating then preserve order but if inserting then put last. + if | k `L.elem` keysFound -> Map.lookup x ixMap `compare` Map.lookup y ixMap + | k == x, k == y -> EQ + | k == x -> GT + | k == y -> LT + | otherwise -> Map.lookup x ixMap `compare` Map.lookup y ixMap + +-- | From an ordered list of YAML lines constructs a comparison respecting that order. +compareInOrder :: [RawYamlLine] + -> [YamlKey] + -> YamlKey + -> (Text -> Text -> Ordering) +compareInOrder rawLines keysFound (YamlKey k) = + let keyLine = findKeyLine rawLines + ixMap = Map.fromList $ (\yk@(YamlKey x) -> (x, keyLine yk)) <$> keysFound + + in preservingCompare ixMap (coerce <$> keysFound) k + -- | Uses the order of the keys in the original to preserve the order in the -- update except that inserting a key orders it last. encodeInOrder :: [RawYamlLine] @@ -138,21 +160,9 @@ encodeInOrder :: [RawYamlLine] -> YamlKey -> Yaml.Object -> Either UnicodeException RawYaml -encodeInOrder rawLines keysFound upsertKey@(YamlKey k) yObject = - let keyLine = findKeyLine rawLines - ixMap = Map.fromList $ (\yk@(YamlKey x) -> (x, keyLine yk)) <$> keysFound - preservingCompare x y = - -- If updating then preserve order but if inserting then put last. - if | upsertKey `L.elem` keysFound -> - Map.lookup x ixMap `compare` Map.lookup y ixMap - | k == x, k == y -> EQ - | k == x -> GT - | k == y -> LT - | otherwise -> Map.lookup x ixMap `compare` Map.lookup y ixMap - - keyCmp = Yaml.setConfCompare preservingCompare Yaml.defConfig - - in RawYaml <$> decodeUtf8' (Yaml.encodePretty keyCmp yObject) +encodeInOrder rawLines keysFound key yObject = + let keyCmp = Yaml.setConfCompare (compareInOrder rawLines keysFound key) Yaml.defConfig + in RawYaml <$> decodeUtf8' (Yaml.encodePretty keyCmp yObject) endSentinel :: Text endSentinel = diff --git a/src/main/Main.hs b/src/main/Main.hs index 619640ef17..a840f6bcc3 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -396,8 +396,20 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions ConfigCmd.cfgCmdName "Subcommands for accessing and modifying configuration values" (do + addCommand' ConfigCmd.cfgCmdDumpProjectName + "Dump project related configuration" + (withConfig NoReexec . cfgCmdDumpProject) + configCmdDumpProjectParser + addCommand' ConfigCmd.cfgCmdDumpStackName + "Dump stack operation related configuration" + (withConfig NoReexec . cfgCmdDumpStack) + configCmdDumpStackParser + addCommand' ConfigCmd.cfgCmdGetName + "Get the current value of a settable field of configuration" + (withConfig NoReexec . cfgCmdGet) + configCmdGetParser addCommand' ConfigCmd.cfgCmdSetName - "Sets a key in YAML configuration file to value" + "A very restricted subset of configuration can be set with this command" (withConfig NoReexec . cfgCmdSet) configCmdSetParser addCommand' ConfigCmd.cfgCmdEnvName diff --git a/stack.cabal b/stack.cabal index 62a7960ee3..2b1562a18c 100644 --- a/stack.cabal +++ b/stack.cabal @@ -229,6 +229,7 @@ library build-depends: Cabal >=3.6.3.0 , aeson >=2.0.3.0 + , aeson-pretty , annotated-wl-pprint , ansi-terminal , array @@ -353,6 +354,7 @@ executable stack build-depends: Cabal >=3.6.3.0 , aeson >=2.0.3.0 + , aeson-pretty , annotated-wl-pprint , ansi-terminal , array @@ -476,6 +478,7 @@ executable stack-integration-test build-depends: Cabal >=3.6.3.0 , aeson >=2.0.3.0 + , aeson-pretty , annotated-wl-pprint , ansi-terminal , array @@ -607,6 +610,7 @@ test-suite stack-test Cabal >=3.6.3.0 , QuickCheck , aeson >=2.0.3.0 + , aeson-pretty , annotated-wl-pprint , ansi-terminal , array