refactor(cabal-install): use LogProgress in InstallPlan

Author: andreabedini

Cabal/src/Distribution/Utils/LogProgress.hs

@@ -9,6 +9,7 @@ module Distribution.Utils.LogProgress
   , infoProgress
   , dieProgress
   , addProgressCtx
+  , eitherToLogProgress
   ) where
 
 import Distribution.Compat.Prelude
@@ -99,3 +100,7 @@ formatMsg ctx doc = doc $$ vcat ctx
 addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a
 addProgressCtx s (LogProgress m) = LogProgress $ \env ->
   m env{le_context = s : le_context env}
+
+eitherToLogProgress :: Either Doc a -> LogProgress a
+eitherToLogProgress (Left err) = dieProgress err
+eitherToLogProgress (Right a) = return a

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

@@ -50,6 +50,9 @@ import Distribution.Simple.Utils
   , warn
   , wrapText
   )
+import Distribution.Utils.LogProgress
+  ( runLogProgress
+  )
 import Distribution.Verbosity
   ( normal
   )
@@ -133,11 +136,12 @@ benchAction flags targetStrings globalFlags = do
             Nothing
             targetSelectors
 
-      let elaboratedPlan' =
+      elaboratedPlan' <- runLogProgress verbosity $
             pruneInstallPlanToTargets
               TargetActionBench
               targets
               elaboratedPlan
+      
       return (elaboratedPlan', targets)
 
   printPlan verbosity baseCtx buildCtx

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 -- | cabal-install CLI command: build
 module Distribution.Client.CmdBuild
   ( -- * The @build@ CLI and action
@@ -55,6 +56,8 @@ import Distribution.Simple.Utils
 import Distribution.Verbosity
   ( normal
   )
+import Distribution.Utils.LogProgress (runLogProgress)
+import qualified Distribution.Client.InstallPlan as InstallPlan
 
 buildCommand :: CommandUI (NixStyleFlags BuildFlags)
 buildCommand =
@@ -161,18 +164,20 @@ buildAction flags@NixStyleFlags{extraFlags = buildFlags} targetStrings globalFla
               Nothing
               targetSelectors
 
-        let elaboratedPlan' =
-              pruneInstallPlanToTargets
-                targetAction
-                targets
-                elaboratedPlan
+        elaboratedPlan' <- runLogProgress verbosity $
+          pruneInstallPlanToTargets
+            targetAction
+            targets
+            elaboratedPlan
+        
         elaboratedPlan'' <-
           if buildSettingOnlyDeps (buildSettings baseCtx)
             then
-              either (reportCannotPruneDependencies verbosity) return $
-                pruneInstallPlanToDependencies
-                  (Map.keysSet targets)
-                  elaboratedPlan'
+              case pruneInstallPlanToDependencies (Map.keysSet targets) elaboratedPlan' of
+                Left err ->
+                  reportCannotPruneDependencies verbosity err
+                Right elaboratedPlan'' ->
+                  runLogProgress verbosity $ InstallPlan.new' elaboratedPlan''
             else return elaboratedPlan'
 
         return (elaboratedPlan'', targets)

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

@@ -18,7 +18,6 @@ import Control.Monad (mapM_)
 import Distribution.Client.Errors
 
 import Distribution.Client.ProjectPlanning hiding (pruneInstallPlanToTargets)
-import Distribution.Client.ProjectPlanning.Types
 import Distribution.Client.Types.ConfiguredId (confInstId)
 import Distribution.Client.Utils hiding (pvpize)
 import Distribution.InstalledPackageInfo (InstalledPackageInfo, installedComponentId)
@@ -28,6 +27,7 @@ import Distribution.Simple.Utils
 import Distribution.Version
 
 import Distribution.Client.Setup (GlobalFlags (..))
+import Distribution.Utils.LogProgress (runLogProgress)
 
 -- Project orchestration imports
 
@@ -44,6 +44,7 @@ import Distribution.Types.Component
 import Distribution.Verbosity
 import qualified Distribution.Compat.Graph as Graph
 
+
 -- | The data type for gen-bounds command flags
 data GenBoundsFlags = GenBoundsFlags {}
 
@@ -115,7 +116,7 @@ genBoundsAction flags targetStrings globalFlags =
           targetSelectors
 
     -- Step 3: Prune the install plan to the targets.
-    let elaboratedPlan' =
+    elaboratedPlan' <- runLogProgress verbosity $
           pruneInstallPlanToTargets
             TargetActionBuild
             targets

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

@@ -76,6 +76,7 @@ import Distribution.Verbosity
 
 import Distribution.Client.Errors
 import qualified System.Exit (exitSuccess)
+import Distribution.Utils.LogProgress (runLogProgress)
 
 newtype ClientHaddockFlags = ClientHaddockFlags {openInBrowser :: Flag Bool}
 
@@ -189,11 +190,12 @@ haddockAction relFlags targetStrings globalFlags = do
             Nothing
             targetSelectors
 
-      let elaboratedPlan' =
+      elaboratedPlan' <- runLogProgress verbosity $
             pruneInstallPlanToTargets
               TargetActionHaddock
               targets
               elaboratedPlan
+      
       return (elaboratedPlan', targets)
 
   printPlan verbosity baseCtx buildCtx

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

@@ -97,6 +97,7 @@ import Distribution.Types.PackageDescription (PackageDescription (benchmarks, su
 import Distribution.Types.PackageId (pkgName)
 import Distribution.Types.PackageName (unPackageName)
 import Distribution.Types.UnitId (unUnitId)
+import Distribution.Utils.LogProgress (runLogProgress)
 import Distribution.Verbosity as Verbosity
   ( normal
   )
@@ -146,11 +147,12 @@ haddockProjectAction flags _extraArgs globalFlags = do
                 Nothing
                 targetSelectors
 
-          let elaboratedPlan' =
-                pruneInstallPlanToTargets
-                  TargetActionBuild
-                  targets
-                  elaboratedPlan
+          elaboratedPlan' <-
+            runLogProgress verbosity $
+              pruneInstallPlanToTargets
+                TargetActionBuild
+                targets
+                elaboratedPlan
           return (elaboratedPlan', targets)
 
       let elaboratedPlan :: ElaboratedInstallPlan

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

@@ -219,6 +219,9 @@ import Distribution.Types.VersionRange
 import Distribution.Utils.Generic
   ( writeFileAtomic
   )
+import Distribution.Utils.LogProgress
+  ( runLogProgress
+  )
 import Distribution.Verbosity
   ( lessVerbose
   , normal
@@ -900,15 +903,17 @@ constructProjectBuildContext verbosity baseCtx targetSelectors = do
           Nothing
           targetSelectors
 
-    let prunedToTargetsElaboratedPlan =
+    prunedToTargetsElaboratedPlan <- runLogProgress verbosity $
           pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan
+    
     prunedElaboratedPlan <-
       if buildSettingOnlyDeps (buildSettings baseCtx)
-        then
-          either (reportCannotPruneDependencies verbosity) return $
-            pruneInstallPlanToDependencies
-              (Map.keysSet targets)
-              prunedToTargetsElaboratedPlan
+        then do
+          case pruneInstallPlanToDependencies (Map.keysSet targets) prunedToTargetsElaboratedPlan of
+            Left err ->
+              reportCannotPruneDependencies verbosity err
+            Right elaboratedPlan'' ->
+              runLogProgress verbosity $ InstallPlan.new' elaboratedPlan''
         else return prunedToTargetsElaboratedPlan
 
     return (prunedElaboratedPlan, targets)

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

@@ -60,6 +60,7 @@ import Distribution.Client.Errors
 import qualified Distribution.Client.InstallPlan as IP
 import qualified Distribution.Simple.InstallDirs as InstallDirs
 import qualified Distribution.Solver.Types.ComponentDeps as CD
+import Distribution.Utils.LogProgress (runLogProgress)
 
 -------------------------------------------------------------------------------
 -- Command
@@ -127,11 +128,12 @@ listbinAction flags args globalFlags = do
             )
             targets
 
-        let elaboratedPlan' =
+        elaboratedPlan' <- runLogProgress verbosity $
               pruneInstallPlanToTargets
                 TargetActionBuild
                 targets
                 elaboratedPlan
+        
         return (elaboratedPlan', targets)
 
     (selectedUnitId, selectedComponent) <-

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

@@ -157,6 +157,9 @@ import Distribution.Types.VersionRange
 import Distribution.Utils.Generic
   ( safeHead
   )
+import Distribution.Utils.LogProgress
+  ( runLogProgress
+  )
 import Distribution.Verbosity
   ( lessVerbose
   , normal
@@ -393,13 +396,13 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
         -- Recalculate with updated project.
         targets <- validatedTargets (projectConfigShared projectConfig) toolchainCompiler elaboratedPlan targetSelectors
 
-        let
-          elaboratedPlan' =
+        elaboratedPlan' <- runLogProgress verbosity $
             pruneInstallPlanToTargets
               TargetActionRepl
               targets
               elaboratedPlan
-          includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags)
+        
+        let includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags)
 
         pkgsBuildStatus <-
           rebuildTargetsDryRun

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

@@ -144,6 +144,7 @@ import System.FilePath
   , isValid
   , (</>)
   )
+import Distribution.Utils.LogProgress (runLogProgress)
 
 runCommand :: CommandUI (NixStyleFlags ())
 runCommand =
@@ -247,11 +248,12 @@ runAction flags targetAndArgs globalFlags =
             )
             targets
 
-        let elaboratedPlan' =
+        elaboratedPlan' <- runLogProgress verbosity $
               pruneInstallPlanToTargets
                 TargetActionBuild
                 targets
                 elaboratedPlan
+
         return (elaboratedPlan', targets)
 
     (selectedUnitId, selectedComponent) <-