(* ounit compatibility layer for fort tests *)
open OUnit2

type ('a, 'b) either =
  | Left of 'a
  | Right of 'b

let str_of_either f g = function
  | Left a -> f a
  | Right b -> g b
;;

let try_with f =
  try Right (f ()) with
  | exn -> Left exn
;;

let expect_equal_app ?printer ?msg f x g y =
  let fx = try_with (fun () -> f x) in
  let gy = try_with (fun () -> g y) in
  let printer =
    let right x =
      match printer with
      | None -> "<no printer>"
      | Some p -> p x
    in
    str_of_either Printexc.to_string right
  in
  assert_equal ~printer ?msg fx gy
;;

let collected_tests = ref []
let id x = x
let not_found () = raise Not_found
let bool_printer i = Printf.sprintf "%b" i
let int_printer i = Printf.sprintf "%d" i
let str_printer s = "\"" ^ String.escaped s ^ "\""
let ofs_printer (i0, i1) = Printf.sprintf "(%d,%d)" i0 i1
let list_printer f l = "[" ^ String.concat "; " (List.map f l) ^ "]"
let arr_printer f a = "[|" ^ String.concat "; " (List.map f (Array.to_list a)) ^ "|]"

let opt_printer f = function
  | None -> "<None>"
  | Some s -> "Some (" ^ f s ^ ")"
;;

let arr_str_printer = arr_printer str_printer
let arr_ofs_printer = arr_printer ofs_printer
let list_ofs_printer = list_printer ofs_printer
let fail = assert_failure
let expect_eq_bool ?msg f x g y = expect_equal_app ?msg ~printer:string_of_bool f x g y
let expect_eq_str ?msg f x g y = expect_equal_app ?msg ~printer:str_printer f x g y

let expect_eq_str_opt ?msg f x g y =
  expect_equal_app ?msg ~printer:(opt_printer str_printer) f x g y
;;

let expect_eq_ofs ?msg f x g y = expect_equal_app ?msg ~printer:ofs_printer f x g y

let expect_eq_arr_str ?msg f x g y =
  expect_equal_app ?msg ~printer:arr_str_printer f x g y
;;

let expect_eq_arr_ofs ?msg f x g y =
  expect_equal_app ?msg ~printer:arr_ofs_printer f x g y
;;

let expect_eq_list_str ?msg f x g y =
  expect_equal_app ?msg ~printer:(list_printer str_printer) f x g y
;;

let expect_pass name run =
  collected_tests := (name >:: fun _ -> run ()) :: !collected_tests
;;

let run_test_suite suite_name = run_test_tt_main (suite_name >::: !collected_tests)
