(** Fuzz tests for Git tree operations.

    Uses a model-based approach: a [Map.Make(String)] acts as the reference
    implementation. A random sequence of [Add] and [Remove] operations is
    applied to both the real [Git.Tree.t] and the model; invariants are checked
    after every step. *)

open Alcobar

(* A small name pool maximises repeated-name collisions, exercising the
   deduplication path that was missing before the [add] fix. *)
let small_names = [| "a"; "b"; "c"; "d"; "e"; "ab"; "foo"; "bar" |]

let sanitize_name s =
  if String.length s = 0 then "x"
  else
    let s = String.sub s 0 (min 32 (String.length s)) in
    String.map (fun c -> if Char.code c = 0 then 'x' else c) s

let gen_name =
  choose
    [
      map [ uint8 ] (fun i -> small_names.(i mod Array.length small_names));
      map [ bytes ] (fun s -> sanitize_name s);
    ]

let gen_hash =
  map [ bytes ] (fun s ->
      let len = String.length s in
      let raw =
        if len >= 20 then String.sub s 0 20
        else s ^ String.make (20 - len) '\x00'
      in
      Git.Hash.of_raw_string raw)

type op = Add of string * Git.Hash.t | Remove of string

let gen_op =
  choose
    [
      map [ gen_name; gen_hash ] (fun name hash -> Add (name, hash));
      map [ gen_name ] (fun name -> Remove name);
    ]

(* Reference model *)
module Ref = Map.Make (String)

let apply_op_ref ref = function
  | Add (name, hash) -> Ref.add name hash ref
  | Remove name -> Ref.remove name ref

let apply_op_tree tree = function
  | Add (name, hash) ->
      Git.Tree.add (Git.Tree.entry ~perm:`Normal ~name hash) tree
  | Remove name -> Git.Tree.remove ~name tree

let check_invariants tree ref_map =
  let entries = Git.Tree.to_list tree in
  let names = List.map (fun (e : Git.Tree.entry) -> e.name) entries in
  (* No duplicate names *)
  let unique = List.sort_uniq String.compare names in
  if List.length names <> List.length unique then
    fail "duplicate names in to_list";
  (* Names are sorted *)
  if names <> List.sort String.compare names then fail "entries not sorted";
  (* Size matches model *)
  if List.length entries <> Ref.cardinal ref_map then
    fail
      (Fmt.str "size mismatch: tree=%d model=%d" (List.length entries)
         (Ref.cardinal ref_map));
  (* Every tree entry agrees with model *)
  List.iter
    (fun (e : Git.Tree.entry) ->
      match Ref.find_opt e.name ref_map with
      | None -> fail (Fmt.str "entry %S in tree but absent from model" e.name)
      | Some h ->
          if not (Git.Hash.equal e.hash h) then
            fail (Fmt.str "hash mismatch for entry %S" e.name))
    entries

(** Apply ops to tree and model simultaneously, checking invariants at each
    step. *)
let test_ops_agree ops =
  ignore
    (List.fold_left
       (fun (tree, ref_map) op ->
         let tree = apply_op_tree tree op in
         let ref_map = apply_op_ref ref_map op in
         check_invariants tree ref_map;
         (tree, ref_map))
       (Git.Tree.empty, Ref.empty)
       ops)

(** After any sequence of ops, the tree must round-trip through the git binary
    format with the same entry count. *)
let test_roundtrip_after_ops ops =
  let tree = List.fold_left apply_op_tree Git.Tree.empty ops in
  let s = Git.Tree.to_string tree in
  match Git.Tree.of_string s with
  | Error (`Msg m) -> fail (Fmt.str "roundtrip parse failed: %s" m)
  | Ok tree' ->
      let n = List.length (Git.Tree.to_list tree) in
      let n' = List.length (Git.Tree.to_list tree') in
      if n <> n' then
        fail (Fmt.str "roundtrip entry count: before=%d after=%d" n n')

let suite =
  ( "tree",
    [
      test_case "ops agree with model" [ list gen_op ] test_ops_agree;
      test_case "roundtrip after ops" [ list gen_op ] test_roundtrip_after_ops;
    ] )