Merge pull request #6489 from commercialhaskell/config-set

Fix known bugs in stack config set snapshot/resolver

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
 

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 <snapshot>` 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 <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
 

src/Stack/ConfigCmd.hs

@@ -109,22 +109,44 @@ 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
           , flow "already contained the intended configuration and remains \
                  \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