Add opt-in patch start mode

lib/patch_controller.ml

@@ -57,6 +57,12 @@ type poll_observation = {
   worktree_path : string option;
 }
 
+type start_mode = Patch_controller_core.start_mode = Naive | Greedy
+[@@deriving show, eq, sexp_of]
+
+let start_mode_to_string = Patch_controller_core.start_mode_to_string
+let start_mode_of_string = Patch_controller_core.start_mode_of_string
+
 let discovery_intents orch =
   Orchestrator.all_agents orch
   |> List.filter_map ~f:(fun (agent : Patch_agent.t) ->
@@ -295,7 +301,11 @@ let branch_map_of_patches patches =
                "Patch_controller.plan_actions: duplicate patch id %s"
                (Patch_id.to_string p.Patch.id)))
 
-let plan_action_for_patch t ~branch_map patch_id =
+let start_deps_satisfied t patch_id ~has_merged ~has_pr ~start_mode =
+  Patch_controller_core.start_deps_satisfied (Orchestrator.graph t) patch_id
+    ~has_merged ~has_pr ~start_mode
+
+let plan_action_for_patch t ~branch_map ~start_mode patch_id =
   let agent = Orchestrator.agent t patch_id in
   let has_merged pid = (Orchestrator.agent t pid).Patch_agent.merged in
   let has_pr pid = Patch_agent.has_pr (Orchestrator.agent t pid) in
@@ -304,7 +314,7 @@ let plan_action_for_patch t ~branch_map patch_id =
     && (not agent.Patch_agent.busy)
     && (not agent.Patch_agent.merged)
     && (not (Patch_agent.needs_intervention agent))
-    && Graph.deps_satisfied (Orchestrator.graph t) patch_id ~has_merged ~has_pr
+    && start_deps_satisfied t patch_id ~has_merged ~has_pr ~start_mode
   then
     let branch_of pid =
       match Map.find branch_map pid with
@@ -380,7 +390,7 @@ let reconcile_action_message t action =
   let msg = Option.value_exn (Orchestrator.find_message t msg.message_id) in
   (t, msg)
 
-let reconcile_messages t ~patches =
+let reconcile_messages ?(start_mode = Greedy) t ~patches =
   let branch_map = branch_map_of_patches patches in
   let missing =
     Graph.all_patch_ids (Orchestrator.graph t)
@@ -412,7 +422,9 @@ let reconcile_messages t ~patches =
         | Some msg when Orchestrator.equal_message_status msg.status Acked ->
             (acc, msg.message_id :: ids)
         | _ -> (
-            match plan_action_for_patch acc ~branch_map patch_id with
+            match
+              plan_action_for_patch acc ~branch_map ~start_mode patch_id
+            with
             | None -> (acc, ids)
             | Some action ->
                 let acc, msg = reconcile_action_message acc action in
@@ -431,27 +443,32 @@ let reconcile_messages t ~patches =
   in
   (t, Orchestrator.runnable_messages t)
 
-let plan_messages t ~patches = snd (reconcile_messages t ~patches)
+let plan_messages ?(start_mode = Greedy) t ~patches =
+  snd (reconcile_messages ~start_mode t ~patches)
 
-let plan_actions t ~patches =
-  plan_messages t ~patches
+let plan_actions ?(start_mode = Greedy) t ~patches =
+  plan_messages ~start_mode t ~patches
   |> List.map ~f:(fun (msg : Orchestrator.patch_agent_message) -> msg.action)
 
-let plan_tick_messages t ~project_name ~gameplan =
+let plan_tick_messages ?(start_mode = Greedy) t ~project_name ~gameplan =
   let t, effects = reconcile_all t ~project_name ~gameplan in
-  let t, messages = reconcile_messages t ~patches:gameplan.Gameplan.patches in
+  let t, messages =
+    reconcile_messages ~start_mode t ~patches:gameplan.Gameplan.patches
+  in
   (t, effects, messages)
 
-let plan_tick t ~project_name ~gameplan =
-  let t, effects, messages = plan_tick_messages t ~project_name ~gameplan in
+let plan_tick ?(start_mode = Greedy) t ~project_name ~gameplan =
+  let t, effects, messages =
+    plan_tick_messages ~start_mode t ~project_name ~gameplan
+  in
   let actions =
     List.map messages ~f:(fun (msg : Orchestrator.patch_agent_message) ->
         msg.action)
   in
   (t, effects, actions)
 
-let tick t ~project_name ~gameplan =
-  let t, effects, actions = plan_tick t ~project_name ~gameplan in
+let tick ?(start_mode = Greedy) t ~project_name ~gameplan =
+  let t, effects, actions = plan_tick ~start_mode t ~project_name ~gameplan in
   let t =
     List.fold actions ~init:t ~f:(fun acc action ->
         Orchestrator.fire acc action)
@@ -656,6 +673,90 @@ let make_orchestrator ~patch_id ~main_branch =
 let pid = Patch_id.of_string "p1"
 let main = Branch.of_string "main"
 
+let scheduler_test_patch ?(dependencies = []) id branch =
+  {
+    Patch.id;
+    title = "test";
+    description = "test";
+    branch;
+    dependencies;
+    spec = "";
+    acceptance_criteria = [];
+    changes = [];
+    files = [];
+    classification = "";
+    test_stubs_introduced = [];
+    test_stubs_implemented = [];
+    complexity = None;
+    precedents = [];
+  }
+
+let has_start_action actions patch_id =
+  List.exists actions ~f:(function
+    | Orchestrator.Start (pid, _) -> Patch_id.equal pid patch_id
+    | Orchestrator.Respond _ | Orchestrator.Rebase _ -> false)
+
+let%test "plan_actions naive blocks patch with unmerged dependency PR" =
+  let dep_id = Patch_id.of_string "p1" in
+  let child_id = Patch_id.of_string "p2" in
+  let dep = scheduler_test_patch dep_id (Branch.of_string "dep-branch") in
+  let child =
+    scheduler_test_patch child_id
+      (Branch.of_string "child-branch")
+      ~dependencies:[ dep_id ]
+  in
+  let patches = [ dep; child ] in
+  let orch = Orchestrator.create ~patches ~main_branch:main in
+  let orch = Orchestrator.fire orch (Orchestrator.Start (dep_id, main)) in
+  let orch = Orchestrator.set_pr_number orch dep_id (Pr_number.of_int 41) in
+  let orch = Orchestrator.complete orch dep_id in
+  let actions = plan_actions ~start_mode:Naive orch ~patches in
+  not (has_start_action actions child_id)
+
+let%test "plan_actions greedy allows patch with sole unmerged dependency PR" =
+  let dep_id = Patch_id.of_string "p1" in
+  let child_id = Patch_id.of_string "p2" in
+  let dep = scheduler_test_patch dep_id (Branch.of_string "dep-branch") in
+  let child =
+    scheduler_test_patch child_id
+      (Branch.of_string "child-branch")
+      ~dependencies:[ dep_id ]
+  in
+  let patches = [ dep; child ] in
+  let orch = Orchestrator.create ~patches ~main_branch:main in
+  let orch = Orchestrator.fire orch (Orchestrator.Start (dep_id, main)) in
+  let orch = Orchestrator.set_pr_number orch dep_id (Pr_number.of_int 41) in
+  let orch = Orchestrator.complete orch dep_id in
+  let actions = plan_actions ~start_mode:Greedy orch ~patches in
+  has_start_action actions child_id
+
+let%test "plan_actions naive allows patch after dependencies merge" =
+  let dep_id = Patch_id.of_string "p1" in
+  let child_id = Patch_id.of_string "p2" in
+  let dep = scheduler_test_patch dep_id (Branch.of_string "dep-branch") in
+  let child =
+    scheduler_test_patch child_id
+      (Branch.of_string "child-branch")
+      ~dependencies:[ dep_id ]
+  in
+  let patches = [ dep; child ] in
+  let orch = Orchestrator.create ~patches ~main_branch:main in
+  let orch = Orchestrator.mark_merged orch dep_id in
+  let actions = plan_actions ~start_mode:Naive orch ~patches in
+  has_start_action actions child_id
+
+let%test "plan_actions naive keeps independent patches parallelizable" =
+  let p1 =
+    scheduler_test_patch (Patch_id.of_string "p1") (Branch.of_string "b1")
+  in
+  let p2 =
+    scheduler_test_patch (Patch_id.of_string "p2") (Branch.of_string "b2")
+  in
+  let patches = [ p1; p2 ] in
+  let orch = Orchestrator.create ~patches ~main_branch:main in
+  let actions = plan_actions ~start_mode:Naive orch ~patches in
+  has_start_action actions p1.Patch.id && has_start_action actions p2.Patch.id
+
 let%test "reconcile_patch escalates repeated start discovery failures" =
   let patch, t = make_orchestrator ~patch_id:pid ~main_branch:main in
   let t =

lib/patch_controller.mli

@@ -23,6 +23,15 @@ type poll_observation = {
   worktree_path : string option;
 }
 
+type start_mode = Patch_controller_core.start_mode = Naive | Greedy
+[@@deriving show, eq, sexp_of]
+
+val start_mode_to_string : start_mode -> string
+(** Stable CLI/config spelling for start scheduling modes. *)
+
+val start_mode_of_string : string -> (start_mode, string) result
+(** Parse a CLI/config spelling for start scheduling modes. *)
+
 val discovery_intents : Orchestrator.t -> (Patch_id.t * Branch.t) list
 (** Patches that have run at least once ([has_session]) but lack a PR and are
     not merged. Returns [(patch_id, branch)] pairs for tick-based PR discovery
@@ -65,11 +74,15 @@ val reconcile_all :
 (** Reconcile all gameplan patches. Ad-hoc patches are ignored. *)
 
 val plan_actions :
-  Orchestrator.t -> patches:Patch.t list -> Orchestrator.action list
+  ?start_mode:start_mode ->
+  Orchestrator.t ->
+  patches:Patch.t list ->
+  Orchestrator.action list
 (** Compute runnable actions from the current snapshot after reconciliation.
     This is the evergreen scheduler used by the main loop. *)
 
 val plan_messages :
+  ?start_mode:start_mode ->
   Orchestrator.t ->
   patches:Patch.t list ->
   Orchestrator.patch_agent_message list
@@ -78,6 +91,7 @@ val plan_messages :
     actions become pending messages in the outbox. *)
 
 val plan_tick_messages :
+  ?start_mode:start_mode ->
   Orchestrator.t ->
   project_name:string ->
   gameplan:Gameplan.t ->
@@ -86,6 +100,7 @@ val plan_tick_messages :
     runnable patch-agent messages for the same snapshot. *)
 
 val plan_tick :
+  ?start_mode:start_mode ->
   Orchestrator.t ->
   project_name:string ->
   gameplan:Gameplan.t ->
@@ -94,6 +109,7 @@ val plan_tick :
     actions for the same snapshot. *)
 
 val tick :
+  ?start_mode:start_mode ->
   Orchestrator.t ->
   project_name:string ->
   gameplan:Gameplan.t ->

lib/project_store.ml

@@ -76,11 +76,12 @@ type stored_config = {
   poll_interval : float;
   repo_root : string;
   max_concurrency : int;
+  start_mode : string;
 }
 [@@deriving yojson]
 
 let save_config ~project_name ~github_token ~github_owner ~github_repo ~backend
-    ~model ~main_branch ~poll_interval ~repo_root ~max_concurrency =
+    ~model ~main_branch ~poll_interval ~repo_root ~max_concurrency ~start_mode =
   let dir = project_dir project_name in
   ensure_dir dir;
   let config =
@@ -95,6 +96,7 @@ let save_config ~project_name ~github_token ~github_owner ~github_repo ~backend
       poll_interval;
       repo_root;
       max_concurrency;
+      start_mode;
     }
   in
   let json = yojson_of_stored_config config in
@@ -134,6 +136,12 @@ let migrate_backend_model fields =
   in
   ("backend", `String backend) :: ("model", `String model) :: without
 
+let migrate_start_mode fields =
+  let assoc = List.Assoc.find fields ~equal:String.equal in
+  match assoc "start_mode" with
+  | Some _ -> fields
+  | None -> ("start_mode", `String "greedy") :: fields
+
 let load_config ~project_name =
   let path = config_path project_name in
   try
@@ -146,7 +154,9 @@ let load_config ~project_name =
     let json = Yojson.Safe.from_string content in
     match json with
     | `Assoc fields ->
-        Ok (stored_config_of_yojson (`Assoc (migrate_backend_model fields)))
+        Ok
+          (stored_config_of_yojson
+             (`Assoc (fields |> migrate_backend_model |> migrate_start_mode)))
     | _ -> Ok (stored_config_of_yojson json)
   with exn -> Error (Stdlib.Printexc.to_string exn)
 

lib/project_store.mli

@@ -33,6 +33,7 @@ type stored_config = {
   poll_interval : float;
   repo_root : string;
   max_concurrency : int;
+  start_mode : string;
 }
 [@@deriving yojson]
 
@@ -47,6 +48,7 @@ val save_config :
   poll_interval:float ->
   repo_root:string ->
   max_concurrency:int ->
+  start_mode:string ->
   unit
 (** Persist project config to the data directory. Creates the directory if
     needed. *)

lib_core/patch_controller_core.ml

@@ -0,0 +1,20 @@
+open Base
+
+type start_mode = Naive | Greedy [@@deriving show, eq, sexp_of]
+
+let start_mode_to_string = function Naive -> "naive" | Greedy -> "greedy"
+
+let start_mode_of_string s =
+  match String.lowercase (String.strip s) with
+  | "naive" -> Ok Naive
+  | "greedy" -> Ok Greedy
+  | other ->
+      Error
+        (Printf.sprintf
+           "invalid start mode %S; expected \"naive\" or \"greedy\"" other)
+
+let start_deps_satisfied graph patch_id ~has_merged ~has_pr ~start_mode =
+  match start_mode with
+  | Greedy -> Graph.deps_satisfied graph patch_id ~has_merged ~has_pr
+  | Naive ->
+      Graph.deps graph patch_id |> List.for_all ~f:(fun dep -> has_merged dep)

lib_core/patch_controller_core.mli

@@ -0,0 +1,23 @@
+open Base
+open Types
+
+type start_mode = Naive | Greedy [@@deriving show, eq, sexp_of]
+
+val start_mode_to_string : start_mode -> string
+(** Stable CLI/config spelling for start scheduling modes. *)
+
+val start_mode_of_string : string -> (start_mode, string) Result.t
+(** Parse a CLI/config spelling for start scheduling modes. *)
+
+val start_deps_satisfied :
+  Graph.t ->
+  Patch_id.t ->
+  has_merged:(Patch_id.t -> bool) ->
+  has_pr:(Patch_id.t -> bool) ->
+  start_mode:start_mode ->
+  bool
+(** Whether [patch_id]'s dependencies allow starting under [start_mode].
+
+    [Greedy] allows a patch when every dependency has either merged or has an
+    open PR, and at most one dependency remains unmerged. [Naive] requires every
+    direct dependency to have merged. *)

test/dune

@@ -189,6 +189,13 @@
  (ocamlopt_flags (:standard -w -40-42))
  (ocamlc_flags (:standard -w -40-42)))
 
+(test
+ (name test_patch_controller_properties)
+ (modules test_patch_controller_properties)
+ (libraries onton_core qcheck-core qcheck-core.runner)
+ (ocamlopt_flags (:standard -w -40-42))
+ (ocamlc_flags (:standard -w -40-42)))
+
 (test
  (name test_patch_controller_state_machine)
  (modules test_patch_controller_state_machine)