content: -----------------------------------------------------------------------------
  -- |
  -- 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 Prelude ()
  import Distribution.Client.Compat.Prelude
  
  import Distribution.Client.Config ( SavedConfig(..) )
  import Distribution.Client.Types
  import Distribution.Client.Targets
  import Distribution.Client.Dependency
  import Distribution.Client.IndexUtils as IndexUtils
           ( getSourcePackages, getInstalledPackages )
  import Distribution.Client.SolverInstallPlan
           ( SolverInstallPlan, SolverPlanPackage )
  import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
  import Distribution.Client.Setup
           ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..)
           , RepoContext(..) )
  import Distribution.Client.Sandbox.PackageEnvironment
           ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,
             userPackageEnvironmentFile )
  import Distribution.Client.Sandbox.Types
           ( SandboxPackageInfo(..) )
  
  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.Package
           ( Package, packageId, packageName, packageVersion )
  import Distribution.Simple.Compiler
           ( Compiler, compilerInfo, PackageDBStack )
  import Distribution.Simple.PackageIndex (InstalledPackageIndex)
  import Distribution.Simple.Program
           ( ProgramDb )
  import Distribution.Simple.Setup
           ( fromFlag, fromFlagOrDefault, flagToMaybe )
  import Distribution.Simple.Utils
           ( die', notice, debug, writeFileAtomic )
  import Distribution.System
           ( Platform )
  import Distribution.Text
           ( display )
  import Distribution.Verbosity
           ( Verbosity )
  
  import qualified Data.ByteString.Lazy.Char8 as BS.Char8
  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
         -> Maybe SandboxPackageInfo
         -> GlobalFlags
         -> FreezeFlags
         -> IO ()
  freeze verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo
        globalFlags freezeFlags = do
  
      pkgs  <- getFreezePkgs
                 verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo
                 globalFlags freezeFlags
  
      if null pkgs
        then notice verbosity $ "No packages to be frozen. "
                             ++ "As this package has no dependencies."
        else if dryRun
               then notice verbosity $ unlines $
                       "The following packages would be frozen:"
                     : formatPkgs pkgs
  
               else freezePackages verbosity globalFlags pkgs
  
    where
      dryRun = fromFlag (freezeDryRun freezeFlags)
  
  -- | Get the list of packages whose versions would be frozen by the @freeze@
  -- command.
  getFreezePkgs :: Verbosity
                -> PackageDBStack
                -> RepoContext
                -> Compiler
                -> Platform
                -> ProgramDb
                -> Maybe SandboxPackageInfo
                -> GlobalFlags
                -> FreezeFlags
                -> IO [SolverPlanPackage]
  getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo
        globalFlags freezeFlags = do
  
      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
      sourcePkgDb       <- getSourcePackages    verbosity repoCtxt binariesPath
      pkgConfigDb       <- readPkgConfigDb      verbosity progdb
  
      pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
                         (fromFlag $ globalWorldFile globalFlags)
                         (packageIndex sourcePkgDb)
                         [UserTargetLocalDir "."]
  
      sanityCheck pkgSpecifiers
      planPackages
                 verbosity comp platform mSandboxPkgInfo freezeFlags
                 installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers
    where
      binariesPath = fromFlag (globalBinariesDir globalFlags)
      sanityCheck pkgSpecifiers = do
        when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
          die' verbosity $ "internal error: 'resolveUserTargets' returned "
             ++ "unexpected named package specifiers!"
        when (length pkgSpecifiers /= 1) $
          die' verbosity $ "internal error: 'resolveUserTargets' returned "
             ++ "unexpected source package specifiers!"
  
  planPackages :: Verbosity
               -> Compiler
               -> Platform
               -> Maybe SandboxPackageInfo
               -> FreezeFlags
               -> InstalledPackageIndex
               -> SourcePackageDb
               -> PkgConfigDb
               -> [PackageSpecifier UnresolvedSourcePackage]
               -> IO [SolverPlanPackage]
  planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
               installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do
  
    solver <- chooseSolver verbosity
              (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp)
    notice verbosity "Resolving dependencies..."
  
    installPlan <- foldProgress logMsg (die' verbosity) return $
                     resolveDependencies
                       platform (compilerInfo comp) pkgConfigDb
                       solver
                       resolverParams
  
    return $ pruneInstallPlan installPlan pkgSpecifiers
  
    where
      resolverParams =
  
          setMaxBackjumps (if maxBackjumps < 0 then Nothing
                                               else Just maxBackjumps)
  
        . setIndependentGoals independentGoals
  
        . setReorderGoals reorderGoals
  
        . setCountConflicts countConflicts
  
        . setShadowPkgs shadowPkgs
  
        . setStrongFlags strongFlags
  
        . setAllowBootLibInstalls allowBootLibInstalls
  
        . setSolverVerbosity verbosity
  
        . addConstraints
            [ let pkg = pkgSpecifierTarget pkgSpecifier
                  pc = PackageConstraint (scopeToplevel pkg)
                                         (PackagePropertyStanzas stanzas)
              in LabeledPackageConstraint pc ConstraintSourceFreeze
            | pkgSpecifier <- pkgSpecifiers ]
  
        . maybe id applySandboxInstallPolicy mSandboxPkgInfo
  
        $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
  
      logMsg message rest = debug verbosity message >> rest
  
      stanzas = [ TestStanzas | testsEnabled ]
             ++ [ BenchStanzas | benchmarksEnabled ]
      testsEnabled      = fromFlagOrDefault False $ freezeTests freezeFlags
      benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags
  
      reorderGoals     = fromFlag (freezeReorderGoals     freezeFlags)
      countConflicts   = fromFlag (freezeCountConflicts   freezeFlags)
      independentGoals = fromFlag (freezeIndependentGoals freezeFlags)
      shadowPkgs       = fromFlag (freezeShadowPkgs       freezeFlags)
      strongFlags      = fromFlag (freezeStrongFlags      freezeFlags)
      maxBackjumps     = fromFlag (freezeMaxBackjumps     freezeFlags)
      allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls 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 installPlan pkgSpecifiers =
      removeSelf pkgIds $
      SolverInstallPlan.dependencyClosure installPlan pkgIds
    where
      pkgIds = [ PlannedId (packageId pkg)
               | SpecificSourcePackage pkg <- pkgSpecifiers ]
      removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)
      removeSelf _  = error $ "internal error: 'pruneInstallPlan' given "
                           ++ "unexpected package specifiers!"
  
  
  freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO ()
  freezePackages verbosity globalFlags pkgs = do
  
      pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $
                     loadUserConfig verbosity ""
                     (flagToMaybe . globalConstraintsFile $ globalFlags)
      writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv
    where
      addFrozenConstraints config =
          config {
              savedConfigureExFlags = (savedConfigureExFlags config) {
                  configExConstraints = map constraint pkgs
              }
          }
      constraint pkg =
          (pkgIdToConstraint $ packageId pkg
          ,ConstraintSourceUserConfig userPackageEnvironmentFile)
        where
          pkgIdToConstraint pkgId =
              UserConstraint (UserQualified UserQualToplevel (packageName pkgId))
                             (PackagePropertyVersion $ thisVersion (packageVersion pkgId))
      createPkgEnv config = mempty { pkgEnvSavedConfig = config }
      showPkgEnv = BS.Char8.pack . showPackageEnvironment
  
  
  formatPkgs :: Package pkg => [pkg] -> [String]
  formatPkgs = map $ showPkg . packageId
    where
      showPkg pid = name pid ++ " == " ++ version pid
      name = display . packageName
      version = display . packageVersion
  