refactor(cabal-install, cabal-install-solver): avoid using "error" in validateSolverResult

cabal-install-solver/src/Distribution/Solver/Types/Progress.hs

@@ -1,10 +1,12 @@
+{-# LANGUAGE FlexibleInstances #-}
 module Distribution.Solver.Types.Progress
     ( Progress(..)
     , foldProgress
+    , step
     ) where
 
 import Prelude ()
-import Distribution.Solver.Compat.Prelude hiding (fail)
+import Distribution.Solver.Compat.Prelude
 
 -- | A type to represent the unfolding of an expensive long running
 -- calculation that may fail. We may get intermediate steps before the final
@@ -22,6 +24,9 @@ instance Functor (Progress step fail) where
   fmap _ (Fail x)   = Fail x
   fmap f (Done r)   = Done (f r)
 
+step :: step -> Progress step fail ()
+step s = Step s (Done ())
+
 -- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two
 -- base cases, one for a final result and one for failure.
 --
@@ -31,15 +36,18 @@ instance Functor (Progress step fail) where
 --
 foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)
              -> Progress step fail done -> a
-foldProgress step fail done = fold
-  where fold (Step s p) = step s (fold p)
-        fold (Fail f)   = fail f
-        fold (Done r)   = done r
+foldProgress step' fail' done' = fold
+  where fold (Step s p) = step' s (fold p)
+        fold (Fail f)   = fail' f
+        fold (Done r)   = done' r
 
 instance Monad (Progress step fail) where
   return   = pure
   p >>= f  = foldProgress Step Fail f p
 
+instance MonadFail (Progress step String) where
+  fail = Fail
+
 instance Applicative (Progress step fail) where
   pure a  = Done a
   p <*> x = foldProgress Step Fail (`fmap` x) p

cabal-install/src/Distribution/Client/Dependency.hs

@@ -832,36 +832,37 @@ resolveDependencies
   -> Maybe PkgConfigDb
   -> DepResolverParams
   -> Progress String String SolverInstallPlan
-resolveDependencies platform comp pkgConfigDB params =
-  Step (showDepResolverParams finalparams) $
-    fmap (validateSolverResult platform comp indGoals) $
-      formatProgress $
-        runSolver
-          ( SolverConfig
-              reordGoals
-              cntConflicts
-              fineGrained
-              minimize
-              indGoals
-              noReinstalls
-              shadowing
-              strFlags
-              onlyConstrained_
-              maxBkjumps
-              enableBj
-              solveExes
-              order
-              verbosity
-              (PruneAfterFirstSuccess False)
-          )
-          platform
-          comp
-          installedPkgIndex
-          sourcePkgIndex
-          pkgConfigDB
-          preferences
-          constraints
-          targets
+resolveDependencies platform comp pkgConfigDB params = do
+  step (showDepResolverParams finalparams)
+  pkgs <-
+    formatProgress $
+      runSolver
+        ( SolverConfig
+            reordGoals
+            cntConflicts
+            fineGrained
+            minimize
+            indGoals
+            noReinstalls
+            shadowing
+            strFlags
+            onlyConstrained_
+            maxBkjumps
+            enableBj
+            solveExes
+            order
+            verbosity
+            (PruneAfterFirstSuccess False)
+        )
+        platform
+        comp
+        installedPkgIndex
+        sourcePkgIndex
+        pkgConfigDB
+        preferences
+        constraints
+        targets
+  validateSolverResult platform comp indGoals pkgs
   where
     finalparams@( DepResolverParams
                     targets
@@ -962,13 +963,13 @@ validateSolverResult
   -> CompilerInfo
   -> IndependentGoals
   -> [ResolverPackage UnresolvedPkgLoc]
-  -> SolverInstallPlan
+  -> Progress String String SolverInstallPlan
 validateSolverResult platform comp indepGoals pkgs =
   case planPackagesProblems platform comp pkgs of
     [] -> case SolverInstallPlan.new indepGoals graph of
-      Right plan -> plan
-      Left problems -> error (formatPlanProblems problems)
-    problems -> error (formatPkgProblems problems)
+      Right plan -> return plan
+      Left problems -> fail (formatPlanProblems problems)
+    problems -> fail (formatPkgProblems problems)
   where
     graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc)
     graph = Graph.fromDistinctList pkgs

cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs

@@ -35,15 +35,15 @@ tests =
       \p (Blind f) ->
         toProgress (retry (fromProgress p) (fromProgress . f))
           === (foldProgress Step f Done (p :: Log Int) :: Log Int)
-  , testProperty "failWith" $ \step failure ->
-      toProgress (failWith step failure)
-        === (Step step (Fail failure) :: Log Int)
-  , testProperty "succeedWith" $ \step success ->
-      toProgress (succeedWith step success)
-        === (Step step (Done success) :: Log Int)
-  , testProperty "continueWith" $ \step p ->
-      toProgress (continueWith step (fromProgress p))
-        === (Step step p :: Log Int)
+  , testProperty "failWith" $ \step' failure ->
+      toProgress (failWith step' failure)
+        === (Step step' (Fail failure) :: Log Int)
+  , testProperty "succeedWith" $ \step' success ->
+      toProgress (succeedWith step' success)
+        === (Step step' (Done success) :: Log Int)
+  , testProperty "continueWith" $ \step' p ->
+      toProgress (continueWith step' (fromProgress p))
+        === (Step step' p :: Log Int)
   , testCase "tryWith with failure" $
       let failure = Fail "Error"
           s = Step Success