jon.recoil.org
this repo has no description
1(** Node.js test for PPX preprocessing support.
2
3 This tests that the PPX preprocessing pipeline works correctly with
4 ppx_deriving. We verify that:
5 1. [@@deriving show] generates working pp and show functions
6 2. [@@deriving eq] generates working equal functions
7 3. Multiple derivers work together
8 4. Basic code still works through the PPX pipeline
9
10 The PPX pipeline in js_top_worker applies old-style Ast_mapper PPXs
11 followed by ppxlib-based PPXs via Ppxlib.Driver.map_structure.
12*)
13
14open Js_top_worker
15open Impl
16
17(* Flusher that writes to process.stdout in Node.js *)
18let console_flusher (s : string) : unit =
19 let open Js_of_ocaml in
20 let process = Js.Unsafe.get Js.Unsafe.global (Js.string "process") in
21 let stdout = Js.Unsafe.get process (Js.string "stdout") in
22 let write = Js.Unsafe.get stdout (Js.string "write") in
23 ignore (Js.Unsafe.call write stdout [| Js.Unsafe.inject (Js.string s) |])
24
25let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
26 fun f () ->
27 let stdout_buff = Buffer.create 1024 in
28 let stderr_buff = Buffer.create 1024 in
29 Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
30 let x = f () in
31 let captured =
32 {
33 Impl.stdout = Buffer.contents stdout_buff;
34 stderr = Buffer.contents stderr_buff;
35 }
36 in
37 Js_of_ocaml.Sys_js.set_channel_flusher stdout console_flusher;
38 (captured, x)
39
40module S : Impl.S = struct
41 type findlib_t = Js_top_worker_web.Findlibish.t
42
43 let capture = capture
44
45 let sync_get f =
46 let f = Fpath.v ("_opam/" ^ f) in
47 try Some (In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all)
48 with _ -> None
49
50 let async_get f =
51 let f = Fpath.v ("_opam/" ^ f) in
52 try
53 let content =
54 In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all
55 in
56 Lwt.return (Ok content)
57 with e -> Lwt.return (Error (`Msg (Printexc.to_string e)))
58
59 let create_file = Js_of_ocaml.Sys_js.create_file
60
61 let import_scripts urls =
62 let open Js_of_ocaml.Js in
63 let import_scripts_fn = Unsafe.get Unsafe.global (string "importScripts") in
64 List.iter
65 (fun url ->
66 let (_ : 'a) =
67 Unsafe.fun_call import_scripts_fn [| Unsafe.inject (string url) |]
68 in
69 ())
70 urls
71
72 let init_function _ () = failwith "Not implemented"
73 let findlib_init = Js_top_worker_web.Findlibish.init async_get
74
75 let get_stdlib_dcs uri =
76 Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get uri
77 |> Result.to_list
78
79 let find_stdlib_dcs v =
80 let pkg = match Js_top_worker_web.Findlibish.find_dcs_url v "stdlib" with
81 | Some _ as r -> r
82 | None -> Js_top_worker_web.Findlibish.find_dcs_url v "ocaml"
83 in
84 match pkg with
85 | Some url ->
86 Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get url
87 |> Result.to_list
88 | None -> []
89
90 let require b v = function
91 | [] -> []
92 | packages -> Js_top_worker_web.Findlibish.require ~import_scripts sync_get b v packages
93
94 let path = "/static/cmis"
95end
96
97module U = Impl.Make (S)
98
99(* Test state *)
100let passed_tests = ref 0
101let total_tests = ref 0
102
103let test name condition message =
104 incr total_tests;
105 let status = if condition then (incr passed_tests; "PASS") else "FAIL" in
106 Printf.printf "[%s] %s: %s\n%!" status name message
107
108let contains s substr =
109 try
110 let _ = Str.search_forward (Str.regexp_string substr) s 0 in
111 true
112 with Not_found -> false
113
114let _ =
115 Printf.printf "=== Node.js PPX Tests ===\n\n%!";
116
117 Logs.set_reporter (Logs_fmt.reporter ());
118 Logs.set_level (Some Logs.Info);
119
120 let ( let* ) m f =
121 let open Lwt in
122 m >>= function
123 | Ok x -> f x
124 | Error e -> return (Error e)
125 in
126
127 let run_toplevel code =
128 let* result = U.exec_toplevel "" ("# " ^ code) in
129 Lwt.return (Ok result.script)
130 in
131
132 let init_config =
133 { stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
134 in
135
136 let test_sequence =
137 (* Initialize *)
138 let* _ = U.init init_config in
139 let* _ = U.setup "" in
140
141 Printf.printf "--- Loading PPX dynamically ---\n%!";
142
143 (* Dynamically load ppx_deriving.show - this should:
144 1. Load the PPX deriver (registers with ppxlib)
145 2. Auto-load ppx_deriving.runtime (via findlibish -ppx_driver predicate) *)
146 let* r = run_toplevel "#require \"ppx_deriving.show\";;" in
147 test "load_ppx_show" (not (contains r "Error"))
148 (if contains r "Error" then r else "ppx_deriving.show loaded");
149
150 (* Also load eq deriver *)
151 let* r = run_toplevel "#require \"ppx_deriving.eq\";;" in
152 test "load_ppx_eq" (not (contains r "Error"))
153 (if contains r "Error" then r else "ppx_deriving.eq loaded");
154
155 Printf.printf "\n--- Section 1: ppx_deriving.show ---\n%!";
156
157 (* Test [@@deriving show] generates pp and show functions *)
158 let* r = run_toplevel "type color = Red | Green | Blue [@@deriving show];;" in
159 test "show_type_defined" (contains r "type color") "type color defined";
160 test "show_pp_generated" (contains r "val pp_color")
161 (if contains r "val pp_color" then "pp_color generated" else r);
162 test "show_fn_generated" (contains r "val show_color")
163 (if contains r "val show_color" then "show_color generated" else r);
164
165 (* Test the generated show function works *)
166 let* r = run_toplevel "show_color Red;;" in
167 test "show_fn_works" (contains r "Red")
168 (String.sub r 0 (min 60 (String.length r)));
169
170 (* Test with a record type *)
171 let* r = run_toplevel "type point = { x: int; y: int } [@@deriving show];;" in
172 test "show_record_type" (contains r "type point") "point type defined";
173 test "show_record_pp" (contains r "val pp_point")
174 (if contains r "val pp_point" then "pp_point generated" else r);
175
176 let* r = run_toplevel "show_point { x = 10; y = 20 };;" in
177 test "show_record_works" (contains r "10" && contains r "20")
178 (String.sub r 0 (min 60 (String.length r)));
179
180 Printf.printf "\n--- Section 2: ppx_deriving.eq ---\n%!";
181
182 (* Test [@@deriving eq] generates equal function *)
183 let* r = run_toplevel "type status = Active | Inactive [@@deriving eq];;" in
184 test "eq_type_defined" (contains r "type status") "status type defined";
185 test "eq_fn_generated" (contains r "val equal_status")
186 (if contains r "val equal_status" then "equal_status generated" else r);
187
188 (* Test the generated equal function works *)
189 let* r = run_toplevel "equal_status Active Active;;" in
190 test "eq_same_true" (contains r "true") r;
191
192 let* r = run_toplevel "equal_status Active Inactive;;" in
193 test "eq_diff_false" (contains r "false") r;
194
195 Printf.printf "\n--- Section 3: Combined Derivers ---\n%!";
196
197 (* Test multiple derivers on one type *)
198 let* r = run_toplevel "type expr = Num of int | Add of expr * expr [@@deriving show, eq];;" in
199 test "combined_type" (contains r "type expr") "expr type defined";
200 test "combined_pp" (contains r "val pp_expr")
201 (if contains r "val pp_expr" then "pp_expr generated" else r);
202 test "combined_eq" (contains r "val equal_expr")
203 (if contains r "val equal_expr" then "equal_expr generated" else r);
204
205 (* Test they work together *)
206 let* r = run_toplevel "let e1 = Add (Num 1, Num 2);;" in
207 test "combined_value" (contains r "val e1") r;
208
209 let* r = run_toplevel "show_expr e1;;" in
210 test "combined_show_works" (contains r "Add" || contains r "Num")
211 (String.sub r 0 (min 80 (String.length r)));
212
213 let* r = run_toplevel "equal_expr e1 e1;;" in
214 test "combined_eq_self" (contains r "true") r;
215
216 let* r = run_toplevel "equal_expr e1 (Num 1);;" in
217 test "combined_eq_diff" (contains r "false") r;
218
219 Printf.printf "\n--- Section 4: Basic Code Still Works ---\n%!";
220
221 (* Verify normal code without PPX still works *)
222 let* r = run_toplevel "let x = 1 + 2;;" in
223 test "basic_arithmetic" (contains r "val x : int = 3") r;
224
225 let* r = run_toplevel "let rec fib n = if n <= 1 then n else fib (n-1) + fib (n-2);;" in
226 test "recursive_fn" (contains r "val fib : int -> int") r;
227
228 let* r = run_toplevel "fib 10;;" in
229 test "fib_result" (contains r "55") r;
230
231 Printf.printf "\n--- Section 5: Module Support ---\n%!";
232
233 let* r = run_toplevel "module M = struct type t = A | B [@@deriving show] end;;" in
234 test "module_with_deriving" (contains r "module M") r;
235
236 let* r = run_toplevel "M.show_t M.A;;" in
237 test "module_show_works" (contains r "A")
238 (String.sub r 0 (min 60 (String.length r)));
239
240 Lwt.return (Ok ())
241 in
242
243 let promise = test_sequence in
244 (match Lwt.state promise with
245 | Lwt.Return (Ok ()) -> ()
246 | Lwt.Return (Error (InternalError s)) ->
247 Printf.printf "\n[ERROR] Test failed with: %s\n%!" s
248 | Lwt.Fail e ->
249 Printf.printf "\n[ERROR] Exception: %s\n%!" (Printexc.to_string e)
250 | Lwt.Sleep -> Printf.printf "\n[ERROR] Promise still pending\n%!");
251
252 Printf.printf "\n=== Results: %d/%d tests passed ===\n%!" !passed_tests
253 !total_tests;
254 if !passed_tests = !total_tests then
255 Printf.printf "SUCCESS: All PPX tests passed!\n%!"
256 else Printf.printf "FAILURE: Some tests failed.\n%!"