New freeze command

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

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 ()

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

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

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,

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 ()

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

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