{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}

-- | cabal-install CLI command: freeze
--
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 [])
   }

-- | 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 :: 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 -- ClientInstallFlags, not needed here

-- | Given the install plan, produce a config value with constraints that
-- freezes the versions of packages used in the plan.
--
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

-- | 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 :: ElaboratedInstallPlan
-> Map PackageName [(UserConstraint, ConstraintSource)]
projectFreezeConstraints ElaboratedInstallPlan
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
    -- /version/ 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). We do however keep flag
    -- constraints of local packages.
    --
    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) ]

    -- As described above, remove the version constraints on local packages,
    -- but leave any flag constraints.
    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
        ]