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

- Add a `step` helper and a `MonadFail` instance to `Progress`
- Refactor `validateSolverResult` to integrate into the `Progress` monad chain
  using `fail` instead of `error`, giving structured failure instead of an
  uncatchable exception

Author: andreabedini

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

@@ -1,10 +1,13 @@
+{-# LANGUAGE FlexibleInstances #-}
 module Distribution.Solver.Types.Progress
     ( Progress(..)
     , foldProgress
+    , step
+    , fail
     ) 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 +25,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 +37,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

@@ -1,7 +1,3 @@
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
-
 -- |
 -- Module      :  Distribution.Client.Dependency
 -- Copyright   :  (c) David Himmelstrup 2005,
@@ -805,9 +801,9 @@ resolveDependencies
   -> Maybe PkgConfigDb
   -> DepResolverParams
   -> Progress String String SolverInstallPlan
-resolveDependencies platform comp pkgConfigDB params =
-  Step (showDepResolverParams finalparams) $
-    fmap (validateSolverResult platform comp indGoals) $
+resolveDependencies platform comp pkgConfigDB params = do
+  step (showDepResolverParams finalparams)
+  pkgs <-
       formatProgress $
         runSolver
           ( SolverConfig
@@ -835,6 +831,7 @@ resolveDependencies platform comp pkgConfigDB params =
           preferences
           constraints
           targets
+  validateSolverResult platform comp indGoals pkgs
   where
     finalparams@( DepResolverParams
                     targets
@@ -935,13 +932,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