cabal-install/src/Distribution/Client/Freeze.hs

   1 -----------------------------------------------------------------------------
   2
   3 -----------------------------------------------------------------------------
   4
   5 -- |
   6 -- Module      :  Distribution.Client.Freeze
   7 -- Copyright   :  (c) David Himmelstrup 2005
   8 --                    Duncan Coutts 2011
   9 -- License     :  BSD-like
  10 --
  11 -- Maintainer  :  cabal-devel@gmail.com
  12 -- Stability   :  provisional
  13 -- Portability :  portable
  14 --
  15 -- The cabal freeze command
  16 module Distribution.Client.Freeze
  17   ( freeze
  18   , getFreezePkgs
  19   ) where
  20
  21 import Distribution.Client.Compat.Prelude
  22 import Prelude ()
  23
  24 import Distribution.Client.Config (SavedConfig (..))
  25 import Distribution.Client.Dependency
  26 import Distribution.Client.IndexUtils as IndexUtils
  27   ( getInstalledPackages
  28   , getSourcePackages
  29   )
  30 import Distribution.Client.Sandbox.PackageEnvironment
  31   ( loadUserConfig
  32   , pkgEnvSavedConfig
  33   , showPackageEnvironment
  34   , userPackageEnvironmentFile
  35   )
  36 import Distribution.Client.Setup
  37   ( ConfigExFlags (..)
  38   , FreezeFlags (..)
  39   , GlobalFlags (..)
  40   , RepoContext (..)
  41   )
  42 import Distribution.Client.SolverInstallPlan
  43   ( SolverInstallPlan
  44   , SolverPlanPackage
  45   )
  46 import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
  47 import Distribution.Client.Targets
  48 import Distribution.Client.Types
  49
  50 import Distribution.Solver.Types.ConstraintSource
  51 import Distribution.Solver.Types.LabeledPackageConstraint
  52 import Distribution.Solver.Types.OptionalStanza
  53 import Distribution.Solver.Types.PkgConfigDb
  54 import Distribution.Solver.Types.SolverId
  55
  56 import Distribution.Client.Errors
  57 import Distribution.Package
  58   ( Package
  59   , packageId
  60   , packageName
  61   , packageVersion
  62   )
  63 import Distribution.Simple.Compiler
  64 import Distribution.Simple.PackageIndex (InstalledPackageIndex)
  65 import Distribution.Simple.Program
  66   ( ProgramDb
  67   )
  68 import Distribution.Simple.Setup
  69   ( flagToMaybe
  70   , fromFlag
  71   , fromFlagOrDefault
  72   )
  73 import Distribution.Simple.Utils
  74   ( debug
  75   , dieWithException
  76   , notice
  77   , toUTF8LBS
  78   , writeFileAtomic
  79   )
  80 import Distribution.System
  81   ( Platform
  82   )
  83 import Distribution.Version
  84   ( thisVersion
  85   )
  86
  87 -- ------------------------------------------------------------
  88
  89 -- * The freeze command
  90
  91 -- ------------------------------------------------------------
  92
  93 -- | Freeze all of the dependencies by writing a constraints section
  94 -- constraining each dependency to an exact version.
  95 freeze
  96   :: Verbosity
  97   -> PackageDBStackCWD
  98   -> RepoContext
  99   -> Compiler
 100   -> Platform
 101   -> ProgramDb
 102   -> GlobalFlags
 103   -> FreezeFlags
 104   -> IO ()
 105 freeze
 106   verbosity
 107   packageDBs
 108   repoCtxt
 109   comp
 110   platform
 111   progdb
 112   globalFlags
 113   freezeFlags = do
 114     pkgs <-
 115       getFreezePkgs
 116         verbosity
 117         packageDBs
 118         repoCtxt
 119         comp
 120         platform
 121         progdb
 122         globalFlags
 123         freezeFlags
 124
 125     if null pkgs
 126       then
 127         notice verbosity $
 128           "No packages to be frozen. "
 129             ++ "As this package has no dependencies."
 130       else
 131         if dryRun
 132           then
 133             notice verbosity $
 134               unlines $
 135                 "The following packages would be frozen:"
 136                   : formatPkgs pkgs
 137           else freezePackages verbosity globalFlags pkgs
 138     where
 139       dryRun = fromFlag (freezeDryRun freezeFlags)
 140
 141 -- | Get the list of packages whose versions would be frozen by the @freeze@
 142 -- command.
 143 getFreezePkgs
 144   :: Verbosity
 145   -> PackageDBStackCWD
 146   -> RepoContext
 147   -> Compiler
 148   -> Platform
 149   -> ProgramDb
 150   -> GlobalFlags
 151   -> FreezeFlags
 152   -> IO [SolverPlanPackage]
 153 getFreezePkgs
 154   verbosity
 155   packageDBs
 156   repoCtxt
 157   comp
 158   platform
 159   progdb
 160   _
 161   freezeFlags = do
 162     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
 163     sourcePkgDb <- getSourcePackages verbosity repoCtxt
 164     pkgConfigDb <- readPkgConfigDb verbosity progdb
 165
 166     pkgSpecifiers <-
 167       resolveUserTargets
 168         verbosity
 169         repoCtxt
 170         (packageIndex sourcePkgDb)
 171         [UserTargetLocalDir "."]
 172
 173     sanityCheck pkgSpecifiers
 174     planPackages
 175       verbosity
 176       comp
 177       platform
 178       freezeFlags
 179       installedPkgIndex
 180       sourcePkgDb
 181       pkgConfigDb
 182       pkgSpecifiers
 183     where
 184       sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO ()
 185       sanityCheck pkgSpecifiers = do
 186         when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
 187           dieWithException verbosity UnexpectedNamedPkgSpecifiers
 188         when (length pkgSpecifiers /= 1) $
 189           dieWithException verbosity UnexpectedSourcePkgSpecifiers
 190
 191 planPackages
 192   :: Verbosity
 193   -> Compiler
 194   -> Platform
 195   -> FreezeFlags
 196   -> InstalledPackageIndex
 197   -> SourcePackageDb
 198   -> Maybe PkgConfigDb
 199   -> [PackageSpecifier UnresolvedSourcePackage]
 200   -> IO [SolverPlanPackage]
 201 planPackages
 202   verbosity
 203   comp
 204   platform
 205   freezeFlags
 206   installedPkgIndex
 207   sourcePkgDb
 208   pkgConfigDb
 209   pkgSpecifiers = do
 210     notice verbosity "Resolving dependencies..."
 211
 212     installPlan <-
 213       foldProgress logMsg (dieWithException verbosity . FreezeException) return $
 214         resolveDependencies
 215           platform
 216           (compilerInfo comp)
 217           pkgConfigDb
 218           resolverParams
 219
 220     return $ pruneInstallPlan installPlan pkgSpecifiers
 221     where
 222       resolverParams :: DepResolverParams
 223       resolverParams =
 224         setMaxBackjumps
 225           ( if maxBackjumps < 0
 226               then Nothing
 227               else Just maxBackjumps
 228           )
 229           . setIndependentGoals independentGoals
 230           . setReorderGoals reorderGoals
 231           . setCountConflicts countConflicts
 232           . setFineGrainedConflicts fineGrainedConflicts
 233           . setMinimizeConflictSet minimizeConflictSet
 234           . setShadowPkgs shadowPkgs
 235           . setStrongFlags strongFlags
 236           . setAllowBootLibInstalls allowBootLibInstalls
 237           . setOnlyConstrained onlyConstrained
 238           . setSolverVerbosity verbosity
 239           . addConstraints
 240             [ let pkg = pkgSpecifierTarget pkgSpecifier
 241                   pc =
 242                     PackageConstraint
 243                       (scopeToplevel pkg)
 244                       (PackagePropertyStanzas stanzas)
 245                in LabeledPackageConstraint pc ConstraintSourceFreeze
 246             | pkgSpecifier <- pkgSpecifiers
 247             ]
 248           $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
 249
 250       logMsg message rest = debug verbosity message >> rest
 251
 252       stanzas =
 253         [TestStanzas | testsEnabled]
 254           ++ [BenchStanzas | benchmarksEnabled]
 255       testsEnabled = fromFlagOrDefault False $ freezeTests freezeFlags
 256       benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags
 257
 258       reorderGoals = fromFlag (freezeReorderGoals freezeFlags)
 259       countConflicts = fromFlag (freezeCountConflicts freezeFlags)
 260       fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags)
 261       minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags)
 262       independentGoals = fromFlag (freezeIndependentGoals freezeFlags)
 263       shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags)
 264       strongFlags = fromFlag (freezeStrongFlags freezeFlags)
 265       maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags)
 266       allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags)
 267       onlyConstrained = fromFlag (freezeOnlyConstrained freezeFlags)
 268
 269 -- | Remove all unneeded packages from an install plan.
 270 --
 271 -- A package is unneeded if it is either
 272 --
 273 -- 1) the package that we are freezing, or
 274 --
 275 -- 2) not a dependency (directly or transitively) of the package we are
 276 --    freezing.  This is useful for removing previously installed packages
 277 --    which are no longer required from the install plan.
 278 --
 279 -- Invariant: @pkgSpecifiers@ must refer to packages which are not
 280 -- 'PreExisting' in the 'SolverInstallPlan'.
 281 pruneInstallPlan
 282   :: SolverInstallPlan
 283   -> [PackageSpecifier UnresolvedSourcePackage]
 284   -> [SolverPlanPackage]
 285 pruneInstallPlan installPlan pkgSpecifiers =
 286   removeSelf pkgIds $
 287     SolverInstallPlan.dependencyClosure installPlan pkgIds
 288   where
 289     pkgIds =
 290       [ PlannedId (packageId pkg)
 291       | SpecificSourcePackage pkg <- pkgSpecifiers
 292       ]
 293     removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)
 294     removeSelf _ =
 295       error $
 296         "internal error: 'pruneInstallPlan' given "
 297           ++ "unexpected package specifiers!"
 298
 299 freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO ()
 300 freezePackages verbosity globalFlags pkgs = do
 301   pkgEnv <-
 302     fmap (createPkgEnv . addFrozenConstraints) $
 303       loadUserConfig
 304         verbosity
 305         ""
 306         (flagToMaybe . globalConstraintsFile $ globalFlags)
 307   writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv
 308   where
 309     addFrozenConstraints config =
 310       config
 311         { savedConfigureExFlags =
 312             (savedConfigureExFlags config)
 313               { configExConstraints = map constraint pkgs
 314               }
 315         }
 316     constraint pkg =
 317       ( pkgIdToConstraint $ packageId pkg
 318       , ConstraintSourceUserConfig userPackageEnvironmentFile
 319       )
 320       where
 321         pkgIdToConstraint pkgId =
 322           UserConstraint
 323             (UserQualified UserQualToplevel (packageName pkgId))
 324             (PackagePropertyVersion $ thisVersion (packageVersion pkgId))
 325     createPkgEnv config = mempty{pkgEnvSavedConfig = config}
 326     showPkgEnv = toUTF8LBS . showPackageEnvironment
 327
 328 formatPkgs :: Package pkg => [pkg] -> [String]
 329 formatPkgs = map $ showPkg . packageId
 330   where
 331     showPkg pid = name pid ++ " == " ++ version pid
 332     name = prettyShow . packageName
 333     version = prettyShow . packageVersion