jon.recoil.org
this repo has no description
1(** Node.js test for OCaml toplevel directives.
2
3 This tests the js_of_ocaml implementation of the toplevel,
4 running in Node.js to verify directives work in the JS context.
5
6 Directives tested:
7 - Environment query: #show, #show_type, #show_val, #show_module, #show_exception
8 - Pretty-printing: #print_depth, #print_length
9 - Custom printers: #install_printer, #remove_printer
10 - Warnings: #warnings, #warn_error
11 - Type system: #rectypes
12 - Directory: #directory, #remove_directory
13 - Help: #help
14 - Compiler options: #labels, #principal
15 - Error handling: unknown directives, missing identifiers
16
17 NOT tested (require file system or special setup):
18 - #use, #mod_use (file loading)
19 - #load (bytecode loading)
20 - #require, #list (findlib - tested separately)
21 - #trace (excluded per user request)
22*)
23
24open Js_top_worker
25open Impl
26
27(* Flusher that writes to process.stdout in Node.js *)
28let console_flusher (s : string) : unit =
29 let open Js_of_ocaml in
30 let process = Js.Unsafe.get Js.Unsafe.global (Js.string "process") in
31 let stdout = Js.Unsafe.get process (Js.string "stdout") in
32 let write = Js.Unsafe.get stdout (Js.string "write") in
33 ignore (Js.Unsafe.call write stdout [| Js.Unsafe.inject (Js.string s) |])
34
35let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
36 fun f () ->
37 let stdout_buff = Buffer.create 1024 in
38 let stderr_buff = Buffer.create 1024 in
39 Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
40 (* Note: Do NOT set stderr flusher - it causes hangs in js_of_ocaml *)
41 let x = f () in
42 let captured =
43 {
44 Impl.stdout = Buffer.contents stdout_buff;
45 stderr = Buffer.contents stderr_buff;
46 }
47 in
48 (* Restore flusher that writes to console so Printf.printf works for test output *)
49 Js_of_ocaml.Sys_js.set_channel_flusher stdout console_flusher;
50 (captured, x)
51
52module S : Impl.S = struct
53 type findlib_t = Js_top_worker_web.Findlibish.t
54
55 let capture = capture
56
57 let sync_get f =
58 let f = Fpath.v ("_opam/" ^ f) in
59 try Some (In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all)
60 with _ -> None
61
62 let async_get f =
63 let f = Fpath.v ("_opam/" ^ f) in
64 try
65 let content =
66 In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all
67 in
68 Lwt.return (Ok content)
69 with e -> Lwt.return (Error (`Msg (Printexc.to_string e)))
70
71 let create_file = Js_of_ocaml.Sys_js.create_file
72
73 let import_scripts urls =
74 let open Js_of_ocaml.Js in
75 let import_scripts_fn = Unsafe.get Unsafe.global (string "importScripts") in
76 List.iter
77 (fun url ->
78 let (_ : 'a) =
79 Unsafe.fun_call import_scripts_fn [| Unsafe.inject (string url) |]
80 in
81 ())
82 urls
83
84 let init_function _ () = failwith "Not implemented"
85 let findlib_init = Js_top_worker_web.Findlibish.init async_get
86
87 let get_stdlib_dcs uri =
88 Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get uri
89 |> Result.to_list
90
91 let find_stdlib_dcs v =
92 let pkg = match Js_top_worker_web.Findlibish.find_dcs_url v "stdlib" with
93 | Some _ as r -> r
94 | None -> Js_top_worker_web.Findlibish.find_dcs_url v "ocaml"
95 in
96 match pkg with
97 | Some url ->
98 Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get url
99 |> Result.to_list
100 | None -> []
101
102 let require b v = function
103 | [] -> []
104 | packages ->
105 Js_top_worker_web.Findlibish.require ~import_scripts sync_get b v
106 packages
107
108 let path = "/static/cmis"
109end
110
111module U = Impl.Make (S)
112
113(* Test result tracking *)
114let total_tests = ref 0
115let passed_tests = ref 0
116
117let test name check message =
118 incr total_tests;
119 let passed = check in
120 if passed then incr passed_tests;
121 let status = if passed then "PASS" else "FAIL" in
122 Printf.printf "[%s] %s: %s\n%!" status name message
123
124let contains s substr =
125 try
126 let _ = Str.search_forward (Str.regexp_string substr) s 0 in
127 true
128 with Not_found -> false
129
130let run_directive code =
131 let open Lwt in
132 U.exec_toplevel "" ("# " ^ code) >|= Result.map (fun r -> r.script)
133
134let _ =
135 Printf.printf "=== Node.js Directive Tests ===\n\n%!";
136
137 Logs.set_reporter (Logs_fmt.reporter ());
138 Logs.set_level (Some Logs.Info);
139
140 let ( let* ) m f =
141 let open Lwt in
142 m >>= function
143 | Ok x -> f x
144 | Error e -> return (Error e)
145 in
146
147 let init_config =
148 { stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
149 in
150
151 let test_sequence =
152 (* Initialize *)
153 let* _ = U.init init_config in
154 let* _ = U.setup "" in
155
156 Printf.printf "--- Section 1: Basic Execution ---\n%!";
157
158 let* r = run_directive "1 + 2;;" in
159 test "basic_eval" (contains r "- : int = 3") r;
160
161 let* r = run_directive "let x = 42;;" in
162 test "let_binding" (contains r "val x : int = 42") r;
163
164 Printf.printf "\n--- Section 2: #show Directives ---\n%!";
165
166 (* Define types/values to query *)
167 let* _ = run_directive "type point = { x: float; y: float };;" in
168 let* _ = run_directive "let origin = { x = 0.0; y = 0.0 };;" in
169 let* _ =
170 run_directive
171 "module MyMod = struct type t = int let zero = 0 end;;"
172 in
173 let* _ = run_directive "exception My_error of string;;" in
174
175 let* r = run_directive "#show point;;" in
176 test "show_type_point" (contains r "type point") r;
177
178 let* r = run_directive "#show origin;;" in
179 test "show_val_origin" (contains r "val origin") r;
180
181 let* r = run_directive "#show MyMod;;" in
182 test "show_module" (contains r "module MyMod") r;
183
184 let* r = run_directive "#show My_error;;" in
185 test "show_exception" (contains r "exception My_error") r;
186
187 let* r = run_directive "#show_type list;;" in
188 test "show_type_list" (contains r "type 'a list") r;
189
190 let* r = run_directive "#show_val List.map;;" in
191 test "show_val_list_map" (contains r "val map") r;
192
193 let* r = run_directive "#show_module List;;" in
194 test "show_module_list" (contains r "module List") r;
195
196 let* r = run_directive "#show_exception Not_found;;" in
197 test "show_exception_not_found" (contains r "exception Not_found") r;
198
199 Printf.printf "\n--- Section 3: #print_depth and #print_length ---\n%!";
200
201 let* _ = run_directive "let nested = [[[[1;2;3]]]];;" in
202 let* _ = run_directive "#print_depth 2;;" in
203 let* r = run_directive "nested;;" in
204 test "print_depth_truncated" (contains r "...") r;
205
206 let* _ = run_directive "#print_depth 100;;" in
207 let* r = run_directive "nested;;" in
208 test "print_depth_full" (contains r "1; 2; 3") r;
209
210 let* _ = run_directive "let long_list = [1;2;3;4;5;6;7;8;9;10];;" in
211 let* _ = run_directive "#print_length 3;;" in
212 let* r = run_directive "long_list;;" in
213 test "print_length_truncated" (contains r "...") r;
214
215 let* _ = run_directive "#print_length 100;;" in
216 let* r = run_directive "long_list;;" in
217 test "print_length_full" (contains r "10") r;
218
219 Printf.printf "\n--- Section 4: #install_printer / #remove_printer ---\n%!";
220
221 let* _ = run_directive "type color = Red | Green | Blue;;" in
222 let* _ =
223 run_directive
224 {|let pp_color fmt c = Format.fprintf fmt "<color:%s>" (match c with Red -> "red" | Green -> "green" | Blue -> "blue");;|}
225 in
226 let* _ = run_directive "#install_printer pp_color;;" in
227 let* r = run_directive "Red;;" in
228 test "install_printer" (contains r "<color:red>") r;
229
230 let* _ = run_directive "#remove_printer pp_color;;" in
231 let* r = run_directive "Red;;" in
232 test "remove_printer" (contains r "Red" && not (contains r "<color:red>")) r;
233
234 Printf.printf "\n--- Section 5: #warnings / #warn_error ---\n%!";
235
236 let* _ = run_directive "#warnings \"-26\";;" in
237 let* r = run_directive "let _ = let unused = 1 in 2;;" in
238 test "warnings_disabled"
239 (not (contains r "Warning") || contains r "- : int = 2")
240 r;
241
242 let* _ = run_directive "#warnings \"+26\";;" in
243 let* r = run_directive "let _ = let unused2 = 1 in 2;;" in
244 test "warnings_enabled" (contains r "Warning" || contains r "unused2") r;
245
246 let* _ = run_directive "#warn_error \"+26\";;" in
247 let* r = run_directive "let _ = let unused3 = 1 in 2;;" in
248 test "warn_error" (contains r "Error") r;
249
250 let* _ = run_directive "#warn_error \"-a\";;" in
251
252 Printf.printf "\n--- Section 6: #rectypes ---\n%!";
253
254 let* r = run_directive "type 'a t = 'a t -> int;;" in
255 test "rectypes_before" (contains r "Error" || contains r "cyclic") r;
256
257 let* _ = run_directive "#rectypes;;" in
258 let* r = run_directive "type 'a u = 'a u -> int;;" in
259 test "rectypes_after" (contains r "type 'a u") r;
260
261 Printf.printf "\n--- Section 7: #directory ---\n%!";
262
263 let* r = run_directive "#directory \"/tmp\";;" in
264 test "directory_add" (String.length r >= 0) "(no error)";
265
266 let* r = run_directive "#remove_directory \"/tmp\";;" in
267 test "directory_remove" (String.length r >= 0) "(no error)";
268
269 Printf.printf "\n--- Section 8: #help ---\n%!";
270
271 let* r = run_directive "#help;;" in
272 test "help"
273 (contains r "directive" || contains r "Directive" || contains r "#")
274 (String.sub r 0 (min 100 (String.length r)) ^ "...");
275
276 Printf.printf "\n--- Section 9: #labels / #principal ---\n%!";
277
278 let* r = run_directive "#labels true;;" in
279 test "labels_true" (String.length r >= 0) "(no error)";
280
281 let* r = run_directive "#labels false;;" in
282 test "labels_false" (String.length r >= 0) "(no error)";
283
284 let* r = run_directive "#principal true;;" in
285 test "principal_true" (String.length r >= 0) "(no error)";
286
287 let* r = run_directive "#principal false;;" in
288 test "principal_false" (String.length r >= 0) "(no error)";
289
290 Printf.printf "\n--- Section 10: Error Cases ---\n%!";
291
292 let* r = run_directive "#unknown_directive;;" in
293 test "unknown_directive" (contains r "Unknown") r;
294
295 let* r = run_directive "#show nonexistent_value;;" in
296 test "show_nonexistent" (contains r "Unknown" || contains r "not found") r;
297
298 Printf.printf "\n--- Section 11: Classes ---\n%!";
299
300 let* _ =
301 run_directive
302 "class counter = object val mutable n = 0 method incr = n <- n + 1 \
303 method get = n end;;"
304 in
305 let* r = run_directive "#show_class counter;;" in
306 test "show_class" (contains r "class counter") r;
307
308 Lwt.return (Ok ())
309 in
310
311 let promise = test_sequence in
312 (match Lwt.state promise with
313 | Lwt.Return (Ok ()) -> ()
314 | Lwt.Return (Error (InternalError s)) ->
315 Printf.printf "\n[ERROR] Test failed with: %s\n%!" s
316 | Lwt.Fail e ->
317 Printf.printf "\n[ERROR] Exception: %s\n%!" (Printexc.to_string e)
318 | Lwt.Sleep -> Printf.printf "\n[ERROR] Promise still pending\n%!");
319
320 Printf.printf "\n=== Results: %d/%d tests passed ===\n%!" !passed_tests
321 !total_tests;
322 if !passed_tests = !total_tests then
323 Printf.printf "SUCCESS: All directive tests passed!\n%!"
324 else Printf.printf "FAILURE: Some tests failed.\n%!"