Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
3.0 kB · 91 lines
OCaml
at main
1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192type status = Exited of int | Signaled of int | Bound | Not_started of stringtype call = { status : status; first_line : string option }
let pp_status ppf = function | Exited n -> Fmt.pf ppf "exited %d" n | Signaled s -> Fmt.pf ppf "ended by signal %d" s | Bound -> Fmt.string ppf "stopped at bounds.hook_wall" | Not_started why -> Fmt.pf ppf "not started: %s" why
(* The first line a command wrote, as a terminal shows it and as one field of a record holds it: the hook's text enters mq here. *)let first_line s = let line = List.hd (String.split_on_char '\n' s) in match String.trim (Console_text.strip ~keep_newlines:false line) with | "" -> None | l -> Some l
let said c = Option.bind c.first_line first_line
(* A reason is one line: a record's field holds it. *)let one_line s = Option.value ~default:"the hook gave no reason" (first_line s)
let reason ~wall c = Option.map one_line @@ match c.status with | Exited 0 -> None | Bound -> Fmt.kstr Option.some "the hook ran past bounds.hook_wall (%ds)" wall | Not_started why -> Fmt.kstr Option.some "the hook could not start: %s" why | Exited n -> ( match said c with | Some l -> Some l | None -> Fmt.kstr Option.some "the hook exited %d" n) | Signaled s -> ( match said c with | Some l -> Some l | None -> Fmt.kstr Option.some "the hook was ended by signal %d" s)
(* {1 Answers} *)
type answer = { final : bool }
let no_answer = { final = false }
let answer s = let rec read acc = function | [] -> Ok acc | line :: rest -> ( match String.trim line with | "" -> read acc rest | "final" -> read { final = true } rest | _ -> Fmt.error "the hook's answer holds %S, which is not final" line) in read no_answer (String.split_on_char '\n' s)
type verdict = Admitted | Refused of string | Unavailable of string
let verdict ~wall c = match (c.status, reason ~wall c) with | _, None -> Admitted | (Bound | Not_started _), Some why -> Unavailable why | (Exited _ | Signaled _), Some why -> Refused why
let put_to ~rules_branch ~named target = (not named) && not (Branch.equal rules_branch target)
(* {1 The records put} *)
let unknown_types rules = match Rules.delivered_types rules with | None -> [] | Some types -> let known = Event.types () in List.filter (fun ty -> not (List.mem (Event.type_prefix ^ ty) known)) types
(* Whether [e] is put to a hook delivered [types]: a delivery's own attempt and answer are recorded, not delivered, and an event of a type not named is passed over. *)let put ?types (e : Event.t) = match (e.kind, types) with | (Hook_refused _ | Hook_delivered _ | Folded _), _ -> false | _, None -> true | k, Some types -> List.mem (Event.type_name k) types
let puts (rules : Rules.t) e = match (rules.hook, rules.hook_deliver) with | None, _ | Some _, `Nothing -> false | Some _, (`Every | `Types _) -> put ?types:(Rules.delivered_types rules) e