content: {-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards #-}
  
  -- | etlas CLI command: freeze
  --
  module Distribution.Client.CmdFreeze (
      freezeCommand,
      freezeAction,
    ) where
  
  import Distribution.Client.ProjectOrchestration
  import Distribution.Client.ProjectPlanning
  import Distribution.Client.ProjectConfig
           ( ProjectConfig(..), ProjectConfigShared(..)
           , writeProjectLocalFreezeConfig )
  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 )
  import Distribution.Client.Setup
           ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
  import Distribution.Simple.Setup
           ( HaddockFlags, fromFlagOrDefault )
  import Distribution.Simple.Utils
           ( die', notice )
  import Distribution.Verbosity
           ( normal )
  
  import Data.Monoid as Monoid
  import qualified Data.Map as Map
  import Data.Map (Map)
  import Control.Monad (unless)
  
  import Distribution.Simple.Command
           ( CommandUI(..), usageAlternatives )
  import Distribution.Simple.Utils
           ( wrapText )
  import qualified Distribution.Client.Setup as Client
  
  
  freezeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
  freezeCommand = Client.installCommand {
    commandName         = "freeze",
    commandSynopsis     = "Freeze dependencies.",
    commandUsage        = usageAlternatives "freeze" [ "[FLAGS]" ],
    commandDescription  = Just $ \_ -> wrapText $
          "The project configuration is frozen so that it will be reproducible "
       ++ "in future.\n\n"
  
       ++ "The precise dependency configuration for the project is written to "
       ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if "
       ++ "'--project-file' is specified). This file extends the configuration "
       ++ "from the 'cabal.project' file and thus is used as the project "
       ++ "configuration for all other commands (such as 'build', "
       ++ "'repl' etc).\n\n"
  
       ++ "The freeze file can be kept in source control. To make small "
       ++ "adjustments it may be edited manually, or to make bigger changes "
       ++ "you may wish to delete the file and re-freeze. For more control, "
       ++ "one approach is to try variations using 'build --dry-run' with "
       ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have "
       ++ "a satisfactory solution to freeze it using the 'freeze' command "
       ++ "with the same set of flags.",
    commandNotes        = Just $ \pname ->
          "Examples:\n"
       ++ "  " ++ pname ++ " freeze\n"
       ++ "    Freeze the configuration of the current project\n\n"
       ++ "  " ++ pname ++ " build --dry-run --constraint=\"aeson < 1\"\n"
       ++ "    Check what a solution with the given constraints would look like\n"
       ++ "  " ++ pname ++ " freeze --constraint=\"aeson < 1\"\n"
       ++ "    Freeze a solution using the given constraints\n\n"
  
       ++ "Note: this command is part of the new project-based system (aka "
       ++ "nix-style\nlocal builds). These features are currently in beta. "
       ++ "Please see\n"
       ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html "
       ++ "for\ndetails and advice on what you can expect to work. If you "
       ++ "encounter problems\nplease file issues at "
       ++ "https://github.com/haskell/cabal/issues and if you\nhave any time "
       ++ "to get involved and help with testing, fixing bugs etc then\nthat "
       ++ "is very much appreciated.\n"
     }
  
  -- | 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 :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
               -> [String] -> GlobalFlags -> IO ()
  freezeAction (configFlags, configExFlags, installFlags, haddockFlags)
               extraArgs globalFlags = do
  
      unless (null extraArgs) $
        die' verbosity $ "'freeze' doesn't take any extra arguments: "
           ++ unwords extraArgs
  
      ProjectBaseContext {
        distDirLayout,
        cabalDirLayout,
        projectConfig,
        localPackages
      } <- establishProjectBaseContext verbosity cliConfig
  
      (_, elaboratedPlan, _) <-
        rebuildInstallPlan verbosity
                           distDirLayout cabalDirLayout
                           projectConfig
                           localPackages
  
      let freezeConfig = projectFreezeConfig elaboratedPlan
      writeProjectLocalFreezeConfig distDirLayout freezeConfig
      notice verbosity $
        "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"
  
    where
      verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
      cliConfig = commandLineFlagsToProjectConfig
                    globalFlags configFlags configExFlags
                    installFlags haddockFlags
  
  
  
  -- | Given the install plan, produce a config value with constraints that
  -- freezes the versions of packages used in the plan.
  --
  projectFreezeConfig :: ElaboratedInstallPlan -> ProjectConfig
  projectFreezeConfig elaboratedPlan =
      Monoid.mempty {
        projectConfigShared = Monoid.mempty {
          projectConfigConstraints =
            concat (Map.elems (projectFreezeConstraints elaboratedPlan))
        }
      }
  
  -- | 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 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.
      --
      deleteLocalPackagesVersionConstraints
        (Map.unionWith (++) versionConstraints flagConstraints)
    where
      versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
      versionConstraints =
        Map.mapWithKey
          (\p v -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyVersion v),
                     ConstraintSourceFreeze)])
          versionRanges
  
      versionRanges :: Map PackageName VersionRange
      versionRanges =
        Map.map simplifyVersionRange $
        Map.fromListWith unionVersionRanges $
            [ (packageName pkg, thisVersion (packageVersion pkg))
            | InstallPlan.PreExisting pkg <- InstallPlan.toList plan
            ]
         ++ [ (packageName pkg, thisVersion (packageVersion pkg))
            | InstallPlan.Configured pkg <- InstallPlan.toList plan
            ]
  
      flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
      flagConstraints =
        Map.mapWithKey
          (\p f -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f),
                     ConstraintSourceFreeze)])
          flagAssignments
  
      flagAssignments :: Map PackageName FlagAssignment
      flagAssignments =
        Map.fromList
          [ (pkgname, flags)
          | InstallPlan.Configured elab <- InstallPlan.toList plan
          , let flags   = elabFlagAssignment elab
                pkgname = packageName elab
          , not (null 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 =
  #if MIN_VERSION_containers(0,5,0)
        Map.mergeWithKey
          (\_pkgname () constraints ->
              case filter (not . isVersionConstraint . fst) constraints of
                []           -> Nothing
                constraints' -> Just constraints')
          (const Map.empty) id
          localPackages
  #else
        Map.mapMaybeWithKey
          (\pkgname constraints ->
              if pkgname `Map.member` localPackages
                then case filter (not . isVersionConstraint . fst) constraints of
                       []           -> Nothing
                       constraints' -> Just constraints'
                else Just constraints)
  #endif
  
      isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True
      isVersionConstraint _                                             = False
  
      localPackages :: Map PackageName ()
      localPackages =
        Map.fromList
          [ (packageName elab, ())
          | InstallPlan.Configured elab <- InstallPlan.toList plan
          , elabLocalToProject elab
          ]
  
  