Source file Speed_assertions.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
module AssertionResult = struct
  type ('a, 'b) t = ('a, 'b) result

  let bind ~f x = Result.bind x f
  let map = Result.map
end

type print = Format.formatter -> unit

exception AssertionError
exception FormattedAssertionError of (Format.formatter -> unit)

let match_success x = Ok x

let match_failure ?(pp : print option) x =
  match pp with
  | None -> Error (`AssertionError x)
  | Some x -> Error (`AssertionErrorWithFormat x)
;;

let equality_failure expected actual pp =
  match_failure
    ~pp:
      (Format.dprintf "Expected: @{<green>%a@}@,Actual: @{<red>%a@}" pp expected
         pp actual
      )
    ()
;;

let be_true = function
  | true -> match_success true
  | false -> match_failure ()
;;

let be_ok = function
  | Ok x -> match_success x
  | Error _ -> match_failure ()
;;

let be_error = function
  | Error x -> match_success x
  | Ok _ -> match_failure ()
;;

let be_false = function
  | false -> match_success false
  | true -> match_failure ()
;;

let equal_int expected actual =
  match Int.equal actual expected with
  | true -> Ok actual
  | false -> equality_failure expected actual Format.pp_print_int
;;

let equal_string expected actual =
  match String.equal expected actual with
  | true -> match_success actual
  | false -> equality_failure expected actual Format.pp_print_string
;;

let contain substring actual =
  match Base.String.is_substring ~substring actual with
  | true -> match_success actual
  | false ->
    equality_failure
      (Format.sprintf "string containing '%s'" substring)
      actual Format.pp_print_string
;;

let run_matcher matcher actual = matcher actual

let expect ?name actual assertion =
  let print_header f =
    Format.fprintf f "@[<v2>@{<bold>@{<orange>Assertion error@}@}";
    match name with
    | Some n -> Format.fprintf f ": %s" n
    | None -> ()
  in
  match assertion actual with
  | Ok _ -> ()
  | Error (`AssertionErrorWithFormat pp) ->
    let errorFormat f =
      print_header f;
      Format.fprintf f "@,%t@]" pp
    in
    raise (FormattedAssertionError errorFormat)
  | Error _ ->
    let errorFormat f =
      print_header f;
      Format.fprintf f "@]"
    in
    raise (FormattedAssertionError errorFormat)
;;

let ( >=> ) m1 m2 actual = actual |> m1 |> Base.Result.bind ~f:m2
let should ?name assertion actual = expect ?name actual assertion