Merge pull request #3781 from Armael/parallel_apply_refactor

Refactor the return types of OpamSolution.{apply,resolve_and_apply}

src/client/opamClient.ml

@@ -292,7 +292,7 @@ let upgrade_t ?strict_upgrade ?auto_install ?ask ?(check=false) ~all atoms t =
          then `False
          else `Success)
     else
-    let t, result = OpamSolution.apply ?ask t Upgrade ~requested solution in
+    let t, result = OpamSolution.apply ?ask t ~requested solution in
     if result = Nothing_to_do then (
       let to_check =
         if OpamPackage.Name.Set.is_empty requested then t.installed
@@ -431,7 +431,7 @@ let upgrade_t ?strict_upgrade ?auto_install ?ask ?(check=false) ~all atoms t =
 
         )
     );
-    OpamSolution.check_solution t result;
+    OpamSolution.check_solution t (Success result);
     t
 
 let upgrade t ?check ~all names =
@@ -496,12 +496,14 @@ let fixup t =
       OpamConsole.errmsg "%s"
         (OpamCudf.string_of_conflict t.packages
            (OpamSwitchState.unavailable_reason t) cs);
-      t, No_solution
+      t, Conflicts cs
     | Success solution ->
       let _, req_rm, _ = orphans ~transitive:false t in
-      OpamSolution.apply ~ask:true t Upgrade
-        ~requested:(OpamPackage.names_of_packages (requested ++ req_rm))
-        solution
+      let t, res =
+        OpamSolution.apply ~ask:true t
+          ~requested:(OpamPackage.names_of_packages (requested ++ req_rm))
+          solution in
+      t, Success res
   in
   OpamSolution.check_solution t result;
   t
@@ -1081,7 +1083,7 @@ let install_t t ?ask atoms add_to_roots ~deps_only ~assume_built =
       OpamConsole.msg "%s"
         (OpamCudf.string_of_conflict t.packages
            (OpamSwitchState.unavailable_reason t) cs);
-      t, No_solution
+      t, Conflicts cs
     | Success solution ->
       let solution =
         if deps_only then
@@ -1095,8 +1097,10 @@ let install_t t ?ask atoms add_to_roots ~deps_only ~assume_built =
             | false -> OpamPackage.Name.Set.empty)
           add_to_roots
       in
-      OpamSolution.apply ?ask t Install ~requested:names ?add_roots
-        ~assume_built solution
+      let t, res =
+        OpamSolution.apply ?ask t ~requested:names ?add_roots
+          ~assume_built solution in
+      t, Success res
   in
   OpamSolution.check_solution t solution;
   t

src/client/opamSolution.ml

@@ -74,22 +74,22 @@ let print_depexts_helper st actions =
   )
 
 let check_solution ?(quiet=false) st = function
-  | No_solution ->
+  | Conflicts _ ->
     OpamConsole.msg "No solution found, exiting\n";
     OpamStd.Sys.exit_because `No_solution
-  | Partial_error (success, failed, _remaining) ->
-    List.iter (post_message st) success;
-    List.iter (post_message ~failed:true st) failed;
-    print_depexts_helper st failed;
+  | Success (Partial_error { actions_successes; actions_errors; _ }) ->
+    List.iter (post_message st) actions_successes;
+    List.iter (fun (a, _) -> post_message ~failed:true st a) actions_errors;
+    print_depexts_helper st (List.map fst actions_errors);
     OpamEnv.check_and_print_env_warning st;
     OpamStd.Sys.exit_because `Package_operation_error
-  | OK actions ->
+  | Success (OK actions) ->
     List.iter (post_message st) actions;
     OpamEnv.check_and_print_env_warning st
-  | Nothing_to_do ->
+  | Success Nothing_to_do ->
     if not quiet then OpamConsole.msg "Nothing to do.\n";
     OpamEnv.check_and_print_env_warning st
-  | Aborted     ->
+  | Success Aborted ->
     if not OpamClientConfig.(!r.show) then
       OpamStd.Sys.exit_because `Aborted
 
@@ -260,7 +260,7 @@ end
 
 (* Process the atomic actions in a graph in parallel, respecting graph order,
    and report to user. Takes a graph of atomic actions *)
-let parallel_apply t _action ~requested ?add_roots ~assume_built action_graph =
+let parallel_apply t ~requested ?add_roots ~assume_built action_graph =
   log "parallel_apply";
 
   let remove_action_packages =
@@ -586,15 +586,25 @@ let parallel_apply t _action ~requested ?add_roots ~assume_built action_graph =
             | a, `Error (`Aborted _) -> success, failure, a::aborted
           ) ([], [], []) results
       in
-      if failure = [] && aborted = [] then `Successful ()
+      let actions_result = {
+        actions_successes = success;
+        actions_errors = failure;
+        actions_aborted = aborted;
+      } in
+      if failure = [] && aborted = [] then `Successful success
       else (
         List.iter display_error failure;
-        `Error (Partial_error (success, List.map fst failure, aborted))
+        `Error (Partial_error actions_result)
       )
     with
     | PackageActionGraph.Parallel.Errors (success, errors, remaining) ->
+      let actions_result = {
+        actions_successes = success;
+        actions_errors = errors;
+        actions_aborted = remaining;
+      } in
       List.iter display_error errors;
-      `Error (Partial_error (success, List.map fst errors, remaining))
+      `Error (Partial_error actions_result)
     | e -> `Exception e
   in
   let t = !t_ref in
@@ -618,10 +628,10 @@ let parallel_apply t _action ~requested ?add_roots ~assume_built action_graph =
       graph
   in
   match action_results with
-  | `Successful () ->
+  | `Successful successful ->
     cleanup_artefacts action_graph;
     OpamConsole.msg "Done.\n";
-    t, OK (PackageActionGraph.fold_vertex (fun a b -> a::b) action_graph [])
+    t, OK successful
   | `Exception (OpamStd.Sys.Exit _ | Sys.Break as e) ->
     OpamConsole.msg "Aborting.\n";
     raise e
@@ -642,7 +652,10 @@ let parallel_apply t _action ~requested ?add_roots ~assume_built action_graph =
   | `Error err ->
     match err with
     | Aborted -> t, err
-    | Partial_error (successful, failed, remaining) ->
+    | Partial_error solution_res ->
+      let successful = solution_res.actions_successes in
+      let failed = List.map fst solution_res.actions_errors in
+      let remaining = solution_res.actions_aborted in
       (* Cleanup build/install actions when one of them failed, it's verbose and
          doesn't add information *)
       let successful =
@@ -784,7 +797,7 @@ let run_hook_job t name ?(local=[]) w =
     Done true
 
 (* Apply a solution *)
-let apply ?ask t action ~requested ?add_roots ?(assume_built=false) solution =
+let apply ?ask t ~requested ?add_roots ?(assume_built=false) solution =
   log "apply";
   if OpamSolver.solution_is_empty solution then
     (* The current state satisfies the request contraints *)
@@ -872,7 +885,7 @@ let apply ?ask t action ~requested ?add_roots ?(assume_built=false) solution =
         OpamStd.Sys.exit_because `Configuration_error;
       let t0 = t in
       let t, r =
-        parallel_apply t action ~requested ?add_roots ~assume_built action_graph
+        parallel_apply t ~requested ?add_roots ~assume_built action_graph
       in
       let success = match r with | OK _ -> true | _ -> false in
       let post_session =
@@ -920,5 +933,7 @@ let resolve_and_apply ?ask t action ~orphans ?reinstall ~requested ?add_roots
     OpamConsole.msg "%s"
       (OpamCudf.string_of_conflict t.packages
          (OpamSwitchState.unavailable_reason t) cs);
-    t, No_solution
-  | Success solution -> apply ?ask t action ~requested ?add_roots ~assume_built solution
+    t, Conflicts cs
+  | Success solution ->
+    let t, res = apply ?ask t ~requested ?add_roots ~assume_built solution in
+    t, Success res

src/client/opamSolution.mli

@@ -31,12 +31,11 @@ val resolve:
 val apply:
   ?ask:bool ->
   rw switch_state ->
-  user_action ->
   requested:OpamPackage.Name.Set.t ->
   ?add_roots:OpamPackage.Name.Set.t ->
   ?assume_built:bool ->
   OpamSolver.solution ->
-  rw switch_state * solver_result
+  rw switch_state * solution_result
 
 (** Call the solver to get a solution and then call [apply]. If [ask] is not
     specified, prompts the user whenever the solution isn't obvious from the
@@ -52,12 +51,15 @@ val resolve_and_apply:
   ?add_roots:OpamPackage.Name.Set.t ->
   ?assume_built:bool ->
   atom request ->
-  rw switch_state * solver_result
+  rw switch_state * (solution_result, OpamCudf.conflict) result
 
 (** Raise an error if no solution is found or in case of error. Unless [quiet]
     is set, print a message indicating that nothing was done on an empty
     solution. *)
-val check_solution: ?quiet:bool -> 'a switch_state -> solver_result -> unit
+val check_solution:
+  ?quiet:bool -> 'a switch_state ->
+  (solution_result, 'conflict) result ->
+  unit
 
 (** {2 Atoms} *)
 

src/client/opamSwitchCommand.ml

@@ -263,10 +263,11 @@ let install_compiler_packages t atoms =
   in
   let t = { t with compiler_packages = to_install_pkgs } in
   let t, result =
-    OpamSolution.apply ~ask:OpamClientConfig.(!r.show) t Switch
+    OpamSolution.apply ~ask:OpamClientConfig.(!r.show) t
       ~requested:roots
       solution in
-  OpamSolution.check_solution ~quiet:OpamClientConfig.(not !r.show) t result;
+  OpamSolution.check_solution ~quiet:OpamClientConfig.(not !r.show) t
+    (Success result);
   t
 
 let install gt ~rt ?synopsis ?repos ~update_config ~packages ?(local_compiler=false) switch =

src/format/opamTypes.mli

@@ -251,14 +251,17 @@ type 'a cause =
   | Unknown
 
 (** Solver result *)
-type solver_result =
+type actions_result = {
+  actions_successes : package action list;
+  actions_errors : (package action * exn) list;
+  actions_aborted : package action list;
+}
+
+type solution_result =
   | Nothing_to_do
   | OK of package action list (** List of successful actions *)
   | Aborted
-  | No_solution
-  | Partial_error of package action list * package action list * package action list
-  (** List of successful actions, list of actions with errors,
-      list of remaining undone actions *)
+  | Partial_error of actions_result
 
 (** Solver result *)
 type ('a, 'b) result =