type append = { message : string; on_tip : bool }
type notes_lock = { held : Settle.held; append : append option }

let stale l =
  match l.append with
  | Some a -> a.on_tip && Note.is_commit_message a.message
  | None -> false

type request = {
  checks : Check.t list;
  key : Key.t;
  notes : Note.t list;
  scripts : (Check.name * string) list;
  inputs : (Check.name * (string * Commit.t option) list) list;
  logs : (Check.name * int * Fpath.t) list;
  notes_lock : notes_lock option;
  leftovers : Fpath.t list;
  retry : bool;
  first_red : bool;
  stored_red_ends : bool;
  gives_way : string option;
  mode : Note.mode;
  machine : Host.t;
  platform : Platform_name.t;
  supported : Platform_name.t list option;
  rules : Commit.t;
  commit : Commit.t;
  target : Branch.t;
  target_tip : Commit.t;
  check_wall : int;
  grace : int;
  slot_wait : int;
  slots : int;
  estimates : Order.estimates;
  job : Branch.t;
  kind : Order.kind;
  absent_unknown : bool;
  probe : bool;
  confinement : Confinement.t;
  prerequisites : Generation.t list;
}

type event =
  | Log_read of { note : Note.t; log : Fpath.t option }
  | Run of Check.name * Check_run.event
  | Recorded of Check.name
  | Not_recorded of Check.name * string
  | Cancelled of string
  | Drain of string
  | Failed of string
  | Prepared
  | Unprepared of [ `Msg of string | `Busy of string ]
  | Give_way of string

type action =
  | Read_log of { note : Note.t; paths : Fpath.t list }
  | Run of Check.name * Check_run.action
  | Note of { key : Key.t; note : Note.t }
  | Journal of Event.kind
  | Remove_lock of Settle.held
  | Remove_worktree of Fpath.t
  | Prepare of { commit : Commit.t; generations : Generation.t list }
  | Stop_prepare of string

type ending =
  | Passed of string
  | Red of {
      check : Check.name;
      detail : string;
      log : Fpath.t option;
      recorded : Ptime.t option;
      reds : Outcome.red list;
    }
  | Base_red of { detail : string; reds : Outcome.red list }
  | Stuck of { detail : string; log : Fpath.t option; attempt : int option }
  | Unavailable of string
  | Busy of string
  | Withdrawn
  | Drained of string
  | Elsewhere of string

type t = {
  req : request;
  results : Results.t;
  queue : Check.t list;  (** The checks still to start, in order. *)
  running : (Check.t * Check_run.t) list;
  ran : (Check.t * Check_run.ending * int) list;  (** With its seconds. *)
  reds : (Check.t * string * Outcome.red) list;
      (** The confirmed reds, with why and the last run's log and failures, in
          the order they ended. *)
  inherited : (Check.t * Outcome.red) list;
      (** The checks red only as the target's tip is, with the last run's log
          and failures, in the order they ended. *)
  reused : (Check.t * Note.t) list;
  captured : Note.t list;
  pending : int;  (** The notes asked for and not answered yet. *)
  reading : Note.t list;  (** The stored logs asked for and not answered yet. *)
  stopping : (Check.name * int) list;
      (** The attempts a [Stop] cancelled, whose task has not answered yet. *)
  withdrawing : (Check.t * Check_run.t) list;
      (** The runs stopped under way, whose answer records them. *)
  unrecorded : string list;  (** What could not be recorded, said. *)
  decided : ending option;
      (** How the checks end, once every note asked for is answered. *)
  drained : string option;
      (** Why the checks not started were dropped, once a [Drain] dropped any:
          the checks end {!Drained} once the runs under way have. *)
  gave_way : (Check.name list * string) option;
      (** The checks a [Give_way] stopped or left unstarted, and why. *)
  preparing : bool;
      (** The prerequisites are asked for and not answered yet: no check starts
          before. *)
  preparation_deadline : Ptime.t option;
      (** The wait wall of the outstanding preparation, cleared once stopped. *)
  began : Ptime.t;  (** When the checks began. *)
  last_end : Ptime.t option;  (** When the last run that ended ended. *)
}

let machine = "checking"

(* {1 Words} *)

(* The build configuration of [c]. *)
let inputs branches tips checks =
  List.filter_map
    (fun (k : Check.t) ->
      match k.inputs with
      | [] -> None
      | _ -> Some (k.name, Check.commits branches tips k))
    checks

let inputs_of req (c : Check.t) =
  Option.value ~default:[] (List.assoc_opt c.name req.inputs)

let config req (c : Check.t) =
  Build_config.v
    ?script:(List.assoc_opt c.name req.scripts)
    ~inputs:(inputs_of req c) c

let wall_of req (c : Check.t) = Option.value c.wall ~default:req.check_wall
let names l = List.map (fun ((k : Check.t), _) -> Check.string_of_name k.name) l
let run_seconds t = List.fold_left (fun n (_, _, s) -> n + s) 0 t.ran

let wall t =
  match t.last_end with
  | Some e when Ptime.is_later e ~than:t.began -> (t.began, e)
  | Some _ | None -> (t.began, t.began)

(* The clause of an outcome whose checks passed (doc/outcomes.md: "the checks
   and the time they took", their wall beside their runs' time, and "checks
   reused from build-host"). *)
let clause t =
  (* In the order the branch lists them, whichever ended first. *)
  let listed (k : Check.t) =
    Option.value ~default:max_int
      (List.find_index
         (fun (c : Check.t) -> Check.equal_name c.name k.name)
         t.req.checks)
  in
  let ran =
    List.stable_sort
      (fun ((a : Check.t), _, _) ((b : Check.t), _, _) ->
        Int.compare (listed a) (listed b))
      t.ran
  in
  let flaked =
    List.filter_map
      (fun ((k : Check.t), e, _) ->
        match e with
        | Check_run.Flaked -> Some (Check.string_of_name k.name)
        | _ -> None)
      ran
  in
  let ran =
    List.map (fun ((k : Check.t), _, _) -> Check.string_of_name k.name) ran
  in
  let took =
    let began, ended = wall t in
    Fmt.str "%a wall, %a of runs" Duration.pp
      (Duration.of_span (Ptime.Span.to_float_s (Ptime.diff ended began)))
      Duration.pp
      (Duration.of_seconds (run_seconds t))
  in
  let machines =
    List.sort_uniq String.compare
      (List.map (fun (_, (n : Note.t)) -> Host.to_string n.machine) t.reused)
  in
  let base =
    match (ran, names t.reused) with
    | [], [] -> "no checks configured"
    | [], _ -> Fmt.str "checks reused from %s" (String.concat ", " machines)
    | _, [] -> Fmt.str "checks %s (%s)" (String.concat " " ran) took
    | _, rs ->
        Fmt.str "checks %s (%s), %s reused from %s" (String.concat " " ran) took
          (String.concat " " rs)
          (String.concat ", " machines)
  in
  let flaked =
    match flaked with
    | [] -> []
    | fs ->
        [ Fmt.str "%s flaked and passed on its rerun" (String.concat " " fs) ]
  in
  String.concat "; " ((base :: flaked) @ t.unrecorded)

let with_unrecorded t detail = String.concat "; " (detail :: t.unrecorded)

(* [l]'s checks in the order the branch lists them. *)
let in_order t l =
  List.filter_map
    (fun (k : Check.t) ->
      List.find_opt (fun ((r : Check.t), _) -> Check.equal_name r.name k.name) l)
    t.req.checks

let is_inherited t (k : Check.t) =
  List.exists
    (fun ((r : Check.t), _) -> Check.equal_name r.name k.name)
    t.inherited

(* An inherited check, as a clause of the checks' ending. *)
let inherited_clause t ((k : Check.t), _) =
  Fmt.str "check %a fails as %a's tip %s does" Check.pp_name k.name Branch.pp
    t.req.target
    (Commit.short t.req.target_tip)

(* The clause that names the checks that passed: every check but those
   [left_out] says. *)
let passed_clause t ~left_out =
  match
    List.filter_map
      (fun (k : Check.t) ->
        if left_out k then None else Some (Check.string_of_name k.name))
      t.req.checks
  with
  | [] -> []
  | [ k ] -> [ Fmt.str "check %s passed" k ]
  | ks -> [ Fmt.str "checks %s passed" (String.concat " " ks) ]

(* The checks that ended, none red of its own and some inherited: the
   change is held until its target moves. *)
let base_red t =
  let inherited = in_order t t.inherited in
  let passed = passed_clause t ~left_out:(is_inherited t) in
  Base_red
    {
      detail =
        String.concat "; " (List.map (inherited_clause t) inherited @ passed);
      reds = List.map snd inherited;
    }

let failure_clause (_, clause, _) = clause

(* The red of checks that all ended, some red: each red with why, in the
   order the branch lists them, then the checks that passed. *)
let red t =
  let is_red (k : Check.t) =
    List.exists (fun ((r : Check.t), _, _) -> Check.equal_name r.name k.name)
  in
  let reds =
    List.filter_map
      (fun (k : Check.t) ->
        List.find_opt
          (fun ((r : Check.t), _, _) -> Check.equal_name r.name k.name)
          t.reds)
      t.req.checks
  in
  let failed = List.map failure_clause reds in
  let gave_way, stopped =
    match t.gave_way with
    | Some (names, why) ->
        ( names,
          [
            Fmt.str "%s %s stopped: %s"
              (match names with [ _ ] -> "check" | _ -> "checks")
              (String.concat " " (List.map Check.string_of_name names))
              why;
          ] )
    | None -> ([], [])
  in
  let passed =
    passed_clause t ~left_out:(fun k ->
        is_red k t.reds || is_inherited t k
        || List.exists (Check.equal_name k.name) gave_way)
  in
  let failed =
    failed @ List.map (inherited_clause t) (in_order t t.inherited) @ stopped
  in
  let check, log =
    match reds with
    | ((k : Check.t), _, (r : Outcome.red)) :: _ -> (k.name, r.log)
    | [] -> invalid_arg "Checking.red: no red"
  in
  Red
    {
      check;
      detail = String.concat "; " (failed @ passed);
      log;
      recorded = None;
      reds = List.map (fun (_, _, r) -> r) reds;
    }

(* The selected immutable note supplies both the recorded time and payload
   identity. The interpreter resolves its content address only on reuse. *)
let stored_why (note : Note.t option) =
  match note with
  | Some n -> Fmt.str ", recorded %s" (Timestamp.Rfc3339.format n.at)
  | None -> ""

let stored_failure ?clause (k : Check.t) note =
  let clause =
    match clause with
    | Some c -> c
    | None -> Fmt.str "check %a failed" Check.pp_name k.name
  in
  ( k,
    clause ^ stored_why note,
    { Outcome.check = k.name; log = None; failures = Failures.empty } )

(* A portable check red on one platform and passed on another (doc/
   configuration.md, "[platforms]"). *)
let not_portable ~(passed : Note.t) ~(failed : Note.t) (k : Check.t) =
  Fmt.str "check %a is not portable: passed on %a (%a), failed on %a (%a)"
    Check.pp_name k.name Platform_name.pp passed.platform Host.pp passed.machine
    Platform_name.pp failed.platform Host.pp failed.machine

let stored_red ?clause (k : Check.t) (note : Note.t option) =
  let ((_, _, r) as failure) = stored_failure ?clause k note in
  Red
    {
      check = k.name;
      detail = failure_clause failure;
      log = None;
      recorded = Option.map (fun (n : Note.t) -> n.at) note;
      reds = [ r ];
    }

let stored_paths req (n : Note.t) =
  List.filter_map
    (fun (check, attempt, path) ->
      if Check.equal_name check n.check && attempt = n.attempt then Some path
      else None)
    req.logs

(* The lookup of the log of [note], a stored red's newest run, when its note
   names the bytes and this machine holds candidates for them. *)
let lookup req (note : Note.t option) =
  match note with
  | Some ({ log = Some _; _ } as note) -> (
      match stored_paths req note with
      | [] -> None
      | paths -> Some (Read_log { note; paths }))
  | Some _ | None -> None

let looked_up =
  List.filter_map (function Read_log { note; _ } -> Some note | _ -> None)

let held_detail (l : notes_lock) =
  Fmt.str "%a is held by another process, or was left by one that died" Fpath.pp
    l.held.path

(* {1 Printing} *)

let pp_ending ppf = function
  | Passed c -> Fmt.pf ppf "passed (%s)" c
  | Red { detail; _ } -> Fmt.pf ppf "red (%s)" detail
  | Base_red { detail; _ } -> Fmt.pf ppf "base red (%s)" detail
  | Stuck { detail; _ } -> Fmt.pf ppf "stuck (%s)" detail
  | Unavailable why -> Fmt.pf ppf "unavailable (%s)" why
  | Busy why -> Fmt.pf ppf "busy (%s)" why
  | Withdrawn -> Fmt.string ppf "withdrawn"
  | Drained why -> Fmt.pf ppf "drained (%s)" why
  | Elsewhere why -> Fmt.pf ppf "elsewhere (%s)" why

let pp ppf t =
  Fmt.pf ppf "checks of %a: %d to start, %d running, %d ran, %d reused%a" Key.pp
    t.req.key (List.length t.queue) (List.length t.running) (List.length t.ran)
    (List.length t.reused)
    Fmt.(option (any ", " ++ pp_ending))
    t.decided

let pp_event ppf (e : event) =
  match e with
  | Log_read { log; _ } -> Fmt.pf ppf "stored log %a" Fmt.(option Fpath.pp) log
  | Run (n, e) -> Fmt.pf ppf "check %a: %a" Check.pp_name n Check_run.pp_event e
  | Recorded n -> Fmt.pf ppf "recorded %a" Check.pp_name n
  | Not_recorded (n, why) ->
      Fmt.pf ppf "not recorded %a: %s" Check.pp_name n why
  | Cancelled why -> Fmt.pf ppf "cancelled because %s" why
  | Drain why -> Fmt.pf ppf "drained because %s" why
  | Failed why -> Fmt.pf ppf "failed: %s" why
  | Prepared -> Fmt.string ppf "prepared"
  | Unprepared (`Msg why) -> Fmt.pf ppf "unprepared: %s" why
  | Unprepared (`Busy why) -> Fmt.pf ppf "unprepared, busy: %s" why
  | Give_way why -> Fmt.pf ppf "give way: %s" why

let pp_action ppf (a : action) =
  match a with
  | Read_log { note; _ } -> Fmt.pf ppf "read log of %a" Note.pp note
  | Run (n, a) ->
      Fmt.pf ppf "check %a: %a" Check.pp_name n Check_run.pp_action a
  | Note { note; _ } -> Fmt.pf ppf "note %a" Note.pp note
  | Journal k -> Fmt.pf ppf "journal %s" (Event.kind_name k)
  | Remove_lock h -> Fmt.pf ppf "remove %a" Fpath.pp h.path
  | Remove_worktree p -> Fmt.pf ppf "remove the worktree %a" Fpath.pp p
  | Prepare { generations; _ } ->
      Fmt.pf ppf "prepare %a"
        Fmt.(list ~sep:sp (using Generation.path Fpath.pp))
        generations
  | Stop_prepare why -> Fmt.pf ppf "stop preparation: %s" why

(* {1 Transitions} *)

(* How the checks end: at once once withdrawn; otherwise once the
   preparation asked for and every run stopped have answered, and, but for an
   unavailable ending, every note asked for, with what could not be recorded
   said. *)
let ending t =
  match t.decided with
  | Some (Withdrawn as e) -> Some e
  | Some _ when t.preparing || t.stopping <> [] -> None
  | Some ((Unavailable _ | Busy _) as e) -> Some e
  | Some _ when t.pending > 0 || t.reading <> [] -> None
  | Some (Red r) -> Some (Red { r with detail = with_unrecorded t r.detail })
  | Some (Base_red r) ->
      Some (Base_red { r with detail = with_unrecorded t r.detail })
  | Some (Stuck s) ->
      Some (Stuck { s with detail = with_unrecorded t s.detail })
  | Some (Passed _) -> Some (Passed (clause t))
  | Some ((Drained _ | Elsewhere _) as e) -> Some e
  | None -> None

let decide t e = { t with decided = Some e }

(* A check that lists its platforms and still needs a pass on one this
   machine is not, with the results this land recorded: only a result
   recorded there decides it (doc/configuration.md, "[platforms]"). *)
let elsewhere t =
  let results =
    List.fold_left (fun r n -> Results.add n r) t.results t.captured
  in
  List.filter_map
    (fun (k : Check.t) ->
      match k.platforms with
      | [] -> None
      | _ -> (
          match
            Results.verdict ~reader:t.req.mode ~here:t.req.platform
              ?supported:t.req.supported results k (config t.req k)
          with
          | Results.Elsewhere ps -> Some (k, ps)
          | _ -> None))
    t.req.checks

(* The checks passed, unless a check still needs a pass elsewhere. *)
let passed t =
  match elsewhere t with
  | [] -> Passed (clause t)
  | ks ->
      Elsewhere
        (String.concat "; "
           (List.map
              (fun ((k : Check.t), ps) ->
                Fmt.str
                  "check %a needs a pass on %a, and this machine is %a; a \
                   result from a machine that is decides it"
                  Check.pp_name k.name
                  Fmt.(list ~sep:(any " and ") Platform_name.pp)
                  ps Platform_name.pp t.req.platform)
              ks))

let run_actions n = List.map (fun a -> (Run (n, a) : action))

let start t ~now ~gang (k : Check.t) =
  let req = t.req in
  let run, actions =
    Check_run.v
      {
        Check_run.check = k;
        key = req.key;
        commit = req.commit;
        target = req.target;
        target_tip = req.target_tip;
        inputs = inputs_of req k;
        wall = wall_of req k;
        grace = req.grace;
        slot_wait = req.slot_wait;
        tag = { job = req.job; kind = req.kind; gang };
        absent_unknown = req.absent_unknown;
        probe = req.probe;
      }
      ~now
  in
  ({ t with running = t.running @ [ (k, run) ] }, run_actions k.name actions)

(* The checks to start while fewer than [slots] run, shortest first, a
   failure's rerun holding its check's place, those started at once a gang
   ({!Order.tag}); or the end once none is left. *)
let rec next ?gang t ~now =
  match (t.queue, t.running) with
  | [], [] -> (
      match (t.drained, t.reds, t.inherited) with
      | Some why, _, _ -> (decide t (Drained why), [])
      | None, [], [] -> (decide t (passed t), [])
      | None, [], _ -> (decide t (base_red t), [])
      | None, _, _ -> (decide t (red t), []))
  | k :: queue, running when List.length running < max 1 t.req.slots ->
      let gang =
        match gang with
        | Some g -> g
        | None ->
            min (List.length t.queue) (max 1 t.req.slots - List.length running)
      in
      let t, actions = start { t with queue } ~now ~gang k in
      let t, more = next ~gang t ~now in
      (t, actions @ more)
  | _ -> (t, [])

(* The runs under way, stopped because of [why]: each stopped attempt is
   awaited until its task answers, and a run stopped under way is recorded
   then, stopped and why ({!Check_run}); one still waiting for a build slot
   records nothing. *)
let stop_running ?(only = fun _ -> true) t ~now ~why =
  let stopped, kept = List.partition (fun (_, run) -> only run) t.running in
  let withdrawing, actions =
    List.fold_left
      (fun (ws, acc) ((k : Check.t), run) ->
        match Check_run.incoming run ~now (Check_run.Cancelled why) with
        | Ok (run, actions) ->
            let ws =
              match Check_run.ending run with
              | Some _ -> ws
              | None -> ws @ [ (k, run) ]
            in
            (ws, acc @ run_actions k.name actions)
        | Error _ -> (ws, acc))
      (t.withdrawing, []) stopped
  in
  ({ t with running = kept; queue = []; withdrawing }, actions)

(* Each run a [Stop] among [actions] cancels owes its task's answer, which is
   an end of that attempt: the ending waits for it. *)
let track t actions =
  let stopped =
    List.filter_map
      (function
        | (Run (n, Check_run.Stop { attempt; _ }) : action) -> Some (n, attempt)
        | Run (_, (Start _ | Hold _))
        | Read_log _ | Note _ | Journal _ | Remove_lock _ | Remove_worktree _
        | Prepare _ | Stop_prepare _ ->
            None)
      actions
  in
  ({ t with stopping = t.stopping @ stopped }, actions)

let answer t n (ce : Check_run.event) =
  match ce with
  | Ended { attempt; _ } ->
      {
        t with
        stopping =
          List.filter
            (fun (n', a) -> not (Check.equal_name n n' && Int.equal a attempt))
            t.stopping;
      }
  | Slot_taken _ | Command_started _ | Cancelled _ -> t

let newest ns = List.nth_opt (List.rev ns) 0

(* The verdict on [key] taken from the stored result [n], as a fact. *)
let reuse key (n : Note.t) =
  Journal
    (Event.reused ~check:n.check ~key ~result:n.result ~machine:n.machine
       ~seconds:(Duration.seconds n.seconds)
       ~at:n.at ())

let verdict t (k : Check.t) =
  if (not t.req.retry) && Check.reusable k then
    Results.verdict ~reader:t.req.mode ~here:t.req.platform
      ?supported:t.req.supported t.results k (config t.req k)
  else Results.Missing

(* A stored red of [v]: its newest failure and the clause that names it. *)
let stored_of k (v : Results.verdict) =
  match v with
  | Results.Failed ns -> Some (k, newest ns, None)
  | Results.Not_portable { passed; failed } ->
      let note = newest failed in
      let clause =
        Option.map (fun failed -> not_portable ~passed ~failed k) note
      in
      Some (k, note, clause)
  | Results.Passed _ | Self_only _ | Flake _ | Elsewhere _ | Missing -> None

(* [checks] in the order {!Order.v} gives the land's one job: shortest
   estimate first, ties in the order the branch lists them. *)
let shortest_first req ~now (checks : Check.t list) =
  let job =
    {
      Order.branch = req.target;
      arrived = now;
      ready = List.map (fun (k : Check.t) -> k.name) checks;
      expedited = false;
    }
  in
  Order.v req.estimates ~now [ job ]
  |> List.filter_map (fun (_, n) ->
      List.find_opt (fun (k : Check.t) -> Check.equal_name k.name n) checks)

(* The checks stuck on the notes ref another writer holds: no run ended
   them. *)
let held l = Stuck { detail = held_detail l; log = None; attempt = None }

(* The checks of [req], before any verdict. *)
let fresh req ~now =
  {
    req;
    results = Results.of_notes req.key req.notes;
    queue = [];
    running = [];
    ran = [];
    reds = [];
    inherited = [];
    reused = [];
    captured = [];
    pending = 0;
    reading = [];
    stopping = [];
    withdrawing = [];
    unrecorded = [];
    decided = None;
    drained = None;
    gave_way = None;
    preparing = false;
    preparation_deadline = None;
    began = now;
    last_end = None;
  }

(* The ending of checks that each have a stored verdict, some red: dated by
   the note of the first red. *)
let stored_ending t (note : Note.t option) =
  let recorded = Option.map (fun (n : Note.t) -> n.at) note in
  match red t with Red r -> Red { r with recorded } | ending -> ending

(* The checks to run begin: the prerequisites every check reads come first,
   once, so that no check waits on another's preparation of them. *)
let begin_checks t ~now =
  let req = t.req in
  let t, actions =
    match req.prerequisites with
    | [] -> next t ~now
    | generations ->
        ( {
            t with
            preparing = true;
            preparation_deadline =
              Some
                (Option.value ~default:now
                   (Ptime.add_span now (Ptime.Span.of_int_s req.slot_wait)));
          },
          [ Prepare { commit = req.commit; generations } ] )
  in
  let checks = List.map (fun (k : Check.t) -> k.name) req.checks in
  ( t,
    Journal (Event.Checking { target = req.target; checks; batch = None })
    :: actions )

(* A stored red is one verdict of the land: the checks with no reusable
   result still run to theirs, beside it. *)
let with_stored t ~now ~unlock verdicts failed =
  let req = t.req in
  let reads = List.filter_map (fun (_, note, _) -> lookup req note) failed in
  let reuses =
    List.filter_map
      (fun (_, v) ->
        match v with
        | Results.Passed n -> Some (reuse req.key n)
        | Results.Failed ns -> Option.map (reuse req.key) (newest ns)
        | Results.Not_portable { failed; _ } ->
            Option.map (reuse req.key) (newest failed)
        | _ -> None)
      verdicts
  in
  let t =
    {
      t with
      reused =
        List.filter_map
          (fun (k, v) ->
            match v with Results.Passed n -> Some (k, n) | _ -> None)
          verdicts;
      reds =
        List.map (fun (k, note, clause) -> stored_failure ?clause k note) failed;
      queue =
        shortest_first req ~now
          (List.filter_map
             (fun (k, v) ->
               match v with
               | Results.Passed _ | Results.Failed _ | Results.Not_portable _
               | Results.Elsewhere _ ->
                   None
               | Results.Self_only _ | Results.Flake _ | Results.Missing ->
                   Some k)
             verdicts);
      reading = looked_up reads;
    }
  in
  match (t.queue, failed, req.gives_way) with
  | [], [], _ -> (decide t (passed t), unlock @ reuses)
  | [], (_, note, _) :: _, _ ->
      (decide t (stored_ending t note), unlock @ reuses @ reads)
  | queue, (_, note, _) :: _, Some why ->
      (* Waiting work takes the slots the stored red would leave to the
         checks with no verdict: none starts. *)
      let left (k : Check.t) =
        List.exists (fun (q : Check.t) -> Check.equal_name q.name k.name) queue
      in
      let names =
        List.filter_map
          (fun (k : Check.t) -> if left k then Some k.name else None)
          req.checks
      in
      let t = { t with queue = []; gave_way = Some (names, why) } in
      (decide t (stored_ending t note), unlock @ reuses @ reads)
  | _ :: _, _, _ ->
      let t, actions = begin_checks t ~now in
      (t, unlock @ reuses @ reads @ actions)

let v req ~now =
  let t = fresh req ~now in
  match req.notes_lock with
  | Some l when not (stale l) -> (decide t (held l), [])
  | lock -> (
      let unlock =
        (match lock with Some l -> [ Remove_lock l.held ] | None -> [])
        @ List.map (fun p -> Remove_worktree p) req.leftovers
      in
      let verdicts = List.map (fun k -> (k, verdict t k)) req.checks in
      let failed = List.filter_map (fun (k, v) -> stored_of k v) verdicts in
      match failed with
      | (k, note, clause) :: _ when req.first_red || req.stored_red_ends ->
          (* The verdict is red whatever the others say: none starts. *)
          let reuse = Option.to_list (Option.map (reuse req.key) note) in
          let read = Option.to_list (lookup req note) in
          let t = decide t (stored_red ?clause k note) in
          ({ t with reading = looked_up read }, unlock @ reuse @ read)
      | _ -> with_stored t ~now ~unlock verdicts failed)

let note_of t (k : Check.t) (r : Check_run.run) =
  Note.v ~result:r.result ~check:k.name ~tree:(Key.tree t.req.key)
    ~attempt:r.attempt ~config:(config t.req k) ~rules:t.req.rules
    ~machine:t.req.machine ~platform:t.req.platform ~mode:t.req.mode
    ~confined:
      (match (k.definition, t.req.confinement) with
      | (Check.Command _ | Check.Hook _), Confinement.Confined m -> Some m
      | (Check.Command _ | Check.Hook _), Confinement.Unconfined _
      | Check.Rules, _ ->
          None)
    ~seconds:(Duration.of_seconds r.seconds)
    ~at:r.at ?log:r.digest ()

(* The records of the runs [run] finished since [before]: a journal record
   and a note asked for each, the journal's first, the journal saying whether
   the run is rerun, which [started] says: the attempts [run] started meanwhile.
   A run of a check the land withdrew ([~withdrawn]) has its journal record
   and no note: stopped, it says nothing about the tree, and ended by itself
   first, it is no longer the land's to record. A result that cannot be
   written as a note line is said, never dropped. *)
let records ?(withdrawn = false) t (k : Check.t) run ~before ~started =
  List.filteri (fun i _ -> i >= before) (Check_run.runs run)
  |> List.fold_left
       (fun (t, (journals, notes)) (r : Check_run.run) ->
         let journal =
           Journal
             (Event.check ?log:r.log ?build:r.build ?phases:r.phases
                ?stopped:r.stopped ?reason:r.reason ~failures:r.failures
                ~key:t.req.key ~result:r.result ~seconds:r.seconds
                ~attempt:r.attempt
                ~rerun:(List.mem (r.attempt + 1) started)
                k.name)
         in
         match note_of t k r with
         | _ when withdrawn -> (t, (journals @ [ journal ], notes))
         | Ok note ->
             ( { t with pending = t.pending + 1; captured = note :: t.captured },
               ( journals @ [ journal ],
                 notes @ [ Note { key = t.req.key; note } ] ) )
         | Error (`Msg m) ->
             ( {
                 t with
                 unrecorded =
                   t.unrecorded
                   @ [
                       Fmt.str "the result of check %a was not recorded: %s"
                         Check.pp_name k.name m;
                     ];
               },
               (journals @ [ journal ], notes) ))
       (t, ([], []))

let last_log run =
  match List.rev (Check_run.runs run) with r :: _ -> r.log | [] -> None

(* A confirmed red as its outcome lists it: its last run's log and what that
   run named as failed. *)
let last_red (k : Check.t) run : Outcome.red =
  match List.rev (Check_run.runs run) with
  | r :: _ -> { check = k.name; log = r.log; failures = r.failures }
  | [] -> { check = k.name; log = None; failures = Failures.empty }

(* Why a confirmed red failed, after "check NAME failed": what its last run
   marked as failed, its count and the first; else the run's exit status, as a
   CI runner gives it, then what its confinement denied or the last line it
   wrote (doc/outcomes.md). The rules check runs in mq, so its status is its
   verdict and its line mq's finding, said bare. *)
let why_red (k : Check.t) run =
  match (k.definition, List.rev (Check_run.runs run)) with
  | Check.Rules, { said = Some said; _ } :: _ -> Fmt.str " (%s)" said
  | _, { status = Denied { code; what }; _ } :: _ ->
      Fmt.str " with exit code %d, denied: %s" code what
  | _, { status = Exited code; _ } :: _ when code = Check.exit_not_found ->
      Fmt.str ": its command is not in this tree (exit %d)" code
  | _, { failures; status = Exited code; said; _ } :: _ -> (
      match (Failures.summary failures, said) with
      | Some marked, _ ->
          Fmt.str " with exit code %d: %s" code (Check_run.cut marked)
      | None, Some said ->
          Fmt.str " with exit code %d, last line \"%s\"" code said
      | None, None -> Fmt.str " with exit code %d" code)
  | _ -> ""

let seconds run =
  List.fold_left
    (fun s (r : Check_run.run) -> s + r.seconds)
    0 (Check_run.runs run)

(* The attempts on this tree of [k] that its run did not decide, this one
   included: the stuck and errored results recorded for the tree under [k]'s
   configuration, and one. *)
let undecided_attempt t (k : Check.t) =
  let config = config t.req k in
  let undecided (n : Note.t) =
    Check.equal_name n.check k.name
    && Build_config.equal n.config config
    &&
    match n.result with
    | Check.Stuck | Check.Error -> true
    | Check.Passed | Check.Failed | Check.Inherited | Check.Stopped -> false
  in
  1 + List.length (List.filter undecided (Results.notes t.results))

(* Whether a confirmed red decides how the checks end while some are still
   under way or not started yet. *)
let red_decided t =
  t.reds <> [] && Option.is_none t.decided && (t.running <> [] || t.queue <> [])

(* [t] with the confirmed red of [k]'s [run]. *)
let with_red t (k : Check.t) run =
  {
    t with
    reds =
      t.reds
      @ [
          ( k,
            Fmt.str "check %a failed%s" Check.pp_name k.name (why_red k run),
            last_red k run );
        ];
  }

(* A run that ended: the next check, or how the checks end. A confirmed red
   alone stops no other check: they run to their verdicts until a
   [Give_way]. *)
let ended t ~now (k : Check.t) run ending =
  let t =
    {
      t with
      running =
        List.filter
          (fun ((k' : Check.t), _) -> not (Check.equal_name k'.name k.name))
          t.running;
      ran = t.ran @ [ (k, ending, seconds run) ];
      last_end = Some now;
    }
  in
  (* The checks stuck: the runs still under way are stopped, because of what
     ended them. *)
  (* A machine's ending names the confirmed reds already known. *)
  let known_reds detail =
    String.concat "; " (detail :: List.map failure_clause t.reds)
  in
  let stuck detail log =
    let detail = known_reds detail in
    let t, stops = stop_running t ~now ~why:detail in
    ( decide t (Stuck { detail; log; attempt = Some (undecided_attempt t k) }),
      stops )
  in
  match (ending : Check_run.ending) with
  | Passed | Flaked -> next t ~now
  | Confirmed_red when t.req.first_red ->
      (* The tree is red whatever the others say: they are stopped. *)
      let t = with_red t k run in
      let t, stops =
        stop_running t ~now
          ~why:(Fmt.str "check %a is red on this tree" Check.pp_name k.name)
      in
      (decide t (red t), stops)
  | Confirmed_red -> next (with_red t k run) ~now
  | Inherited ->
      next { t with inherited = t.inherited @ [ (k, last_red k run) ] } ~now
  | Stuck ->
      stuck
        (Fmt.str "check %a %s" Check.pp_name k.name
           (Check_run.wall_clause (Check_run.request run)))
        (last_log run)
  | Starved ->
      let detail =
        Fmt.str "check %a waited for a build slot (%a)" Check.pp_name k.name
          Rules.pp_bound
          (Rules.Wait_wall, t.req.slot_wait)
      in
      let t, stops = stop_running t ~now ~why:detail in
      (decide t (Busy (known_reds detail)), stops)
  | Errored why ->
      stuck (Fmt.str "check %a %s" Check.pp_name k.name why) (last_log run)
  | Waited why ->
      let detail = Fmt.str "check %a %s" Check.pp_name k.name why in
      let t, stops = stop_running t ~now ~why:detail in
      (decide t (Busy (known_reds detail)), stops)
  | Withdrawn ->
      let t, stops =
        stop_running t ~now
          ~why:(Fmt.str "check %a was withdrawn" Check.pp_name k.name)
      in
      (decide t Withdrawn, stops)

(* The answer of a run stopped under way: its record, once it has one. *)
let on_withdrawn t ~now (k : Check.t) run ce =
  let before = List.length (Check_run.runs run) in
  match Check_run.incoming run ~now ce with
  | Error _ as err -> err
  | Ok (run, cactions) ->
      let others =
        List.filter
          (fun ((k' : Check.t), _) -> not (Check.equal_name k'.name k.name))
          t.withdrawing
      in
      let withdrawing =
        match Check_run.ending run with
        | Some _ -> others
        | None -> t.withdrawing
      in
      let t, (journals, notes) =
        records ~withdrawn:true { t with withdrawing } k run ~before ~started:[]
      in
      Ok (t, run_actions k.name cactions @ journals @ notes)

(* Where a run under way is, journaled for whoever follows the land. *)
let phase_record t (k : Check.t) (ce : Check_run.event) : action list =
  let started attempt phase =
    [
      Journal
        (Event.check_started ~check:k.name ~key:t.req.key ~attempt ~phase ());
    ]
  in
  match ce with
  | Slot_taken { attempt; _ } -> started attempt Event.Preparing
  | Command_started { attempt } -> started attempt Event.Running
  | Ended _ | Cancelled _ -> []

let on_run t ~now e n ce =
  (* Whether [ce] is an answer of a task stopped that still owes its end
     ({!track}): the end itself, or what it sent before the stop reached
     it. *)
  let owed =
    match ce with
    | Check_run.Ended { attempt; _ }
    | Slot_taken { attempt; _ }
    | Command_started { attempt } ->
        List.exists
          (fun (n', a) -> Check.equal_name n n' && Int.equal a attempt)
          t.stopping
    | Cancelled _ -> false
  in
  let t = answer t n ce in
  let named ((k : Check.t), _) = Check.equal_name k.name n in
  match List.find_opt named t.running with
  | None -> (
      match (List.find_opt named t.withdrawing, t.decided) with
      | Some (k, run), _ -> on_withdrawn t ~now k run ce
      | None, Some _ ->
          (* A late answer of a run cancelled: an end is its task's last. *)
          Ok (t, [])
      | None, None when owed -> (
          match ce with
          | Ended _ ->
              (* The end a run stopped before it started owes, a rerun a
                 drain dropped among them: it records nothing, and the
                 checks end once nothing else is under way. *)
              if t.running = [] && not t.preparing then Ok (next t ~now)
              else Ok (t, [])
          | Slot_taken _ | Command_started _ | Cancelled _ ->
              (* Sent before the stop reached the task, whose end is still
                 owed. *)
              Ok (t, []))
      | None, None ->
          Machine.unexpected machine ~state:(Fmt.str "%a" pp t)
            ~event:(Fmt.str "%a" pp_event e))
  | Some (k, run) -> (
      let before = List.length (Check_run.runs run) in
      match Check_run.incoming run ~now ce with
      | Error _ as err -> err
      | Ok (run, cactions) -> (
          let t =
            {
              t with
              running =
                List.map
                  (fun ((k' : Check.t), r) ->
                    if Check.equal_name k'.name k.name then (k, run) else (k', r))
                  t.running;
            }
          in
          (* The notes come last: a note the shell could not write stops only
             the actions after it in its list (doc/design.md, "A failed action
             is an event"), each answered as not recorded. *)
          let started =
            List.filter_map
              (function
                | Check_run.Start { attempt; _ } -> Some attempt
                | Check_run.Stop _ | Check_run.Hold _ -> None)
              cactions
          in
          let t, (journals, notes) = records t k run ~before ~started in
          let journals = phase_record t k ce @ journals in
          let runs = run_actions k.name cactions in
          match Check_run.ending run with
          | None -> Ok (t, runs @ journals @ notes)
          | Some ending ->
              let t, next = ended t ~now k run ending in
              Ok (t, runs @ next @ journals @ notes)))

let answered t = { t with pending = max 0 (t.pending - 1) }

(* The stored log of [note], once its lookup is answered: set on the red of
   [note]'s check. An answer to no lookup under way is late and changes
   nothing. *)
let on_log_read t (note : Note.t) log =
  if not (List.exists (Note.equal note) t.reading) then Ok (t, [])
  else
    let mine c = Check.equal_name c note.check in
    let set (r : Outcome.red) = if mine r.check then { r with log } else r in
    let decided =
      match t.decided with
      | Some (Red red) ->
          Some
            (Red
               {
                 red with
                 log = (if mine red.check then log else red.log);
                 reds = List.map set red.reds;
               })
      | other -> other
    in
    Ok
      ( {
          t with
          decided;
          reds = List.map (fun (k, why, r) -> (k, why, set r)) t.reds;
          reading = List.filter (fun n -> not (Note.equal note n)) t.reading;
        },
        [] )

(* The prerequisites could not be made: the checks end stuck, or busy for a
   lease held past its wait, unless they were decided while it was under way,
   when no check waits for it and the ending stands. *)
let on_prepared t ~now =
  let was_preparing = t.preparing in
  let t = { t with preparing = false; preparation_deadline = None } in
  if was_preparing && Option.is_none t.decided then Ok (next t ~now)
  else Ok (t, [])

let on_unprepared t ~now cause =
  let t = { t with preparing = false; preparation_deadline = None } in
  match t.decided with
  | Some _ -> Ok (t, [])
  | None ->
      let why = match cause with `Msg why | `Busy why -> why in
      let detail = "the dependency generations could not be prepared: " ^ why in
      let t, stops = stop_running t ~now ~why:detail in
      let ending =
        match cause with
        | `Busy _ -> Busy detail
        | `Msg _ -> Stuck { detail; log = None; attempt = None }
      in
      Ok (decide t ending, stops)

let incoming t ~now (e : event) =
  Result.map (fun (t, actions) -> track t actions)
  @@
  match e with
  | Log_read { note; log } -> on_log_read t note log
  | Run (n, ce) -> on_run t ~now e n ce
  | Recorded _ -> Ok (answered t, [])
  | Not_recorded (n, why) ->
      let t = answered t in
      Ok
        ( {
            t with
            unrecorded =
              t.unrecorded
              @ [
                  Fmt.str "the result of check %a was not recorded: %s"
                    Check.pp_name n why;
                ];
          },
          [] )
  | Cancelled why ->
      let t, stops = stop_running t ~now ~why in
      let stop = if t.preparing then [ Stop_prepare why ] else [] in
      Ok
        ( decide { t with reading = []; preparation_deadline = None } Withdrawn,
          stops @ stop )
  | Drain _ when Option.is_some t.decided -> Ok (t, [])
  | Drain why ->
      (* The checks not started yet, and the runs still waiting for a build
         slot, are dropped; the runs under way go on to their verdicts. *)
      let dropped =
        t.queue <> []
        || List.exists (fun (_, r) -> Check_run.waiting r) t.running
      in
      let t, stops = stop_running ~only:Check_run.waiting t ~now ~why in
      let t = if dropped then { t with drained = Some why } else t in
      if t.running = [] && not t.preparing then
        let t, more = next t ~now in
        Ok (t, stops @ more)
      else Ok (t, stops)
  | Failed why -> (
      let t, stops =
        stop_running t ~now ~why:("mq could not record the checks: " ^ why)
      in
      (* A failed action cancels the actions after it in its list: their
         answers say nothing the first failure did not, and its reason
         stands. *)
      match t.decided with
      | Some (Unavailable _) -> Ok (t, stops)
      | _ -> Ok (decide { t with reading = [] } (Unavailable why), stops))
  | Give_way why -> (
      match t.reds with
      | ((first : Check.t), _, _) :: _ when red_decided t ->
          (* The checks under way or not started give their build slots up:
         the confirmed red decides the ending, and a run stopped here keeps
         its log and its journal record, and asks for no note. *)
          let left = List.map fst t.running @ t.queue in
          let names =
            List.filter_map
              (fun (k : Check.t) ->
                if
                  List.exists
                    (fun (l : Check.t) -> Check.equal_name l.name k.name)
                    left
                then Some k.name
                else None)
              t.req.checks
          in
          let t, stops =
            stop_running t ~now
              ~why:
                (Fmt.str "check %a is red and %s" Check.pp_name first.name why)
          in
          let t, more = next { t with gave_way = Some (names, why) } ~now in
          Ok (t, stops @ more)
      | _ -> Ok (t, []))
  | Prepared -> on_prepared t ~now
  | Unprepared cause -> on_unprepared t ~now cause

(* Each run's timer, in turn, on the runs still under way: a run the timer
   ends (no build slot within bounds.wait_wall) ends the checks as an Ended
   would. *)
let tick t ~now =
  List.fold_left
    (fun acc ((k : Check.t), _) ->
      match acc with
      | Error _ -> acc
      | Ok (t, actions) -> (
          match
            List.find_opt
              (fun ((k' : Check.t), _) -> Check.equal_name k'.name k.name)
              t.running
          with
          | None -> acc
          | Some (_, run) -> (
              match Check_run.timer run ~now with
              | Error _ as e -> e
              | Ok (run, more) -> (
                  let t =
                    {
                      t with
                      running =
                        List.map
                          (fun ((k' : Check.t), r) ->
                            if Check.equal_name k'.name k.name then (k, run)
                            else (k', r))
                          t.running;
                    }
                  in
                  let more = run_actions k.name more in
                  match Check_run.ending run with
                  | None -> Ok (t, actions @ more)
                  | Some ending ->
                      let t, next = ended t ~now k run ending in
                      Ok (t, actions @ more @ next)))))
    (Ok (t, []))
    t.running

let timer t ~now =
  let t, prepare =
    match t.preparation_deadline with
    | Some deadline when Ptime.compare deadline now <= 0 ->
        let detail =
          Fmt.str "dependency preparation reached %a" Rules.pp_bound
            (Rules.Wait_wall, t.req.slot_wait)
        in
        let decided =
          match t.decided with
          | Some _ as decided -> decided
          | None -> Some (Stuck { detail; log = None; attempt = None })
        in
        ( { t with preparation_deadline = None; decided },
          [ Stop_prepare detail ] )
    | _ -> (t, [])
  in
  Result.map (fun (t, actions) -> track t (prepare @ actions)) (tick t ~now)

let next_timeout t =
  List.fold_left
    (fun acc (_, run) ->
      match (acc, Check_run.next_timeout run) with
      | None, d | d, None -> d
      | Some a, Some b -> Some (if Ptime.compare a b <= 0 then a else b))
    t.preparation_deadline t.running

let prepare_task = Machine.Task.v "prepare"

let task : action -> Machine.Task.t = function
  | Run (n, a) ->
      Machine.Task.under ("check " ^ Check.string_of_name n) (Check_run.task a)
  | Prepare _ -> Machine.Task.Start prepare_task
  | Stop_prepare why -> Machine.Task.Stop (prepare_task, why)
  | Read_log _ | Note _ | Journal _ | Remove_lock _ | Remove_worktree _ ->
      Machine.Task.Now

let unanswered a why : event =
  match a with
  | Run (n, a) -> Run (n, Check_run.unanswered a why)
  | Note { note; _ } ->
      Fmt.kstr
        (fun s -> Not_recorded (note.check, s))
        "%a" Machine.pp_unanswered why
  | Prepare _ ->
      Fmt.kstr (fun s -> Unprepared (`Msg s)) "%a" Machine.pp_unanswered why
  | Stop_prepare _ ->
      Fmt.kstr (fun s -> Failed s) "%a" Machine.pp_unanswered why
  | Read_log _ | Journal _ | Remove_lock _ | Remove_worktree _ ->
      Fmt.kstr (fun s -> Failed s) "%a" Machine.pp_unanswered why

let running t = List.map (fun ((k : Check.t), _) -> k.name) t.running

let waiting t =
  List.length t.queue
  + List.length (List.filter (fun (_, r) -> Check_run.waiting r) t.running)

let asking t =
  List.length t.queue + List.length t.running + List.length t.stopping

let idle t =
  match (t.running, t.stopping) with
  | [], [] -> (not t.preparing) && t.pending = 0 && t.reading = []
  | _ -> false

let ending_kind = function
  | Passed _ -> "passed"
  | Red _ -> "red"
  | Base_red _ -> "base red"
  | Stuck { attempt = Some n; _ } -> Fmt.str "stuck at attempt %d" n
  | Stuck { attempt = None; _ } -> "stuck"
  | Unavailable _ -> "unavailable"
  | Busy _ -> "busy"
  | Withdrawn -> "withdrawn"
  | Drained _ -> "drained"
  | Elsewhere _ -> "elsewhere"

let control t =
  let checks l =
    String.concat ","
      (List.map (fun (k : Check.t) -> Check.string_of_name k.name) l)
  in
  let runs l =
    String.concat ","
      (List.map
         (fun ((k : Check.t), r) ->
           Fmt.str "%a %s" Check.pp_name k.name (Check_run.control r))
         l)
  in
  let first (k, _, _) = k in
  Fmt.str
    "%squeue [%s]; running [%s]; withdrawing [%s]; owed [%s]; notes %d; red \
     [%s]; inherited [%s]%s%s%s%s"
    (if t.preparing then "preparing; " else "")
    (checks t.queue) (runs t.running) (runs t.withdrawing)
    (String.concat ","
       (List.map (fun (n, a) -> Fmt.str "%a %d" Check.pp_name n a) t.stopping))
    t.pending
    (checks (List.map first t.reds))
    (checks (List.map fst t.inherited))
    (match t.preparation_deadline with
    | None -> ""
    | Some deadline -> Fmt.str "; preparation bound %a" Ptime.pp deadline)
    (if Option.is_some t.drained then "; drained" else "")
    (if Option.is_some t.gave_way then "; gave way" else "")
    (match t.decided with None -> "" | Some e -> "; decided " ^ ending_kind e)

let footprint t =
  let n = List.length in
  n (Results.notes t.results)
  + n t.req.scripts + n t.req.logs + n t.req.leftovers + n t.queue + n t.ran
  + n t.reds + n t.inherited + n t.captured + n t.reused + n t.unrecorded
  + n t.stopping + n t.reading
  + List.fold_left
      (fun s (_, r) -> s + 1 + n (Check_run.runs r))
      0
      (t.running @ t.withdrawing)

let certificates t =
  match t.decided with
  | Some (Passed _) ->
      let notes = t.captured @ List.map snd t.reused in
      let rec collect acc = function
        | [] -> Ok (List.rev acc)
        | (c : Check.t) :: rest -> (
            match
              List.find_opt
                (fun (n : Note.t) ->
                  Check.equal_name n.check c.name && n.result = Check.Passed)
                notes
            with
            | Some n -> collect (n :: acc) rest
            | None ->
                Fmt.error "check %a passed without a representable certificate"
                  Check.pp_name c.name)
      in
      collect [] t.req.checks
  | _ -> Error "checks have not passed"

let read_of t name = Option.value ~default:[] (List.assoc_opt name t.req.inputs)

(* The decided results of each check of [checks] that declares inputs, on
   [tree] under the configuration the inputs' commits give it now. *)
let decided ~branches ~tips ~tree notes checks =
  let inputs = inputs branches tips checks in
  List.filter_map
    (fun (c : Check.t) ->
      if c.inputs = [] then None
      else
        let config =
          Build_config.v
            ~inputs:(Option.value ~default:[] (List.assoc_opt c.name inputs))
            c
        in
        Some
          ( c,
            List.filter_map
              (fun (n : Note.t) ->
                if
                  Check.equal_name n.check c.name
                  && Tree.equal n.tree tree
                  && Build_config.equal n.config config
                then
                  match n.result with
                  | (Check.Passed | Check.Failed) as r -> Some r
                  | Check.Inherited | Check.Stuck | Check.Error | Check.Stopped
                    ->
                      None
                else None)
              notes ))
    checks

let unchecked ~branches ~tips ~tree notes checks =
  List.filter_map
    (fun (c, rs) -> if rs = [] then Some c else None)
    (decided ~branches ~tips ~tree notes checks)

let failing ~branches ~tips ~tree notes checks =
  List.filter_map
    (fun (c, rs) ->
      match List.rev rs with Check.Failed :: _ -> Some c | _ -> None)
    (decided ~branches ~tips ~tree notes checks)