refactor(cabal-install): merge two almost identical functions

Merge fromSolverInstallPlan and fromSolverInstallPlanWithProgress.

Author: andreabedini

Cabal/src/Distribution/Utils/LogProgress.hs

@@ -4,6 +4,7 @@
 module Distribution.Utils.LogProgress
   ( LogProgress
   , runLogProgress
+  , runLogProgress'
   , warnProgress
   , infoProgress
   , dieProgress
@@ -61,6 +62,16 @@ runLogProgress verbosity (LogProgress m) =
     fail_fn doc = do
       dieNoWrap verbosity (render doc)
 
+-- | Run 'LogProgress' ignoring all traces.
+runLogProgress' :: LogProgress a -> Either ErrMsg a
+runLogProgress' (LogProgress m) = foldProgress (\_ x -> x) Left Right (m env)
+  where
+    env =
+      LogEnv
+        { le_verbosity = silent
+        , le_context = []
+        }
+
 -- | Output a warning trace message in 'LogProgress'.
 warnProgress :: Doc -> LogProgress ()
 warnProgress s = LogProgress $ \env ->

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

@@ -528,35 +528,11 @@ fromSolverInstallPlan
   -> SolverInstallPlan
   -> GenericInstallPlan ipkg srcpkg
 fromSolverInstallPlan f plan =
-  mkInstallPlan
-    "fromSolverInstallPlan"
-    (Graph.fromDistinctList pkgs'')
-  where
-    (_, _, pkgs'') =
-      foldl'
-        f'
-        (Map.empty, Map.empty, [])
-        (SolverInstallPlan.reverseTopologicalOrder plan)
-
-    f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs)
-      where
-        pkgs' = f (mapDep pidMap ipiMap) pkg
-
-        (pidMap', ipiMap') =
-          case nodeKey pkg of
-            PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
-            PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
-
-    mapDep _ ipiMap (PreExistingId _pid uid)
-      | Just pkgs <- Map.lookup uid ipiMap = pkgs
-      | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)
-    mapDep pidMap _ (PlannedId pid)
-      | Just pkgs <- Map.lookup pid pidMap = pkgs
-      | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)
-
--- This shouldn't happen, since mapDep should only be called
--- on neighbor SolverId, which must have all been done already
--- by the reverse top-sort (we assume the graph is not broken).
+  either (error . show) id $
+    runLogProgress' $
+      fromSolverInstallPlanWithProgress
+        (\mapDep planpkg -> return $ f mapDep planpkg)
+        plan
 
 fromSolverInstallPlanWithProgress
   :: (IsUnit ipkg, IsUnit srcpkg)
@@ -585,17 +561,18 @@ fromSolverInstallPlanWithProgress f plan = do
               PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
       return (pidMap', ipiMap', pkgs' ++ pkgs)
 
+    -- The error below shouldn't happen, since mapDep should only
+    -- be called on neighbor SolverId, which must have all been done
+    -- already by the reverse top-sort (we assume the graph is not broken).
+    --
+    -- FIXME: stage is ignored
     mapDep _ ipiMap (PreExistingId _pid uid)
       | Just pkgs <- Map.lookup uid ipiMap = pkgs
       | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)
     mapDep pidMap _ (PlannedId pid)
       | Just pkgs <- Map.lookup pid pidMap = pkgs
       | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)
 
--- This shouldn't happen, since mapDep should only be called
--- on neighbor SolverId, which must have all been done already
--- by the reverse top-sort (we assume the graph is not broken).
-
 -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'.
 -- Similar to 'elaboratedInstallPlan'
 configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan