From 3d4d48ce171c9c6616357663a1708a02acca6f93 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Mon, 20 Jun 2016 12:38:41 +0100 Subject: [PATCH 1/4] Change rebuildInstallPlan to return pre-improvement plan It takes a solver plan, makes an "elaborated plan" with nix style hashes but still of mostly source package and then does an improvement phase to make a plan with pre-existing packages from the store. Previously it only returned the improved plan, but for some things it's also useful to see the original elaborated plan with the source packages. In partciular it will be useful for plan.json status output. It will also be needed for the freeze command to be able to get at the flag choices, since this info is not preserved in installed packages. --- .../Client/ProjectOrchestration.hs | 2 +- .../Distribution/Client/ProjectPlanning.hs | 30 ++++++++++++++----- cabal-install/tests/IntegrationTests2.hs | 2 +- 3 files changed, 25 insertions(+), 9 deletions(-) diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index af3294fa9c0..90e6e534b61 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -151,7 +151,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 diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index bb653c1bfcd..4ff9ed7b537 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -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 diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index e86805c9d71..9824dc384a4 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -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 From 638d0a2ef6cd8f276cccbed3126f0cf7d030b4a8 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Mon, 20 Jun 2016 12:43:02 +0100 Subject: [PATCH 2/4] Add a package property pkgLocalToProject There are various related properties here like packages that are going to be built locally inplace rather than added to the store, but sometimes we need to know if a package was originally specified by the cabal.project file (explicitly or implicitly). --- cabal-install/Distribution/Client/ProjectPlanning.hs | 1 + cabal-install/Distribution/Client/ProjectPlanning/Types.hs | 7 +++++++ 2 files changed, 8 insertions(+) diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 4ff9ed7b537..9a2a3857cc6 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -1106,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 diff --git a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs index fb3b40b05d3..ddaa8222ec5 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs @@ -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, From b18d61c79ea1bea3a68ddbcc7d603485f17c7601 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Mon, 20 Jun 2016 12:45:34 +0100 Subject: [PATCH 3/4] Add config support for cabal.project.freeze Code to write it and to pick it up by default when reading the cabal.project file. --- .../Distribution/Client/ProjectConfig.hs | 60 ++++++++++++++----- 1 file changed, 44 insertions(+), 16 deletions(-) diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index 8307e1db19b..a6e84a28070 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/Distribution/Client/ProjectConfig.hs @@ -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 () From f24d4a3331898af8ba97783655e0ffc9921bfbfe Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Mon, 20 Jun 2016 12:46:40 +0100 Subject: [PATCH 4/4] Add a new-freeze command This is ok, but not perfect since freezing is now more tricky with setup deps. See https://github.com/haskell/cabal/issues/3502 --- .../Distribution/Client/CmdFreeze.hs | 164 ++++++++++++++++++ cabal-install/Main.hs | 3 + cabal-install/cabal-install.cabal | 1 + 3 files changed, 168 insertions(+) create mode 100644 cabal-install/Distribution/Client/CmdFreeze.hs diff --git a/cabal-install/Distribution/Client/CmdFreeze.hs b/cabal-install/Distribution/Client/CmdFreeze.hs new file mode 100644 index 00000000000..1aa072ecd98 --- /dev/null +++ b/cabal-install/Distribution/Client/CmdFreeze.hs @@ -0,0 +1,164 @@ +{-# 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 + ] + diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs index 57f2cf7c96c..d68a126ccff 100644 --- a/cabal-install/Main.hs +++ b/cabal-install/Main.hs @@ -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 () diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 43d5cd146ce..a46949c4b83 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -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