Skip to content

Commit 23e01da

Browse files
andreabediniandreabedini
committed
refactor(cabal-install): use LogProgress in InstallPlan
1 parent 94e60c4 commit 23e01da

File tree

17 files changed

+246
-178
lines changed

17 files changed

+246
-178
lines changed

‎Cabal/src/Distribution/Utils/LogProgress.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ module Distribution.Utils.LogProgress
99
, infoProgress
1010
, dieProgress
1111
, addProgressCtx
12+
, eitherToLogProgress
1213
, ErrMsg
1314
) where
1415

@@ -100,3 +101,7 @@ formatMsg ctx doc = doc $$ vcat ctx
100101
addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a
101102
addProgressCtx s (LogProgress m) = LogProgress $ \env ->
102103
m env{le_context = s : le_context env}
104+
105+
eitherToLogProgress :: Either Doc a -> LogProgress a
106+
eitherToLogProgress (Left err) = dieProgress err
107+
eitherToLogProgress (Right a) = return a

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

Lines changed: 10 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -50,6 +50,9 @@ import Distribution.Simple.Utils
5050
, warn
5151
, wrapText
5252
)
53+
import Distribution.Utils.LogProgress
54+
( runLogProgress
55+
)
5356
import Distribution.Verbosity
5457
( normal
5558
)
@@ -133,11 +136,13 @@ benchAction flags targetStrings globalFlags = do
133136
Nothing
134137
targetSelectors
135138

136-
let elaboratedPlan' =
137-
pruneInstallPlanToTargets
138-
TargetActionBench
139-
targets
140-
elaboratedPlan
139+
elaboratedPlan' <-
140+
runLogProgress verbosity $
141+
pruneInstallPlanToTargets
142+
TargetActionBench
143+
targets
144+
elaboratedPlan
145+
141146
return (elaboratedPlan', targets)
142147

143148
printPlan verbosity baseCtx buildCtx

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

Lines changed: 16 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,5 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
13
-- | cabal-install CLI command: build
24
module Distribution.Client.CmdBuild
35
( -- * The @build@ CLI and action
@@ -26,6 +28,7 @@ import Distribution.Client.TargetProblem
2628

2729
import qualified Data.Map as Map
2830
import Distribution.Client.Errors
31+
import qualified Distribution.Client.InstallPlan as InstallPlan
2932
import Distribution.Client.NixStyleOptions
3033
( NixStyleFlags (..)
3134
, cfgVerbosity
@@ -52,6 +55,7 @@ import Distribution.Simple.Utils
5255
( dieWithException
5356
, wrapText
5457
)
58+
import Distribution.Utils.LogProgress (runLogProgress)
5559
import Distribution.Verbosity
5660
( normal
5761
)
@@ -161,18 +165,20 @@ buildAction flags@NixStyleFlags{extraFlags = buildFlags} targetStrings globalFla
161165
Nothing
162166
targetSelectors
163167

164-
let elaboratedPlan' =
165-
pruneInstallPlanToTargets
166-
targetAction
167-
targets
168-
elaboratedPlan
168+
elaboratedPlan' <-
169+
runLogProgress verbosity $
170+
pruneInstallPlanToTargets
171+
targetAction
172+
targets
173+
elaboratedPlan
174+
169175
elaboratedPlan'' <-
170176
if buildSettingOnlyDeps (buildSettings baseCtx)
171-
then
172-
either (reportCannotPruneDependencies verbosity) return $
173-
pruneInstallPlanToDependencies
174-
(Map.keysSet targets)
175-
elaboratedPlan'
177+
then case pruneInstallPlanToDependencies (Map.keysSet targets) elaboratedPlan' of
178+
Left err ->
179+
reportCannotPruneDependencies verbosity err
180+
Right elaboratedPlan'' ->
181+
runLogProgress verbosity $ InstallPlan.new' elaboratedPlan''
176182
else return elaboratedPlan'
177183

178184
return (elaboratedPlan'', targets)

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

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ import Distribution.Simple.Utils
2727
import Distribution.Version
2828

2929
import Distribution.Client.Setup (GlobalFlags (..))
30+
import Distribution.Utils.LogProgress (runLogProgress)
3031

3132
-- Project orchestration imports
3233

@@ -114,11 +115,12 @@ genBoundsAction flags targetStrings globalFlags =
114115
targetSelectors
115116

116117
-- Step 3: Prune the install plan to the targets.
117-
let elaboratedPlan' =
118-
pruneInstallPlanToTargets
119-
TargetActionBuild
120-
targets
121-
elaboratedPlan
118+
elaboratedPlan' <-
119+
runLogProgress verbosity $
120+
pruneInstallPlanToTargets
121+
TargetActionBuild
122+
targets
123+
elaboratedPlan
122124

123125
let
124126
-- Step 4a: Find the local packages from the install plan. These are the

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

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -75,6 +75,7 @@ import Distribution.Verbosity
7575
)
7676

7777
import Distribution.Client.Errors
78+
import Distribution.Utils.LogProgress (runLogProgress)
7879
import qualified System.Exit (exitSuccess)
7980

8081
newtype ClientHaddockFlags = ClientHaddockFlags {openInBrowser :: Flag Bool}
@@ -189,11 +190,13 @@ haddockAction relFlags targetStrings globalFlags = do
189190
Nothing
190191
targetSelectors
191192

192-
let elaboratedPlan' =
193-
pruneInstallPlanToTargets
194-
TargetActionHaddock
195-
targets
196-
elaboratedPlan
193+
elaboratedPlan' <-
194+
runLogProgress verbosity $
195+
pruneInstallPlanToTargets
196+
TargetActionHaddock
197+
targets
198+
elaboratedPlan
199+
197200
return (elaboratedPlan', targets)
198201

199202
printPlan verbosity baseCtx buildCtx

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

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -98,6 +98,7 @@ import Distribution.Types.PackageDescription (PackageDescription (benchmarks, su
9898
import Distribution.Types.PackageId (pkgName)
9999
import Distribution.Types.PackageName (unPackageName)
100100
import Distribution.Types.UnitId (unUnitId)
101+
import Distribution.Utils.LogProgress (runLogProgress)
101102
import Distribution.Verbosity as Verbosity
102103
( normal
103104
)
@@ -147,11 +148,12 @@ haddockProjectAction flags _extraArgs globalFlags = do
147148
Nothing
148149
targetSelectors
149150

150-
let elaboratedPlan' =
151-
pruneInstallPlanToTargets
152-
TargetActionBuild
153-
targets
154-
elaboratedPlan
151+
elaboratedPlan' <-
152+
runLogProgress verbosity $
153+
pruneInstallPlanToTargets
154+
TargetActionBuild
155+
targets
156+
elaboratedPlan
155157
return (elaboratedPlan', targets)
156158

157159
let elaboratedPlan :: ElaboratedInstallPlan

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

Lines changed: 13 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -219,6 +219,9 @@ import Distribution.Types.VersionRange
219219
import Distribution.Utils.Generic
220220
( writeFileAtomic
221221
)
222+
import Distribution.Utils.LogProgress
223+
( runLogProgress
224+
)
222225
import Distribution.Verbosity
223226
( lessVerbose
224227
, normal
@@ -900,15 +903,18 @@ constructProjectBuildContext verbosity baseCtx targetSelectors = do
900903
Nothing
901904
targetSelectors
902905

903-
let prunedToTargetsElaboratedPlan =
904-
pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan
906+
prunedToTargetsElaboratedPlan <-
907+
runLogProgress verbosity $
908+
pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan
909+
905910
prunedElaboratedPlan <-
906911
if buildSettingOnlyDeps (buildSettings baseCtx)
907-
then
908-
either (reportCannotPruneDependencies verbosity) return $
909-
pruneInstallPlanToDependencies
910-
(Map.keysSet targets)
911-
prunedToTargetsElaboratedPlan
912+
then do
913+
case pruneInstallPlanToDependencies (Map.keysSet targets) prunedToTargetsElaboratedPlan of
914+
Left err ->
915+
reportCannotPruneDependencies verbosity err
916+
Right elaboratedPlan'' ->
917+
runLogProgress verbosity $ InstallPlan.new' elaboratedPlan''
912918
else return prunedToTargetsElaboratedPlan
913919

914920
return (prunedElaboratedPlan, targets)

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

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -60,6 +60,7 @@ import Distribution.Client.Errors
6060
import qualified Distribution.Client.InstallPlan as IP
6161
import qualified Distribution.Simple.InstallDirs as InstallDirs
6262
import qualified Distribution.Solver.Types.ComponentDeps as CD
63+
import Distribution.Utils.LogProgress (runLogProgress)
6364

6465
-------------------------------------------------------------------------------
6566
-- Command
@@ -127,11 +128,13 @@ listbinAction flags args globalFlags = do
127128
)
128129
targets
129130

130-
let elaboratedPlan' =
131-
pruneInstallPlanToTargets
132-
TargetActionBuild
133-
targets
134-
elaboratedPlan
131+
elaboratedPlan' <-
132+
runLogProgress verbosity $
133+
pruneInstallPlanToTargets
134+
TargetActionBuild
135+
targets
136+
elaboratedPlan
137+
135138
return (elaboratedPlan', targets)
136139

137140
(selectedUnitId, selectedComponent) <-

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

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -157,6 +157,9 @@ import Distribution.Types.VersionRange
157157
import Distribution.Utils.Generic
158158
( safeHead
159159
)
160+
import Distribution.Utils.LogProgress
161+
( runLogProgress
162+
)
160163
import Distribution.Verbosity
161164
( lessVerbose
162165
, normal
@@ -394,13 +397,14 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
394397
-- Recalculate with updated project.
395398
targets <- validatedTargets (projectConfigShared projectConfig) toolchainCompiler elaboratedPlan targetSelectors
396399

397-
let
398-
elaboratedPlan' =
400+
elaboratedPlan' <-
401+
runLogProgress verbosity $
399402
pruneInstallPlanToTargets
400403
TargetActionRepl
401404
targets
402405
elaboratedPlan
403-
includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags)
406+
407+
let includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags)
404408

405409
pkgsBuildStatus <-
406410
rebuildTargetsDryRun

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

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -126,6 +126,7 @@ import Distribution.Types.UnqualComponentName
126126
( UnqualComponentName
127127
, unUnqualComponentName
128128
)
129+
import Distribution.Utils.LogProgress (runLogProgress)
129130
import Distribution.Utils.NubList
130131
( fromNubList
131132
)
@@ -247,11 +248,13 @@ runAction flags targetAndArgs globalFlags =
247248
)
248249
targets
249250

250-
let elaboratedPlan' =
251-
pruneInstallPlanToTargets
252-
TargetActionBuild
253-
targets
254-
elaboratedPlan
251+
elaboratedPlan' <-
252+
runLogProgress verbosity $
253+
pruneInstallPlanToTargets
254+
TargetActionBuild
255+
targets
256+
elaboratedPlan
257+
255258
return (elaboratedPlan', targets)
256259

257260
(selectedUnitId, selectedComponent) <-

0 commit comments

Comments
 (0)