Implement spago update for solver projects

bin/src/Main.purs

@@ -189,6 +189,7 @@ type PublishArgs =
 
 type UpgradeArgs =
   { setVersion :: Maybe String
+  , selectedPackage :: Maybe String
   }
 
 data SpagoCmd a = SpagoCmd GlobalArgs (Command a)
@@ -374,6 +375,7 @@ runArgsParser = Optparse.fromRecord
 upgradeArgsParser :: Parser UpgradeArgs
 upgradeArgsParser = Optparse.fromRecord
   { setVersion: Flags.maybeSetVersion
+  , selectedPackage: Flags.selectedPackage
   }
 
 testArgsParser :: Parser TestArgs
@@ -688,7 +690,7 @@ main = do
             runSpago docsEnv Docs.run
           Upgrade args -> do
             setVersion <- parseSetVersion args.setVersion
-            { env } <- mkFetchEnv { packages: mempty, selectedPackage: Nothing, pure: false, ensureRanges: false, testDeps: false, isRepl: false, migrateConfig, offline }
+            { env } <- mkFetchEnv { packages: mempty, selectedPackage: args.selectedPackage, pure: false, ensureRanges: false, testDeps: false, isRepl: false, migrateConfig, offline }
             runSpago env (Upgrade.run { setVersion })
           Auth args -> do
             { env } <- mkFetchEnv { packages: mempty, selectedPackage: Nothing, pure: false, ensureRanges: false, testDeps: false, isRepl: false, migrateConfig, offline }

core/src/Config.purs

@@ -18,10 +18,12 @@ module Spago.Core.Config
   , SetAddress(..)
   , StatVerbosity(..)
   , TestConfig
+  , VersionConstraint(..)
   , WarningCensorTest(..)
   , WorkspaceBuildOptionsInput
   , WorkspaceConfig
   , configCodec
+  , constraintToRange
   , dependenciesCodec
   , extraPackageCodec
   , gitPackageCodec
@@ -263,7 +265,18 @@ parseBundleType = case _ of
 bundleTypeCodec :: CJ.Codec BundleType
 bundleTypeCodec = CJ.Sum.enumSum show (parseBundleType)
 
-newtype Dependencies = Dependencies (Map PackageName (Maybe Range))
+-- | Version constraint for a dependency - either an exact version or a range
+data VersionConstraint
+  = ExactVersion Version
+  | VersionRange Range
+
+derive instance Eq VersionConstraint
+
+instance Show VersionConstraint where
+  show (ExactVersion v) = show $ Version.print v
+  show (VersionRange r) = show $ Range.print r
+
+newtype Dependencies = Dependencies (Map PackageName (Maybe VersionConstraint))
 
 derive instance Eq Dependencies
 derive instance Newtype Dependencies _
@@ -272,38 +285,48 @@ instance Semigroup Dependencies where
   append (Dependencies d1) (Dependencies d2) = Dependencies $ Map.unionWith
     ( case _, _ of
         Nothing, Nothing -> Nothing
-        Just r, Nothing -> Just r
-        Nothing, Just r -> Just r
-        Just r1, Just r2 -> Range.intersect r1 r2
+        Just c, Nothing -> Just c
+        Nothing, Just c -> Just c
+        Just c1, Just c2 -> constraintIntersect c1 c2
     )
     d1
     d2
+    where
+    constraintIntersect c1 c2 = Range.intersect (constraintToRange' c1) (constraintToRange' c2) <#> VersionRange
+    constraintToRange' (ExactVersion v) = Range.exact v
+    constraintToRange' (VersionRange r) = r
 
 instance Monoid Dependencies where
   mempty = Dependencies (Map.empty)
 
+-- | Convert a version constraint to a range (for solver compatibility)
+constraintToRange :: Maybe VersionConstraint -> Range
+constraintToRange Nothing = widestRange
+constraintToRange (Just (ExactVersion v)) = Range.exact v
+constraintToRange (Just (VersionRange r)) = r
+
 dependenciesCodec :: CJ.Codec Dependencies
 dependenciesCodec = Profunctor.dimap to from $ CJ.array dependencyCodec
   where
-  packageSingletonCodec = Reg.Internal.Codec.packageMap spagoRangeCodec
+  packageSingletonCodec = Reg.Internal.Codec.packageMap versionConstraintCodec
 
-  to :: Dependencies -> Array (Either PackageName (Map PackageName Range))
+  to :: Dependencies -> Array (Either PackageName (Map PackageName VersionConstraint))
   to (Dependencies deps) =
     map
-      ( \(Tuple name maybeRange) -> case maybeRange of
+      ( \(Tuple name maybeConstraint) -> case maybeConstraint of
           Nothing -> Left name
-          Just r -> Right (Map.singleton name r)
+          Just c -> Right (Map.singleton name c)
       )
       $ Map.toUnfoldable deps :: Array _
 
-  from :: Array (Either PackageName (Map PackageName Range)) -> Dependencies
+  from :: Array (Either PackageName (Map PackageName VersionConstraint)) -> Dependencies
   from = Dependencies <<< Map.fromFoldable <<< map
     ( case _ of
         Left name -> Tuple name Nothing
         Right m -> rmap Just $ unsafeFromJust (List.head (Map.toUnfoldable m))
     )
 
-  dependencyCodec :: CJ.Codec (Either PackageName (Map PackageName Range))
+  dependencyCodec :: CJ.Codec (Either PackageName (Map PackageName VersionConstraint))
   dependencyCodec = Codec.codec' decode encode
     where
     encode = case _ of
@@ -318,16 +341,21 @@ widestRange :: Range
 widestRange = Either.fromRight' (\_ -> unsafeCrashWith "Fake range failed")
   $ Range.parse ">=0.0.0 <2147483647.0.0"
 
-spagoRangeCodec :: CJ.Codec Range
-spagoRangeCodec = CJ.prismaticCodec "SpagoRange" rangeParse printSpagoRange CJ.string
+versionConstraintCodec :: CJ.Codec VersionConstraint
+versionConstraintCodec = CJ.prismaticCodec "VersionConstraint" constraintParse printConstraint CJ.string
   where
-  rangeParse str =
-    if str == "*" then Just widestRange
-    -- First try parsing as a range (e.g. ">=1.0.0 <2.0.0")
+  constraintParse str =
+    -- First check for widest range
+    if str == "*" then Just (VersionRange widestRange)
+    -- Then try parsing as a range (e.g. ">=1.0.0 <2.0.0")
     else case hush $ Range.parse str of
-      Just range -> Just range
-      -- Then try parsing as an exact version (e.g. "1.0.0" -> ">=1.0.0 <1.0.1")
-      Nothing -> Range.exact <$> hush (Version.parse str)
+      Just range -> Just (VersionRange range)
+      -- Finally try parsing as an exact version (e.g. "1.0.0")
+      Nothing -> ExactVersion <$> hush (Version.parse str)
+
+  printConstraint = case _ of
+    ExactVersion v -> Version.print v
+    VersionRange r -> printSpagoRange r
 
 printSpagoRange :: Range -> String
 printSpagoRange range =

src/Spago/Command/Fetch.purs

@@ -540,7 +540,7 @@ getPackageDependencies packageName package = case package of
         when (offline == Offline) do
           unlessM (FS.exists packageLocation) do
             die $ "Package '" <> PackageName.print packageName <> "' is not in the local cache, and Spago is running in offline mode - can't make progress."
-        pure $ Just { core: map (fromMaybe Config.widestRange) dependencies, test: Map.empty }
+        pure $ Just { core: map Config.constraintToRange dependencies, test: Map.empty }
       -- if the dependencies are not declared, then we need to clone the repo
       -- to look at the package manifest inside
       Nothing -> do
@@ -552,7 +552,7 @@ getPackageDependencies packageName package = case package of
   LocalPackage p -> do
     readLocalDependencies $ Path.global p.path
   WorkspacePackage p ->
-    pure $ Just $ (map (fromMaybe Config.widestRange) <<< unwrap) `onEachEnv` getWorkspacePackageDeps p
+    pure $ Just $ (map Config.constraintToRange <<< unwrap) `onEachEnv` getWorkspacePackageDeps p
   where
   -- try to see if the package has a spago config, and if it's there we read it
   readLocalDependencies :: GlobalPath -> Spago (FetchEnv a) (Maybe (ByEnv (Map PackageName Range)))
@@ -561,8 +561,8 @@ getPackageDependencies packageName package = case package of
     Config.readConfig (configLocation </> "spago.yaml") >>= case _ of
       Right { yaml: { package: Just { dependencies: Dependencies deps, test } } } ->
         pure $ Just
-          { core: fromMaybe Config.widestRange <$> deps
-          , test: fromMaybe Config.widestRange <$> (test <#> _.dependencies <#> unwrap # fromMaybe Map.empty)
+          { core: Config.constraintToRange <$> deps
+          , test: Config.constraintToRange <$> (test <#> _.dependencies <#> unwrap # fromMaybe Map.empty)
           }
       Right _ -> die
         [ "Read the configuration at path " <> Path.quote configLocation
@@ -620,7 +620,7 @@ getWorkspaceTransitiveDeps = do
 -- | workspace is using.
 getTransitiveDeps :: forall a. Config.WorkspacePackage -> Spago (FetchEnv a) (ByEnv PackageMap)
 getTransitiveDeps workspacePackage = do
-  let depsRanges = (map (fromMaybe Config.widestRange) <<< unwrap) `onEachEnv` getWorkspacePackageDeps workspacePackage
+  let depsRanges = (map Config.constraintToRange <<< unwrap) `onEachEnv` getWorkspacePackageDeps workspacePackage
   { workspace } <- ask
   case workspace.packageSet.lockfile of
     -- If we have a lockfile we can compute transitive deps from the lockfile data

src/Spago/Command/Publish.purs

@@ -120,7 +120,7 @@ publish _args = do
       $ map
           ( case _ of
               Tuple pkg Nothing -> Left pkg
-              Tuple pkg (Just range) -> Right (Tuple pkg range)
+              Tuple pkg (Just constraint) -> Right (Tuple pkg (Config.constraintToRange (Just constraint)))
           )
       $ (Map.toUnfoldable :: Map _ _ -> Array _)
       $ unwrap selected.package.dependencies

src/Spago/Command/Upgrade.purs

@@ -2,16 +2,36 @@ module Spago.Command.Upgrade where
 
 import Spago.Prelude
 
+import Data.Array.NonEmpty as NEA
+import Data.FunctorWithIndex (mapWithIndex)
+import Data.Map as Map
+import Registry.PackageName as PackageName
+import Registry.Range as Range
 import Registry.Version as Version
+import Spago.Command.Build as Build
 import Spago.Command.Fetch (FetchEnv)
+import Spago.Command.Fetch as Fetch
+import Spago.Config (WorkspacePackage)
 import Spago.Config as Config
 import Spago.Core.Config as Core
+import Spago.FS as FS
+import Spago.Path as Path
 import Spago.Registry as Registry
 
 type UpgradeArgs =
   { setVersion :: Maybe Version
   }
 
+type UpgradePlan =
+  { workspacePackage :: WorkspacePackage
+  , pkgDoc :: YamlDoc Core.Config
+  , currentCore :: Map PackageName (Maybe Core.VersionConstraint)
+  , currentTest :: Map PackageName (Maybe Core.VersionConstraint)
+  , upgradedCore :: Map PackageName (Maybe Core.VersionConstraint)
+  , upgradedTest :: Map PackageName (Maybe Core.VersionConstraint)
+  , resolvedVersions :: Map PackageName Version
+  }
+
 run :: ∀ a. UpgradeArgs -> Spago (FetchEnv a) Unit
 run args = do
   { workspace, rootPath } <- ask
@@ -30,4 +50,106 @@ run args = do
           Config.setPackageSetVersionInConfig rootPath doc latestPackageSet
           logSuccess "Upgrade successful!"
     Just _ -> die "This command is not yet implemented for projects using a custom package set."
-    Nothing -> die "This command is not yet implemented for projects using a solver. See https://github.com/purescript/spago/issues/1001"
+    Nothing -> do
+      -- Solver-based project: upgrade dependency ranges to latest compatible versions
+      { logOptions, git, purs } <- ask
+      let
+        extraPackages = case workspace.packageSet.buildType of
+          Config.RegistrySolverBuild ep -> ep
+          _ -> Map.empty
+
+      let workspacePackages = Config.getWorkspacePackages workspace.packageSet
+
+      packagesToUpgrade <- case workspace.selected of
+        Just wp -> pure (NEA.singleton wp)
+        Nothing -> pure workspacePackages
+
+      -- (1) compute all upgrade plans
+      upgradePlans <- for packagesToUpgrade \workspacePackage -> do
+        pkgDoc <- justOrDieWith workspacePackage.doc Config.configDocMissingErrorMessage
+        computeUpgradePlan workspacePackage pkgDoc extraPackages
+
+      -- (2) build all to verify upgraded dependencies work
+      logInfo "Building with upgraded dependencies to verify compatibility..."
+
+      -- Construct PackageTransitiveDeps from resolved versions
+      let
+        plans = NEA.toArray upgradePlans
+        toPkgMap plan = plan.resolvedVersions # mapWithIndex \pkgName version ->
+          fromMaybe (Config.RegistryVersion version) (Map.lookup pkgName extraPackages)
+
+        dependencies :: Fetch.PackageTransitiveDeps
+        dependencies = Map.fromFoldable $ plans <#>
+          \p -> p.workspacePackage.package.name /\ { core: toPkgMap p, test: Map.empty }
+
+      -- Install all, construct a BuildEnv and run the build
+      Fetch.fetchPackagesToLocalCache (Fetch.toAllDependencies dependencies)
+      let
+        buildEnv =
+          { logOptions
+          , rootPath
+          , purs
+          , git
+          , dependencies
+          , workspace
+          , strictWarnings: Nothing
+          , pedanticPackages: false
+          }
+      buildSuccess <- runSpago buildEnv (Build.run { depsOnly: false, pursArgs: [], jsonErrors: false })
+
+      unless buildSuccess do
+        die
+          [ "Build failed with upgraded dependencies. Config was not modified."
+          , "Check the build errors above to identify incompatible packages."
+          ]
+
+      -- (3) persist config changes only if there are actual upgrades
+      for_ plans \plan -> do
+        let hasChanges = plan.upgradedCore /= plan.currentCore || plan.upgradedTest /= plan.currentTest
+        when hasChanges do
+          let configPath = plan.workspacePackage.path </> "spago.yaml"
+          logInfo $ "Updating dependency ranges in " <> Path.quote configPath
+          unless (Map.isEmpty plan.upgradedCore) do
+            liftEffect $ Config.addConstraintsToConfig plan.pkgDoc plan.upgradedCore
+          unless (Map.isEmpty plan.upgradedTest) do
+            liftEffect $ Config.addTestConstraintsToConfig plan.pkgDoc plan.upgradedTest
+          liftAff $ FS.writeYamlDocFile configPath plan.pkgDoc
+
+      logSuccess "Upgrade successful!"
+
+-- | Computes an upgrade plan for a package without persisting changes.
+computeUpgradePlan :: forall a. WorkspacePackage -> YamlDoc Core.Config -> Config.PackageMap -> Spago (FetchEnv a) UpgradePlan
+computeUpgradePlan workspacePackage pkgDoc extraPackages = do
+  -- Get current dependencies
+  let currentDeps = Fetch.getWorkspacePackageDeps workspacePackage
+  let currentCore = unwrap currentDeps.core
+  let currentTest = unwrap currentDeps.test
+
+  -- Widen all constraints to * and call solver for all dependencies combined
+  let allWidened = map (const Core.widestRange) $ Map.union currentCore currentTest
+  logInfo $ "Resolving latest compatible versions for " <> PackageName.print workspacePackage.package.name <> "..."
+  allPlan <- Fetch.getTransitiveDepsFromRegistry allWidened extraPackages
+
+  -- Upgrade constraints preserving their type:
+  -- - If solver didn't resolve the dep, keep the old constraint
+  -- - Nothing (bare dep) stays Nothing
+  -- - ExactVersion gets new exact version
+  -- - VersionRange gets union with new caret (widest range stays widest)
+  let
+    upgradeConstraints :: Map PackageName (Maybe Core.VersionConstraint) -> Map PackageName Version -> Map PackageName (Maybe Core.VersionConstraint)
+    upgradeConstraints oldDeps newVersions = mapWithIndex computeConstraint oldDeps
+      where
+      computeConstraint name maybeOldConstraint =
+        case Map.lookup name newVersions of
+          Nothing -> maybeOldConstraint -- solver didn't resolve, keep old
+          Just newVersion -> case maybeOldConstraint of
+            Nothing -> Nothing -- bare dep stays bare
+            Just (Core.ExactVersion _) -> Just (Core.ExactVersion newVersion) -- exact stays exact
+            Just (Core.VersionRange r)
+              | r == Core.widestRange -> Just (Core.VersionRange Core.widestRange) -- "*" stays "*"
+              | otherwise -> Just (Core.VersionRange (Range.union r (Range.caret newVersion)))
+
+    upgradedCore = upgradeConstraints currentCore allPlan
+    upgradedTest = upgradeConstraints currentTest allPlan
+
+  pure { workspacePackage, pkgDoc, currentCore, currentTest, upgradedCore, upgradedTest, resolvedVersions: allPlan }