Re #6466 Add config set snapshot command

commercialhaskell · Feb 1, 2024 · ca8438c · ca8438c
1 parent 5ef27c7
commit ca8438c
Show file tree

Hide file tree

Showing 3 changed files with 55 additions and 13 deletions.
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -92,6 +92,8 @@ Other enhancements:
   filter out an item from the results, if present. The item can be `$locals` for
   all local packages.
 * Add option `--snapshot` as synonym for `--resolver`.
+* Add the `config set snapshot` command, corresponding to the
+  `config set resolver` command.
 
 Bug fixes:
 

diff --git 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 of the current project.
+  resolver                 Change the resolver key of the current project.
+  snapshot                 Change the snapshot of the current project.
   system-ghc               Configure whether Stack should use a system GHC
                            installation or not.
 ~~~
@@ -85,13 +86,32 @@ stack config set resolver SNAPSHOT
 project-level configuration file (`stack.yaml`).
 
 A snapshot of `lts` or `nightly` will be translated into the most recent
-available. A snapshot of `lts-20` will be translated into the most recent
-available in the `lts-20` sequence.
+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.
 
+## The `stack config set snapshot` command
+
+:octicons-tag-24: UNRELEASED
+
+~~~text
+stack config set snapshot SNAPSHOT
+~~~
+
+`stack config set snapshot <snapshot>` sets the `snapshot` 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 `resolver` key.
+
 ## The `stack config set system-ghc` command
 
 ~~~text

diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs
@@ -64,7 +64,8 @@ instance Exception ConfigCmdException where
     ++ "'config' command used when no project configuration available."
 
 data ConfigCmdSet
-  = ConfigCmdSetResolver !(Unresolved AbstractResolver)
+  = ConfigCmdSetSnapshot !(Unresolved AbstractResolver)
+  | ConfigCmdSetResolver !(Unresolved AbstractResolver)
   | ConfigCmdSetSystemGhc !CommandScope !Bool
   | ConfigCmdSetInstallGhc !CommandScope !Bool
   | ConfigCmdSetDownloadPrefix !CommandScope !Text
@@ -77,6 +78,7 @@ data CommandScope
     -- ^ Apply changes to the project @stack.yaml@.
 
 configCmdSetScope :: ConfigCmdSet -> CommandScope
+configCmdSetScope (ConfigCmdSetSnapshot _) = CommandScopeProject
 configCmdSetScope (ConfigCmdSetResolver _) = CommandScopeProject
 configCmdSetScope (ConfigCmdSetSystemGhc scope _) = scope
 configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope
@@ -224,18 +226,27 @@ cfgCmdSetValue ::
      (HasConfig env, HasGHCVariant env)
   => Path Abs Dir -- ^ root directory of project
   -> ConfigCmdSet -> RIO env Yaml.Value
-cfgCmdSetValue root (ConfigCmdSetResolver newResolver) = do
-  newResolver' <- resolvePaths (Just root) newResolver
-  concreteResolver <- makeConcreteResolver newResolver'
-  -- Check that the snapshot actually exists
-  void $ loadSnapshot =<< completeSnapshotLocation concreteResolver
-  pure (Yaml.toJSON concreteResolver)
+cfgCmdSetValue root (ConfigCmdSetSnapshot newSnapshot) =
+  snapshotValue root newSnapshot
+cfgCmdSetValue root (ConfigCmdSetResolver newSnapshot) =
+  snapshotValue root newSnapshot
 cfgCmdSetValue _ (ConfigCmdSetSystemGhc _ bool') = pure $ Yaml.Bool bool'
 cfgCmdSetValue _ (ConfigCmdSetInstallGhc _ bool') = pure $ Yaml.Bool bool'
 cfgCmdSetValue _ (ConfigCmdSetDownloadPrefix _ url) = pure $ Yaml.String url
 
+snapshotValue ::
+     HasConfig env
+  => Path Abs Dir -- ^ root directory of project
+  -> Unresolved AbstractResolver -> RIO env Yaml.Value
+snapshotValue root snapshot = do
+  snapshot' <- resolvePaths (Just root) snapshot
+  concreteSnapshot <- makeConcreteResolver snapshot'
+  -- Check that the snapshot actually exists
+  void $ loadSnapshot =<< completeSnapshotLocation concreteSnapshot
+  pure (Yaml.toJSON concreteSnapshot)
 
 cfgCmdSetKeys :: ConfigCmdSet -> NonEmpty Text
+cfgCmdSetKeys (ConfigCmdSetSnapshot _) = ["snapshot"]
 cfgCmdSetKeys (ConfigCmdSetResolver _) = ["resolver"]
 cfgCmdSetKeys (ConfigCmdSetSystemGhc _ _) = [configMonoidSystemGHCName]
 cfgCmdSetKeys (ConfigCmdSetInstallGhc _ _) = [configMonoidInstallGHCName]
@@ -255,15 +266,24 @@ configCmdSetParser :: OA.Parser ConfigCmdSet
 configCmdSetParser =
   OA.hsubparser $
     mconcat
-      [ OA.command "resolver"
+      [ OA.command "snapshot"
+          ( OA.info
+              (   ConfigCmdSetSnapshot
+              <$> OA.argument
+                    readAbstractResolver
+                    (  OA.metavar "SNAPSHOT"
+                    <> OA.help "E.g. \"nightly\" or \"lts-22.8\"" ))
+              ( OA.progDesc
+                  "Change the snapshot of the current project." ))
+      , OA.command "resolver"
           ( OA.info
               (   ConfigCmdSetResolver
               <$> OA.argument
                     readAbstractResolver
                     (  OA.metavar "SNAPSHOT"
-                    <> OA.help "E.g. \"nightly\" or \"lts-7.2\"" ))
+                    <> OA.help "E.g. \"nightly\" or \"lts-22.8\"" ))
               ( OA.progDesc
-                  "Change the resolver of the current project." ))
+                  "Change the resolver key of the current project." ))
       , OA.command (T.unpack configMonoidSystemGHCName)
           ( OA.info
               (   ConfigCmdSetSystemGhc