-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Client.Freeze
-- Copyright   :  (c) David Himmelstrup 2005
--                    Duncan Coutts 2011
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- The cabal freeze command
module Distribution.Client.Freeze
  ( freeze
  , getFreezePkgs
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.Config (SavedConfig (..))
import Distribution.Client.Dependency
import Distribution.Client.IndexUtils as IndexUtils
  ( getInstalledPackages
  , getSourcePackages
  )
import Distribution.Client.Sandbox.PackageEnvironment
  ( loadUserConfig
  , pkgEnvSavedConfig
  , showPackageEnvironment
  , userPackageEnvironmentFile
  )
import Distribution.Client.Setup
  ( ConfigExFlags (..)
  , FreezeFlags (..)
  , GlobalFlags (..)
  , RepoContext (..)
  )
import Distribution.Client.SolverInstallPlan
  ( SolverInstallPlan
  , SolverPlanPackage
  )
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.Targets
import Distribution.Client.Types

import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PkgConfigDb
import Distribution.Solver.Types.SolverId

import Distribution.Client.Errors
import Distribution.Package
  ( Package
  , packageId
  , packageName
  , packageVersion
  )
import Distribution.Simple.Compiler
  ( Compiler
  , PackageDBStack
  , compilerInfo
  )
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.Program
  ( ProgramDb
  )
import Distribution.Simple.Setup
  ( flagToMaybe
  , fromFlag
  , fromFlagOrDefault
  )
import Distribution.Simple.Utils
  ( debug
  , dieWithException
  , notice
  , toUTF8LBS
  , writeFileAtomic
  )
import Distribution.System
  ( Platform
  )
import Distribution.Version
  ( thisVersion
  )

-- ------------------------------------------------------------

-- * The freeze command

-- ------------------------------------------------------------

-- | Freeze all of the dependencies by writing a constraints section
-- constraining each dependency to an exact version.
freeze
  :: Verbosity
  -> PackageDBStack
  -> RepoContext
  -> Compiler
  -> Platform
  -> ProgramDb
  -> GlobalFlags
  -> FreezeFlags
  -> IO ()
freeze :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO ()
freeze
  Verbosity
verbosity
  PackageDBStack
packageDBs
  RepoContext
repoCtxt
  Compiler
comp
  Platform
platform
  ProgramDb
progdb
  GlobalFlags
globalFlags
  FreezeFlags
freezeFlags = do
    [SolverPlanPackage]
pkgs <-
      Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO [SolverPlanPackage]
getFreezePkgs
        Verbosity
verbosity
        PackageDBStack
packageDBs
        RepoContext
repoCtxt
        Compiler
comp
        Platform
platform
        ProgramDb
progdb
        GlobalFlags
globalFlags
        FreezeFlags
freezeFlags

    if [SolverPlanPackage] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SolverPlanPackage]
pkgs
      then
        Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"No packages to be frozen. "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"As this package has no dependencies."
      else
        if Bool
dryRun
          then
            Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                String
"The following packages would be frozen:"
                  String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [SolverPlanPackage] -> [String]
forall pkg. Package pkg => [pkg] -> [String]
formatPkgs [SolverPlanPackage]
pkgs
          else Verbosity -> GlobalFlags -> [SolverPlanPackage] -> IO ()
forall pkg.
Package pkg =>
Verbosity -> GlobalFlags -> [pkg] -> IO ()
freezePackages Verbosity
verbosity GlobalFlags
globalFlags [SolverPlanPackage]
pkgs
    where
      dryRun :: Bool
dryRun = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag Bool
freezeDryRun FreezeFlags
freezeFlags)

-- | Get the list of packages whose versions would be frozen by the @freeze@
-- command.
getFreezePkgs
  :: Verbosity
  -> PackageDBStack
  -> RepoContext
  -> Compiler
  -> Platform
  -> ProgramDb
  -> GlobalFlags
  -> FreezeFlags
  -> IO [SolverPlanPackage]
getFreezePkgs :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO [SolverPlanPackage]
getFreezePkgs
  Verbosity
verbosity
  PackageDBStack
packageDBs
  RepoContext
repoCtxt
  Compiler
comp
  Platform
platform
  ProgramDb
progdb
  GlobalFlags
_
  FreezeFlags
freezeFlags = do
    InstalledPackageIndex
installedPkgIndex <- Verbosity
-> Compiler
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp PackageDBStack
packageDBs ProgramDb
progdb
    SourcePackageDb
sourcePkgDb <- Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages Verbosity
verbosity RepoContext
repoCtxt
    PkgConfigDb
pkgConfigDb <- Verbosity -> ProgramDb -> IO PkgConfigDb
readPkgConfigDb Verbosity
verbosity ProgramDb
progdb

    [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers <-
      Verbosity
-> RepoContext
-> PackageIndex UnresolvedSourcePackage
-> [UserTarget]
-> IO [PackageSpecifier UnresolvedSourcePackage]
forall pkg.
Package pkg =>
Verbosity
-> RepoContext
-> PackageIndex pkg
-> [UserTarget]
-> IO [PackageSpecifier UnresolvedSourcePackage]
resolveUserTargets
        Verbosity
verbosity
        RepoContext
repoCtxt
        (SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex SourcePackageDb
sourcePkgDb)
        [String -> UserTarget
UserTargetLocalDir String
"."]

    [PackageSpecifier UnresolvedSourcePackage] -> IO ()
sanityCheck [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
    Verbosity
-> Compiler
-> Platform
-> FreezeFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO [SolverPlanPackage]
planPackages
      Verbosity
verbosity
      Compiler
comp
      Platform
platform
      FreezeFlags
freezeFlags
      InstalledPackageIndex
installedPkgIndex
      SourcePackageDb
sourcePkgDb
      PkgConfigDb
pkgConfigDb
      [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
    where
      sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO ()
      sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO ()
sanityCheck [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers = do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool)
-> ([PackageSpecifier UnresolvedSourcePackage] -> Bool)
-> [PackageSpecifier UnresolvedSourcePackage]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageSpecifier UnresolvedSourcePackage] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([PackageSpecifier UnresolvedSourcePackage] -> Bool)
-> [PackageSpecifier UnresolvedSourcePackage] -> Bool
forall a b. (a -> b) -> a -> b
$ [PackageSpecifier UnresolvedSourcePackage
n | n :: PackageSpecifier UnresolvedSourcePackage
n@(NamedPackage PackageName
_ [PackageProperty]
_) <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
UnexpectedNamedPkgSpecifiers
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PackageSpecifier UnresolvedSourcePackage] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
UnexpectedSourcePkgSpecifiers

planPackages
  :: Verbosity
  -> Compiler
  -> Platform
  -> FreezeFlags
  -> InstalledPackageIndex
  -> SourcePackageDb
  -> PkgConfigDb
  -> [PackageSpecifier UnresolvedSourcePackage]
  -> IO [SolverPlanPackage]
planPackages :: Verbosity
-> Compiler
-> Platform
-> FreezeFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO [SolverPlanPackage]
planPackages
  Verbosity
verbosity
  Compiler
comp
  Platform
platform
  FreezeFlags
freezeFlags
  InstalledPackageIndex
installedPkgIndex
  SourcePackageDb
sourcePkgDb
  PkgConfigDb
pkgConfigDb
  [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers = do
    Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"Resolving dependencies..."

    SolverInstallPlan
installPlan <-
      (String -> IO SolverInstallPlan -> IO SolverInstallPlan)
-> (String -> IO SolverInstallPlan)
-> (SolverInstallPlan -> IO SolverInstallPlan)
-> Progress String String SolverInstallPlan
-> IO SolverInstallPlan
forall step a fail done.
(step -> a -> a)
-> (fail -> a) -> (done -> a) -> Progress step fail done -> a
foldProgress String -> IO SolverInstallPlan -> IO SolverInstallPlan
forall {b}. String -> IO b -> IO b
logMsg (Verbosity -> CabalInstallException -> IO SolverInstallPlan
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO SolverInstallPlan)
-> (String -> CabalInstallException)
-> String
-> IO SolverInstallPlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CabalInstallException
FreezeException) SolverInstallPlan -> IO SolverInstallPlan
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Progress String String SolverInstallPlan -> IO SolverInstallPlan)
-> Progress String String SolverInstallPlan -> IO SolverInstallPlan
forall a b. (a -> b) -> a -> b
$
        Platform
-> CompilerInfo
-> PkgConfigDb
-> DepResolverParams
-> Progress String String SolverInstallPlan
resolveDependencies
          Platform
platform
          (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
          PkgConfigDb
pkgConfigDb
          DepResolverParams
resolverParams

    [SolverPlanPackage] -> IO [SolverPlanPackage]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([SolverPlanPackage] -> IO [SolverPlanPackage])
-> [SolverPlanPackage] -> IO [SolverPlanPackage]
forall a b. (a -> b) -> a -> b
$ SolverInstallPlan
-> [PackageSpecifier UnresolvedSourcePackage]
-> [SolverPlanPackage]
pruneInstallPlan SolverInstallPlan
installPlan [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
    where
      resolverParams :: DepResolverParams
      resolverParams :: DepResolverParams
resolverParams =
        Maybe Int -> DepResolverParams -> DepResolverParams
setMaxBackjumps
          ( if Int
maxBackjumps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
              then Maybe Int
forall a. Maybe a
Nothing
              else Int -> Maybe Int
forall a. a -> Maybe a
Just Int
maxBackjumps
          )
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndependentGoals -> DepResolverParams -> DepResolverParams
setIndependentGoals IndependentGoals
independentGoals
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReorderGoals -> DepResolverParams -> DepResolverParams
setReorderGoals ReorderGoals
reorderGoals
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CountConflicts -> DepResolverParams -> DepResolverParams
setCountConflicts CountConflicts
countConflicts
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FineGrainedConflicts -> DepResolverParams -> DepResolverParams
setFineGrainedConflicts FineGrainedConflicts
fineGrainedConflicts
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MinimizeConflictSet -> DepResolverParams -> DepResolverParams
setMinimizeConflictSet MinimizeConflictSet
minimizeConflictSet
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShadowPkgs -> DepResolverParams -> DepResolverParams
setShadowPkgs ShadowPkgs
shadowPkgs
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrongFlags -> DepResolverParams -> DepResolverParams
setStrongFlags StrongFlags
strongFlags
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowBootLibInstalls -> DepResolverParams -> DepResolverParams
setAllowBootLibInstalls AllowBootLibInstalls
allowBootLibInstalls
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlyConstrained -> DepResolverParams -> DepResolverParams
setOnlyConstrained OnlyConstrained
onlyConstrained
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> DepResolverParams -> DepResolverParams
setSolverVerbosity Verbosity
verbosity
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints
            [ let pkg :: PackageName
pkg = PackageSpecifier UnresolvedSourcePackage -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget PackageSpecifier UnresolvedSourcePackage
pkgSpecifier
                  pc :: PackageConstraint
pc =
                    ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint
                      (PackageName -> ConstraintScope
scopeToplevel PackageName
pkg)
                      ([OptionalStanza] -> PackageProperty
PackagePropertyStanzas [OptionalStanza]
stanzas)
               in PackageConstraint -> ConstraintSource -> LabeledPackageConstraint
LabeledPackageConstraint PackageConstraint
pc ConstraintSource
ConstraintSourceFreeze
            | PackageSpecifier UnresolvedSourcePackage
pkgSpecifier <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
            ]
          (DepResolverParams -> DepResolverParams)
-> DepResolverParams -> DepResolverParams
forall a b. (a -> b) -> a -> b
$ InstalledPackageIndex
-> SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
standardInstallPolicy InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers

      logMsg :: String -> IO b -> IO b
logMsg String
message IO b
rest = Verbosity -> String -> IO ()
debug Verbosity
verbosity String
message IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
rest

      stanzas :: [OptionalStanza]
stanzas =
        [OptionalStanza
TestStanzas | Bool
testsEnabled]
          [OptionalStanza] -> [OptionalStanza] -> [OptionalStanza]
forall a. [a] -> [a] -> [a]
++ [OptionalStanza
BenchStanzas | Bool
benchmarksEnabled]
      testsEnabled :: Bool
testsEnabled = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FreezeFlags -> Flag Bool
freezeTests FreezeFlags
freezeFlags
      benchmarksEnabled :: Bool
benchmarksEnabled = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FreezeFlags -> Flag Bool
freezeBenchmarks FreezeFlags
freezeFlags

      reorderGoals :: ReorderGoals
reorderGoals = Flag ReorderGoals -> ReorderGoals
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag ReorderGoals
freezeReorderGoals FreezeFlags
freezeFlags)
      countConflicts :: CountConflicts
countConflicts = Flag CountConflicts -> CountConflicts
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag CountConflicts
freezeCountConflicts FreezeFlags
freezeFlags)
      fineGrainedConflicts :: FineGrainedConflicts
fineGrainedConflicts = Flag FineGrainedConflicts -> FineGrainedConflicts
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag FineGrainedConflicts
freezeFineGrainedConflicts FreezeFlags
freezeFlags)
      minimizeConflictSet :: MinimizeConflictSet
minimizeConflictSet = Flag MinimizeConflictSet -> MinimizeConflictSet
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag MinimizeConflictSet
freezeMinimizeConflictSet FreezeFlags
freezeFlags)
      independentGoals :: IndependentGoals
independentGoals = Flag IndependentGoals -> IndependentGoals
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag IndependentGoals
freezeIndependentGoals FreezeFlags
freezeFlags)
      shadowPkgs :: ShadowPkgs
shadowPkgs = Flag ShadowPkgs -> ShadowPkgs
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag ShadowPkgs
freezeShadowPkgs FreezeFlags
freezeFlags)
      strongFlags :: StrongFlags
strongFlags = Flag StrongFlags -> StrongFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag StrongFlags
freezeStrongFlags FreezeFlags
freezeFlags)
      maxBackjumps :: Int
maxBackjumps = Flag Int -> Int
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag Int
freezeMaxBackjumps FreezeFlags
freezeFlags)
      allowBootLibInstalls :: AllowBootLibInstalls
allowBootLibInstalls = Flag AllowBootLibInstalls -> AllowBootLibInstalls
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag AllowBootLibInstalls
freezeAllowBootLibInstalls FreezeFlags
freezeFlags)
      onlyConstrained :: OnlyConstrained
onlyConstrained = Flag OnlyConstrained -> OnlyConstrained
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag OnlyConstrained
freezeOnlyConstrained FreezeFlags
freezeFlags)

-- | Remove all unneeded packages from an install plan.
--
-- A package is unneeded if it is either
--
-- 1) the package that we are freezing, or
--
-- 2) not a dependency (directly or transitively) of the package we are
--    freezing.  This is useful for removing previously installed packages
--    which are no longer required from the install plan.
--
-- Invariant: @pkgSpecifiers@ must refer to packages which are not
-- 'PreExisting' in the 'SolverInstallPlan'.
pruneInstallPlan
  :: SolverInstallPlan
  -> [PackageSpecifier UnresolvedSourcePackage]
  -> [SolverPlanPackage]
pruneInstallPlan :: SolverInstallPlan
-> [PackageSpecifier UnresolvedSourcePackage]
-> [SolverPlanPackage]
pruneInstallPlan SolverInstallPlan
installPlan [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers =
  [SolverId] -> [SolverPlanPackage] -> [SolverPlanPackage]
forall {pkg} {pkg}.
(Package pkg, Package pkg) =>
[pkg] -> [pkg] -> [pkg]
removeSelf [SolverId]
pkgIds ([SolverPlanPackage] -> [SolverPlanPackage])
-> [SolverPlanPackage] -> [SolverPlanPackage]
forall a b. (a -> b) -> a -> b
$
    SolverInstallPlan -> [SolverId] -> [SolverPlanPackage]
SolverInstallPlan.dependencyClosure SolverInstallPlan
installPlan [SolverId]
pkgIds
  where
    pkgIds :: [SolverId]
pkgIds =
      [ PackageId -> SolverId
PlannedId (UnresolvedSourcePackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId UnresolvedSourcePackage
pkg)
      | SpecificSourcePackage UnresolvedSourcePackage
pkg <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
      ]
    removeSelf :: [pkg] -> [pkg] -> [pkg]
removeSelf [pkg
thisPkg] = (pkg -> Bool) -> [pkg] -> [pkg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\pkg
pp -> pkg -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId pkg
pp PackageId -> PackageId -> Bool
forall a. Eq a => a -> a -> Bool
/= pkg -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId pkg
thisPkg)
    removeSelf [pkg]
_ =
      String -> [pkg] -> [pkg]
forall a. HasCallStack => String -> a
error (String -> [pkg] -> [pkg]) -> String -> [pkg] -> [pkg]
forall a b. (a -> b) -> a -> b
$
        String
"internal error: 'pruneInstallPlan' given "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"unexpected package specifiers!"

freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO ()
freezePackages :: forall pkg.
Package pkg =>
Verbosity -> GlobalFlags -> [pkg] -> IO ()
freezePackages Verbosity
verbosity GlobalFlags
globalFlags [pkg]
pkgs = do
  PackageEnvironment
pkgEnv <-
    (SavedConfig -> PackageEnvironment)
-> IO SavedConfig -> IO PackageEnvironment
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SavedConfig -> PackageEnvironment
createPkgEnv (SavedConfig -> PackageEnvironment)
-> (SavedConfig -> SavedConfig)
-> SavedConfig
-> PackageEnvironment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> SavedConfig
addFrozenConstraints) (IO SavedConfig -> IO PackageEnvironment)
-> IO SavedConfig -> IO PackageEnvironment
forall a b. (a -> b) -> a -> b
$
      Verbosity -> String -> Maybe String -> IO SavedConfig
loadUserConfig
        Verbosity
verbosity
        String
""
        (Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> Maybe String)
-> (GlobalFlags -> Flag String) -> GlobalFlags -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalFlags -> Flag String
globalConstraintsFile (GlobalFlags -> Maybe String) -> GlobalFlags -> Maybe String
forall a b. (a -> b) -> a -> b
$ GlobalFlags
globalFlags)
  String -> ByteString -> IO ()
writeFileAtomic String
userPackageEnvironmentFile (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ PackageEnvironment -> ByteString
showPkgEnv PackageEnvironment
pkgEnv
  where
    addFrozenConstraints :: SavedConfig -> SavedConfig
addFrozenConstraints SavedConfig
config =
      SavedConfig
config
        { savedConfigureExFlags =
            (savedConfigureExFlags config)
              { configExConstraints = map constraint pkgs
              }
        }
    constraint :: pkg -> (UserConstraint, ConstraintSource)
constraint pkg
pkg =
      ( PackageId -> UserConstraint
forall {pkg}. Package pkg => pkg -> UserConstraint
pkgIdToConstraint (PackageId -> UserConstraint) -> PackageId -> UserConstraint
forall a b. (a -> b) -> a -> b
$ pkg -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId pkg
pkg
      , String -> ConstraintSource
ConstraintSourceUserConfig String
userPackageEnvironmentFile
      )
      where
        pkgIdToConstraint :: pkg -> UserConstraint
pkgIdToConstraint pkg
pkgId =
          UserConstraintScope -> PackageProperty -> UserConstraint
UserConstraint
            (UserQualifier -> PackageName -> UserConstraintScope
UserQualified UserQualifier
UserQualToplevel (pkg -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName pkg
pkgId))
            (VersionRange -> PackageProperty
PackagePropertyVersion (VersionRange -> PackageProperty)
-> VersionRange -> PackageProperty
forall a b. (a -> b) -> a -> b
$ Version -> VersionRange
thisVersion (pkg -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion pkg
pkgId))
    createPkgEnv :: SavedConfig -> PackageEnvironment
createPkgEnv SavedConfig
config = PackageEnvironment
forall a. Monoid a => a
mempty{pkgEnvSavedConfig = config}
    showPkgEnv :: PackageEnvironment -> ByteString
showPkgEnv = String -> ByteString
toUTF8LBS (String -> ByteString)
-> (PackageEnvironment -> String)
-> PackageEnvironment
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageEnvironment -> String
showPackageEnvironment

formatPkgs :: Package pkg => [pkg] -> [String]
formatPkgs :: forall pkg. Package pkg => [pkg] -> [String]
formatPkgs = (pkg -> String) -> [pkg] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((pkg -> String) -> [pkg] -> [String])
-> (pkg -> String) -> [pkg] -> [String]
forall a b. (a -> b) -> a -> b
$ PackageId -> String
showPkg (PackageId -> String) -> (pkg -> PackageId) -> pkg -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. pkg -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId
  where
    showPkg :: PackageId -> String
showPkg PackageId
pid = PackageId -> String
name PackageId
pid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" == " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
version PackageId
pid
    name :: PackageId -> String
name = PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageName -> String)
-> (PackageId -> PackageName) -> PackageId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName
    version :: PackageId -> String
version = Version -> String
forall a. Pretty a => a -> String
prettyShow (Version -> String)
-> (PackageId -> Version) -> PackageId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageId -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion