Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
5.4 kB · 165 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166type repository = { identity : string; name : string }
type edge = { consumer : string; dependency : string; path : Fpath.t; selected : Commit.t;}
type selected = { repository : repository; commit : Commit.t }
type reason = | Missing_repository of string | Duplicate_repository of string | Cycle | Commit_conflict
type error = { reason : reason; paths : edge list list }type t = { order : selected list; lags : (edge * Commit.t) list }
let order t = t.orderlet lags t = t.lags
let pp_reason ppf = function | Missing_repository id -> Fmt.pf ppf "repository %s has no declaration" id | Duplicate_repository id -> Fmt.pf ppf "repository %s has several declarations" id | Cycle -> Fmt.string ppf "dependency cycle" | Commit_conflict -> Fmt.string ppf "dependency selected at different commits"
let pp_edge ppf e = Fmt.pf ppf "%s:%a -> %s@%a" e.consumer Fpath.pp e.path e.dependency Commit.pp e.selected
let pp_error ppf e = Fmt.pf ppf "%a%a" pp_reason e.reason (Fmt.list ~sep:Fmt.cut (fun ppf path -> Fmt.pf ppf " [%a]" (Fmt.list ~sep:(Fmt.any " / ") pp_edge) path)) e.paths
let pp ppf t = Fmt.list ~sep:(Fmt.any " -> ") (fun ppf x -> Fmt.pf ppf "%s@%a" x.repository.name Commit.pp x.commit) ppf t.order
let ( let* ) = Result.bindlet refuse reason paths = Error { reason; paths = List.map List.rev paths }
(* Index declarations without resolving or normalizing the caller's tokens. *)let declarations repositories = let table = Hashtbl.create 16 in List.iter (fun r -> let previous = Option.value ~default:[] (Hashtbl.find_opt table r.identity) in Hashtbl.replace table r.identity (r :: previous)) repositories; table
let adjacency edges = let table = Hashtbl.create 16 in List.iter (fun e -> let previous = Option.value ~default:[] (Hashtbl.find_opt table e.consumer) in Hashtbl.replace table e.consumer (e :: previous)) edges; table
let repository table identity path = match Hashtbl.find_opt table identity with | None -> refuse (Missing_repository identity) [ path ] | Some [ r ] -> Ok r | Some _ -> refuse (Duplicate_repository identity) [ path ]
type visit = Active | Complete
(* Of two commits of one repository, keep the one that contains the other. *)let select ~contains selections identity commit path = match Hashtbl.find_opt selections identity with | None -> Hashtbl.add selections identity (commit, path); Ok () | Some (previous, _) when Commit.equal previous commit -> Ok () | Some (previous, first) -> if contains ~repository:identity ~ancestor:previous commit then ( Hashtbl.replace selections identity (commit, path); Ok ()) else if contains ~repository:identity ~ancestor:commit previous then Ok () else refuse Commit_conflict [ first; path ]
(* The reached links that select another commit than their dependency's. *)let lagging ~reached ~selected edges = List.filter_map (fun e -> if not (reached e.consumer) then None else let commit = selected e.dependency in if Commit.equal commit e.selected then None else Some (e, commit)) edges
(* [contains ~repository ~ancestor c] reads ancestry; the strict plan reads none, so any two commits of one repository conflict. *)let plan ~contains ~root ~commit repositories edges = let nodes = declarations repositories in let links = adjacency edges in let states = Hashtbl.create 16 in let selections = Hashtbl.create 16 in let output = ref [] in let rec walk identity commit path = match Hashtbl.find_opt states identity with | Some Active -> refuse Cycle [ path ] | state -> ( let* r = repository nodes identity path in let* () = select ~contains selections identity commit path in match state with | Some Complete -> Ok () | Some Active -> assert false | None -> Hashtbl.add states identity Active; let children = List.rev (Option.value ~default:[] (Hashtbl.find_opt links identity)) in let rec children_first = function | [] -> Ok () | e :: rest -> let* () = walk e.dependency e.selected (e :: path) in children_first rest in let* () = children_first children in Hashtbl.replace states identity Complete; output := r :: !output; Ok ()) in let* () = walk root commit [] in let selected identity = fst (Hashtbl.find selections identity) in let order = List.rev_map (fun repository -> { repository; commit = selected repository.identity }) !output in Ok { order; lags = lagging ~reached:(Hashtbl.mem states) ~selected edges }
let v = plan ~contains:(fun ~repository:_ ~ancestor:_ _ -> false)
let equal_reason a b = match (a, b) with | Missing_repository a, Missing_repository b | Duplicate_repository a, Duplicate_repository b -> String.equal a b | Cycle, Cycle | Commit_conflict, Commit_conflict -> true | _ -> false
module type ANCESTRY = sig type t
val contains : t -> repository:string -> ancestor:Commit.t -> Commit.t -> boolend
module Make (A : ANCESTRY) = struct let v a = plan ~contains:(A.contains a)end