From 5af57779da0ec809746cb712b86f20999d32c669 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Sat, 17 Feb 2024 18:36:07 +0000 Subject: [PATCH] Fix known bugs in stack config set snapshot/resolver --- ChangeLog.md | 2 ++ doc/config_command.md | 22 +++++--------- src/Stack/ConfigCmd.hs | 66 ++++++++++++++++++++++++++++-------------- 3 files changed, 54 insertions(+), 36 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index d4cfa9ff63..80844144a9 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -28,6 +28,8 @@ Other enhancements: Bug fixes: * `--haddock-for-hackage` does not ignore `--haddock-arguments`. +* The `config set snapshot` and `config set resolver` commands now respect the + presence of a synoymous key. ## v2.15.1 - 2024-02-09 diff --git a/doc/config_command.md b/doc/config_command.md index 4c7d735e42..df19cc4601 100644 --- a/doc/config_command.md +++ b/doc/config_command.md @@ -42,7 +42,8 @@ Available commands: install-ghc Configure whether Stack should automatically install GHC when necessary. package-index Configure Stack's package index - resolver Change the resolver key of the current project. + resolver Change the snapshot of the current project, using the + resolver key. snapshot Change the snapshot of the current project. system-ghc Configure whether Stack should use a system GHC installation or not. @@ -82,16 +83,9 @@ file (`config.yaml`). stack config set resolver SNAPSHOT ~~~ -`stack config set resolver ` sets the `resolver` key in the -project-level configuration file (`stack.yaml`). - -A snapshot of `lts` or `nightly` will be translated into the most recent -available. A snapshot of `lts-22` will be translated into the most recent -available in the `lts-22` sequence. - -Known bug: - -* The command does not respect the presence of a `snapshot` key. +A command corresponding to the +[`stack config set snapshot` command](#the-stack-config-set-snapshot-command) +but using the `resolver` key instead of the `snapshot` key. ## The `stack config set snapshot` command @@ -102,15 +96,13 @@ stack config set snapshot SNAPSHOT ~~~ `stack config set snapshot ` sets the `snapshot` key in the -project-level configuration file (`stack.yaml`). +project-level configuration file (`stack.yaml`) to the specified snapshot. A snapshot of `lts` or `nightly` will be translated into the most recent available. A snapshot of `lts-22` will be translated into the most recent available in the `lts-22` sequence. -Known bug: - -* The command does not respect the presence of a `resolver` key. +If a `resolver` key is present, it will be replaced by a `snapshot` key. ## The `stack config set system-ghc` command diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index 14a8091a62..3eb3389d0c 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -109,14 +109,16 @@ cfgCmdSet cmd = do newValue' = T.stripEnd $ decodeUtf8With lenientDecode $ Yaml.encode newValue -- Text file = toFilePath configFilePath -- String - newYamlLines <- case inConfig config cmdKeys of - Nothing -> do + hits = catMaybes $ NE.toList $ NE.map (inConfig config) cmdKeys + primaryCmdKey = NE.last $ NE.head cmdKeys + newYamlLines <- case hits of + [] -> do prettyInfoL [ pretty configFilePath , flow "has been extended." ] - pure $ writeLines yamlLines "" cmdKeys newValue' - Just oldValue -> if oldValue == newValue + pure $ writeLines yamlLines "" (NE.head cmdKeys) newValue' + [(cmdKey, oldValue)] -> if oldValue == newValue && cmdKey == primaryCmdKey then do prettyInfoL [ pretty configFilePath @@ -124,7 +126,27 @@ cfgCmdSet cmd = do \unchanged." ] pure yamlLines - else switchLine configFilePath (NE.last cmdKeys) newValue' [] yamlLines + else do + when (cmdKey /= primaryCmdKey) $ + prettyWarn $ + fillSep + [ pretty configFilePath + , flow "contained a synonym for" + , style Target (fromString $ T.unpack primaryCmdKey) + , parens (style Current (fromString $ T.unpack cmdKey)) + , flow "which has been replaced." + ] + <> line + switchLine configFilePath cmdKey primaryCmdKey newValue' [] yamlLines + _ -> do + -- In practice, this warning should not be encountered because with + -- snapshot and resolver present, Stack will not parse the YAML file. + prettyWarnL + [ pretty configFilePath + , flow "contains more than one possible existing configuration and, \ + \consequently, remains unchanged." + ] + pure yamlLines liftIO $ writeFileUtf8 file (T.unlines newYamlLines) where -- This assumes that if the key does not exist, the lines that can be @@ -145,14 +167,15 @@ cfgCmdSet cmd = do inConfig v cmdKeys = case v of Yaml.Object obj -> - case KeyMap.lookup (Key.fromText (NE.head cmdKeys)) obj of - Nothing -> Nothing - Just v' -> case nonEmpty $ NE.tail cmdKeys of - Nothing -> Just v' - Just ks -> inConfig v' ks + let cmdKey = NE.head cmdKeys + in case KeyMap.lookup (Key.fromText cmdKey) obj of + Nothing -> Nothing + Just v' -> case nonEmpty $ NE.tail cmdKeys of + Nothing -> Just (cmdKey, v') + Just ks -> inConfig v' ks _ -> Nothing - switchLine file cmdKey _ searched [] = do + switchLine file cmdKey _ _ searched [] = do prettyWarnL [ style Current (fromString $ T.unpack cmdKey) , flow "not found in YAML file" @@ -161,11 +184,11 @@ cfgCmdSet cmd = do \supported." ] pure $ reverse searched - switchLine file cmdKey newValue searched (oldLine:rest) = + switchLine file cmdKey cmdKey' newValue searched (oldLine:rest) = case parseOnly (parseLine cmdKey) oldLine of - Left _ -> switchLine file cmdKey newValue (oldLine:searched) rest + Left _ -> switchLine file cmdKey cmdKey' newValue (oldLine:searched) rest Right (kt, spaces1, spaces2, spaces3, comment) -> do - let newLine = spaces1 <> renderKey cmdKey kt <> spaces2 <> + let newLine = spaces1 <> renderKey cmdKey' kt <> spaces2 <> ":" <> spaces3 <> newValue <> comment prettyInfoL [ pretty file @@ -246,13 +269,13 @@ snapshotValue root snapshot = do void $ loadSnapshot =<< completeSnapshotLocation concreteSnapshot pure (Yaml.toJSON concreteSnapshot) -cfgCmdSetKeys :: ConfigCmdSet -> NonEmpty Text -cfgCmdSetKeys (ConfigCmdSetSnapshot _) = ["snapshot"] -cfgCmdSetKeys (ConfigCmdSetResolver _) = ["resolver"] -cfgCmdSetKeys (ConfigCmdSetSystemGhc _ _) = [configMonoidSystemGHCName] -cfgCmdSetKeys (ConfigCmdSetInstallGhc _ _) = [configMonoidInstallGHCName] +cfgCmdSetKeys :: ConfigCmdSet -> NonEmpty (NonEmpty Text) +cfgCmdSetKeys (ConfigCmdSetSnapshot _) = [["snapshot"], ["resolver"]] +cfgCmdSetKeys (ConfigCmdSetResolver _) = [["resolver"], ["snapshot"]] +cfgCmdSetKeys (ConfigCmdSetSystemGhc _ _) = [[configMonoidSystemGHCName]] +cfgCmdSetKeys (ConfigCmdSetInstallGhc _ _) = [[configMonoidInstallGHCName]] cfgCmdSetKeys (ConfigCmdSetDownloadPrefix _ _) = - ["package-index", "download-prefix"] + [["package-index", "download-prefix"]] cfgCmdName :: String cfgCmdName = "config" @@ -284,7 +307,8 @@ configCmdSetParser = ( OA.metavar "SNAPSHOT" <> OA.help "E.g. \"nightly\" or \"lts-22.8\"" )) ( OA.progDesc - "Change the resolver key of the current project." )) + "Change the snapshot of the current project, using the \ + \resolver key." )) , OA.command (T.unpack configMonoidSystemGHCName) ( OA.info ( ConfigCmdSetSystemGhc