Source file check.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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
(*---------------------------------------------------------------------------
   Copyright (c) 2026 Invariant Systems. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

(* ───── Types ───── *)

type pos = Failure.pos
type here = Failure.here

(* ───── Internal Helpers ───── *)

let fail_with_values ?here ?pos ?msg ?diff ~expected ~actual default_msg =
  Failure.raise_failure ?here ?pos ~expected ~actual ?diff
    (Option.value ~default:default_msg msg)

let fail_simple ?here ?pos ?msg default_msg =
  Failure.raise_failure ?here ?pos (Option.value ~default:default_msg msg)

(* Shared logic for [some], [ok], and [error]: compare inner values using the
   testable's [check] when available, wrapping result strings with a constructor
   prefix (e.g., "Some ", "Ok ", "Error "). *)
let check_inner ?here ?pos ?msg ~prefix ~fail_msg testable expected actual =
  match Testable.check testable with
  | Some check_fn -> (
      match check_fn expected actual with
      | Testable.Pass -> ()
      | Testable.Fail { expected_str; actual_str; diff } ->
          fail_with_values ?here ?pos ?msg ?diff
            ~expected:(Pp.str "%s%s" prefix expected_str)
            ~actual:(Pp.str "%s%s" prefix actual_str)
            fail_msg)
  | None ->
      if not (Testable.equal testable expected actual) then
        fail_with_values ?here ?pos ?msg
          ~expected:
            (Pp.str "%s%s" prefix
               (Pp.to_string (Testable.pp testable) expected))
          ~actual:
            (Pp.str "%s%s" prefix (Pp.to_string (Testable.pp testable) actual))
          fail_msg

(* ───── Equality Assertions ───── *)

(* Uses the testable's [check] function when available for structured diff
   output (e.g., highlighted character-level diffs for strings). Falls back to
   [equal] + [pp] for testables without a custom checker. *)
let equal ?here ?pos ?msg testable expected actual =
  match Testable.check testable with
  | Some check_fn -> (
      match check_fn expected actual with
      | Testable.Pass -> ()
      | Testable.Fail { expected_str; actual_str; diff } ->
          fail_with_values ?here ?pos ?msg ?diff ~expected:expected_str
            ~actual:actual_str "Values are not equal")
  | None ->
      if not (Testable.equal testable expected actual) then
        fail_with_values ?here ?pos ?msg
          ~expected:(Pp.to_string (Testable.pp testable) expected)
          ~actual:(Pp.to_string (Testable.pp testable) actual)
          "Values are not equal"

let not_equal ?here ?pos ?msg testable expected actual =
  if Testable.equal testable expected actual then
    let value_str = Pp.to_string (Testable.pp testable) expected in
    fail_simple ?here ?pos ?msg
      (Pp.str "Expected values to be different, but both are: %s" value_str)

(* ───── Boolean Assertions ───── *)

let is_true ?here ?pos ?msg = function
  | true -> ()
  | false ->
      fail_with_values ?here ?pos ?msg ~expected:"true" ~actual:"false"
        "Boolean mismatch"

let is_false ?here ?pos ?msg = function
  | false -> ()
  | true ->
      fail_with_values ?here ?pos ?msg ~expected:"false" ~actual:"true"
        "Boolean mismatch"

(* ───── Option Assertions ───── *)

let is_some ?here ?pos ?msg = function
  | Some _ -> ()
  | None ->
      fail_with_values ?here ?pos ?msg ~expected:"Some _" ~actual:"None"
        "Option mismatch"

let is_none ?here ?pos ?msg = function
  | None -> ()
  | Some _ ->
      fail_with_values ?here ?pos ?msg ~expected:"None" ~actual:"Some _"
        "Option mismatch"

let some ?here ?pos ?msg testable expected = function
  | None ->
      fail_with_values ?here ?pos ?msg
        ~expected:
          (Pp.str "Some %s" (Pp.to_string (Testable.pp testable) expected))
        ~actual:"None" "Option mismatch"
  | Some actual ->
      check_inner ?here ?pos ?msg ~prefix:"Some "
        ~fail_msg:"Option values are not equal" testable expected actual

(* ───── Result Assertions ───── *)

let is_ok ?here ?pos ?msg = function
  | Ok _ -> ()
  | Error _ ->
      fail_with_values ?here ?pos ?msg ~expected:"Ok _" ~actual:"Error _"
        "Result mismatch"

let is_error ?here ?pos ?msg = function
  | Error _ -> ()
  | Ok _ ->
      fail_with_values ?here ?pos ?msg ~expected:"Error _" ~actual:"Ok _"
        "Result mismatch"

let ok ?here ?pos ?msg testable expected = function
  | Error _ ->
      fail_with_values ?here ?pos ?msg
        ~expected:
          (Pp.str "Ok %s" (Pp.to_string (Testable.pp testable) expected))
        ~actual:"Error _" "Result mismatch"
  | Ok actual ->
      check_inner ?here ?pos ?msg ~prefix:"Ok "
        ~fail_msg:"Result values are not equal" testable expected actual

let error ?here ?pos ?msg testable expected = function
  | Ok _ ->
      fail_with_values ?here ?pos ?msg
        ~expected:
          (Pp.str "Error %s" (Pp.to_string (Testable.pp testable) expected))
        ~actual:"Ok _" "Result mismatch"
  | Error actual ->
      check_inner ?here ?pos ?msg ~prefix:"Error "
        ~fail_msg:"Error values are not equal" testable expected actual

(* ───── Exception Assertions ───── *)

(* All exception assertions must re-raise [Check_failure] to avoid swallowing
   assertion failures from within the tested function itself. Without this,
   a test using [raises] that internally calls [equal] would silently catch
   the [Check_failure] and report "wrong exception" instead of the real error. *)

let raises ?here ?pos ?msg expected_exn fn =
  try
    let _ = fn () in
    fail_with_values ?here ?pos ?msg
      ~expected:(Pp.str "exception %s" (Printexc.to_string expected_exn))
      ~actual:"no exception" "Exception mismatch"
  with
  | Failure.Check_failure _ as e -> raise e
  | exn when exn = expected_exn -> ()
  | exn ->
      fail_with_values ?here ?pos ?msg
        ~expected:(Printexc.to_string expected_exn)
        ~actual:(Printexc.to_string exn) "Wrong exception raised"

let raises_match ?here ?pos ?msg pred fn =
  try
    let _ = fn () in
    fail_with_values ?here ?pos ?msg ~expected:"an exception"
      ~actual:"no exception" "Exception mismatch"
  with
  | Failure.Check_failure _ as e -> raise e
  | exn when pred exn -> ()
  | exn ->
      fail_with_values ?here ?pos ?msg ~expected:"exception matching predicate"
        ~actual:(Pp.str "exception %s" (Printexc.to_string exn))
        "Exception did not match predicate"

let no_raise ?here ?pos ?msg fn =
  try fn () with
  | Failure.Check_failure _ as e -> raise e
  | exn ->
      fail_with_values ?here ?pos ?msg ~expected:"no exception"
        ~actual:(Pp.str "exception %s" (Printexc.to_string exn))
        "Unexpected exception"

let raises_invalid_arg ?here ?pos ?msg expected_msg fn =
  try
    let _ = fn () in
    fail_with_values ?here ?pos ?msg
      ~expected:(Pp.str "Invalid_argument %S" expected_msg)
      ~actual:"no exception" "Exception mismatch"
  with
  | Failure.Check_failure _ as e -> raise e
  | Invalid_argument actual_msg when String.equal actual_msg expected_msg -> ()
  | Invalid_argument actual_msg ->
      fail_with_values ?here ?pos ?msg
        ~expected:(Pp.str "Invalid_argument %S" expected_msg)
        ~actual:(Pp.str "Invalid_argument %S" actual_msg)
        "Wrong exception message"
  | exn ->
      fail_with_values ?here ?pos ?msg
        ~expected:(Pp.str "Invalid_argument %S" expected_msg)
        ~actual:(Printexc.to_string exn) "Wrong exception raised"

let raises_failure ?here ?pos ?msg expected_msg fn =
  try
    let _ = fn () in
    fail_with_values ?here ?pos ?msg
      ~expected:(Pp.str "Failure %S" expected_msg)
      ~actual:"no exception" "Exception mismatch"
  with
  | Failure.Check_failure _ as e -> raise e
  | Stdlib.Failure actual_msg when String.equal actual_msg expected_msg -> ()
  | Stdlib.Failure actual_msg ->
      fail_with_values ?here ?pos ?msg
        ~expected:(Pp.str "Failure %S" expected_msg)
        ~actual:(Pp.str "Failure %S" actual_msg)
        "Wrong exception message"
  | exn ->
      fail_with_values ?here ?pos ?msg
        ~expected:(Pp.str "Failure %S" expected_msg)
        ~actual:(Printexc.to_string exn) "Wrong exception raised"

(* ───── Custom Failures ───── *)

let fail ?here ?pos msg = Failure.raise_failure ?here ?pos msg
let failf ?here ?pos fmt = Format.kasprintf (fail ?here ?pos) fmt