mbarbin / vcs / 87

Committed 30 Jul 2024 05:55PM UTC coverage: 99.847% (-0.2%) from 100.0%

Build # 87

Build Type

push

github

Committed by

mbarbin

Commit Message

Clarify the branching happening in descendance computation

Run Details

7 of 8 new or added lines in 1 file covered. (87.5%)

1 existing line in 1 file now uncovered.

1963 of 1966 relevant lines covered (99.85%)

26.82 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

98.97

/lib/vcs/src/tree.ml

(*******************************************************************************)
(*  Vcs - a Versatile OCaml Library for Git Interaction                        *)
(*  Copyright (C) 2024 Mathieu Barbin <mathieu.barbin@gmail.com>               *)
(*                                                                             *)
(*  This file is part of Vcs.                                                  *)
(*                                                                             *)
(*  Vcs is free software; you can redistribute it and/or modify it under       *)
(*  the terms of the GNU Lesser General Public License as published by the     *)
(*  Free Software Foundation either version 3 of the License, or any later     *)
(*  version, with the LGPL-3.0 Linking Exception.                              *)
(*                                                                             *)
(*  Vcs is distributed in the hope that it will be useful, but WITHOUT ANY     *)
(*  WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS  *)
(*  FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License and    *)
(*  the file `NOTICE.md` at the root of this repository for more details.      *)
(*                                                                             *)
(*  You should have received a copy of the GNU Lesser General Public License   *)
(*  and the LGPL-3.0 Linking Exception along with this library. If not, see    *)
(*  <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.       *)
(*******************************************************************************)

module Node = struct
  module T0 = struct
    type t = int [@@deriving compare, hash]

    let sexp_of_t i = Sexp.Atom ("#" ^ Int.to_string_hum i)
  end

  include T0
  include Comparable.Make (T0)
end

module Node_kind = struct
  module T = struct
    [@@@coverage off]

    type t =
      | Root of { rev : Rev.t }
      | Commit of
          { rev : Rev.t
          ; parent : Node.t
          }
      | Merge of
          { rev : Rev.t
          ; parent1 : Node.t
          ; parent2 : Node.t
          }
    [@@deriving equal, sexp_of]
  end

  include T

  let rev = function
    | Root { rev } -> rev
    | Commit { rev; _ } -> rev
    | Merge { rev; _ } -> rev
  ;;

  let to_log_line t ~f =
    match t with
    | Root { rev } -> Log.Line.Root { rev }
    | Commit { rev; parent } -> Log.Line.Commit { rev; parent = f parent }
    | Merge { rev; parent1; parent2 } ->
      Log.Line.Merge { rev; parent1 = f parent1; parent2 = f parent2 }
  ;;
end

module T = struct
  [@@@coverage off]

  module Nodes = struct
    type t = Node_kind.t array

    let sexp_of_t t =
      Array.mapi t ~f:(fun i node -> i, node)
      |> Array.rev
      |> [%sexp_of: (Node.t * Node_kind.t) array]
    ;;
  end

  module Revs = struct
    type t = int Hashtbl.M(Rev).t

    let sexp_of_t (t : t) =
      let revs = Hashtbl.to_alist t |> Array.of_list in
      Array.sort revs ~compare:(fun (_, n1) (_, n2) -> Int.compare n2 n1);
      revs
      |> Array.map ~f:(fun (rev, index) -> index, rev)
      |> [%sexp_of: (Node.t * Rev.t) array]
    ;;
  end

  module Reverse_refs = struct
    type t = Ref_kind.t list Hashtbl.M(Int).t

    let sexp_of_t (t : t) =
      let revs = Hashtbl.to_alist t |> Array.of_list in
      Array.sort revs ~compare:(fun (n1, _) (n2, _) -> Int.compare n2 n1);
      revs |> [%sexp_of: (Node.t * Ref_kind.t list) array]
    ;;
  end

  type t =
    { mutable nodes : Nodes.t
    ; revs : int Hashtbl.M(Rev).t
    ; refs : int Hashtbl.M(Ref_kind).t
    ; reverse_refs : Ref_kind.t list Hashtbl.M(Int).t
    }

  let sexp_of_t { nodes; revs; refs = _; reverse_refs } =
    [%sexp { nodes : Nodes.t; revs : Revs.t; refs = (reverse_refs : Reverse_refs.t) }]
  ;;
end

include T

let create () =
  { nodes = [||]
  ; revs = Hashtbl.create (module Rev)
  ; refs = Hashtbl.create (module Ref_kind)
  ; reverse_refs = Hashtbl.create (module Int)
  }
;;

let node_count t = Array.length t.nodes
let node_kind t node = t.nodes.(node)
let ( .$() ) = node_kind
let rev t node = Node_kind.rev t.$(node)

let parents t node =
  match t.$(node) with
  | Node_kind.Root _ -> []
  | Commit { parent; _ } -> [ parent ]
  | Merge { parent1; parent2; _ } -> [ parent1; parent2 ]
;;

let prepend_parents t node list =
  match t.$(node) with
  | Node_kind.Root _ -> list
  | Commit { parent; _ } -> parent :: list
  | Merge { parent1; parent2; _ } -> parent1 :: parent2 :: list
;;

let node_refs t node =
  Hashtbl.find t.reverse_refs node
  |> Option.value ~default:[]
  |> List.sort ~compare:Ref_kind.compare
;;

let log_line t node = Node_kind.to_log_line t.$(node) ~f:(fun i -> Node_kind.rev t.$(i))

(* Helper function to iter over all ancestors of a given node, itself included.
   [visited] is taken as an input so we can re-use the same array multiple
   times, rather than re-allocating it. *)
let iter_ancestors t ~visited node ~f =
  Bit_vector.reset visited false;
  let rec loop to_visit =
    match to_visit with
    | [] -> ()
    | node :: to_visit ->
      let to_visit =
        if Bit_vector.get visited node
        then to_visit
        else (
          Bit_vector.set visited node true;
          f node;
          prepend_parents t node to_visit)
      in
      loop to_visit
  in
  loop [ node ]
;;

let greatest_common_ancestors t nodes =
  match nodes with
  | [] -> []
  | [ node ] -> [ node ]
  | node1 :: nodes ->
    let node_count = Array.length t.nodes in
    let visited = Bit_vector.create ~len:node_count false in
    let common_ancestors =
      iter_ancestors t ~visited node1 ~f:(fun _ -> ());
      Bit_vector.copy visited
    in
    List.iter nodes ~f:(fun node ->
      iter_ancestors t ~visited node ~f:(fun _ -> ());
      Bit_vector.bw_and_in_place ~mutates:common_ancestors visited);
    for i = node_count - 1 downto 0 do
      if Bit_vector.get common_ancestors i
      then
        iter_ancestors t ~visited i ~f:(fun j ->
          if j <> i then Bit_vector.set common_ancestors j false)
    done;
    Bit_vector.filter_mapi common_ancestors ~f:(fun i b -> if b then Some i else None)
    |> Array.to_list
;;

let refs t =
  Hashtbl.to_alist t.refs
  |> List.sort ~compare:(fun (r1, _) (r2, _) -> Ref_kind.compare r1 r2)
  |> List.map ~f:(fun (ref_kind, index) ->
    { Refs.Line.rev = Node_kind.rev t.$(index); ref_kind })
;;

let set_ref t ~rev ~ref_kind =
  match Hashtbl.find t.revs rev with
  | None -> raise_s [%sexp "Rev not found", (rev : Rev.t)]
  | Some index ->
    Hashtbl.set t.refs ~key:ref_kind ~data:index;
    Hashtbl.add_multi t.reverse_refs ~key:index ~data:ref_kind
;;

let set_refs t ~refs =
  List.iter refs ~f:(fun { Refs.Line.rev; ref_kind } -> set_ref t ~rev ~ref_kind)
;;

let find_ref t ~ref_kind = Hashtbl.find t.refs ref_kind
let mem_rev t ~rev = Hashtbl.mem t.revs rev
let find_rev t ~rev = Hashtbl.find t.revs rev

let add_nodes t ~log =
  let nodes_table =
    let table = Hashtbl.create (module Rev) in
    List.iter log ~f:(fun line ->
      Hashtbl.add_exn table ~key:(Log.Line.rev line) ~data:line);
    table
  in
  let new_nodes = Queue.create ~capacity:(List.length log) () in
  let visited = Hash_set.create (module Rev) in
  let is_visited rev =
    if Hash_set.mem visited rev
    then true
    else if mem_rev t ~rev
    then (
      Hash_set.add visited rev;
      true)
    else false
  in
  let rec visit (line : Log.Line.t) =
    match (line : Log.Line.t) with
    | Root { rev } ->
      if not (is_visited rev)
      then (
        Hash_set.add visited rev;
        Queue.enqueue new_nodes line)
    | Commit { rev; parent } ->
      if not (is_visited rev)
      then (
        Hash_set.add visited rev;
        if not (Hashtbl.mem t.revs parent)
        then visit (Hashtbl.find_exn nodes_table parent);
        Queue.enqueue new_nodes line)
    | Merge { rev; parent1; parent2 } ->
      if not (is_visited rev)
      then (
        Hash_set.add visited rev;
        if not (Hashtbl.mem t.revs parent1)
        then visit (Hashtbl.find_exn nodes_table parent1);
        if not (Hashtbl.mem t.revs parent2)
        then visit (Hashtbl.find_exn nodes_table parent2);
        Queue.enqueue new_nodes line)
  in
  (* We iter in reverse order to makes the depth of visited path shorter. *)
  List.iter (List.rev log) ~f:visit;
  let new_index = Array.length t.nodes in
  let new_nodes =
    let find_node_exn rev = Hashtbl.find_exn t.revs rev in
    Queue.to_array new_nodes
    |> Array.mapi ~f:(fun i node ->
      let index = new_index + i in
      let rev = Log.Line.rev node in
      Hashtbl.add_exn t.revs ~key:rev ~data:index;
      match node with
      | Root _ -> Node_kind.Root { rev }
      | Commit { rev; parent; _ } ->
        Node_kind.Commit { rev; parent = find_node_exn parent }
      | Merge { rev; parent1; parent2; _ } ->
        Node_kind.Merge
          { rev; parent1 = find_node_exn parent1; parent2 = find_node_exn parent2 })
  in
  t.nodes <- Array.append t.nodes new_nodes;
  ()
;;

let roots t =
  Array.filter_mapi t.nodes ~f:(fun i node ->
    match node with
    | Root _ -> Some i
    | Commit _ | Merge _ -> None)
  |> Array.to_list
;;

(* Pre condition: ancestor < descendant. *)
let is_strict_ancestor_internal t ~ancestor ~descendant =
  assert (ancestor < descendant);
  let visited = Bit_vector.create ~len:(descendant - ancestor + 1) false in
  let rec loop to_visit =
    match to_visit with
    | [] -> false
    | node :: to_visit ->
      (match Int.compare ancestor node |> Ordering.of_int with
       | Equal -> true
       | Greater -> loop to_visit
       | Less ->
         let to_visit =
           let visited_index = node - ancestor in
           if Bit_vector.get visited visited_index
           then to_visit
           else (
             Bit_vector.set visited visited_index true;
             prepend_parents t node to_visit)
         in
         loop to_visit)
  in
  loop [ descendant ]
;;

let is_strict_ancestor t ~ancestor ~descendant =
  ancestor < descendant && is_strict_ancestor_internal t ~ancestor ~descendant
;;

let is_ancestor_or_equal t ~ancestor ~descendant =
  ancestor = descendant || is_strict_ancestor t ~ancestor ~descendant
;;

module Descendance = struct
  [@@@coverage off]

  type t =
    | Same_node
    | Strict_ancestor
    | Strict_descendant
    | Other
  [@@deriving equal, enumerate, hash, sexp_of]
end

let descendance t a b : Descendance.t =
  match Int.compare a b |> Ordering.of_int with
  | Equal -> Same_node
  | Less ->
    if is_strict_ancestor_internal t ~ancestor:a ~descendant:b
    then Strict_ancestor
    else Other
  | Greater ->
    if is_strict_ancestor_internal t ~ancestor:b ~descendant:a
    then Strict_descendant
    else Other
;;

let tips t =
  let has_children = Bit_vector.create ~len:(node_count t) false in
  Array.iter t.nodes ~f:(fun node ->
    match node with
    | Root _ -> ()
    | Commit { parent; _ } -> Bit_vector.set has_children parent true
    | Merge { parent1; parent2; _ } ->
      Bit_vector.set has_children parent1 true;
      Bit_vector.set has_children parent2 true);
  Array.filter_mapi t.nodes ~f:(fun i _ ->
    if Bit_vector.get has_children i then None else Some i)
  |> Array.to_list
;;

let log t = Array.mapi t.nodes ~f:(fun node _ -> log_line t node) |> Array.to_list

module Subtree = struct
  module T = struct
    [@@@coverage off]

    type t =
      { log : Log.t
      ; refs : Refs.t
      }
    [@@deriving sexp_of]
  end

  include T

  let is_empty { log; refs } = List.is_empty log && List.is_empty refs
end

let of_subtree { Subtree.log; refs } =
  let t = create () in
  add_nodes t ~log;
  set_refs t ~refs;
  t
;;

let subtrees t =
  let dummy_cell = Union_find.create (-1) in
  let components = Array.map t.nodes ~f:(fun _ -> dummy_cell) in
  let component_id = ref 0 in
  Array.iteri t.nodes ~f:(fun i node ->
    match node with
    | Root { rev = _ } ->
      let id = !component_id in
      Int.incr component_id;
      components.(i) <- Union_find.create id
    | Commit { rev = _; parent } -> components.(i) <- components.(parent)
    | Merge { rev = _; parent1; parent2 } ->
      let component1 = components.(parent1) in
      Union_find.union component1 components.(parent2);
      components.(i) <- component1);
  let num_id = !component_id in
  let logs = Array.init num_id ~f:(fun _ -> Queue.create ()) in
  let refs = Array.init num_id ~f:(fun _ -> Queue.create ()) in
  Array.iteri components ~f:(fun i cell ->
    let id = Union_find.get cell in
    Queue.enqueue logs.(id) (log_line t i));
  Hashtbl.iteri t.refs ~f:(fun ~key:ref_kind ~data:index ->
    let id = Union_find.get components.(index) in
    Queue.enqueue refs.(id) { Refs.Line.rev = Node_kind.rev t.$(index); ref_kind });
  Array.map2_exn logs refs ~f:(fun log refs ->
    { Subtree.log = Queue.to_list log; refs = Queue.to_list refs })
  |> Array.filter ~f:(fun subtree -> not (Subtree.is_empty subtree))
  |> Array.to_list
;;

module Summary = struct
  [@@@coverage off]

  type t =
    { refs : (Rev.t * string) list
    ; roots : Rev.t list
    ; tips : (Rev.t * string list) list
    ; subtrees : t list [@sexp_drop_if List.is_empty]
    }
  [@@deriving sexp_of]
end

let rec summary t =
  let refs =
    List.map (refs t) ~f:(fun { Refs.Line.rev; ref_kind } ->
      rev, Ref_kind.to_string ref_kind)
  in
  let tips =
    List.map (tips t) ~f:(fun node ->
      rev t node, node_refs t node |> List.map ~f:Ref_kind.to_string)
  in
  let subtrees =
    match subtrees t with
    | [] | [ _ ] -> []
    | subtrees -> List.map subtrees ~f:(fun subtree -> summary (of_subtree subtree))
  in
  { Summary.refs; roots = roots t |> List.map ~f:(fun id -> rev t id); tips; subtrees }
;;

let check_index_exn t ~index =
  let node_count = node_count t in
  if index < 0 || index >= node_count
  then raise_s [%sexp "Node index out of bounds", { index : int; node_count : int }]
;;

let get_node_exn t ~index =
  check_index_exn t ~index;
  (index :> Node.t)
;;

let node_index _ (node : Node.t) = (node :> int)

1	(*******************************************************************************)
2	(* Vcs - a Versatile OCaml Library for Git Interaction *)
3	(* Copyright (C) 2024 Mathieu Barbin <mathieu.barbin@gmail.com> *)
4	(* *)
5	(* This file is part of Vcs. *)
6	(* *)
7	(* Vcs is free software; you can redistribute it and/or modify it under *)
8	(* the terms of the GNU Lesser General Public License as published by the *)
9	(* Free Software Foundation either version 3 of the License, or any later *)
10	(* version, with the LGPL-3.0 Linking Exception. *)
11	(* *)
12	(* Vcs is distributed in the hope that it will be useful, but WITHOUT ANY *)
13	(* WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS *)
14	(* FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License and *)
15	(* the file `NOTICE.md` at the root of this repository for more details. *)
16	(* *)
17	(* You should have received a copy of the GNU Lesser General Public License *)
18	(* and the LGPL-3.0 Linking Exception along with this library. If not, see *)
19	(* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively. *)
20	(*******************************************************************************)
21
22	module Node = struct
23	module T0 = struct
UNCOV 24	type t = int [@@deriving compare, hash]	×
25
26	let sexp_of_t i = Sexp.Atom ("#" ^ Int.to_string_hum i)	37✔
27	end
28
29	include T0
30	include Comparable.Make (T0)
31	end
32
33	module Node_kind = struct
34	module T = struct
35	[@@@coverage off]
36
37	type t =
38	\| Root of { rev : Rev.t }
39	\| Commit of
40	{ rev : Rev.t
41	; parent : Node.t
42	}
43	\| Merge of
44	{ rev : Rev.t
45	; parent1 : Node.t
46	; parent2 : Node.t
47	}
48	[@@deriving equal, sexp_of]
49	end
50
51	include T
52
53	let rev = function
54	\| Root { rev } -> rev	16✔
55	\| Commit { rev; _ } -> rev	656✔
56	\| Merge { rev; _ } -> rev	6✔
57	;;
58
59	let to_log_line t ~f =
60	match t with	566✔
61	\| Root { rev } -> Log.Line.Root { rev }	14✔
62	\| Commit { rev; parent } -> Log.Line.Commit { rev; parent = f parent }	543✔
63	\| Merge { rev; parent1; parent2 } ->	9✔
64	Log.Line.Merge { rev; parent1 = f parent1; parent2 = f parent2 }	9✔
65	;;
66	end
67
68	module T = struct
69	[@@@coverage off]
70
71	module Nodes = struct
72	type t = Node_kind.t array
73
74	let sexp_of_t t =
75	Array.mapi t ~f:(fun i node -> i, node)
76	\|> Array.rev
77	\|> [%sexp_of: (Node.t * Node_kind.t) array]
78	;;
79	end
80
81	module Revs = struct
82	type t = int Hashtbl.M(Rev).t
83
84	let sexp_of_t (t : t) =
85	let revs = Hashtbl.to_alist t \|> Array.of_list in
86	Array.sort revs ~compare:(fun (_, n1) (_, n2) -> Int.compare n2 n1);
87	revs
88	\|> Array.map ~f:(fun (rev, index) -> index, rev)
89	\|> [%sexp_of: (Node.t * Rev.t) array]
90	;;
91	end
92
93	module Reverse_refs = struct
94	type t = Ref_kind.t list Hashtbl.M(Int).t
95
96	let sexp_of_t (t : t) =
97	let revs = Hashtbl.to_alist t \|> Array.of_list in
98	Array.sort revs ~compare:(fun (n1, _) (n2, _) -> Int.compare n2 n1);
99	revs \|> [%sexp_of: (Node.t * Ref_kind.t list) array]
100	;;
101	end
102
103	type t =
104	{ mutable nodes : Nodes.t
105	; revs : int Hashtbl.M(Rev).t
106	; refs : int Hashtbl.M(Ref_kind).t
107	; reverse_refs : Ref_kind.t list Hashtbl.M(Int).t
108	}
109
110	let sexp_of_t { nodes; revs; refs = _; reverse_refs } =
111	[%sexp { nodes : Nodes.t; revs : Revs.t; refs = (reverse_refs : Reverse_refs.t) }]
112	;;
113	end
114
115	include T
116
117	let create () =
118	{ nodes = [\|\|]	14✔
119	; revs = Hashtbl.create (module Rev)	14✔
120	; refs = Hashtbl.create (module Ref_kind)	14✔
121	; reverse_refs = Hashtbl.create (module Int)	14✔
122	}
123	;;
124
125	let node_count t = Array.length t.nodes	12✔
126	let node_kind t node = t.nodes.(node)	1,695✔
127	let ( .$() ) = node_kind
128	let rev t node = Node_kind.rev t.$(node)	54✔
129
130	let parents t node =
131	match t.$(node) with	15✔
132	\| Node_kind.Root _ -> []	1✔
133	\| Commit { parent; _ } -> [ parent ]	13✔
134	\| Merge { parent1; parent2; _ } -> [ parent1; parent2 ]	1✔
135	;;
136
137	let prepend_parents t node list =
138	match t.$(node) with	432✔
139	\| Node_kind.Root _ -> list	34✔
140	\| Commit { parent; _ } -> parent :: list	383✔
141	\| Merge { parent1; parent2; _ } -> parent1 :: parent2 :: list	15✔
142	;;
143
144	let node_refs t node =
145	Hashtbl.find t.reverse_refs node	26✔
146	\|> Option.value ~default:[]	26✔
147	\|> List.sort ~compare:Ref_kind.compare	26✔
148	;;
149
150	let log_line t node = Node_kind.to_log_line t.$(node) ~f:(fun i -> Node_kind.rev t.$(i))	561✔
151
152	(* Helper function to iter over all ancestors of a given node, itself included.
153	[visited] is taken as an input so we can re-use the same array multiple
154	times, rather than re-allocating it. *)
155	let iter_ancestors t ~visited node ~f =
156	Bit_vector.reset visited false;	27✔
157	let rec loop to_visit =	27✔
158	match to_visit with	113✔
159	\| [] -> ()	27✔
160	\| node :: to_visit ->	86✔
161	let to_visit =
162	if Bit_vector.get visited node
163	then to_visit	6✔
164	else (	80✔
165	Bit_vector.set visited node true;
166	f node;	80✔
167	prepend_parents t node to_visit)	80✔
168	in
169	loop to_visit
170	in
171	loop [ node ]
172	;;
173
174	let greatest_common_ancestors t nodes =
175	match nodes with	15✔
176	\| [] -> []	2✔
177	\| [ node ] -> [ node ]	4✔
178	\| node1 :: nodes ->	9✔
179	let node_count = Array.length t.nodes in
180	let visited = Bit_vector.create ~len:node_count false in	9✔
181	let common_ancestors =	9✔
182	iter_ancestors t ~visited node1 ~f:(fun _ -> ());	28✔
183	Bit_vector.copy visited	9✔
184	in
185	List.iter nodes ~f:(fun node ->
186	iter_ancestors t ~visited node ~f:(fun _ -> ());	10✔
187	Bit_vector.bw_and_in_place ~mutates:common_ancestors visited);	10✔
188	for i = node_count - 1 downto 0 do	9✔
189	if Bit_vector.get common_ancestors i	76✔
190	then
191	iter_ancestors t ~visited i ~f:(fun j ->	8✔
192	if j <> i then Bit_vector.set common_ancestors j false)	7✔
193	done;
194	Bit_vector.filter_mapi common_ancestors ~f:(fun i b -> if b then Some i else None)	8✔
195	\|> Array.to_list	9✔
196	;;
197
198	let refs t =
199	Hashtbl.to_alist t.refs	7✔
200	\|> List.sort ~compare:(fun (r1, _) (r2, _) -> Ref_kind.compare r1 r2)	7✔
201	\|> List.map ~f:(fun (ref_kind, index) ->	7✔
202	{ Refs.Line.rev = Node_kind.rev t.$(index); ref_kind })	38✔
203	;;
204
205	let set_ref t ~rev ~ref_kind =
206	match Hashtbl.find t.revs rev with	45✔
207	\| None -> raise_s [%sexp "Rev not found", (rev : Rev.t)]	1✔
208	\| Some index ->	44✔
209	Hashtbl.set t.refs ~key:ref_kind ~data:index;
210	Hashtbl.add_multi t.reverse_refs ~key:index ~data:ref_kind	44✔
211	;;
212
213	let set_refs t ~refs =
214	List.iter refs ~f:(fun { Refs.Line.rev; ref_kind } -> set_ref t ~rev ~ref_kind)	9✔
215	;;
216
217	let find_ref t ~ref_kind = Hashtbl.find t.refs ref_kind	21✔
218	let mem_rev t ~rev = Hashtbl.mem t.revs rev	427✔
219	let find_rev t ~rev = Hashtbl.find t.revs rev	68✔
220
221	let add_nodes t ~log =
222	let nodes_table =	47✔
223	let table = Hashtbl.create (module Rev) in
224	List.iter log ~f:(fun line ->	47✔
225	Hashtbl.add_exn table ~key:(Log.Line.rev line) ~data:line);	427✔
226	table	47✔
227	in
228	let new_nodes = Queue.create ~capacity:(List.length log) () in	47✔
229	let visited = Hash_set.create (module Rev) in	47✔
230	let is_visited rev =	47✔
231	if Hash_set.mem visited rev	803✔
232	then true	376✔
233	else if mem_rev t ~rev	427✔
234	then (	6✔
235	Hash_set.add visited rev;
236	true)	6✔
237	else false	421✔
238	in
239	let rec visit (line : Log.Line.t) =
240	match (line : Log.Line.t) with	803✔
241	\| Root { rev } ->	30✔
242	if not (is_visited rev)	30✔
243	then (	16✔
244	Hash_set.add visited rev;
245	Queue.enqueue new_nodes line)	16✔
246	\| Commit { rev; parent } ->	760✔
247	if not (is_visited rev)	760✔
248	then (	396✔
249	Hash_set.add visited rev;
250	if not (Hashtbl.mem t.revs parent)	396✔
251	then visit (Hashtbl.find_exn nodes_table parent);	368✔
252	Queue.enqueue new_nodes line)	396✔
253	\| Merge { rev; parent1; parent2 } ->	13✔
254	if not (is_visited rev)	13✔
255	then (	9✔
256	Hash_set.add visited rev;
257	if not (Hashtbl.mem t.revs parent1)	9✔
258	then visit (Hashtbl.find_exn nodes_table parent1);	4✔
259	if not (Hashtbl.mem t.revs parent2)	9✔
260	then visit (Hashtbl.find_exn nodes_table parent2);	4✔
261	Queue.enqueue new_nodes line)	9✔
262	in
263	(* We iter in reverse order to makes the depth of visited path shorter. *)
264	List.iter (List.rev log) ~f:visit;	47✔
265	let new_index = Array.length t.nodes in	47✔
266	let new_nodes =	47✔
267	let find_node_exn rev = Hashtbl.find_exn t.revs rev in	414✔
268	Queue.to_array new_nodes
269	\|> Array.mapi ~f:(fun i node ->	47✔
270	let index = new_index + i in	421✔
271	let rev = Log.Line.rev node in
272	Hashtbl.add_exn t.revs ~key:rev ~data:index;	421✔
273	match node with	421✔
274	\| Root _ -> Node_kind.Root { rev }	16✔
275	\| Commit { rev; parent; _ } ->	396✔
276	Node_kind.Commit { rev; parent = find_node_exn parent }	396✔
277	\| Merge { rev; parent1; parent2; _ } ->	9✔
278	Node_kind.Merge
279	{ rev; parent1 = find_node_exn parent1; parent2 = find_node_exn parent2 })	9✔
280	in
281	t.nodes <- Array.append t.nodes new_nodes;	47✔
282	()
283	;;
284
285	let roots t =
286	Array.filter_mapi t.nodes ~f:(fun i node ->	5✔
287	match node with	363✔
288	\| Root _ -> Some i	5✔
289	\| Commit _ \| Merge _ -> None)	4✔
290	\|> Array.to_list	5✔
291	;;
292
293	(* Pre condition: ancestor < descendant. *)
294	let is_strict_ancestor_internal t ~ancestor ~descendant =
295	assert (ancestor < descendant);	8✔
296	let visited = Bit_vector.create ~len:(descendant - ancestor + 1) false in
297	let rec loop to_visit =	8✔
298	match to_visit with	348✔
299	\| [] -> false	2✔
300	\| node :: to_visit ->	346✔
301	(match Int.compare ancestor node \|> Ordering.of_int with	346✔
302	\| Equal -> true	6✔
303	\| Greater -> loop to_visit	1✔
304	\| Less ->	339✔
305	let to_visit =
306	let visited_index = node - ancestor in
307	if Bit_vector.get visited visited_index
308	then to_visit	1✔
309	else (	338✔
310	Bit_vector.set visited visited_index true;
311	prepend_parents t node to_visit)	338✔
312	in
313	loop to_visit)
314	in
315	loop [ descendant ]
316	;;
317
318	let is_strict_ancestor t ~ancestor ~descendant =
319	ancestor < descendant && is_strict_ancestor_internal t ~ancestor ~descendant	5✔
320	;;
321
322	let is_ancestor_or_equal t ~ancestor ~descendant =
323	ancestor = descendant \|\| is_strict_ancestor t ~ancestor ~descendant	1✔
324	;;
325
326	module Descendance = struct
327	[@@@coverage off]
328
329	type t =
330	\| Same_node
331	\| Strict_ancestor
332	\| Strict_descendant
333	\| Other
334	[@@deriving equal, enumerate, hash, sexp_of]
335	end
336
337	let descendance t a b : Descendance.t =
338	match Int.compare a b \|> Ordering.of_int with	4✔
339	\| Equal -> Same_node	1✔
340	\| Less ->	2✔
341	if is_strict_ancestor_internal t ~ancestor:a ~descendant:b
342	then Strict_ancestor	1✔
343	else Other	1✔
344	\| Greater ->	1✔
345	if is_strict_ancestor_internal t ~ancestor:b ~descendant:a
346	then Strict_descendant	1✔
NEW 347	else Other	×
348	;;
349
350	let tips t =
351	let has_children = Bit_vector.create ~len:(node_count t) false in	5✔
352	Array.iter t.nodes ~f:(fun node ->	5✔
353	match node with	363✔
354	\| Root _ -> ()	5✔
355	\| Commit { parent; _ } -> Bit_vector.set has_children parent true	354✔
356	\| Merge { parent1; parent2; _ } ->	4✔
357	Bit_vector.set has_children parent1 true;
358	Bit_vector.set has_children parent2 true);	4✔
359	Array.filter_mapi t.nodes ~f:(fun i _ ->	5✔
360	if Bit_vector.get has_children i then None else Some i)	11✔
361	\|> Array.to_list	5✔
362	;;
363
364	let log t = Array.mapi t.nodes ~f:(fun node _ -> log_line t node) \|> Array.to_list	4✔
365
366	module Subtree = struct
367	module T = struct
368	[@@@coverage off]
369
370	type t =
371	{ log : Log.t
372	; refs : Refs.t
373	}
374	[@@deriving sexp_of]
375	end
376
377	include T
378
379	let is_empty { log; refs } = List.is_empty log && List.is_empty refs	1✔
380	end
381
382	let of_subtree { Subtree.log; refs } =
383	let t = create () in	2✔
384	add_nodes t ~log;	2✔
385	set_refs t ~refs;	2✔
386	t	2✔
387	;;
388
389	let subtrees t =
390	let dummy_cell = Union_find.create (-1) in	5✔
391	let components = Array.map t.nodes ~f:(fun _ -> dummy_cell) in	5✔
392	let component_id = ref 0 in	5✔
393	Array.iteri t.nodes ~f:(fun i node ->
394	match node with	363✔
395	\| Root { rev = _ } ->	5✔
396	let id = !component_id in
397	Int.incr component_id;
398	components.(i) <- Union_find.create id	5✔
399	\| Commit { rev = _; parent } -> components.(i) <- components.(parent)	354✔
400	\| Merge { rev = _; parent1; parent2 } ->	4✔
401	let component1 = components.(parent1) in
402	Union_find.union component1 components.(parent2);	4✔
403	components.(i) <- component1);	4✔
404	let num_id = !component_id in	5✔
405	let logs = Array.init num_id ~f:(fun _ -> Queue.create ()) in	5✔
406	let refs = Array.init num_id ~f:(fun _ -> Queue.create ()) in	5✔
407	Array.iteri components ~f:(fun i cell ->	5✔
408	let id = Union_find.get cell in	363✔
409	Queue.enqueue logs.(id) (log_line t i));	363✔
410	Hashtbl.iteri t.refs ~f:(fun ~key:ref_kind ~data:index ->	5✔
411	let id = Union_find.get components.(index) in	25✔
412	Queue.enqueue refs.(id) { Refs.Line.rev = Node_kind.rev t.$(index); ref_kind });	25✔
413	Array.map2_exn logs refs ~f:(fun log refs ->	5✔
414	{ Subtree.log = Queue.to_list log; refs = Queue.to_list refs })	5✔
415	\|> Array.filter ~f:(fun subtree -> not (Subtree.is_empty subtree))	5✔
416	\|> Array.to_list	5✔
417	;;
418
419	module Summary = struct
420	[@@@coverage off]
421
422	type t =
423	{ refs : (Rev.t * string) list
424	; roots : Rev.t list
425	; tips : (Rev.t * string list) list
426	; subtrees : t list [@sexp_drop_if List.is_empty]
427	}
428	[@@deriving sexp_of]
429	end
430
431	let rec summary t =
432	let refs =	5✔
433	List.map (refs t) ~f:(fun { Refs.Line.rev; ref_kind } ->	5✔
434	rev, Ref_kind.to_string ref_kind)	25✔
435	in
436	let tips =	5✔
437	List.map (tips t) ~f:(fun node ->	5✔
438	rev t node, node_refs t node \|> List.map ~f:Ref_kind.to_string)	11✔
439	in
440	let subtrees =	5✔
441	match subtrees t with
442	\| [] \| [ _ ] -> []	1✔
443	\| subtrees -> List.map subtrees ~f:(fun subtree -> summary (of_subtree subtree))	1✔
444	in
445	{ Summary.refs; roots = roots t \|> List.map ~f:(fun id -> rev t id); tips; subtrees }	5✔
446	;;
447
448	let check_index_exn t ~index =
449	let node_count = node_count t in	4✔
450	if index < 0 \|\| index >= node_count	1✔
451	then raise_s [%sexp "Node index out of bounds", { index : int; node_count : int }]	2✔
452	;;
453
454	let get_node_exn t ~index =
455	check_index_exn t ~index;	4✔
456	(index :> Node.t)	2✔
457	;;
458
459	let node_index _ (node : Node.t) = (node :> int)	2✔

mbarbin / vcs / 87

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous