Commit 108d15ac authored by Duncan Coutts's avatar Duncan Coutts Committed by GitHub
Browse files

Merge pull request #3503 from dcoutts/new-freeze

New freeze command
parents fb514630 f24d4a33
{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
-- | cabal-install CLI command: freeze
--
module Distribution.Client.CmdFreeze (
freezeAction,
) where
import Distribution.Client.ProjectPlanning
( ElaboratedInstallPlan, rebuildInstallPlan )
import Distribution.Client.ProjectConfig
( ProjectConfig(..), ProjectConfigShared(..)
, commandLineFlagsToProjectConfig, writeProjectLocalFreezeConfig
, findProjectRoot )
import Distribution.Client.ProjectPlanning.Types
( ElaboratedConfiguredPackage(..) )
import Distribution.Client.Targets
( UserConstraint(..) )
import Distribution.Solver.Types.ConstraintSource
( ConstraintSource(..) )
import Distribution.Client.DistDirLayout
( defaultDistDirLayout, defaultCabalDirLayout )
import Distribution.Client.Config
( defaultCabalDir )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Package
( PackageName, packageName, packageVersion )
import Distribution.Version
( VersionRange, thisVersion, unionVersionRanges )
import Distribution.PackageDescription
( FlagAssignment )
import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
import Distribution.Simple.Setup
( HaddockFlags, fromFlagOrDefault )
import Distribution.Simple.Utils
( die, notice )
import Distribution.Verbosity
( normal )
import Data.Monoid as Monoid
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Monad (unless)
import System.FilePath
-- | To a first approximation, the @freeze@ command runs the first phase of
-- the @build@ command where we bring the install plan up to date, and then
-- based on the install plan we write out a @cabal.project.freeze@ config file.
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
-> [String] -> GlobalFlags -> IO ()
freezeAction (configFlags, configExFlags, installFlags, haddockFlags)
extraArgs globalFlags = do
unless (null extraArgs) $
die $ "'freeze' doesn't take any extra arguments: "
++ unwords extraArgs
cabalDir <- defaultCabalDir
let cabalDirLayout = defaultCabalDirLayout cabalDir
projectRootDir <- findProjectRoot
let distDirLayout = defaultDistDirLayout projectRootDir
let cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags
installFlags haddockFlags
(_, elaboratedPlan, _, _) <-
rebuildInstallPlan verbosity
projectRootDir distDirLayout cabalDirLayout
cliConfig
let freezeConfig = projectFreezeConfig elaboratedPlan
writeProjectLocalFreezeConfig projectRootDir freezeConfig
notice verbosity $
"Wrote freeze file: " ++ projectRootDir </> "cabal.project.freeze"
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
-- | Given the install plan, produce a config value with constraints that
-- freezes the versions of packages used in the plan.
--
projectFreezeConfig :: ElaboratedInstallPlan -> ProjectConfig
projectFreezeConfig elaboratedPlan =
Monoid.mempty {
projectConfigShared = Monoid.mempty {
projectConfigConstraints =
concat (Map.elems (projectFreezeConstraints elaboratedPlan))
}
}
-- | Given the install plan, produce solver constraints that will ensure the
-- solver picks the same solution again in future in different environments.
--
projectFreezeConstraints :: ElaboratedInstallPlan
-> Map PackageName [(UserConstraint, ConstraintSource)]
projectFreezeConstraints plan =
--
-- TODO: [required eventually] this is currently an underapproximation
-- since the constraints language is not expressive enough to specify the
-- precise solution. See https://github.com/haskell/cabal/issues/3502.
--
-- For the moment we deal with multiple versions in the solution by using
-- constraints that allow either version. Also, we do not include any
-- constraints for packages that are local to the project (e.g. if the
-- solution has two instances of Cabal, one from the local project and one
-- pulled in as a setup deps then we exclude all constraints on Cabal, not
-- just the constraint for the local instance since any constraint would
-- apply to both instances).
--
Map.unionWith (++) versionConstraints flagConstraints
`Map.difference` localPackages
where
versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
versionConstraints =
Map.mapWithKey
(\p v -> [(UserConstraintVersion p v, ConstraintSourceFreeze)])
versionRanges
versionRanges :: Map PackageName VersionRange
versionRanges =
Map.fromListWith unionVersionRanges $
[ (packageName pkg, thisVersion (packageVersion pkg))
| InstallPlan.PreExisting pkg <- InstallPlan.toList plan
]
++ [ (packageName pkg, thisVersion (packageVersion pkg))
| InstallPlan.Configured pkg <- InstallPlan.toList plan
]
flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
flagConstraints =
Map.mapWithKey
(\p f -> [(UserConstraintFlags p f, ConstraintSourceFreeze)])
flagAssignments
flagAssignments :: Map PackageName FlagAssignment
flagAssignments =
Map.fromList
[ (pkgname, flags)
| InstallPlan.Configured pkg <- InstallPlan.toList plan
, let flags = pkgFlagAssignment pkg
pkgname = packageName pkg
, not (null flags) ]
localPackages :: Map PackageName ()
localPackages =
Map.fromList
[ (packageName pkg, ())
| InstallPlan.Configured pkg <- InstallPlan.toList plan
, pkgLocalToProject pkg
]
......@@ -16,6 +16,7 @@ module Distribution.Client.ProjectConfig (
findProjectRoot,
readProjectConfig,
writeProjectLocalExtraConfig,
writeProjectLocalFreezeConfig,
writeProjectConfigFile,
commandLineFlagsToProjectConfig,
......@@ -362,9 +363,10 @@ findProjectRoot = do
readProjectConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig
readProjectConfig verbosity projectRootDir = do
global <- readGlobalConfig verbosity
local <- readProjectLocalConfig verbosity projectRootDir
extra <- readProjectLocalExtraConfig verbosity projectRootDir
return (global <> local <> extra)
local <- readProjectLocalConfig verbosity projectRootDir
freeze <- readProjectLocalFreezeConfig verbosity projectRootDir
extra <- readProjectLocalExtraConfig verbosity projectRootDir
return (global <> local <> freeze <> extra)
-- | Reads an explicit @cabal.project@ file in the given project root dir,
......@@ -399,26 +401,43 @@ readProjectLocalConfig verbosity projectRootDir = do
}
-- | Reads a @cabal.project.extra@ file in the given project root dir,
-- | Reads a @cabal.project.local@ file in the given project root dir,
-- or returns empty. This file gets written by @cabal configure@, or in
-- principle can be edited manually or by other tools.
--
readProjectLocalExtraConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig
readProjectLocalExtraConfig verbosity projectRootDir = do
hasExtraConfig <- liftIO $ doesFileExist projectExtraConfigFile
if hasExtraConfig
then do monitorFiles [monitorFileHashed projectExtraConfigFile]
liftIO readProjectExtraConfigFile
else do monitorFiles [monitorNonExistentFile projectExtraConfigFile]
readProjectLocalExtraConfig verbosity =
readProjectExtensionFile verbosity "local"
"project local configuration file"
-- | Reads a @cabal.project.freeze@ file in the given project root dir,
-- or returns empty. This file gets written by @cabal freeze@, or in
-- principle can be edited manually or by other tools.
--
readProjectLocalFreezeConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig
readProjectLocalFreezeConfig verbosity =
readProjectExtensionFile verbosity "freeze"
"project freeze file"
-- | Reads a named config file in the given project root dir, or returns empty.
--
readProjectExtensionFile :: Verbosity -> String -> FilePath
-> FilePath -> Rebuild ProjectConfig
readProjectExtensionFile verbosity extensionName extensionDescription
projectRootDir = do
exists <- liftIO $ doesFileExist extensionFile
if exists
then do monitorFiles [monitorFileHashed extensionFile]
liftIO readExtensionFile
else do monitorFiles [monitorNonExistentFile extensionFile]
return mempty
where
projectExtraConfigFile = projectRootDir </> "cabal.project.local"
extensionFile = projectRootDir </> "cabal.project" <.> extensionName
readProjectExtraConfigFile =
reportParseResult verbosity "project local configuration file"
projectExtraConfigFile
readExtensionFile =
reportParseResult verbosity extensionDescription extensionFile
. parseProjectConfig
=<< readFile projectExtraConfigFile
=<< readFile extensionFile
-- | Parse the 'ProjectConfig' format.
......@@ -442,7 +461,7 @@ showProjectConfig =
showLegacyProjectConfig . convertToLegacyProjectConfig
-- | Write a @cabal.project.extra@ file in the given project root dir.
-- | Write a @cabal.project.local@ file in the given project root dir.
--
writeProjectLocalExtraConfig :: FilePath -> ProjectConfig -> IO ()
writeProjectLocalExtraConfig projectRootDir =
......@@ -451,6 +470,15 @@ writeProjectLocalExtraConfig projectRootDir =
projectExtraConfigFile = projectRootDir </> "cabal.project.local"
-- | Write a @cabal.project.freeze@ file in the given project root dir.
--
writeProjectLocalFreezeConfig :: FilePath -> ProjectConfig -> IO ()
writeProjectLocalFreezeConfig projectRootDir =
writeProjectConfigFile projectFreezeConfigFile
where
projectFreezeConfigFile = projectRootDir </> "cabal.project.freeze"
-- | Write in the @cabal.project@ format to the given file.
--
writeProjectConfigFile :: FilePath -> ProjectConfig -> IO ()
......
......@@ -155,7 +155,7 @@ runProjectPreBuildPhase
-- everything in the project. This is independent of any specific targets
-- the user has asked for.
--
(elaboratedPlan, elaboratedShared, projectConfig) <-
(elaboratedPlan, _, elaboratedShared, projectConfig) <-
rebuildInstallPlan verbosity
projectRootDir distDirLayout cabalDirLayout
cliConfig
......
......@@ -231,12 +231,27 @@ sanityCheckElaboratedConfiguredPackage sharedConfig
-- * Deciding what to do: making an 'ElaboratedInstallPlan'
------------------------------------------------------------------------------
-- | Return an up-to-date elaborated install plan and associated config.
--
-- Two variants of the install plan are returned: with and without packages
-- from the store. That is, the \"improved\" plan where source packages are
-- replaced by pre-existing installed packages from the store (when their ids
-- match), and also the original elaborated plan which uses primarily source
-- packages.
-- The improved plan is what we use for building, but the original elaborated
-- plan is useful for reporting and configuration. For example the @freeze@
-- command needs the source package info to know about flag choices and
-- dependencies of executables and setup scripts.
--
rebuildInstallPlan :: Verbosity
-> FilePath -> DistDirLayout -> CabalDirLayout
-> ProjectConfig
-> IO ( ElaboratedInstallPlan
-> IO ( ElaboratedInstallPlan -- with store packages
, ElaboratedInstallPlan -- with source packages
, ElaboratedSharedConfig
, ProjectConfig )
-- ^ @(improvedPlan, elaboratedPlan, _, _)@
rebuildInstallPlan verbosity
projectRootDir
distDirLayout@DistDirLayout {
......@@ -275,16 +290,16 @@ rebuildInstallPlan verbosity
elaboratedShared) <- phaseElaboratePlan projectConfigTransient
compilerEtc
solverPlan localPackages
phaseMaintainPlanOutputs elaboratedPlan elaboratedShared
return (elaboratedPlan, elaboratedShared,
projectConfig)
return (elaboratedPlan, elaboratedShared, projectConfig)
-- The improved plan changes each time we install something, whereas
-- the underlying elaborated plan only changes when input config
-- changes, so it's worth caching them separately.
improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared
return (improvedPlan, elaboratedShared, projectConfig)
phaseMaintainPlanOutputs improvedPlan elaboratedPlan elaboratedShared
return (improvedPlan, elaboratedPlan, elaboratedShared, projectConfig)
where
fileMonitorCompiler = newFileMonitorInCacheDir "compiler"
......@@ -537,9 +552,10 @@ rebuildInstallPlan verbosity
-- the libs available. This will need to be after plan improvement phase.
--
phaseMaintainPlanOutputs :: ElaboratedInstallPlan
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> Rebuild ()
phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = do
phaseMaintainPlanOutputs _improvedPlan elaboratedPlan elaboratedShared = do
liftIO $ debug verbosity "Updating plan.json"
liftIO $ writePlanExternalRepresentation
distDirLayout
......@@ -1090,6 +1106,7 @@ elaborateInstallPlan platform compiler compilerprogdb
pkgSourceLocation = srcloc
pkgSourceHash = Map.lookup pkgid sourcePackageHashes
pkgLocalToProject = isLocalToProject pkg
pkgBuildStyle = if shouldBuildInplaceOnly pkg
then BuildInplaceOnly else BuildAndInstall
pkgBuildPackageDBStack = buildAndRegisterDbs
......
......@@ -165,6 +165,13 @@ data ElaboratedConfiguredPackage
--pkgSourceDir ? -- currently passed in later because they can use temp locations
--pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc
-- | Is this package one of the ones specified by location in the
-- project file? (As opposed to a dependency, or a named package pulled
-- in)
pkgLocalToProject :: Bool,
-- | Are we going to build and install this package to the store, or are
-- we going to build it and register it locally.
pkgBuildStyle :: BuildStyle,
pkgSetupPackageDBStack :: PackageDBStack,
......
......@@ -71,6 +71,7 @@ import qualified Distribution.Client.List as List
import qualified Distribution.Client.CmdConfigure as CmdConfigure
import qualified Distribution.Client.CmdBuild as CmdBuild
import qualified Distribution.Client.CmdRepl as CmdRepl
import qualified Distribution.Client.CmdFreeze as CmdFreeze
import Distribution.Client.Install (install)
import Distribution.Client.Configure (configure)
......@@ -283,6 +284,8 @@ mainWorker args = topHandler $
CmdBuild.buildAction
, hiddenCmd installCommand { commandName = "new-repl" }
CmdRepl.replAction
, hiddenCmd installCommand { commandName = "new-freeze" }
CmdFreeze.freezeAction
]
type Action = GlobalFlags -> IO ()
......
......@@ -182,6 +182,7 @@ executable cabal
Distribution.Client.Check
Distribution.Client.CmdBuild
Distribution.Client.CmdConfigure
Distribution.Client.CmdFreeze
Distribution.Client.CmdRepl
Distribution.Client.Config
Distribution.Client.Configure
......
......@@ -231,7 +231,7 @@ planProject testdir cliConfig = do
-- ended in an exception (as we leave the files to help with debugging).
cleanProject testdir
(elaboratedPlan, elaboratedShared, projectConfig) <-
(elaboratedPlan, _, elaboratedShared, projectConfig) <-
rebuildInstallPlan verbosity
projectRootDir distDirLayout cabalDirLayout
cliConfig
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment