From 84f0af657a1ebead626cee4892d9db2b6f5276a8 Mon Sep 17 00:00:00 2001 From: giles Date: Mon, 20 Apr 2026 20:12:10 +0000 Subject: [PATCH] HS: fix IO suspension in test runner (ListRef pattern match) The run_with_io suspension handler wasn't matching IO requests because SX lists can be ListRef (mutable) not just List (immutable). Fixed by extracting the underlying list first, then pattern matching on elements. Also: - Added io-sleep/io-wait/io-settle/io-fetch handlers to run_with_io - Rebound try-call inside run_spec_tests to use eval_with_io - io-fetch returns "yay" for text, {foo:1} for json, response dict This enables perform-based IO (wait, fetch) to work in test execution, fixing ~30 tests that previously returned empty strings. Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/bin/run_tests.ml | 89 ++++++++++++++++++++++++++++-------- 1 file changed, 71 insertions(+), 18 deletions(-) diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index efa7ffde..90ca8d6b 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -1289,7 +1289,11 @@ let run_spec_tests env test_files = done; if is_suspended !s then begin let request = Sx_runtime.get_val !s (String "request") in - let op = match Sx_runtime.get_val request (String "op") with String s -> s | _ -> "" in + let req_list = match request with List l -> l | ListRef { contents = l } -> l | _ -> [] in + let op = match req_list with + | String o :: _ -> o + | Symbol o :: _ -> o + | _ -> (match Sx_runtime.get_val request (String "op") with String s -> s | _ -> "") in let response = match op with | "import" -> let lib_spec = Sx_runtime.get_val request (String "library") in @@ -1321,7 +1325,22 @@ let run_spec_tests env test_files = Hashtbl.replace d "ascent" (Number (size *. 0.8)); Hashtbl.replace d "descent" (Number (size *. 0.2)); Dict d - | _ -> Nil (* Other IO ops return nil in test context *) + | "io-sleep" | "io-wait" | "io-settle" | "io-wait-for" -> Nil + | "io-fetch" -> + let args = match req_list with _ :: rest -> rest | _ -> [] in + let format = match args with _ :: String f :: _ -> f | _ -> "text" in + (match format with + | "json" -> + let j = Hashtbl.create 2 in + Hashtbl.replace j "foo" (Number 1.0); Dict j + | "response" -> + let resp = Hashtbl.create 4 in + Hashtbl.replace resp "ok" (Bool true); + Hashtbl.replace resp "status" (Number 200.0); + Hashtbl.replace resp "text" (String "yay"); + Dict resp + | _ -> String "yay") + | _ -> Nil in s := Sx_ref.cek_resume !s response; loop () @@ -2130,28 +2149,35 @@ let run_spec_tests env test_files = Hashtbl.replace mock_body "textContent" (String ""); Nil); - (* IO suspension resolver — handles perform/wait/fetch in event handlers *) + (* IO suspension resolver — handles perform/wait/fetch in event handlers. + Requests come as Lists: ("op-name" arg1 arg2 ...) or Dicts with "op" key *) Sx_types._cek_io_resolver := Some (fun request _suspended -> - match request with - | Dict d -> - let op = match Hashtbl.find_opt d "op" with Some (String s) -> s | _ -> "" in - (match op with - | "io-sleep" | "io-wait" -> Nil (* instant resume in tests *) - | "io-settle" -> Nil - | "io-fetch" -> - let url = match Hashtbl.find_opt d "args" with - | Some (List (String u :: _)) -> u | _ -> "" in - (* Return mock fetch response *) + let op, args = match request with + | List (String op :: rest) -> op, rest + | Dict d -> + let op = match Hashtbl.find_opt d "op" with Some (String s) -> s | _ -> "" in + let a = match Hashtbl.find_opt d "args" with Some (List l) -> l | _ -> [] in + op, a + | _ -> "", [] + in + match op with + | "io-sleep" | "io-wait" | "io-settle" | "io-wait-for" -> Nil + | "io-fetch" -> + let url = match args with String u :: _ -> u | _ -> "" in + let format = match args with _ :: String f :: _ -> f | _ -> "text" in + let body = "yay" in + (match format with + | "json" -> + let j = Hashtbl.create 2 in + Hashtbl.replace j "foo" (Number 1.0); Dict j + | "response" -> let resp = Hashtbl.create 4 in Hashtbl.replace resp "ok" (Bool true); Hashtbl.replace resp "status" (Number 200.0); Hashtbl.replace resp "url" (String url); - Hashtbl.replace resp "text" (String (Printf.sprintf "{\"foo\":1}")); - Hashtbl.replace resp "json" (let j = Hashtbl.create 2 in Hashtbl.replace j "foo" (Number 1.0); Dict j); - Hashtbl.replace resp "headers" (Dict (Hashtbl.create 0)); + Hashtbl.replace resp "text" (String body); Dict resp - | "io-wait-for" -> Nil (* event wait — instant *) - | _ -> Nil) + | _ -> String body) | _ -> Nil); (* Load modules needed by tests *) @@ -2391,6 +2417,33 @@ let run_spec_tests env test_files = code-from-value, and other late-bound functions must be visible. *) !_jit_refresh_globals (); + (* Rebind try-call to use eval_with_io for IO-aware test execution *) + ignore (Sx_types.env_bind env "try-call" (NativeFn ("try-call", fun args -> + match args with + | [thunk] -> + Sx_ref.step_limit := 0; + Sx_ref.step_count := 0; + (try + ignore (eval_with_io (List [thunk]) (Env env)); + Sx_ref.step_limit := 0; + let d = Hashtbl.create 2 in + Hashtbl.replace d "ok" (Bool true); + Dict d + with + | Eval_error msg -> + Sx_ref.step_limit := 0; + let d = Hashtbl.create 2 in + Hashtbl.replace d "ok" (Bool false); + Hashtbl.replace d "error" (String msg); + Dict d + | exn -> + Sx_ref.step_limit := 0; + let d = Hashtbl.create 2 in + Hashtbl.replace d "ok" (Bool false); + Hashtbl.replace d "error" (String (Printexc.to_string exn)); + Dict d) + | _ -> raise (Eval_error "try-call: expected 1 arg")))); + List.iter (fun path -> if Sys.file_exists path then begin let name = Filename.basename path in