Skip to content

Commit 108d15a

Browse files
dcouttsdcoutts
authored
Merge pull request #3503 from dcoutts/new-freeze
New freeze command
2 parents fb51463 + f24d4a3 commit 108d15a

File tree

8 files changed

+245
-25
lines changed

8 files changed

+245
-25
lines changed

‎cabal-install/Distribution/Client/CmdFreeze.hs

Lines changed: 164 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,164 @@
1+
{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
2+
3+
-- | cabal-install CLI command: freeze
4+
--
5+
module Distribution.Client.CmdFreeze (
6+
freezeAction,
7+
) where
8+
9+
import Distribution.Client.ProjectPlanning
10+
( ElaboratedInstallPlan, rebuildInstallPlan )
11+
import Distribution.Client.ProjectConfig
12+
( ProjectConfig(..), ProjectConfigShared(..)
13+
, commandLineFlagsToProjectConfig, writeProjectLocalFreezeConfig
14+
, findProjectRoot )
15+
import Distribution.Client.ProjectPlanning.Types
16+
( ElaboratedConfiguredPackage(..) )
17+
import Distribution.Client.Targets
18+
( UserConstraint(..) )
19+
import Distribution.Solver.Types.ConstraintSource
20+
( ConstraintSource(..) )
21+
import Distribution.Client.DistDirLayout
22+
( defaultDistDirLayout, defaultCabalDirLayout )
23+
import Distribution.Client.Config
24+
( defaultCabalDir )
25+
import qualified Distribution.Client.InstallPlan as InstallPlan
26+
27+
28+
import Distribution.Package
29+
( PackageName, packageName, packageVersion )
30+
import Distribution.Version
31+
( VersionRange, thisVersion, unionVersionRanges )
32+
import Distribution.PackageDescription
33+
( FlagAssignment )
34+
import Distribution.Client.Setup
35+
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
36+
import Distribution.Simple.Setup
37+
( HaddockFlags, fromFlagOrDefault )
38+
import Distribution.Simple.Utils
39+
( die, notice )
40+
import Distribution.Verbosity
41+
( normal )
42+
43+
import Data.Monoid as Monoid
44+
import qualified Data.Map as Map
45+
import Data.Map (Map)
46+
import Control.Monad (unless)
47+
import System.FilePath
48+
49+
50+
-- | To a first approximation, the @freeze@ command runs the first phase of
51+
-- the @build@ command where we bring the install plan up to date, and then
52+
-- based on the install plan we write out a @cabal.project.freeze@ config file.
53+
--
54+
-- For more details on how this works, see the module
55+
-- "Distribution.Client.ProjectOrchestration"
56+
--
57+
freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
58+
-> [String] -> GlobalFlags -> IO ()
59+
freezeAction (configFlags, configExFlags, installFlags, haddockFlags)
60+
extraArgs globalFlags = do
61+
62+
unless (null extraArgs) $
63+
die $ "'freeze' doesn't take any extra arguments: "
64+
++ unwords extraArgs
65+
66+
cabalDir <- defaultCabalDir
67+
let cabalDirLayout = defaultCabalDirLayout cabalDir
68+
69+
projectRootDir <- findProjectRoot
70+
let distDirLayout = defaultDistDirLayout projectRootDir
71+
72+
let cliConfig = commandLineFlagsToProjectConfig
73+
globalFlags configFlags configExFlags
74+
installFlags haddockFlags
75+
76+
77+
(_, elaboratedPlan, _, _) <-
78+
rebuildInstallPlan verbosity
79+
projectRootDir distDirLayout cabalDirLayout
80+
cliConfig
81+
82+
let freezeConfig = projectFreezeConfig elaboratedPlan
83+
writeProjectLocalFreezeConfig projectRootDir freezeConfig
84+
notice verbosity $
85+
"Wrote freeze file: " ++ projectRootDir </> "cabal.project.freeze"
86+
87+
where
88+
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
89+
90+
91+
92+
-- | Given the install plan, produce a config value with constraints that
93+
-- freezes the versions of packages used in the plan.
94+
--
95+
projectFreezeConfig :: ElaboratedInstallPlan -> ProjectConfig
96+
projectFreezeConfig elaboratedPlan =
97+
Monoid.mempty {
98+
projectConfigShared = Monoid.mempty {
99+
projectConfigConstraints =
100+
concat (Map.elems (projectFreezeConstraints elaboratedPlan))
101+
}
102+
}
103+
104+
-- | Given the install plan, produce solver constraints that will ensure the
105+
-- solver picks the same solution again in future in different environments.
106+
--
107+
projectFreezeConstraints :: ElaboratedInstallPlan
108+
-> Map PackageName [(UserConstraint, ConstraintSource)]
109+
projectFreezeConstraints plan =
110+
--
111+
-- TODO: [required eventually] this is currently an underapproximation
112+
-- since the constraints language is not expressive enough to specify the
113+
-- precise solution. See https://github.com/haskell/cabal/issues/3502.
114+
--
115+
-- For the moment we deal with multiple versions in the solution by using
116+
-- constraints that allow either version. Also, we do not include any
117+
-- constraints for packages that are local to the project (e.g. if the
118+
-- solution has two instances of Cabal, one from the local project and one
119+
-- pulled in as a setup deps then we exclude all constraints on Cabal, not
120+
-- just the constraint for the local instance since any constraint would
121+
-- apply to both instances).
122+
--
123+
Map.unionWith (++) versionConstraints flagConstraints
124+
`Map.difference` localPackages
125+
where
126+
versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
127+
versionConstraints =
128+
Map.mapWithKey
129+
(\p v -> [(UserConstraintVersion p v, ConstraintSourceFreeze)])
130+
versionRanges
131+
132+
versionRanges :: Map PackageName VersionRange
133+
versionRanges =
134+
Map.fromListWith unionVersionRanges $
135+
[ (packageName pkg, thisVersion (packageVersion pkg))
136+
| InstallPlan.PreExisting pkg <- InstallPlan.toList plan
137+
]
138+
++ [ (packageName pkg, thisVersion (packageVersion pkg))
139+
| InstallPlan.Configured pkg <- InstallPlan.toList plan
140+
]
141+
142+
flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
143+
flagConstraints =
144+
Map.mapWithKey
145+
(\p f -> [(UserConstraintFlags p f, ConstraintSourceFreeze)])
146+
flagAssignments
147+
148+
flagAssignments :: Map PackageName FlagAssignment
149+
flagAssignments =
150+
Map.fromList
151+
[ (pkgname, flags)
152+
| InstallPlan.Configured pkg <- InstallPlan.toList plan
153+
, let flags = pkgFlagAssignment pkg
154+
pkgname = packageName pkg
155+
, not (null flags) ]
156+
157+
localPackages :: Map PackageName ()
158+
localPackages =
159+
Map.fromList
160+
[ (packageName pkg, ())
161+
| InstallPlan.Configured pkg <- InstallPlan.toList plan
162+
, pkgLocalToProject pkg
163+
]
164+

‎cabal-install/Distribution/Client/ProjectConfig.hs

Lines changed: 44 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ module Distribution.Client.ProjectConfig (
1616
findProjectRoot,
1717
readProjectConfig,
1818
writeProjectLocalExtraConfig,
19+
writeProjectLocalFreezeConfig,
1920
writeProjectConfigFile,
2021
commandLineFlagsToProjectConfig,
2122

@@ -362,9 +363,10 @@ findProjectRoot = do
362363
readProjectConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig
363364
readProjectConfig verbosity projectRootDir = do
364365
global <- readGlobalConfig verbosity
365-
local <- readProjectLocalConfig verbosity projectRootDir
366-
extra <- readProjectLocalExtraConfig verbosity projectRootDir
367-
return (global <> local <> extra)
366+
local <- readProjectLocalConfig verbosity projectRootDir
367+
freeze <- readProjectLocalFreezeConfig verbosity projectRootDir
368+
extra <- readProjectLocalExtraConfig verbosity projectRootDir
369+
return (global <> local <> freeze <> extra)
368370

369371

370372
-- | Reads an explicit @cabal.project@ file in the given project root dir,
@@ -399,26 +401,43 @@ readProjectLocalConfig verbosity projectRootDir = do
399401
}
400402

401403

402-
-- | Reads a @cabal.project.extra@ file in the given project root dir,
404+
-- | Reads a @cabal.project.local@ file in the given project root dir,
403405
-- or returns empty. This file gets written by @cabal configure@, or in
404406
-- principle can be edited manually or by other tools.
405407
--
406408
readProjectLocalExtraConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig
407-
readProjectLocalExtraConfig verbosity projectRootDir = do
408-
hasExtraConfig <- liftIO $ doesFileExist projectExtraConfigFile
409-
if hasExtraConfig
410-
then do monitorFiles [monitorFileHashed projectExtraConfigFile]
411-
liftIO readProjectExtraConfigFile
412-
else do monitorFiles [monitorNonExistentFile projectExtraConfigFile]
409+
readProjectLocalExtraConfig verbosity =
410+
readProjectExtensionFile verbosity "local"
411+
"project local configuration file"
412+
413+
-- | Reads a @cabal.project.freeze@ file in the given project root dir,
414+
-- or returns empty. This file gets written by @cabal freeze@, or in
415+
-- principle can be edited manually or by other tools.
416+
--
417+
readProjectLocalFreezeConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig
418+
readProjectLocalFreezeConfig verbosity =
419+
readProjectExtensionFile verbosity "freeze"
420+
"project freeze file"
421+
422+
-- | Reads a named config file in the given project root dir, or returns empty.
423+
--
424+
readProjectExtensionFile :: Verbosity -> String -> FilePath
425+
-> FilePath -> Rebuild ProjectConfig
426+
readProjectExtensionFile verbosity extensionName extensionDescription
427+
projectRootDir = do
428+
exists <- liftIO $ doesFileExist extensionFile
429+
if exists
430+
then do monitorFiles [monitorFileHashed extensionFile]
431+
liftIO readExtensionFile
432+
else do monitorFiles [monitorNonExistentFile extensionFile]
413433
return mempty
414434
where
415-
projectExtraConfigFile = projectRootDir </> "cabal.project.local"
435+
extensionFile = projectRootDir </> "cabal.project" <.> extensionName
416436

417-
readProjectExtraConfigFile =
418-
reportParseResult verbosity "project local configuration file"
419-
projectExtraConfigFile
437+
readExtensionFile =
438+
reportParseResult verbosity extensionDescription extensionFile
420439
. parseProjectConfig
421-
=<< readFile projectExtraConfigFile
440+
=<< readFile extensionFile
422441

423442

424443
-- | Parse the 'ProjectConfig' format.
@@ -442,7 +461,7 @@ showProjectConfig =
442461
showLegacyProjectConfig . convertToLegacyProjectConfig
443462

444463

445-
-- | Write a @cabal.project.extra@ file in the given project root dir.
464+
-- | Write a @cabal.project.local@ file in the given project root dir.
446465
--
447466
writeProjectLocalExtraConfig :: FilePath -> ProjectConfig -> IO ()
448467
writeProjectLocalExtraConfig projectRootDir =
@@ -451,6 +470,15 @@ writeProjectLocalExtraConfig projectRootDir =
451470
projectExtraConfigFile = projectRootDir </> "cabal.project.local"
452471

453472

473+
-- | Write a @cabal.project.freeze@ file in the given project root dir.
474+
--
475+
writeProjectLocalFreezeConfig :: FilePath -> ProjectConfig -> IO ()
476+
writeProjectLocalFreezeConfig projectRootDir =
477+
writeProjectConfigFile projectFreezeConfigFile
478+
where
479+
projectFreezeConfigFile = projectRootDir </> "cabal.project.freeze"
480+
481+
454482
-- | Write in the @cabal.project@ format to the given file.
455483
--
456484
writeProjectConfigFile :: FilePath -> ProjectConfig -> IO ()

‎cabal-install/Distribution/Client/ProjectOrchestration.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -155,7 +155,7 @@ runProjectPreBuildPhase
155155
-- everything in the project. This is independent of any specific targets
156156
-- the user has asked for.
157157
--
158-
(elaboratedPlan, elaboratedShared, projectConfig) <-
158+
(elaboratedPlan, _, elaboratedShared, projectConfig) <-
159159
rebuildInstallPlan verbosity
160160
projectRootDir distDirLayout cabalDirLayout
161161
cliConfig

‎cabal-install/Distribution/Client/ProjectPlanning.hs

Lines changed: 24 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -231,12 +231,27 @@ sanityCheckElaboratedConfiguredPackage sharedConfig
231231
-- * Deciding what to do: making an 'ElaboratedInstallPlan'
232232
------------------------------------------------------------------------------
233233

234+
-- | Return an up-to-date elaborated install plan and associated config.
235+
--
236+
-- Two variants of the install plan are returned: with and without packages
237+
-- from the store. That is, the \"improved\" plan where source packages are
238+
-- replaced by pre-existing installed packages from the store (when their ids
239+
-- match), and also the original elaborated plan which uses primarily source
240+
-- packages.
241+
242+
-- The improved plan is what we use for building, but the original elaborated
243+
-- plan is useful for reporting and configuration. For example the @freeze@
244+
-- command needs the source package info to know about flag choices and
245+
-- dependencies of executables and setup scripts.
246+
--
234247
rebuildInstallPlan :: Verbosity
235248
-> FilePath -> DistDirLayout -> CabalDirLayout
236249
-> ProjectConfig
237-
-> IO ( ElaboratedInstallPlan
250+
-> IO ( ElaboratedInstallPlan -- with store packages
251+
, ElaboratedInstallPlan -- with source packages
238252
, ElaboratedSharedConfig
239253
, ProjectConfig )
254+
-- ^ @(improvedPlan, elaboratedPlan, _, _)@
240255
rebuildInstallPlan verbosity
241256
projectRootDir
242257
distDirLayout@DistDirLayout {
@@ -275,16 +290,16 @@ rebuildInstallPlan verbosity
275290
elaboratedShared) <- phaseElaboratePlan projectConfigTransient
276291
compilerEtc
277292
solverPlan localPackages
278-
phaseMaintainPlanOutputs elaboratedPlan elaboratedShared
279-
280-
return (elaboratedPlan, elaboratedShared,
281-
projectConfig)
293+
return (elaboratedPlan, elaboratedShared, projectConfig)
282294

283295
-- The improved plan changes each time we install something, whereas
284296
-- the underlying elaborated plan only changes when input config
285297
-- changes, so it's worth caching them separately.
286298
improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared
287-
return (improvedPlan, elaboratedShared, projectConfig)
299+
300+
phaseMaintainPlanOutputs improvedPlan elaboratedPlan elaboratedShared
301+
302+
return (improvedPlan, elaboratedPlan, elaboratedShared, projectConfig)
288303

289304
where
290305
fileMonitorCompiler = newFileMonitorInCacheDir "compiler"
@@ -537,9 +552,10 @@ rebuildInstallPlan verbosity
537552
-- the libs available. This will need to be after plan improvement phase.
538553
--
539554
phaseMaintainPlanOutputs :: ElaboratedInstallPlan
555+
-> ElaboratedInstallPlan
540556
-> ElaboratedSharedConfig
541557
-> Rebuild ()
542-
phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = do
558+
phaseMaintainPlanOutputs _improvedPlan elaboratedPlan elaboratedShared = do
543559
liftIO $ debug verbosity "Updating plan.json"
544560
liftIO $ writePlanExternalRepresentation
545561
distDirLayout
@@ -1090,6 +1106,7 @@ elaborateInstallPlan platform compiler compilerprogdb
10901106

10911107
pkgSourceLocation = srcloc
10921108
pkgSourceHash = Map.lookup pkgid sourcePackageHashes
1109+
pkgLocalToProject = isLocalToProject pkg
10931110
pkgBuildStyle = if shouldBuildInplaceOnly pkg
10941111
then BuildInplaceOnly else BuildAndInstall
10951112
pkgBuildPackageDBStack = buildAndRegisterDbs

‎cabal-install/Distribution/Client/ProjectPlanning/Types.hs

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -165,6 +165,13 @@ data ElaboratedConfiguredPackage
165165
--pkgSourceDir ? -- currently passed in later because they can use temp locations
166166
--pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc
167167

168+
-- | Is this package one of the ones specified by location in the
169+
-- project file? (As opposed to a dependency, or a named package pulled
170+
-- in)
171+
pkgLocalToProject :: Bool,
172+
173+
-- | Are we going to build and install this package to the store, or are
174+
-- we going to build it and register it locally.
168175
pkgBuildStyle :: BuildStyle,
169176

170177
pkgSetupPackageDBStack :: PackageDBStack,

‎cabal-install/Main.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -71,6 +71,7 @@ import qualified Distribution.Client.List as List
7171
import qualified Distribution.Client.CmdConfigure as CmdConfigure
7272
import qualified Distribution.Client.CmdBuild as CmdBuild
7373
import qualified Distribution.Client.CmdRepl as CmdRepl
74+
import qualified Distribution.Client.CmdFreeze as CmdFreeze
7475

7576
import Distribution.Client.Install (install)
7677
import Distribution.Client.Configure (configure)
@@ -283,6 +284,8 @@ mainWorker args = topHandler $
283284
CmdBuild.buildAction
284285
, hiddenCmd installCommand { commandName = "new-repl" }
285286
CmdRepl.replAction
287+
, hiddenCmd installCommand { commandName = "new-freeze" }
288+
CmdFreeze.freezeAction
286289
]
287290

288291
type Action = GlobalFlags -> IO ()

‎cabal-install/cabal-install.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -182,6 +182,7 @@ executable cabal
182182
Distribution.Client.Check
183183
Distribution.Client.CmdBuild
184184
Distribution.Client.CmdConfigure
185+
Distribution.Client.CmdFreeze
185186
Distribution.Client.CmdRepl
186187
Distribution.Client.Config
187188
Distribution.Client.Configure

‎cabal-install/tests/IntegrationTests2.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -231,7 +231,7 @@ planProject testdir cliConfig = do
231231
-- ended in an exception (as we leave the files to help with debugging).
232232
cleanProject testdir
233233

234-
(elaboratedPlan, elaboratedShared, projectConfig) <-
234+
(elaboratedPlan, _, elaboratedShared, projectConfig) <-
235235
rebuildInstallPlan verbosity
236236
projectRootDir distDirLayout cabalDirLayout
237237
cliConfig

0 commit comments

Comments
 (0)