Something went wrong. Try again.
My own corner of monopam
Something went wrong. Try again.
9.2 kB · 236 lines
OCaml
at staging
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237(* Copyright (c) 2024-2026 Thomas Gazagnaire <thomas@gazagnaire.org>
Permission to use, copy, modify, and distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *)
(** Tree and commit diff operations, functored over a {!Store.S}. *)
module Hash = Object_hash
type change = | Added of { path : string; hash : Hash.t; perm : Tree.perm } | Removed of { path : string; hash : Hash.t; perm : Tree.perm } | Modified of { path : string; old_hash : Hash.t; new_hash : Hash.t; old_perm : Tree.perm; new_perm : Tree.perm; }
type t = change listtype stats = { additions : int; deletions : int; modifications : int }
let change_path = function | Added { path; _ } | Removed { path; _ } | Modified { path; _ } -> path
let compare_by_path c1 c2 = String.compare (change_path c1) (change_path c2)let path prefix name = if prefix = "" then name else prefix ^ "/" ^ name
(** Check if an entry is a directory (tree). *)let is_dir (entry : Tree.entry) = entry.perm = `Dir
let added_change prefix (entry : Tree.entry) = Added { path = path prefix entry.name; hash = entry.hash; perm = entry.perm }
let removed_change prefix (entry : Tree.entry) = Removed { path = path prefix entry.name; hash = entry.hash; perm = entry.perm }
let filter_by_path ~prefix diff = let prefix_len = String.length prefix in List.filter (fun change -> let path = change_path change in String.length path >= prefix_len && String.sub path 0 prefix_len = prefix && (String.length path = prefix_len || path.[prefix_len] = '/')) diff
let stats diff = List.fold_left (fun acc change -> match change with | Added _ -> { acc with additions = acc.additions + 1 } | Removed _ -> { acc with deletions = acc.deletions + 1 } | Modified _ -> { acc with modifications = acc.modifications + 1 }) { additions = 0; deletions = 0; modifications = 0 } diff
let pp_change ppf change = match change with | Added { path; _ } -> Fmt.pf ppf "A %s" path | Removed { path; _ } -> Fmt.pf ppf "D %s" path | Modified { path; _ } -> Fmt.pf ppf "M %s" path
let pp ppf diff = Fmt.pf ppf "@[<v>%a@]" Fmt.(list ~sep:cut pp_change) diff
let pp_stats ppf stats = Fmt.pf ppf "%d additions, %d deletions, %d modifications" stats.additions stats.deletions stats.modifications
module Make (S : Store.S) = struct (** Read a tree from the repository, returning empty list if not found. *) let read_tree repo hash = match S.read repo hash with | Ok (Value.Tree tree) -> Ok (Tree.to_list tree) | Ok _ -> Error (`Msg "expected tree object") | Error e -> Error e
(** Recursively collect all entries in a tree as Added changes. *) let rec collect_added repo prefix entries acc = List.fold_left (fun acc entry -> Result.bind acc (fun changes -> process_added_entry repo prefix entry changes)) acc entries
(** Recursively collect all entries in a tree as Removed changes. *) and collect_removed repo prefix entries acc = List.fold_left (fun acc entry -> Result.bind acc (fun changes -> process_removed_entry repo prefix entry changes)) acc entries
(** Process a single added entry (file or directory). *) and process_added_entry repo prefix (entry : Tree.entry) changes = let path = path prefix entry.name in if is_dir entry then match read_tree repo entry.hash with | Error e -> Error e | Ok sub -> collect_added repo path sub (Ok changes) else Ok (added_change prefix entry :: changes)
(** Process a single removed entry (file or directory). *) and process_removed_entry repo prefix (entry : Tree.entry) changes = let path = path prefix entry.name in if is_dir entry then match read_tree repo entry.hash with | Error e -> Error e | Ok sub -> collect_removed repo path sub (Ok changes) else Ok (removed_change prefix entry :: changes)
(** Handle entries with same name but different content/type. *) let process_matched_entries repo prefix old_e new_e changes walk_fn = let path = path prefix old_e.Tree.name in match (is_dir old_e, is_dir new_e) with | true, true -> ( (* Both directories, recurse *) match (read_tree repo old_e.hash, read_tree repo new_e.hash) with | Ok old_entries', Ok new_entries' -> walk_fn repo path old_entries' new_entries' (Ok changes) | Error e, _ | _, Error e -> Error e) | false, false -> (* Both files, content changed *) Ok (Modified { path; old_hash = old_e.hash; new_hash = new_e.hash; old_perm = old_e.perm; new_perm = new_e.perm; } :: changes) | true, false -> ( (* Dir became file: remove dir contents, add file *) match read_tree repo old_e.hash with | Error e -> Error e | Ok sub -> ( match collect_removed repo path sub (Ok changes) with | Error e -> Error e | Ok changes' -> Ok (Added { path; hash = new_e.hash; perm = new_e.perm } :: changes'))) | false, true -> ( (* File became dir: remove file, add dir contents *) let change = Removed { path; hash = old_e.hash; perm = old_e.perm } in match read_tree repo new_e.hash with | Error e -> Error e | Ok sub -> collect_added repo path sub (Ok (change :: changes)))
(** Merge-walk two sorted entry lists and compute differences. *) let rec walk_trees repo prefix old_entries new_entries acc = match (old_entries, new_entries, acc) with | _, _, Error _ -> acc | [], [], Ok changes -> Ok changes | [], new_e :: rest, Ok changes -> ( match process_added_entry repo prefix new_e changes with | Error e -> Error e | Ok changes' -> walk_trees repo prefix [] rest (Ok changes')) | old_e :: rest, [], Ok changes -> ( match process_removed_entry repo prefix old_e changes with | Error e -> Error e | Ok changes' -> walk_trees repo prefix rest [] (Ok changes')) | old_e :: old_rest, new_e :: new_rest, Ok changes -> ( let cmp = String.compare old_e.Tree.name new_e.Tree.name in if cmp < 0 then match process_removed_entry repo prefix old_e changes with | Error e -> Error e | Ok changes' -> walk_trees repo prefix old_rest new_entries (Ok changes') else if cmp > 0 then match process_added_entry repo prefix new_e changes with | Error e -> Error e | Ok changes' -> walk_trees repo prefix old_entries new_rest (Ok changes') else if Hash.equal old_e.hash new_e.hash && Tree.equal_perm old_e.perm new_e.perm then walk_trees repo prefix old_rest new_rest acc else match process_matched_entries repo prefix old_e new_e changes walk_trees with | Error e -> Error e | Ok changes' -> walk_trees repo prefix old_rest new_rest (Ok changes'))
let trees repo ~old_tree ~new_tree = let old_entries = read_tree repo old_tree in let new_entries = read_tree repo new_tree in match (old_entries, new_entries) with | Error e, _ | _, Error e -> Error e | Ok old_e, Ok new_e -> ( match walk_trees repo "" old_e new_e (Ok []) with | Error e -> Error e | Ok changes -> Ok (List.sort compare_by_path changes))
let commits repo ~old_commit ~new_commit = let read_commit_tree hash = match S.read repo hash with | Ok (Value.Commit commit) -> Ok (Commit.tree commit) | Ok _ -> Error (`Msg "expected commit object") | Error e -> Error e in match (read_commit_tree old_commit, read_commit_tree new_commit) with | Error e, _ | _, Error e -> Error e | Ok old_tree, Ok new_tree -> trees repo ~old_tree ~new_tree
let empty_of_tree repo tree = match read_tree repo tree with | Error e -> Error e | Ok entries -> ( match collect_added repo "" entries (Ok []) with | Error e -> Error e | Ok changes -> Ok (List.sort compare_by_path changes))
let tree_of_empty repo tree = match read_tree repo tree with | Error e -> Error e | Ok entries -> ( match collect_removed repo "" entries (Ok []) with | Error e -> Error e | Ok changes -> Ok (List.sort compare_by_path changes))end