package windtrap

  1. Overview
  2. Docs

Source file test.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
(*---------------------------------------------------------------------------
   Copyright (c) 2026 Invariant Systems. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

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

type pos = string * int * int * int

type t =
  | Test of {
      name : string;
      fn : unit -> unit;
      pos : pos option;
      tags : Tag.t;
      timeout : float option;
      retries : int;
      focused : bool;
    }
  | Group of {
      name : string;
      children : t list;
      pos : pos option;
      tags : Tag.t;
      setup : (unit -> unit) option;
      teardown : (unit -> unit) option;
      before_each : (unit -> unit) option;
      after_each : (unit -> unit) option;
      focused : bool;
    }

(* ───── Test Creation ───── *)

(* Wraps [fn] to discard its return value, so users can write tests returning
   any type without needing to add [ignore] themselves. *)
let test ?pos ?(tags = Tag.empty) ?timeout ?(retries = 0) name fn =
  Test
    {
      name;
      fn = (fun () -> ignore (fn ()));
      pos;
      tags;
      timeout;
      retries;
      focused = false;
    }

let ftest ?pos ?tags ?timeout ?retries name fn =
  match test ?pos ?tags ?timeout ?retries name fn with
  | Test t -> Test { t with focused = true }
  | Group _ -> assert false

let group ?pos ?(tags = Tag.empty) ?setup ?teardown ?before_each ?after_each
    name children =
  Group
    {
      name;
      children;
      pos;
      tags;
      setup;
      teardown;
      before_each;
      after_each;
      focused = false;
    }

let fgroup ?pos ?tags ?setup ?teardown ?before_each ?after_each name children =
  match
    group ?pos ?tags ?setup ?teardown ?before_each ?after_each name children
  with
  | Group g -> Group { g with focused = true }
  | Test _ -> assert false

let slow ?pos ?(tags = Tag.empty) ?timeout ?retries name fn =
  test ?pos ~tags:(Tag.merge tags (Tag.speed Slow)) ?timeout ?retries name fn

let bracket ?pos ?(tags = Tag.empty) ?timeout ?(retries = 0) ~setup ~teardown
    name fn =
  let wrapped () =
    let resource = setup () in
    Fun.protect ~finally:(fun () -> teardown resource) (fun () -> fn resource)
  in
  Test
    {
      name;
      fn = (fun () -> ignore (wrapped ()));
      pos;
      tags;
      timeout;
      retries;
      focused = false;
    }

let rec has_focused_one = function
  | Test { focused; _ } -> focused
  | Group { focused; children; _ } ->
      focused || List.exists has_focused_one children

let has_focused tests = List.exists has_focused_one tests

(* ───── Test Traversal ───── *)

(* Visitor events for depth-first traversal. This decouples the runner from the
   tree representation: consumers see a flat stream of enter/leave/case events
   without needing to pattern-match on [t] directly. *)
type visit =
  | Case of {
      name : string;
      fn : unit -> unit;
      pos : pos option;
      tags : Tag.t;
      timeout : float option;
      retries : int;
      focused : bool;
    }
  | Enter_group of {
      name : string;
      pos : pos option;
      tags : Tag.t;
      setup : (unit -> unit) option;
      before_each : (unit -> unit) option;
      after_each : (unit -> unit) option;
      focused : bool;
    }
  | Leave_group of { name : string; teardown : (unit -> unit) option }

let rec fold f acc t =
  match t with
  | Test { name; fn; pos; tags; timeout; retries; focused } ->
      f acc (Case { name; fn; pos; tags; timeout; retries; focused })
  | Group
      {
        name;
        children;
        pos;
        tags;
        setup;
        teardown;
        before_each;
        after_each;
        focused;
      } ->
      let acc =
        f acc
          (Enter_group
             { name; pos; tags; setup; before_each; after_each; focused })
      in
      let acc = List.fold_left (fold f) acc children in
      f acc (Leave_group { name; teardown })

let iter f t = fold (fun () v -> f v) () t