From 0efa40b69482c5c9ee96639878d86d40be8275b0 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Fri, 5 Aug 2022 15:16:50 -0400 Subject: [PATCH 01/13] Add config get and dump commands. Get the project resolver. Add config get commands. Get project system-ghc and install-ghc. Extract duplicated as logBool. Show scope. Don't log the key asked for. Should have been NoReexec. Get and Modify variants of scopeFlag help. Dump the project's configuration. Pipe to common functions for config list. Add scope and distinguish what is being dumped. Extract encodeDump* functions. First pass at dump-project and dump-stack. Separate project and stack dumps more. Add DumpStackScope and --lens option. Parse what is needed for the dump. Fix typos and improve help string. Allow for missing stack settings in the project. Fix a typo, aronud. Better explain effective scope. Drop the --global option when dumping the project. --- src/Stack/ConfigCmd.hs | 319 +++++++++++++++++++++++++++++++++++------ src/main/Main.hs | 14 +- 2 files changed, 288 insertions(+), 45 deletions(-) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index b5d45d51fb..faa2e82cd2 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -1,23 +1,53 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} -- | 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 qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap import Data.ByteString.Builder (byteString) @@ -39,40 +69,190 @@ 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 :: ConfigDumpFormat -> (Project -> ByteString) +encodeDumpProject ConfigDumpYaml = Yaml.encode +encodeDumpProject ConfigDumpJson = toStrictBytes . Aeson.encode + +encodeDumpStackBy :: ToJSON a => (Config -> a) -> ConfigCmdDumpStack -> (Config -> ByteString) +encodeDumpStackBy f (ConfigCmdDumpStack _ ConfigDumpYaml) = Yaml.encode . f +encodeDumpStackBy f (ConfigCmdDumpStack _ ConfigDumpJson) = toStrictBytes . Aeson.encode . f + +encodeDumpStack :: ConfigDumpFormat -> (DumpStack -> ByteString) +encodeDumpStack ConfigDumpYaml = Yaml.encode +encodeDumpStack ConfigDumpJson = toStrictBytes . Aeson.encode + +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 -> do + logError . display $ T.pack err + return Nothing + Right (WithJSONWarnings res _warnings) -> do + ProjectAndConfigMonoid project _ <- liftIO res + return $ Just project + +cfgCmdDumpProject :: (HasConfig env, HasLogFunc env) => ConfigCmdDumpProject -> RIO env () +cfgCmdDumpProject (ConfigCmdDumpProject dumpFormat) = do + project <- cfgReadProject CommandScopeProject + project & maybe (logError "Couldn't find project") (\p -> + encodeDumpProject dumpFormat p + & decodeUtf8' + & either throwM (logInfo . display)) + +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 cmd@(ConfigCmdDumpStack scope dumpFormat) + | DumpStackScopeEffective <- scope = cfgCmdDumpStackEffective cmd + | DumpStackScopeProject <- scope = cfgDumpStack CommandScopeProject dumpFormat + | DumpStackScopeGlobal <- scope = cfgDumpStack CommandScopeGlobal dumpFormat + +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) => ConfigCmdDumpStack -> RIO env () +cfgCmdDumpStackEffective cmd = do + conf <- view configL + let f Config{..} = + DumpStack + { dsInstallGHC = Just configInstallGHC + , dsSystemGHC = Just configSystemGHC + } + conf + & encodeDumpStackBy f cmd + & 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,)) + +cfgCmdSet :: (HasConfig env, HasGHCVariant env) => ConfigCmdSet -> RIO env () +cfgCmdSet cmd = do + configFilePath <- cfgLocation $ configCmdSetScope cmd -- We don't need to worry about checking for a valid yaml here rawConfig <- mkRaw <$> liftIO (readFileUtf8 (toFilePath configFilePath)) (config :: Yaml.Object) <- either throwM return (Yaml.decodeEither' . encodeUtf8 $ coerce rawConfig) @@ -117,15 +297,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 +356,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/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 From d1fc7a6689618aea73b6e65fffa4c3ec753d9b1c Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Sun, 4 Sep 2022 16:57:06 -0400 Subject: [PATCH 02/13] Redress the dump project YAML. --- src/Stack/ConfigCmd.hs | 42 +++++++++++++++++++++++++----------------- 1 file changed, 25 insertions(+), 17 deletions(-) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index faa2e82cd2..cf402167f8 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -8,6 +8,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} -- | Make changes to project or global configuration. module Stack.ConfigCmd @@ -49,6 +50,7 @@ import Pantry.Internal.AesonExtended (ToJSON(..), FromJSON, (.=), WithJSONWarnings (WithJSONWarnings), object) import qualified Data.Aeson as Aeson 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 @@ -125,9 +127,11 @@ configCmdSetScope (ConfigCmdSetResolver _) = CommandScopeProject configCmdSetScope (ConfigCmdSetSystemGhc scope _) = scope configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope -encodeDumpProject :: ConfigDumpFormat -> (Project -> ByteString) -encodeDumpProject ConfigDumpYaml = Yaml.encode -encodeDumpProject ConfigDumpJson = toStrictBytes . Aeson.encode +encodeDumpProject :: RawYaml -> ConfigDumpFormat -> Project -> ByteString +encodeDumpProject _ ConfigDumpJson = toStrictBytes . Aeson.encode +encodeDumpProject rawConfig ConfigDumpYaml = \p -> let e = Yaml.encode p in + Yaml.decodeEither' e & either (const e) (\(d :: KeyMap Yaml.Value) -> + either (const e) encodeUtf8 (cfgRedress rawConfig d "")) encodeDumpStackBy :: ToJSON a => (Config -> a) -> ConfigCmdDumpStack -> (Config -> ByteString) encodeDumpStackBy f (ConfigCmdDumpStack _ ConfigDumpYaml) = Yaml.encode . f @@ -151,9 +155,11 @@ cfgReadProject scope = do 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 dumpFormat p + encodeDumpProject rawConfig dumpFormat p & decodeUtf8' & either throwM (logInfo . display)) @@ -250,32 +256,34 @@ cfgRead scope = do 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 - configFilePath <- cfgLocation $ configCmdSetScope cmd -- 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) From e978207b9cc73ca3f4239accceb6163c10cc9e2a Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Sun, 4 Sep 2022 17:05:25 -0400 Subject: [PATCH 03/13] Pretty print the JSON dumps. --- package.yaml | 1 + src/Stack/ConfigCmd.hs | 8 ++++---- stack.cabal | 4 ++++ 3 files changed, 9 insertions(+), 4 deletions(-) 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 cf402167f8..29bfbf3158 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -48,7 +48,7 @@ import Stack.Prelude import Data.Coerce (coerce) import Pantry.Internal.AesonExtended (ToJSON(..), FromJSON, (.=), WithJSONWarnings (WithJSONWarnings), object) -import qualified Data.Aeson as Aeson +import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.Aeson.Key as Key import Data.Aeson.KeyMap (KeyMap) import qualified Data.Aeson.KeyMap as KeyMap @@ -128,18 +128,18 @@ configCmdSetScope (ConfigCmdSetSystemGhc scope _) = scope configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope encodeDumpProject :: RawYaml -> ConfigDumpFormat -> Project -> ByteString -encodeDumpProject _ ConfigDumpJson = toStrictBytes . Aeson.encode +encodeDumpProject _ ConfigDumpJson = toStrictBytes . encodePretty encodeDumpProject rawConfig ConfigDumpYaml = \p -> let e = Yaml.encode p in Yaml.decodeEither' e & either (const e) (\(d :: KeyMap Yaml.Value) -> either (const e) encodeUtf8 (cfgRedress rawConfig d "")) encodeDumpStackBy :: ToJSON a => (Config -> a) -> ConfigCmdDumpStack -> (Config -> ByteString) encodeDumpStackBy f (ConfigCmdDumpStack _ ConfigDumpYaml) = Yaml.encode . f -encodeDumpStackBy f (ConfigCmdDumpStack _ ConfigDumpJson) = toStrictBytes . Aeson.encode . f +encodeDumpStackBy f (ConfigCmdDumpStack _ ConfigDumpJson) = toStrictBytes . encodePretty . f encodeDumpStack :: ConfigDumpFormat -> (DumpStack -> ByteString) encodeDumpStack ConfigDumpYaml = Yaml.encode -encodeDumpStack ConfigDumpJson = toStrictBytes . Aeson.encode +encodeDumpStack ConfigDumpJson = toStrictBytes . encodePretty cfgReadProject :: (HasConfig env, HasLogFunc env) => CommandScope -> RIO env (Maybe Project) cfgReadProject scope = do 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 From 0df31d2ecc251b7493066528d66d83df54dc482d Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Sun, 4 Sep 2022 17:49:34 -0400 Subject: [PATCH 04/13] Dump the project JSON respecting field order. --- src/Stack/ConfigCmd.hs | 13 ++++++++++--- src/Stack/YamlUpdate.hs | 42 +++++++++++++++++++++++++---------------- 2 files changed, 36 insertions(+), 19 deletions(-) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index 29bfbf3158..884734f18b 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -48,7 +48,8 @@ import Stack.Prelude import Data.Coerce (coerce) import Pantry.Internal.AesonExtended (ToJSON(..), FromJSON, (.=), WithJSONWarnings (WithJSONWarnings), object) -import Data.Aeson.Encode.Pretty (encodePretty) +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 @@ -128,10 +129,16 @@ configCmdSetScope (ConfigCmdSetSystemGhc scope _) = scope configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope encodeDumpProject :: RawYaml -> ConfigDumpFormat -> Project -> ByteString -encodeDumpProject _ ConfigDumpJson = toStrictBytes . encodePretty -encodeDumpProject rawConfig ConfigDumpYaml = \p -> let e = Yaml.encode p in +encodeDumpProject rawConfig ConfigDumpYaml p = let e = Yaml.encode p in Yaml.decodeEither' e & either (const e) (\(d :: KeyMap Yaml.Value) -> either (const e) encodeUtf8 (cfgRedress rawConfig d "")) +encodeDumpProject rawConfig ConfigDumpJson p = let e = Yaml.encode p in + Yaml.decodeEither' e & either (const e) (\(d :: KeyMap Yaml.Value) -> + toStrictBytes $ encodePretty' (Aeson.defConfig{confCompare = cfgKeyCompare rawConfig d ""}) 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) encodeDumpStackBy :: ToJSON a => (Config -> a) -> ConfigCmdDumpStack -> (Config -> ByteString) encodeDumpStackBy f (ConfigCmdDumpStack _ ConfigDumpYaml) = Yaml.encode . f 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 = From cfaa3f5fdc764a65c700a40ee43460024ec0e4e3 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Sun, 4 Sep 2022 18:02:47 -0400 Subject: [PATCH 05/13] Reduce duplication in encodeDumpProject. --- src/Stack/ConfigCmd.hs | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index 884734f18b..293422f5f2 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -129,12 +129,17 @@ configCmdSetScope (ConfigCmdSetSystemGhc scope _) = scope configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope encodeDumpProject :: RawYaml -> ConfigDumpFormat -> Project -> ByteString -encodeDumpProject rawConfig ConfigDumpYaml p = let e = Yaml.encode p in - Yaml.decodeEither' e & either (const e) (\(d :: KeyMap Yaml.Value) -> +encodeDumpProject rawConfig format p + | ConfigDumpYaml <- format = dumpProject (\e d -> either (const e) encodeUtf8 (cfgRedress rawConfig d "")) -encodeDumpProject rawConfig ConfigDumpJson p = let e = Yaml.encode p in - Yaml.decodeEither' e & either (const e) (\(d :: KeyMap Yaml.Value) -> - toStrictBytes $ encodePretty' (Aeson.defConfig{confCompare = cfgKeyCompare rawConfig d ""}) d) + | ConfigDumpJson <- format = dumpProject (\_ d -> + let cmp = cfgKeyCompare rawConfig d "" + in toStrictBytes $ encodePretty' (Aeson.defConfig{confCompare = cmp}) 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) cfgKeyCompare :: RawYaml -> KeyMap Yaml.Value -> Text -> (Text -> Text -> Ordering) cfgKeyCompare (yamlLines -> configLines) (fmap Key.toText . KeyMap.keys -> keys) cmdKey = From 18b2f4833cf4f2b6d42e30de80cb2d8244dec5cf Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Mon, 5 Sep 2022 16:37:14 -0400 Subject: [PATCH 06/13] Use where instead of let for setting up aeson config. --- src/Stack/ConfigCmd.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index 293422f5f2..f6eb415f46 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -133,14 +133,15 @@ encodeDumpProject rawConfig format p | ConfigDumpYaml <- format = dumpProject (\e d -> either (const e) encodeUtf8 (cfgRedress rawConfig d "")) | ConfigDumpJson <- format = dumpProject (\_ d -> - let cmp = cfgKeyCompare rawConfig d "" - in toStrictBytes $ encodePretty' (Aeson.defConfig{confCompare = cmp}) 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) From b52320786876f57e56bddd6aee4a0c248024047b Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Mon, 5 Sep 2022 17:11:13 -0400 Subject: [PATCH 07/13] Respect existing module import formatting. --- src/Stack/ConfigCmd.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index f6eb415f46..d0567d4eb4 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -48,10 +48,10 @@ 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 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 Data.Aeson.KeyMap (KeyMap) import qualified Data.Aeson.KeyMap as KeyMap import Data.ByteString.Builder (byteString) import qualified Data.Map.Merge.Strict as Map From 92d314162e59f1d4c2b8da88443013d61866ad9e Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Mon, 5 Sep 2022 17:35:28 -0400 Subject: [PATCH 08/13] Don't use do in cfgReadProject. --- src/Stack/ConfigCmd.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index d0567d4eb4..bfd6e23eb1 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -159,12 +159,9 @@ cfgReadProject scope = do (configFilePath, yamlConfig) <- cfgRead scope let parser = parseProjectAndConfigMonoid (parent configFilePath) case Yaml.parseEither parser yamlConfig of - Left err -> do - logError . display $ T.pack err - return Nothing - Right (WithJSONWarnings res _warnings) -> do - ProjectAndConfigMonoid project _ <- liftIO res - return $ Just project + 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 From b35143b4bd170b8beb54d552e691054de0190362 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 6 Sep 2022 07:35:18 -0400 Subject: [PATCH 09/13] Fix a typo, put stack config env last. --- doc/GUIDE_advanced.md | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/doc/GUIDE_advanced.md b/doc/GUIDE_advanced.md index bdf6e65c48..cf09e48392 100644 --- a/doc/GUIDE_advanced.md +++ b/doc/GUIDE_advanced.md @@ -78,24 +78,9 @@ 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 - -`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 config set` commands The `stack config set` commands allow the values of keys in YAML configuration @@ -128,6 +113,21 @@ 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 From 8722d015ed44eb1da96b0de2fb6bd7f115ddbfea Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 6 Sep 2022 07:57:45 -0400 Subject: [PATCH 10/13] Add help for added commands. --- doc/GUIDE_advanced.md | 52 +++++++++++++++++++++++++++++++++++++------ 1 file changed, 45 insertions(+), 7 deletions(-) diff --git a/doc/GUIDE_advanced.md b/doc/GUIDE_advanced.md index cf09e48392..78bde95a71 100644 --- a/doc/GUIDE_advanced.md +++ b/doc/GUIDE_advanced.md @@ -81,18 +81,49 @@ the command, see the [build command](build_command.md) documentation. The `stack config` commands provide assistance with accessing or modifying Stack's configuration. See `stack config` for the available commands. +## The `stack config dump-*` commands + +These commands dump YAML but can dump JSON with an added `--json` flag. + +## 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 @@ -113,6 +144,13 @@ 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 From 79740d999c39045c49faac2aac508882dd5a73d1 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 6 Sep 2022 08:13:22 -0400 Subject: [PATCH 11/13] Rename encodeDumpStackBy to encodeDumpBy. --- src/Stack/ConfigCmd.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index bfd6e23eb1..f85477a45a 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -146,9 +146,9 @@ cfgKeyCompare :: RawYaml -> KeyMap Yaml.Value -> Text -> (Text -> Text -> Orderi cfgKeyCompare (yamlLines -> configLines) (fmap Key.toText . KeyMap.keys -> keys) cmdKey = compareInOrder configLines (coerce keys) (coerce cmdKey) -encodeDumpStackBy :: ToJSON a => (Config -> a) -> ConfigCmdDumpStack -> (Config -> ByteString) -encodeDumpStackBy f (ConfigCmdDumpStack _ ConfigDumpYaml) = Yaml.encode . f -encodeDumpStackBy f (ConfigCmdDumpStack _ ConfigDumpJson) = toStrictBytes . encodePretty . f +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 @@ -186,8 +186,8 @@ instance ToJSON DumpStack where ] cfgCmdDumpStack :: (HasConfig env, HasLogFunc env) => ConfigCmdDumpStack -> RIO env () -cfgCmdDumpStack cmd@(ConfigCmdDumpStack scope dumpFormat) - | DumpStackScopeEffective <- scope = cfgCmdDumpStackEffective cmd +cfgCmdDumpStack (ConfigCmdDumpStack scope dumpFormat) + | DumpStackScopeEffective <- scope = cfgCmdDumpStackEffective dumpFormat | DumpStackScopeProject <- scope = cfgDumpStack CommandScopeProject dumpFormat | DumpStackScopeGlobal <- scope = cfgDumpStack CommandScopeGlobal dumpFormat @@ -208,8 +208,8 @@ cfgDumpStack scope dumpFormat = do & decodeUtf8' & either throwM (logInfo . display) -cfgCmdDumpStackEffective :: (HasConfig env, HasLogFunc env) => ConfigCmdDumpStack -> RIO env () -cfgCmdDumpStackEffective cmd = do +cfgCmdDumpStackEffective :: (HasConfig env, HasLogFunc env) => ConfigDumpFormat -> RIO env () +cfgCmdDumpStackEffective dumpFormat = do conf <- view configL let f Config{..} = DumpStack @@ -217,7 +217,7 @@ cfgCmdDumpStackEffective cmd = do , dsSystemGHC = Just configSystemGHC } conf - & encodeDumpStackBy f cmd + & encodeDumpBy f dumpFormat & decodeUtf8' & either throwM (logInfo . display) From d49990f53cba2944c9ab439a75d062ff8bd722ec Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 6 Sep 2022 08:15:38 -0400 Subject: [PATCH 12/13] Simplify cfgCmdDumpStack. --- src/Stack/ConfigCmd.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index f85477a45a..2fb74f0e3e 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -186,10 +186,10 @@ instance ToJSON DumpStack where ] cfgCmdDumpStack :: (HasConfig env, HasLogFunc env) => ConfigCmdDumpStack -> RIO env () -cfgCmdDumpStack (ConfigCmdDumpStack scope dumpFormat) - | DumpStackScopeEffective <- scope = cfgCmdDumpStackEffective dumpFormat - | DumpStackScopeProject <- scope = cfgDumpStack CommandScopeProject dumpFormat - | DumpStackScopeGlobal <- scope = cfgDumpStack CommandScopeGlobal dumpFormat +cfgCmdDumpStack (ConfigCmdDumpStack scope dumpFormat) = dumpFormat & case scope of + DumpStackScopeEffective -> cfgCmdDumpStackEffective + DumpStackScopeProject -> cfgDumpStack CommandScopeProject + DumpStackScopeGlobal -> cfgDumpStack CommandScopeGlobal cfgDumpStack :: (HasConfig env, HasLogFunc env) From 6f982d3f8656c256b86011d3ff0ec591b0471d18 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Tue, 6 Sep 2022 08:25:42 -0400 Subject: [PATCH 13/13] Add haddocks to DumpStack. --- src/Stack/ConfigCmd.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index 2fb74f0e3e..47cebcc951 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -173,6 +173,7 @@ cfgCmdDumpProject (ConfigCmdDumpProject dumpFormat) = do & decodeUtf8' & either throwM (logInfo . display)) +-- | The subset of stack's configuration that we dump. data DumpStack = DumpStack { dsInstallGHC :: !(Maybe Bool)