Add a 'switch invariant' in switch-config that is enforced by the solver

src/client/opamAdminCheck.ml

@@ -58,6 +58,7 @@ let get_universe ~with_test ~with_doc ~dev opams =
     u_installed_roots = OpamPackage.Set.empty;
     u_pinned = OpamPackage.Set.empty;
     u_base = OpamPackage.Set.empty;
+    u_invariant = OpamFormula.Empty;
     u_attrs = [];
     u_reinstall = OpamPackage.Set.empty;
   }

src/format/opamFile.ml

@@ -1499,6 +1499,7 @@ module Switch_configSyntax = struct
     opam_root: dirname option;
     wrappers: Wrappers.t;
     env: env_update list;
+    invariant: OpamFormula.t;
   }
 
   let empty = {
@@ -1510,6 +1511,7 @@ module Switch_configSyntax = struct
     opam_root = None;
     wrappers = Wrappers.empty;
     env = [];
+    invariant = OpamFormula.Empty;
   }
 
   (* When adding a field or section, make sure to add it in
@@ -1548,6 +1550,10 @@ module Switch_configSyntax = struct
     "setenv", Pp.ppacc
       (fun env t -> {t with env}) (fun t -> t.env)
       (Pp.V.map_list ~depth:2 Pp.V.env_binding);
+    "invariant", Pp.ppacc
+      (fun invariant t -> {t with invariant}) (fun t -> t.invariant)
+      (Pp.V.package_formula `Conj Pp.V.(constraints version));
+
   ] @
     List.map
       (fun (fld, ppacc) ->

src/format/opamFile.mli

@@ -908,6 +908,7 @@ module Switch_config: sig
     opam_root: dirname option;
     wrappers: Wrappers.t;
     env: env_update list;
+    invariant: OpamFormula.t;
   }
   val variable: t -> variable -> variable_contents option
   val path: t -> std_path -> string option

src/format/opamTypes.mli

@@ -296,6 +296,7 @@ type universe = {
   u_installed_roots: package_set;
   u_pinned   : package_set;
   u_base     : package_set;
+  u_invariant: formula;
   u_reinstall: package_set;
   u_attrs    : (string * package_set) list;
 }

src/solver/opamCudf.ml

@@ -23,7 +23,19 @@ let s_installed_root = "installed-root"
 let s_pinned = "pinned"
 let s_version_lag = "version-lag"
 
+let opam_invariant_package_name =
+  Common.CudfAdd.encode "=opam-invariant"
+
+let opam_invariant_package_version = 0
+
+let is_opam_invariant p =
+  p.Cudf.package = opam_invariant_package_name
+
 let cudf2opam cpkg =
+  if is_opam_invariant cpkg then
+    OpamConsole.error_and_exit `Internal_error
+      "Internal error: tried to access the CUDF opam invariant as an opam \
+       package";
   let sname = Cudf.lookup_package_property cpkg s_source in
   let name = OpamPackage.Name.of_string sname in
   let sver = Cudf.lookup_package_property cpkg s_source_number in
@@ -506,7 +518,9 @@ end
 
 (** Special package used by Dose internally, should generally be filtered out *)
 let dose_dummy_request = Algo.Depsolver.dummy_request.Cudf.package
-let is_dose_request cpkg = cpkg.Cudf.package = dose_dummy_request
+let is_artefact cpkg =
+  is_opam_invariant cpkg ||
+  cpkg.Cudf.package = dose_dummy_request
 
 let filter_dependencies f_direction universe packages =
   log ~level:3 "filter deps: build graph";
@@ -601,9 +615,12 @@ let strings_of_reasons packages cudfnv2opam unav_reasons rs =
   let rec aux = function
     | [] -> []
     | Conflict (i,j,jc)::rs ->
-      if is_dose_request i || is_dose_request j then
-        let a = if is_dose_request i then j else i in
-        if is_dose_request a then aux rs else
+      if is_artefact i && is_artefact j then
+        let str = "The request is conflicting with the switch" in
+        str :: aux rs
+      else if is_artefact i || is_artefact j then
+        let a = if is_artefact i then j else i in
+        if is_artefact a then aux rs else
         if is_base a then
           let str =
             Printf.sprintf "Package %s is part of the base for this compiler \
@@ -652,7 +669,7 @@ let strings_of_reasons packages cudfnv2opam unav_reasons rs =
              (OpamFormula.of_atom_formula (Atom (vpkg2atom cudfnv2opam jc))))
       in
       str :: aux rs
-    | Missing (p,missing) :: rs when is_dose_request p ->
+    | Missing (p,missing) :: rs when is_artefact p ->
       (* Requested pkg missing *)
       let atoms =
         List.map (fun vp ->
@@ -687,12 +704,12 @@ let make_chains packages cudfnv2opam depends =
     with Not_found -> Map.add k v map in
   let roots,notroots,deps,vpkgs =
     List.fold_left (fun (roots,notroots,deps,vpkgs) -> function
-        | Dependency (i, vpkgl, jl) when not (is_dose_request i) ->
+        | Dependency (i, vpkgl, jl) when not (is_artefact i) ->
           Set.add i roots,
           List.fold_left (fun notroots j -> Set.add j notroots) notroots jl,
           map_addlist i jl deps,
           map_addlist i vpkgl vpkgs
-        | Missing (i, vpkgl) when not (is_dose_request i) ->
+        | Missing (i, vpkgl) when not (is_artefact i) ->
           let jl =
             List.map (fun (package,_) ->
                 {Cudf.default_package with Cudf.package})
@@ -1049,8 +1066,19 @@ let actions_of_diff (install, remove) =
 
 let resolve ~extern ~version_map universe request =
   log "resolve request=%a" (slog string_of_request) request;
-  if extern then get_final_universe ~version_map universe request
-  else check_request ~version_map universe request
+  let resp =
+    if extern then get_final_universe ~version_map universe request
+    else check_request ~version_map universe request
+  in
+  let cleanup univ =
+    Cudf.remove_package univ
+      (opam_invariant_package_name, opam_invariant_package_version)
+  in
+  let () = match resp with
+    | Success univ -> cleanup univ
+    | Conflicts (univ, _, _) -> cleanup univ
+  in
+  resp
 
 let to_actions f universe result =
   let aux u1 u2 =

src/solver/opamCudf.mli

@@ -183,6 +183,12 @@ val s_pinned: string
 (** the number of versions of the package since this one, cubed *)
 val s_version_lag: string
 
+(** valid cudf name for the dummy package used for enforcing opam's switch
+    invariants *)
+val opam_invariant_package_name: string
+
+val is_opam_invariant: Cudf.package -> bool
+
 (** {2 Pretty-printing} *)
 
 (** Convert a package constraint to something readable. *)

src/solver/opamSolver.ml

@@ -32,6 +32,7 @@ let empty_universe =
     u_installed_roots = OpamPackage.Set.empty;
     u_pinned = OpamPackage.Set.empty;
     u_base = OpamPackage.Set.empty;
+    u_invariant = OpamFormula.Empty;
     u_reinstall = OpamPackage.Set.empty;
     u_attrs = [];
   }
@@ -130,6 +131,26 @@ let atom2cudf _universe (version_map : int OpamPackage.Map.t) (name,cstr) =
   name_to_cudf name,
   OpamStd.Option.Op.(cstr >>= constraint_to_cudf version_map name)
 
+let opam_invariant_package version_map invariant =
+  let depends =
+    OpamFormula.to_atom_formula invariant
+    |> OpamFormula.map (fun at -> Atom (atom2cudf () version_map at))
+    |> OpamFormula.cnf_of_formula
+    |> OpamFormula.ands_to_list
+    |> List.map (OpamFormula.fold_right (fun acc x -> x::acc) [])
+  in {
+    Cudf.
+    package = OpamCudf.opam_invariant_package_name;
+    version = 0;
+    depends;
+    conflicts = [];
+    provides = [];
+    installed = true;
+    was_installed = true;
+    keep = `Keep_version;
+    pkg_extra = [];
+  }
+
 let lag_function =
   let exp =
     OpamStd.Option.default 1 (OpamStd.Config.env_int "VERSIONLAGPOWER")
@@ -314,9 +335,7 @@ let load_cudf_universe
     post;
   let chrono = OpamConsole.timer () in
   let cudf_universe =
-    let cudf_packages =
-      univ_gen ~depopts ~build ~post
-    in
+    let cudf_packages = univ_gen ~depopts ~build ~post in
     log ~level:3 "opam2cudf: done in %.3fs" (chrono ());
     try Cudf.load_universe cudf_packages
     with Cudf.Constraint_violation s ->
@@ -424,7 +443,13 @@ let resolve universe ~orphans request =
   let cudf_request = map_request (atom2cudf universe version_map) request in
   let resolve u req =
     try
+      let invariant_pkg =
+        opam_invariant_package version_map universe.u_invariant
+      in
+      Cudf.add_package u invariant_pkg;
       let resp = OpamCudf.resolve ~extern:true ~version_map u req in
+      Cudf.remove_package u
+        (invariant_pkg.Cudf.package, invariant_pkg.Cudf.version);
       OpamCudf.to_actions add_orphan_packages u resp
     with OpamCudf.Solver_failure msg ->
       OpamConsole.error_and_exit `Solver_failure "%s" msg

src/state/opamFormatUpgrade.ml

@@ -937,6 +937,7 @@ let from_2_0_alpha2_to_2_0_alpha3 root conf =
             repos = None;
             opam_root; paths; variables; wrappers = OpamFile.Wrappers.empty;
             env = [];
+            invariant = OpamFormula.Empty;
           }
         in
         OpamFile.Switch_config.write (OpamFile.make new_config_file) new_config;

src/state/opamStateTypes.mli

@@ -96,8 +96,13 @@ type +'lock switch_state = {
   switch: switch;
   (** The current active switch *)
 
+  switch_invariant: formula;
+  (** Defines the "base" of the switch, e.g. what compiler is desired *)
+
   compiler_packages: package_set;
-  (** The packages that form the base of the current compiler *)
+  (** The packages that form the base of the current compiler. Normally equal to
+      the subset of installed packages matching the invariant defined in
+      switch_config *)
 
   switch_config: OpamFile.Switch_config.t;
   (** The configuration file for this switch *)

src/state/opamSwitchAction.ml

@@ -35,7 +35,8 @@ let gen_switch_config root ?(synopsis="") ?repos _switch =
     opam_root = Some root;
     repos;
     wrappers = OpamFile.Wrappers.empty;
-    env = []; }
+    env = [];
+    invariant = OpamFormula.Empty }
 
 let install_switch_config root switch config =
   log "install_switch_config switch=%a" (slog OpamSwitch.to_string) switch;

src/state/opamSwitchState.ml

@@ -233,6 +233,9 @@ let load lock_kind gt rt switch =
       conf
     else switch_config
   in
+  let switch_invariant =
+    switch_config.OpamFile.Switch_config.invariant
+  in
   let conf_files =
     OpamPackage.Set.fold (fun nv acc ->
         OpamPackage.Name.Map.add nv.name
@@ -293,7 +296,7 @@ let load lock_kind gt rt switch =
     switch_global = (gt :> unlocked global_state);
     switch_repos = (rt :> unlocked repos_state);
     switch_lock = lock;
-    switch; compiler_packages; switch_config;
+    switch; switch_invariant; compiler_packages; switch_config;
     repos_package_index; installed_opams;
     installed; pinned; installed_roots;
     opams; conf_files;
@@ -324,6 +327,7 @@ let load_virtual ?repos_list ?(avail_default=true) gt rt =
     switch_repos = (rt :> unlocked repos_state);
     switch_lock = OpamSystem.lock_none;
     switch = OpamSwitch.unset;
+    switch_invariant = OpamFormula.Empty;
     compiler_packages = OpamPackage.Set.empty;
     switch_config = {
       OpamFile.Switch_config.empty
@@ -636,6 +640,7 @@ let universe st
   u_installed_roots = st.installed_roots;
   u_pinned    = OpamPinned.packages st;
   u_base      = base;
+  u_invariant = st.switch_invariant;
   u_reinstall;
   u_attrs     = ["opam-query", requested_allpkgs];
 }