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/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 () 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..9a2a3857cc6 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 @@ -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 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, 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 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