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

- add step to Progress
- add MonadFail Progress instance
- refactor validateSolverResult

Author: andreabedini

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

@@ -1,11 +1,14 @@
 {-# LANGUAGE DeriveFunctor #-}
+{-# 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
@@ -16,6 +19,9 @@ data Progress step fail done = Step step (Progress step fail done)
                              | Done done
   deriving (Functor)
 
+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.
 --
@@ -25,15 +31,18 @@ data Progress step fail done = Step step (Progress step fail done)
 --
 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 (flip fmap x) p

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

@@ -1,6 +1,7 @@
+{-# LANGUAGE FlexibleContexts #-}
 -----------------------------------------------------------------------------
-
 -----------------------------------------------------------------------------
+{-# LANGUAGE LambdaCase #-}
 
 -- |
 -- Module      :  Distribution.Client.Dependency
@@ -781,35 +782,42 @@ resolveDependencies
   -> Staged InstalledPackageIndex
   -> DepResolverParams
   -> Progress String String SolverInstallPlan
-resolveDependencies toolchains pkgConfigDB installedPkgIndex params =
-  Step (showDepResolverParams finalparams) $
-    fmap (validateSolverResult toolchains) $
-      formatProgress $
-        runSolver
-          ( SolverConfig
-              reordGoals
-              cntConflicts
-              fineGrained
-              minimize
-              noReinstalls
-              shadowing
-              strFlags
-              onlyConstrained_
-              maxBkjumps
-              enableBj
-              solveExes
-              order
-              verbosity
-              (PruneAfterFirstSuccess False)
-          )
-          toolchains
-          pkgConfigDB
-          (fmap installedPkgIndexM installedPkgIndex)
-          sourcePkgIndex
-          preferences
-          constraints
-          targets
+resolveDependencies toolchains pkgConfigDB installedPkgIndex params = do
+  step (showDepResolverParams finalparams)
+  pkgs <-
+    formatProgress $
+      runSolver
+        config
+        toolchains
+        pkgConfigDB
+        installedPkgIndex'
+        sourcePkgIndex
+        preferences
+        constraints
+        targets
+  validateSolverResult toolchains pkgs
   where
+    installedPkgIndex' = Staged $ \case
+      Build -> getStage installedPkgIndex Build
+      Host -> installedPkgIndexM (getStage installedPkgIndex Host)
+
+    config =
+      SolverConfig
+        reordGoals
+        cntConflicts
+        fineGrained
+        minimize
+        noReinstalls
+        shadowing
+        strFlags
+        onlyConstrained_
+        maxBkjumps
+        enableBj
+        solveExes
+        order
+        verbosity
+        (PruneAfterFirstSuccess False)
+
     finalparams@( DepResolverParams
                     targets
                     constraints
@@ -906,13 +914,14 @@ interpretPackagesPreference selected defaultPref prefs =
 validateSolverResult
   :: Staged (CompilerInfo, Platform)
   -> [ResolverPackage UnresolvedPkgLoc]
-  -> SolverInstallPlan
+  -> Progress String String SolverInstallPlan
 validateSolverResult toolchains pkgs =
   case planPackagesProblems toolchains pkgs of
     [] -> case SolverInstallPlan.new 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