{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
module Distribution.Client.CmdFreeze (
freezeCommand,
freezeAction,
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Client.NixStyleOptions
( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
import Distribution.Client.ProjectConfig
( ProjectConfig(..), ProjectConfigShared(..)
, writeProjectLocalFreezeConfig )
import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos, filterSkippedActiveRepos)
import Distribution.Client.Targets
( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) )
import Distribution.Solver.Types.PackageConstraint
( PackageProperty(..) )
import Distribution.Solver.Types.ConstraintSource
( ConstraintSource(..) )
import Distribution.Client.DistDirLayout
( DistDirLayout(distProjectFile) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Package
( PackageName, packageName, packageVersion )
import Distribution.Version
( VersionRange, thisVersion
, unionVersionRanges, simplifyVersionRange )
import Distribution.PackageDescription
( FlagAssignment, nullFlagAssignment )
import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..) )
import Distribution.Simple.Flag
( fromFlagOrDefault )
import Distribution.Simple.Flag (Flag (..))
import Distribution.Simple.Utils
( die', notice, wrapText )
import Distribution.Verbosity
( normal )
import qualified Data.Map as Map
import Distribution.Simple.Command
( CommandUI(..), usageAlternatives )
freezeCommand :: CommandUI (NixStyleFlags ())
freezeCommand :: CommandUI (NixStyleFlags ())
freezeCommand = CommandUI {
commandName :: String
commandName = String
"v2-freeze",
commandSynopsis :: String
commandSynopsis = String
"Freeze dependencies.",
commandUsage :: String -> String
commandUsage = String -> [String] -> String -> String
usageAlternatives String
"v2-freeze" [ String
"[FLAGS]" ],
commandDescription :: Maybe (String -> String)
commandDescription = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \String
_ -> String -> String
wrapText forall a b. (a -> b) -> a -> b
$
String
"The project configuration is frozen so that it will be reproducible "
forall a. [a] -> [a] -> [a]
++ String
"in future.\n\n"
forall a. [a] -> [a] -> [a]
++ String
"The precise dependency configuration for the project is written to "
forall a. [a] -> [a] -> [a]
++ String
"the 'cabal.project.freeze' file (or '$project_file.freeze' if "
forall a. [a] -> [a] -> [a]
++ String
"'--project-file' is specified). This file extends the configuration "
forall a. [a] -> [a] -> [a]
++ String
"from the 'cabal.project' file and thus is used as the project "
forall a. [a] -> [a] -> [a]
++ String
"configuration for all other commands (such as 'v2-build', "
forall a. [a] -> [a] -> [a]
++ String
"'v2-repl' etc).\n\n"
forall a. [a] -> [a] -> [a]
++ String
"The freeze file can be kept in source control. To make small "
forall a. [a] -> [a] -> [a]
++ String
"adjustments it may be edited manually, or to make bigger changes "
forall a. [a] -> [a] -> [a]
++ String
"you may wish to delete the file and re-freeze. For more control, "
forall a. [a] -> [a] -> [a]
++ String
"one approach is to try variations using 'v2-build --dry-run' with "
forall a. [a] -> [a] -> [a]
++ String
"solver flags such as '--constraint=\"pkg < 1.2\"' and once you have "
forall a. [a] -> [a] -> [a]
++ String
"a satisfactory solution to freeze it using the 'v2-freeze' command "
forall a. [a] -> [a] -> [a]
++ String
"with the same set of flags.",
commandNotes :: Maybe (String -> String)
commandNotes = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \String
pname ->
String
"Examples:\n"
forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
pname forall a. [a] -> [a] -> [a]
++ String
" v2-freeze\n"
forall a. [a] -> [a] -> [a]
++ String
" Freeze the configuration of the current project\n\n"
forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
pname forall a. [a] -> [a] -> [a]
++ String
" v2-build --dry-run --constraint=\"aeson < 1\"\n"
forall a. [a] -> [a] -> [a]
++ String
" Check what a solution with the given constraints would look like\n"
forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
pname forall a. [a] -> [a] -> [a]
++ String
" v2-freeze --constraint=\"aeson < 1\"\n"
forall a. [a] -> [a] -> [a]
++ String
" Freeze a solution using the given constraints\n"
, commandDefaultFlags :: NixStyleFlags ()
commandDefaultFlags = forall a. a -> NixStyleFlags a
defaultNixStyleFlags ()
, commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
commandOptions = forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions (forall a b. a -> b -> a
const [])
}
freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
freezeAction flags :: NixStyleFlags ()
flags@NixStyleFlags {()
ConfigFlags
HaddockFlags
TestFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
extraFlags :: forall a. NixStyleFlags a -> a
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
extraFlags :: ()
projectFlags :: ProjectFlags
benchmarkFlags :: BenchmarkFlags
testFlags :: TestFlags
haddockFlags :: HaddockFlags
installFlags :: InstallFlags
configExFlags :: ConfigExFlags
configFlags :: ConfigFlags
..} [String]
extraArgs GlobalFlags
globalFlags = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extraArgs) forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"'freeze' doesn't take any extra arguments: "
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
extraArgs
ProjectBaseContext {
DistDirLayout
distDirLayout :: ProjectBaseContext -> DistDirLayout
distDirLayout :: DistDirLayout
distDirLayout,
CabalDirLayout
cabalDirLayout :: ProjectBaseContext -> CabalDirLayout
cabalDirLayout :: CabalDirLayout
cabalDirLayout,
ProjectConfig
projectConfig :: ProjectBaseContext -> ProjectConfig
projectConfig :: ProjectConfig
projectConfig,
[PackageSpecifier UnresolvedSourcePackage]
localPackages :: ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
localPackages,
BuildTimeSettings
buildSettings :: ProjectBaseContext -> BuildTimeSettings
buildSettings :: BuildTimeSettings
buildSettings
} <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
cliConfig CurrentCommand
OtherCommand
(ElaboratedInstallPlan
_, ElaboratedInstallPlan
elaboratedPlan, ElaboratedSharedConfig
_, TotalIndexState
totalIndexState, ActiveRepos
activeRepos) <-
Verbosity
-> DistDirLayout
-> CabalDirLayout
-> ProjectConfig
-> [PackageSpecifier UnresolvedSourcePackage]
-> Maybe InstalledPackageIndex
-> IO
(ElaboratedInstallPlan, ElaboratedInstallPlan,
ElaboratedSharedConfig, TotalIndexState, ActiveRepos)
rebuildInstallPlan Verbosity
verbosity
DistDirLayout
distDirLayout CabalDirLayout
cabalDirLayout
ProjectConfig
projectConfig
[PackageSpecifier UnresolvedSourcePackage]
localPackages
forall a. Maybe a
Nothing
let freezeConfig :: ProjectConfig
freezeConfig = ElaboratedInstallPlan
-> TotalIndexState -> ActiveRepos -> ProjectConfig
projectFreezeConfig ElaboratedInstallPlan
elaboratedPlan TotalIndexState
totalIndexState ActiveRepos
activeRepos
dryRun :: Bool
dryRun = BuildTimeSettings -> Bool
buildSettingDryRun BuildTimeSettings
buildSettings
Bool -> Bool -> Bool
|| BuildTimeSettings -> Bool
buildSettingOnlyDownload BuildTimeSettings
buildSettings
if Bool
dryRun
then Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"Freeze file not written due to flag(s)"
else do
DistDirLayout -> ProjectConfig -> IO ()
writeProjectLocalFreezeConfig DistDirLayout
distDirLayout ProjectConfig
freezeConfig
Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
String
"Wrote freeze file: " forall a. [a] -> [a] -> [a]
++ DistDirLayout -> String -> String
distProjectFile DistDirLayout
distDirLayout String
"freeze"
where
verbosity :: Verbosity
verbosity = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)
cliConfig :: ProjectConfig
cliConfig = forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig GlobalFlags
globalFlags NixStyleFlags ()
flags
forall a. Monoid a => a
mempty
projectFreezeConfig
:: ElaboratedInstallPlan
-> TotalIndexState
-> ActiveRepos
-> ProjectConfig
projectFreezeConfig :: ElaboratedInstallPlan
-> TotalIndexState -> ActiveRepos -> ProjectConfig
projectFreezeConfig ElaboratedInstallPlan
elaboratedPlan TotalIndexState
totalIndexState ActiveRepos
activeRepos0 = forall a. Monoid a => a
mempty
{ projectConfigShared :: ProjectConfigShared
projectConfigShared = forall a. Monoid a => a
mempty
{ projectConfigConstraints :: [(UserConstraint, ConstraintSource)]
projectConfigConstraints =
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall k a. Map k a -> [a]
Map.elems (ElaboratedInstallPlan
-> Map PackageName [(UserConstraint, ConstraintSource)]
projectFreezeConstraints ElaboratedInstallPlan
elaboratedPlan))
, projectConfigIndexState :: Flag TotalIndexState
projectConfigIndexState = forall a. a -> Flag a
Flag TotalIndexState
totalIndexState
, projectConfigActiveRepos :: Flag ActiveRepos
projectConfigActiveRepos = forall a. a -> Flag a
Flag ActiveRepos
activeRepos
}
}
where
activeRepos :: ActiveRepos
activeRepos :: ActiveRepos
activeRepos = ActiveRepos -> ActiveRepos
filterSkippedActiveRepos ActiveRepos
activeRepos0
projectFreezeConstraints :: ElaboratedInstallPlan
-> Map PackageName [(UserConstraint, ConstraintSource)]
projectFreezeConstraints :: ElaboratedInstallPlan
-> Map PackageName [(UserConstraint, ConstraintSource)]
projectFreezeConstraints ElaboratedInstallPlan
plan =
Map PackageName [(UserConstraint, ConstraintSource)]
-> Map PackageName [(UserConstraint, ConstraintSource)]
deleteLocalPackagesVersionConstraints
(forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. [a] -> [a] -> [a]
(++) Map PackageName [(UserConstraint, ConstraintSource)]
versionConstraints Map PackageName [(UserConstraint, ConstraintSource)]
flagConstraints)
where
versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
versionConstraints =
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
(\PackageName
p VersionRange
v -> [(UserConstraintScope -> PackageProperty -> UserConstraint
UserConstraint (PackageName -> UserConstraintScope
UserAnyQualifier PackageName
p) (VersionRange -> PackageProperty
PackagePropertyVersion VersionRange
v),
ConstraintSource
ConstraintSourceFreeze)])
Map PackageName VersionRange
versionRanges
versionRanges :: Map PackageName VersionRange
versionRanges :: Map PackageName VersionRange
versionRanges =
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map VersionRange -> VersionRange
simplifyVersionRange forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith VersionRange -> VersionRange -> VersionRange
unionVersionRanges forall a b. (a -> b) -> a -> b
$
[ (forall pkg. Package pkg => pkg -> PackageName
packageName InstalledPackageInfo
pkg, Version -> VersionRange
thisVersion (forall pkg. Package pkg => pkg -> Version
packageVersion InstalledPackageInfo
pkg))
| InstallPlan.PreExisting InstalledPackageInfo
pkg <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
plan
]
forall a. [a] -> [a] -> [a]
++ [ (forall pkg. Package pkg => pkg -> PackageName
packageName ElaboratedConfiguredPackage
pkg, Version -> VersionRange
thisVersion (forall pkg. Package pkg => pkg -> Version
packageVersion ElaboratedConfiguredPackage
pkg))
| InstallPlan.Configured ElaboratedConfiguredPackage
pkg <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
plan
]
flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
flagConstraints =
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
(\PackageName
p FlagAssignment
f -> [(UserConstraintScope -> PackageProperty -> UserConstraint
UserConstraint (UserQualifier -> PackageName -> UserConstraintScope
UserQualified UserQualifier
UserQualToplevel PackageName
p) (FlagAssignment -> PackageProperty
PackagePropertyFlags FlagAssignment
f),
ConstraintSource
ConstraintSourceFreeze)])
Map PackageName FlagAssignment
flagAssignments
flagAssignments :: Map PackageName FlagAssignment
flagAssignments :: Map PackageName FlagAssignment
flagAssignments =
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (PackageName
pkgname, FlagAssignment
flags)
| InstallPlan.Configured ElaboratedConfiguredPackage
elab <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
plan
, let flags :: FlagAssignment
flags = ElaboratedConfiguredPackage -> FlagAssignment
elabFlagAssignment ElaboratedConfiguredPackage
elab
pkgname :: PackageName
pkgname = forall pkg. Package pkg => pkg -> PackageName
packageName ElaboratedConfiguredPackage
elab
, Bool -> Bool
not (FlagAssignment -> Bool
nullFlagAssignment FlagAssignment
flags) ]
deleteLocalPackagesVersionConstraints
:: Map PackageName [(UserConstraint, ConstraintSource)]
-> Map PackageName [(UserConstraint, ConstraintSource)]
deleteLocalPackagesVersionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
-> Map PackageName [(UserConstraint, ConstraintSource)]
deleteLocalPackagesVersionConstraints =
forall k a b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
Map.mergeWithKey
(\PackageName
_pkgname () [(UserConstraint, ConstraintSource)]
constraints ->
case forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserConstraint -> Bool
isVersionConstraint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(UserConstraint, ConstraintSource)]
constraints of
[] -> forall a. Maybe a
Nothing
[(UserConstraint, ConstraintSource)]
constraints' -> forall a. a -> Maybe a
Just [(UserConstraint, ConstraintSource)]
constraints')
(forall a b. a -> b -> a
const forall k a. Map k a
Map.empty) forall a. a -> a
id
Map PackageName ()
localPackages
isVersionConstraint :: UserConstraint -> Bool
isVersionConstraint (UserConstraint UserConstraintScope
_ (PackagePropertyVersion VersionRange
_)) = Bool
True
isVersionConstraint UserConstraint
_ = Bool
False
localPackages :: Map PackageName ()
localPackages :: Map PackageName ()
localPackages =
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (forall pkg. Package pkg => pkg -> PackageName
packageName ElaboratedConfiguredPackage
elab, ())
| InstallPlan.Configured ElaboratedConfiguredPackage
elab <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
plan
, ElaboratedConfiguredPackage -> Bool
elabLocalToProject ElaboratedConfiguredPackage
elab
]