Skip to content

Commit 653d59d

Browse files
dcouttsdcoutts
committed
Add a new-freeze command
This is ok, but not perfect since freezing is now more tricky with setup deps. See haskell#3502
1 parent c1fbb1c commit 653d59d

File tree

3 files changed

+168
-0
lines changed

3 files changed

+168
-0
lines changed

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

+164
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
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 $ "'fetch' 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+
mempty {
98+
projectConfigShared = 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/Main.hs

+3
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

+1
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

0 commit comments

Comments
 (0)