Compare commits
175 Commits
8a009df4a3
...
loops/tcl
| Author | SHA1 | Date | |
|---|---|---|---|
| 50b69bcbd0 | |||
| 14986d787d | |||
| 21028c4fb0 | |||
| 7415dd020e | |||
| 2fa0bb4df1 | |||
| 63ad4563cb | |||
| c8b232d40e | |||
| 64d36fa66e | |||
| be820d0337 | |||
| a32561a07d | |||
| 40f0e73386 | |||
| 83dbb5958a | |||
| 16cf4d9316 | |||
| eaab8db840 | |||
| c5d9a8b789 | |||
| d21cde336a | |||
| f0f339709e | |||
| 0596376199 | |||
| 35511db15b | |||
| 40ce4df6b1 | |||
| 0cc36450c4 | |||
| 21e8e51174 | |||
| b0c135412a | |||
| f1428009fd | |||
| 9f57234d1e | |||
| 1751cd05ea | |||
| 82d16597e0 | |||
| ed42561071 | |||
| 6d8f366439 | |||
| 225fa2e86d | |||
| cfe5371354 | |||
| 48eaeb0421 | |||
| c93fe4453a | |||
| 623529d3be | |||
| 0f63216adc | |||
| ecd89270c0 | |||
| 092da5b819 | |||
| 40bf4c38f1 | |||
| b46bef2808 | |||
| 17b5acb71f | |||
| 0753982a02 | |||
| 2f8abb18a3 | |||
| 2de96e7f4f | |||
| f6a1b53c7b | |||
| 42c7a593cf | |||
| 37f8ed74c7 | |||
| 7acbea01ae | |||
| bf9d342c6e | |||
| 7f642a5082 | |||
| 85cef7d80f | |||
| e667d3bc51 | |||
| c26cd500b4 | |||
| 0bef67dd47 | |||
| 8f8f9623e0 | |||
| 297f0603e5 | |||
| 35ace3e74c | |||
| ac4e9ac96e | |||
| 6a40e991b3 | |||
| e9ddf31181 | |||
| 26ee00dff1 | |||
| f547ebf43e | |||
| b14ac6cd70 | |||
| 6d534e8c42 | |||
| 7190a8b1d2 | |||
| 79190e4dac | |||
| 7b72c064c4 | |||
| e7169af985 | |||
| abbb1fe5c6 | |||
| 846650da07 | |||
| 0276571f08 | |||
| fee62a20f0 | |||
| 42184797f1 | |||
| d5aa8a2e74 | |||
| 20e23d233c | |||
| d9b7e1e392 | |||
| d47db58cde | |||
| f4ef4033de | |||
| 73e86fa8e8 | |||
| 51bc075da5 | |||
| 894fd24c3a | |||
| a3abe47286 | |||
| d25a97d464 | |||
| df6480cd96 | |||
| 7990ee5ffe | |||
| 19bd2cb92d | |||
| 1723808517 | |||
| 9256719fa8 | |||
| 0746c90729 | |||
| 83cb75a87b | |||
| eeb4e48230 | |||
| eef2bfdd89 | |||
| c4d9efc8c4 | |||
| 4baf16ac13 | |||
| b40c70a348 | |||
| 310b649fe7 | |||
| 5ddd558eb7 | |||
| 68d81f59a6 | |||
| 245b097c93 | |||
| 2dadb6a521 | |||
| cc800c3004 | |||
| 606b5da1a1 | |||
| 87072e61c1 | |||
| 8b972483ae | |||
| 21c4a7fd5e | |||
| cb59fbba13 | |||
| 54b54f4e19 | |||
| 92adf9d496 | |||
| cabb0467ab | |||
| 820132b839 | |||
| 7480c0f9c9 | |||
| c36fd5b208 | |||
| 41fac7ac29 | |||
| 4c48a8dd57 | |||
| a48110417b | |||
| 61c9697f67 | |||
| f2993f0582 | |||
| da2e6b1bca | |||
| 8e8c2a73d6 | |||
| f38558fcc1 | |||
| daea280837 | |||
| 11917f1bfa | |||
| 875e9ba317 | |||
| f715d23e10 | |||
| 5a76a04010 | |||
| 4b69650336 | |||
| a0bbf74c01 | |||
| 35f498ec80 | |||
| 037acc7998 | |||
| 247bd85cda | |||
| b41d9d143b | |||
| d663c91f4b | |||
| 11ee71d846 | |||
| 835fffb834 | |||
| bb18c05083 | |||
| 6a1cbdcbdb | |||
| 4c43918a99 | |||
| d7244d1dc8 | |||
| 1b1b67c72e | |||
| 3a755947ef | |||
| 880503e2b6 | |||
| e989ff3865 | |||
| 8e2a633b7f | |||
| cc2a296306 | |||
| 9c8da50003 | |||
| 3003c8a069 | |||
| 8c62137d32 | |||
| 573f9fa4b3 | |||
| 8ac669c739 | |||
| 8e4bdb7216 | |||
| 20a643806b | |||
| ea1bdab82c | |||
| 04164aa2d4 | |||
| 912649c426 | |||
| 67a5f13713 | |||
| db8d7aca91 | |||
| d31565d556 | |||
| 337c8265cd | |||
| a4538c71a8 | |||
| 5ff2b7068e | |||
| f011d01b49 | |||
| 122053eda3 | |||
| 7bbffa0401 | |||
| 3044a16817 | |||
| a8a798c592 | |||
| 19c97989d7 | |||
| ff38499bd5 | |||
| e01a3baa5b | |||
| 484b55281b | |||
| 070a983848 | |||
| 13e0254261 | |||
| 1340284bc8 | |||
| 4f98f5f89d | |||
| 84e7bc8a24 | |||
| 7735eb7512 | |||
| 4e2e2c781c |
@@ -2771,8 +2771,8 @@ PLATFORM_DOM_JS = """
|
||||
// If lambda takes 0 params, call without event arg (convenience for on-click handlers)
|
||||
var wrapped = isLambda(handler)
|
||||
? (lambdaParams(handler).length === 0
|
||||
? function(e) { try { cekCall(handler, NIL); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }
|
||||
: function(e) { try { cekCall(handler, [e]); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } })
|
||||
? function(e) { try { var r = cekCall(handler, NIL); if (globalThis._driveAsync) globalThis._driveAsync(r); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }
|
||||
: function(e) { try { var r = cekCall(handler, [e]); if (globalThis._driveAsync) globalThis._driveAsync(r); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } })
|
||||
: handler;
|
||||
if (name === "click") logInfo("domListen: click on <" + (el.tagName||"?").toLowerCase() + "> text=" + (el.textContent||"").substring(0,20) + " isLambda=" + isLambda(handler));
|
||||
var passiveEvents = { touchstart: 1, touchmove: 1, wheel: 1, scroll: 1 };
|
||||
|
||||
@@ -1892,8 +1892,34 @@ let handle_sx_harness_eval args =
|
||||
let file = args |> member "file" |> to_string_option in
|
||||
let setup_str = args |> member "setup" |> to_string_option in
|
||||
let files_json = try args |> member "files" with _ -> `Null in
|
||||
let host_stubs = match args |> member "host_stubs" with `Bool b -> b | _ -> false in
|
||||
let e = !env in
|
||||
let warnings = ref [] in
|
||||
(* Inject stub host primitives so files using host-get/host-new/etc. can load *)
|
||||
if host_stubs then begin
|
||||
let stubs = {|
|
||||
(define host-global (fn (&rest _) nil))
|
||||
(define host-get (fn (&rest _) nil))
|
||||
(define host-set! (fn (obj k v) v))
|
||||
(define host-call (fn (&rest _) nil))
|
||||
(define host-new (fn (&rest _) (dict)))
|
||||
(define host-callback (fn (f) f))
|
||||
(define host-typeof (fn (&rest _) "string"))
|
||||
(define hs-ref-eq (fn (a b) (identical? a b)))
|
||||
(define host-call-fn (fn (&rest _) nil))
|
||||
(define host-iter? (fn (&rest _) false))
|
||||
(define host-to-list (fn (&rest _) (list)))
|
||||
(define host-await (fn (&rest _) nil))
|
||||
(define host-new-function (fn (&rest _) nil))
|
||||
(define load-library! (fn (&rest _) false))
|
||||
|} in
|
||||
let stub_exprs = Sx_parser.parse_all stubs in
|
||||
List.iter (fun expr ->
|
||||
try ignore (Sx_ref.eval_expr expr (Env e))
|
||||
with exn ->
|
||||
warnings := Printf.sprintf "Stub warning: %s" (Printexc.to_string exn) :: !warnings
|
||||
) stub_exprs
|
||||
end;
|
||||
(* Collect all files to load *)
|
||||
let all_files = match files_json with
|
||||
| `List items ->
|
||||
@@ -3018,7 +3044,8 @@ let tool_definitions = `List [
|
||||
("mock", `Assoc [("type", `String "string"); ("description", `String "Optional mock platform overrides as SX dict, e.g. {:fetch (fn (url) {:status 200})}")]);
|
||||
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")]);
|
||||
("files", `Assoc [("type", `String "array"); ("items", `Assoc [("type", `String "string")]); ("description", `String "Multiple .sx files to load in order")]);
|
||||
("setup", `Assoc [("type", `String "string"); ("description", `String "SX setup expression to run before main evaluation")])]
|
||||
("setup", `Assoc [("type", `String "string"); ("description", `String "SX setup expression to run before main evaluation")]);
|
||||
("host_stubs", `Assoc [("type", `String "boolean"); ("description", `String "If true, inject nil-returning stubs for host-get/host-set!/host-call/host-new/etc. so files that use host primitives can load in the harness")])]
|
||||
["expr"];
|
||||
tool "sx_nav" "Manage sx-docs navigation and articles. Modes: list (all nav items with status), check (validate consistency), add (create article + nav entry), delete (remove nav entry + page fn), move (move entry between sections, rewriting hrefs)."
|
||||
[("mode", `Assoc [("type", `String "string"); ("description", `String "Mode: list, check, add, delete, or move")]);
|
||||
|
||||
@@ -703,6 +703,11 @@ let setup_evaluator_bridge env =
|
||||
| [expr; e] -> Sx_ref.eval_expr expr (Env (Sx_runtime.unwrap_env e))
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env env)
|
||||
| _ -> raise (Eval_error "eval-expr: expected (expr env?)"));
|
||||
(* eval-in-env: (env expr) → result. Evaluates expr in the given env. *)
|
||||
Sx_primitives.register "eval-in-env" (fun args ->
|
||||
match args with
|
||||
| [e; expr] -> Sx_ref.eval_expr expr e
|
||||
| _ -> raise (Eval_error "eval-in-env: (env expr)"));
|
||||
bind "trampoline" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
@@ -764,7 +769,13 @@ let setup_evaluator_bridge env =
|
||||
| _ -> raise (Eval_error "register-special-form!: expected (name handler)"));
|
||||
ignore (env_bind env "*custom-special-forms*" Sx_ref.custom_special_forms);
|
||||
ignore (Sx_ref.register_special_form (String "<>") (NativeFn ("<>", fun args ->
|
||||
List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args))))
|
||||
List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args))));
|
||||
(* current-env: special form — returns current lexical env as a first-class value *)
|
||||
ignore (Sx_ref.register_special_form (String "current-env")
|
||||
(NativeFn ("current-env", fun args ->
|
||||
match args with
|
||||
| [_arg_list; env_val] -> env_val
|
||||
| _ -> Nil)))
|
||||
|
||||
(* ---- Type predicates and introspection ---- *)
|
||||
let setup_introspection env =
|
||||
@@ -950,7 +961,24 @@ let setup_env_operations env =
|
||||
bind "env-has?" (fun args -> match args with [e; String k] -> Bool (Sx_types.env_has (uw e) k) | [e; Keyword k] -> Bool (Sx_types.env_has (uw e) k) | _ -> raise (Eval_error "env-has?: expected env and string"));
|
||||
bind "env-bind!" (fun args -> match args with [e; String k; v] -> Sx_types.env_bind (uw e) k v | [e; Keyword k; v] -> Sx_types.env_bind (uw e) k v | _ -> raise (Eval_error "env-bind!: expected env, key, value"));
|
||||
bind "env-set!" (fun args -> match args with [e; String k; v] -> Sx_types.env_set (uw e) k v | [e; Keyword k; v] -> Sx_types.env_set (uw e) k v | _ -> raise (Eval_error "env-set!: expected env, key, value"));
|
||||
bind "env-extend" (fun args -> match args with [e] -> Env (Sx_types.env_extend (uw e)) | _ -> raise (Eval_error "env-extend: expected env"));
|
||||
bind "env-extend" (fun args ->
|
||||
match args with
|
||||
| e :: pairs ->
|
||||
let child = Sx_types.env_extend (uw e) in
|
||||
let rec go = function
|
||||
| [] -> ()
|
||||
| k :: v :: rest ->
|
||||
ignore (Sx_types.env_bind child (Sx_runtime.value_to_str k) v); go rest
|
||||
| [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in
|
||||
go pairs; Env child
|
||||
| _ -> raise (Eval_error "env-extend: expected env"));
|
||||
bind "env-lookup" (fun args ->
|
||||
match args with
|
||||
| [e; key] ->
|
||||
let k = Sx_runtime.value_to_str key in
|
||||
let raw = uw e in
|
||||
if Sx_types.env_has raw k then Sx_types.env_get raw k else Nil
|
||||
| _ -> raise (Eval_error "env-lookup: (env key)"));
|
||||
bind "env-merge" (fun args -> match args with [a; b] -> Sx_runtime.env_merge a b | _ -> raise (Eval_error "env-merge: expected 2 envs"))
|
||||
|
||||
(* ---- Strict mode (gradual type system support) ---- *)
|
||||
|
||||
@@ -528,6 +528,183 @@ let () =
|
||||
| [Rational (_, d)] -> Integer d
|
||||
| [Integer _] -> Integer 1
|
||||
| _ -> raise (Eval_error "denominator: expected rational or integer"));
|
||||
(* printf-spec: apply one Tcl/printf format spec to one arg.
|
||||
spec is like "%5.2f", "%-10s", "%x", "%c", "%d". Always starts with %
|
||||
and ends with the conversion char. Supports d i u x X o c s f e g.
|
||||
Coerces arg to the right type per conversion. *)
|
||||
register "printf-spec" (fun args ->
|
||||
let spec_str, arg = match args with
|
||||
| [String s; v] -> (s, v)
|
||||
| _ -> raise (Eval_error "printf-spec: (spec arg)")
|
||||
in
|
||||
let n = String.length spec_str in
|
||||
if n < 2 || spec_str.[0] <> '%' then
|
||||
raise (Eval_error ("printf-spec: invalid spec " ^ spec_str));
|
||||
let type_char = spec_str.[n - 1] in
|
||||
let to_int v = match v with
|
||||
| Integer i -> i
|
||||
| Number f -> int_of_float f
|
||||
| String s ->
|
||||
let s = String.trim s in
|
||||
(try int_of_string s
|
||||
with _ ->
|
||||
try int_of_float (float_of_string s)
|
||||
with _ -> 0)
|
||||
| Bool true -> 1 | Bool false -> 0
|
||||
| _ -> 0
|
||||
in
|
||||
let to_float v = match v with
|
||||
| Number f -> f
|
||||
| Integer i -> float_of_int i
|
||||
| String s ->
|
||||
let s = String.trim s in
|
||||
(try float_of_string s with _ -> 0.0)
|
||||
| _ -> 0.0
|
||||
in
|
||||
let to_string v = match v with
|
||||
| String s -> s
|
||||
| Integer i -> string_of_int i
|
||||
| Number f -> Sx_types.format_number f
|
||||
| Bool true -> "1" | Bool false -> "0"
|
||||
| Nil -> ""
|
||||
| _ -> Sx_types.inspect v
|
||||
in
|
||||
try
|
||||
match type_char with
|
||||
| 'd' | 'i' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%d" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'u' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%u" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'x' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%x" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'X' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%X" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'o' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%o" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'c' ->
|
||||
let n_val = to_int arg in
|
||||
let body = String.sub spec_str 0 (n - 1) in
|
||||
let fmt = Scanf.format_from_string (body ^ "s") "%s" in
|
||||
String (Printf.sprintf fmt (String.make 1 (Char.chr (n_val land 0xff))))
|
||||
| 's' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%s" in
|
||||
String (Printf.sprintf fmt (to_string arg))
|
||||
| 'f' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%f" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'e' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%e" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'E' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%E" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'g' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%g" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'G' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%G" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| _ -> raise (Eval_error ("printf-spec: unsupported conversion " ^ String.make 1 type_char))
|
||||
with
|
||||
| Eval_error _ as e -> raise e
|
||||
| _ -> raise (Eval_error ("printf-spec: invalid format " ^ spec_str)));
|
||||
|
||||
(* scan-spec: apply one Tcl/scanf format spec to a string.
|
||||
Returns (consumed-count . parsed-value), or nil on failure. *)
|
||||
register "scan-spec" (fun args ->
|
||||
let spec_str, str = match args with
|
||||
| [String s; String input] -> (s, input)
|
||||
| _ -> raise (Eval_error "scan-spec: (spec input)")
|
||||
in
|
||||
let n = String.length spec_str in
|
||||
if n < 2 || spec_str.[0] <> '%' then
|
||||
raise (Eval_error ("scan-spec: invalid spec " ^ spec_str));
|
||||
let type_char = spec_str.[n - 1] in
|
||||
let len = String.length str in
|
||||
(* skip leading whitespace for non-%c/%s conversions *)
|
||||
let i = ref 0 in
|
||||
if type_char <> 'c' then
|
||||
while !i < len && (str.[!i] = ' ' || str.[!i] = '\t' || str.[!i] = '\n') do incr i done;
|
||||
let start = !i in
|
||||
try
|
||||
match type_char with
|
||||
| 'd' | 'i' ->
|
||||
let j = ref !i in
|
||||
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
|
||||
while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done;
|
||||
if !j > start && (str.[start] >= '0' && str.[start] <= '9'
|
||||
|| (!j > start + 1 && (str.[start] = '-' || str.[start] = '+'))) then
|
||||
let n_val = int_of_string (String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer n_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'x' | 'X' ->
|
||||
let j = ref !i in
|
||||
while !j < len &&
|
||||
((str.[!j] >= '0' && str.[!j] <= '9') ||
|
||||
(str.[!j] >= 'a' && str.[!j] <= 'f') ||
|
||||
(str.[!j] >= 'A' && str.[!j] <= 'F')) do incr j done;
|
||||
if !j > start then
|
||||
let n_val = int_of_string ("0x" ^ String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer n_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'o' ->
|
||||
let j = ref !i in
|
||||
while !j < len && str.[!j] >= '0' && str.[!j] <= '7' do incr j done;
|
||||
if !j > start then
|
||||
let n_val = int_of_string ("0o" ^ String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer n_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'f' | 'e' | 'g' ->
|
||||
let j = ref !i in
|
||||
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
|
||||
while !j < len && ((str.[!j] >= '0' && str.[!j] <= '9') || str.[!j] = '.') do incr j done;
|
||||
if !j < len && (str.[!j] = 'e' || str.[!j] = 'E') then begin
|
||||
incr j;
|
||||
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
|
||||
while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done
|
||||
end;
|
||||
if !j > start then
|
||||
let f_val = float_of_string (String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Number f_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 's' ->
|
||||
let j = ref !i in
|
||||
while !j < len && str.[!j] <> ' ' && str.[!j] <> '\t' && str.[!j] <> '\n' do incr j done;
|
||||
if !j > start then
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (String (String.sub str start (!j - start)));
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'c' ->
|
||||
if !i < len then
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer (Char.code str.[!i]));
|
||||
Hashtbl.replace d "consumed" (Integer (!i + 1));
|
||||
Dict d
|
||||
else Nil
|
||||
| _ -> raise (Eval_error ("scan-spec: unsupported conversion " ^ String.make 1 type_char))
|
||||
with
|
||||
| Eval_error _ as e -> raise e
|
||||
| _ -> Nil);
|
||||
|
||||
register "parse-int" (fun args ->
|
||||
let parse_leading_int s =
|
||||
let len = String.length s in
|
||||
@@ -3091,6 +3268,640 @@ let () =
|
||||
| [String pat] -> List (List.map (fun s -> String s) (glob_paths pat))
|
||||
| _ -> raise (Eval_error "file-glob: (pattern)"));
|
||||
|
||||
(* === File metadata + ops (Phase 5d) === *)
|
||||
let stat_or = function
|
||||
| String path -> (try Some (Unix.stat path) with _ -> None)
|
||||
| _ -> raise (Eval_error "file: path must be a string")
|
||||
in
|
||||
register "file-size" (fun args ->
|
||||
match args with
|
||||
| [v] -> (match stat_or v with Some s -> Integer s.Unix.st_size | None -> Integer 0)
|
||||
| _ -> raise (Eval_error "file-size: (path)"));
|
||||
register "file-mtime" (fun args ->
|
||||
match args with
|
||||
| [v] -> (match stat_or v with Some s -> Integer (int_of_float s.Unix.st_mtime) | None -> Integer 0)
|
||||
| _ -> raise (Eval_error "file-mtime: (path)"));
|
||||
register "file-isfile?" (fun args ->
|
||||
match args with
|
||||
| [v] -> (match stat_or v with Some s -> Bool (s.Unix.st_kind = Unix.S_REG) | None -> Bool false)
|
||||
| _ -> raise (Eval_error "file-isfile?: (path)"));
|
||||
register "file-isdir?" (fun args ->
|
||||
match args with
|
||||
| [v] -> (match stat_or v with Some s -> Bool (s.Unix.st_kind = Unix.S_DIR) | None -> Bool false)
|
||||
| _ -> raise (Eval_error "file-isdir?: (path)"));
|
||||
register "file-readable?" (fun args ->
|
||||
match args with
|
||||
| [String path] ->
|
||||
Bool (try Unix.access path [Unix.R_OK]; true with _ -> false)
|
||||
| _ -> raise (Eval_error "file-readable?: (path)"));
|
||||
register "file-writable?" (fun args ->
|
||||
match args with
|
||||
| [String path] ->
|
||||
Bool (try Unix.access path [Unix.W_OK]; true with _ -> false)
|
||||
| _ -> raise (Eval_error "file-writable?: (path)"));
|
||||
register "file-stat" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
(match stat_or v with
|
||||
| None -> Nil
|
||||
| Some s ->
|
||||
let d = Hashtbl.create 6 in
|
||||
Hashtbl.replace d "size" (Integer s.Unix.st_size);
|
||||
Hashtbl.replace d "mtime" (Integer (int_of_float s.Unix.st_mtime));
|
||||
Hashtbl.replace d "atime" (Integer (int_of_float s.Unix.st_atime));
|
||||
Hashtbl.replace d "ctime" (Integer (int_of_float s.Unix.st_ctime));
|
||||
Hashtbl.replace d "mode" (Integer s.Unix.st_perm);
|
||||
Hashtbl.replace d "type" (String (match s.Unix.st_kind with
|
||||
| Unix.S_REG -> "file" | Unix.S_DIR -> "directory"
|
||||
| Unix.S_LNK -> "link" | Unix.S_CHR -> "characterSpecial"
|
||||
| Unix.S_BLK -> "blockSpecial" | Unix.S_FIFO -> "fifo"
|
||||
| Unix.S_SOCK -> "socket"));
|
||||
Dict d)
|
||||
| _ -> raise (Eval_error "file-stat: (path)"));
|
||||
register "file-delete" (fun args ->
|
||||
match args with
|
||||
| [String path] ->
|
||||
(try
|
||||
if Sys.is_directory path then Unix.rmdir path
|
||||
else Unix.unlink path
|
||||
with
|
||||
| Unix.Unix_error (Unix.ENOENT, _, _) -> () (* tolerate missing *)
|
||||
| Unix.Unix_error (e, _, _) -> raise (Eval_error ("file-delete: " ^ Unix.error_message e)));
|
||||
Nil
|
||||
| _ -> raise (Eval_error "file-delete: (path)"));
|
||||
register "file-mkdir" (fun args ->
|
||||
match args with
|
||||
| [String path] ->
|
||||
let rec mk p =
|
||||
if p = "" || p = "." || p = "/" then ()
|
||||
else if Sys.file_exists p then ()
|
||||
else begin
|
||||
mk (Filename.dirname p);
|
||||
(try Unix.mkdir p 0o755
|
||||
with Unix.Unix_error (Unix.EEXIST, _, _) -> ())
|
||||
end
|
||||
in
|
||||
(try mk path
|
||||
with Unix.Unix_error (e, _, _) -> raise (Eval_error ("file-mkdir: " ^ Unix.error_message e)));
|
||||
Nil
|
||||
| _ -> raise (Eval_error "file-mkdir: (path)"));
|
||||
register "file-copy" (fun args ->
|
||||
match args with
|
||||
| [String src; String dst] ->
|
||||
(try
|
||||
let ic = open_in_bin src in
|
||||
let oc = open_out_bin dst in
|
||||
let buf = Bytes.create 8192 in
|
||||
let rec loop () =
|
||||
let n = input ic buf 0 (Bytes.length buf) in
|
||||
if n > 0 then (output oc buf 0 n; loop ())
|
||||
in
|
||||
loop ();
|
||||
close_in ic;
|
||||
close_out oc;
|
||||
Nil
|
||||
with
|
||||
| Sys_error msg -> raise (Eval_error ("file-copy: " ^ msg)))
|
||||
| _ -> raise (Eval_error "file-copy: (src dst)"));
|
||||
register "file-rename" (fun args ->
|
||||
match args with
|
||||
| [String src; String dst] ->
|
||||
(try Sys.rename src dst with Sys_error msg -> raise (Eval_error ("file-rename: " ^ msg)));
|
||||
Nil
|
||||
| _ -> raise (Eval_error "file-rename: (src dst)"));
|
||||
|
||||
(* === Channels (random-access + blocking control) === *)
|
||||
let channel_table : (string, Unix.file_descr * string * bool ref * bool ref) Hashtbl.t = Hashtbl.create 16 in
|
||||
let channel_next_id = ref 0 in
|
||||
let parse_open_mode mode =
|
||||
match mode with
|
||||
| "r" -> [Unix.O_RDONLY]
|
||||
| "w" -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC]
|
||||
| "a" -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND]
|
||||
| "r+" -> [Unix.O_RDWR]
|
||||
| "w+" -> [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC]
|
||||
| "a+" -> [Unix.O_RDWR; Unix.O_CREAT; Unix.O_APPEND]
|
||||
| _ -> raise (Eval_error ("channel-open: invalid mode " ^ mode))
|
||||
in
|
||||
let chan_get name =
|
||||
match Hashtbl.find_opt channel_table name with
|
||||
| Some c -> c
|
||||
| None -> raise (Eval_error ("channel: no such channel " ^ name))
|
||||
in
|
||||
register "channel-open" (fun args ->
|
||||
match args with
|
||||
| [String path; String mode] ->
|
||||
(try
|
||||
let fd = Unix.openfile path (parse_open_mode mode) 0o644 in
|
||||
let id = !channel_next_id in
|
||||
incr channel_next_id;
|
||||
let name = Printf.sprintf "file%d" id in
|
||||
Hashtbl.replace channel_table name (fd, mode, ref false, ref true);
|
||||
String name
|
||||
with Unix.Unix_error (e, _, _) -> raise (Eval_error ("channel-open: " ^ Unix.error_message e)))
|
||||
| _ -> raise (Eval_error "channel-open: (path mode)"));
|
||||
|
||||
register "channel-close" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let (fd, _, _, _) = chan_get name in
|
||||
(try Unix.close fd with _ -> ());
|
||||
Hashtbl.remove channel_table name;
|
||||
Nil
|
||||
| _ -> raise (Eval_error "channel-close: (channel)"));
|
||||
|
||||
register "channel-read" (fun args ->
|
||||
let (name, max_n) = match args with
|
||||
| [String n] -> (n, -1)
|
||||
| [String n; Integer m] -> (n, m)
|
||||
| [String n; Number m] -> (n, int_of_float m)
|
||||
| _ -> raise (Eval_error "channel-read: (channel ?n?)")
|
||||
in
|
||||
let (fd, _, eof, _) = chan_get name in
|
||||
let chunk = 8192 in
|
||||
let buf = Bytes.create chunk in
|
||||
let buffer = Buffer.create chunk in
|
||||
let total = ref 0 in
|
||||
let stop = ref false in
|
||||
while not !stop do
|
||||
let want = if max_n < 0 then chunk else min chunk (max_n - !total) in
|
||||
if want <= 0 then stop := true
|
||||
else begin
|
||||
try
|
||||
let r = Unix.read fd buf 0 want in
|
||||
if r = 0 then begin eof := true; stop := true end
|
||||
else begin
|
||||
Buffer.add_subbytes buffer buf 0 r;
|
||||
total := !total + r
|
||||
end
|
||||
with
|
||||
| Unix.Unix_error (Unix.EAGAIN, _, _)
|
||||
| Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> stop := true
|
||||
end
|
||||
done;
|
||||
String (Buffer.contents buffer));
|
||||
|
||||
register "channel-read-line" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let (fd, _, eof, _) = chan_get name in
|
||||
let buf = Buffer.create 80 in
|
||||
let one = Bytes.create 1 in
|
||||
let got_data = ref false in
|
||||
let stop = ref false in
|
||||
while not !stop do
|
||||
try
|
||||
let r = Unix.read fd one 0 1 in
|
||||
if r = 0 then begin eof := true; stop := true end
|
||||
else begin
|
||||
got_data := true;
|
||||
let c = Bytes.get one 0 in
|
||||
if c = '\n' then stop := true
|
||||
else Buffer.add_char buf c
|
||||
end
|
||||
with
|
||||
| Unix.Unix_error (Unix.EAGAIN, _, _)
|
||||
| Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> stop := true
|
||||
done;
|
||||
if !got_data then String (Buffer.contents buf) else Nil
|
||||
| _ -> raise (Eval_error "channel-read-line: (channel)"));
|
||||
|
||||
register "channel-write" (fun args ->
|
||||
match args with
|
||||
| [String name; String s] ->
|
||||
let (fd, _, _, _) = chan_get name in
|
||||
let b = Bytes.of_string s in
|
||||
let n = Bytes.length b in
|
||||
let written = ref 0 in
|
||||
while !written < n do
|
||||
(try
|
||||
let w = Unix.write fd b !written (n - !written) in
|
||||
written := !written + w
|
||||
with
|
||||
| Unix.Unix_error (Unix.EAGAIN, _, _)
|
||||
| Unix.Unix_error (Unix.EWOULDBLOCK, _, _) ->
|
||||
(* short write — let caller retry *)
|
||||
written := n)
|
||||
done;
|
||||
Nil
|
||||
| _ -> raise (Eval_error "channel-write: (channel string)"));
|
||||
|
||||
register "channel-flush" (fun args ->
|
||||
match args with
|
||||
| [String name] -> let _ = chan_get name in Nil (* no userspace buffer *)
|
||||
| _ -> raise (Eval_error "channel-flush: (channel)"));
|
||||
|
||||
register "channel-seek" (fun args ->
|
||||
let (name, offset, whence) = match args with
|
||||
| [String n; Integer o] -> (n, o, "start")
|
||||
| [String n; Number o] -> (n, int_of_float o, "start")
|
||||
| [String n; Integer o; String w] -> (n, o, w)
|
||||
| [String n; Number o; String w] -> (n, int_of_float o, w)
|
||||
| _ -> raise (Eval_error "channel-seek: (channel offset ?whence?)")
|
||||
in
|
||||
let (fd, _, eof, _) = chan_get name in
|
||||
let cmd = match whence with
|
||||
| "start" -> Unix.SEEK_SET
|
||||
| "current" -> Unix.SEEK_CUR
|
||||
| "end" -> Unix.SEEK_END
|
||||
| _ -> raise (Eval_error ("channel-seek: invalid whence " ^ whence))
|
||||
in
|
||||
let _ = Unix.lseek fd offset cmd in
|
||||
eof := false;
|
||||
Nil);
|
||||
|
||||
register "channel-tell" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let (fd, _, _, _) = chan_get name in
|
||||
Integer (Unix.lseek fd 0 Unix.SEEK_CUR)
|
||||
| _ -> raise (Eval_error "channel-tell: (channel)"));
|
||||
|
||||
register "channel-eof?" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let (_, _, eof, _) = chan_get name in
|
||||
Bool !eof
|
||||
| _ -> raise (Eval_error "channel-eof?: (channel)"));
|
||||
|
||||
register "channel-blocking?" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let (_, _, _, blocking) = chan_get name in
|
||||
Bool !blocking
|
||||
| _ -> raise (Eval_error "channel-blocking?: (channel)"));
|
||||
|
||||
register "channel-set-blocking!" (fun args ->
|
||||
match args with
|
||||
| [String name; Bool b] ->
|
||||
let (fd, _, _, blocking) = chan_get name in
|
||||
blocking := b;
|
||||
(try
|
||||
if b then Unix.clear_nonblock fd
|
||||
else Unix.set_nonblock fd
|
||||
with _ -> ());
|
||||
Nil
|
||||
| _ -> raise (Eval_error "channel-set-blocking!: (channel bool)"));
|
||||
|
||||
(* === Exec === run an external process; capture stdout *)
|
||||
register "exec-process" (fun args ->
|
||||
let items = match args with
|
||||
| [List xs] | [ListRef { contents = xs }] -> xs
|
||||
| _ -> raise (Eval_error "exec-process: (cmd-list)")
|
||||
in
|
||||
let argv = Array.of_list (List.map (function
|
||||
| String s -> s
|
||||
| v -> Sx_types.inspect v
|
||||
) items) in
|
||||
if Array.length argv = 0 then raise (Eval_error "exec: empty command");
|
||||
let (out_r, out_w) = Unix.pipe () in
|
||||
let (err_r, err_w) = Unix.pipe () in
|
||||
let pid =
|
||||
try Unix.create_process argv.(0) argv Unix.stdin out_w err_w
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
Unix.close out_r; Unix.close out_w;
|
||||
Unix.close err_r; Unix.close err_w;
|
||||
raise (Eval_error ("exec: " ^ Unix.error_message e))
|
||||
in
|
||||
Unix.close out_w;
|
||||
Unix.close err_w;
|
||||
let buf = Buffer.create 256 in
|
||||
let errbuf = Buffer.create 64 in
|
||||
let chunk = Bytes.create 4096 in
|
||||
let read_all fd target =
|
||||
try
|
||||
let stop = ref false in
|
||||
while not !stop do
|
||||
let n = Unix.read fd chunk 0 (Bytes.length chunk) in
|
||||
if n = 0 then stop := true
|
||||
else Buffer.add_subbytes target chunk 0 n
|
||||
done
|
||||
with _ -> ()
|
||||
in
|
||||
read_all out_r buf;
|
||||
read_all err_r errbuf;
|
||||
Unix.close out_r;
|
||||
Unix.close err_r;
|
||||
let (_, status) = Unix.waitpid [] pid in
|
||||
let exit_code = match status with
|
||||
| Unix.WEXITED n -> n
|
||||
| Unix.WSIGNALED _ | Unix.WSTOPPED _ -> 1
|
||||
in
|
||||
let s = Buffer.contents buf in
|
||||
let trimmed =
|
||||
if String.length s > 0 && s.[String.length s - 1] = '\n'
|
||||
then String.sub s 0 (String.length s - 1) else s
|
||||
in
|
||||
if exit_code <> 0 then
|
||||
raise (Eval_error ("exec: child exited " ^ string_of_int exit_code
|
||||
^ (if Buffer.length errbuf > 0
|
||||
then ": " ^ Buffer.contents errbuf
|
||||
else "")))
|
||||
else String trimmed);
|
||||
|
||||
(* exec-pipeline: takes a list of words like Tcl `exec` would receive.
|
||||
Recognizes `|` as a stage separator and `> file`, `>> file`, `< file`,
|
||||
`2>@1` (stderr→stdout), `2> file`. Returns trimmed stdout of the last
|
||||
stage; raises Eval_error if the last stage exits non-zero. *)
|
||||
register "exec-pipeline" (fun args ->
|
||||
let items = match args with
|
||||
| [List xs] | [ListRef { contents = xs }] -> xs
|
||||
| _ -> raise (Eval_error "exec-pipeline: (word-list)")
|
||||
in
|
||||
let words = List.map (function
|
||||
| String s -> s
|
||||
| v -> Sx_types.inspect v
|
||||
) items in
|
||||
if words = [] then raise (Eval_error "exec: empty command");
|
||||
let split_stages ws =
|
||||
let rec loop acc cur = function
|
||||
| [] -> List.rev (List.rev cur :: acc)
|
||||
| "|" :: rest -> loop (List.rev cur :: acc) [] rest
|
||||
| w :: rest -> loop acc (w :: cur) rest
|
||||
in
|
||||
loop [] [] ws
|
||||
in
|
||||
let extract_redirs ws =
|
||||
let in_path = ref None in
|
||||
let out_path = ref None in
|
||||
let out_append = ref false in
|
||||
let err_path = ref None in
|
||||
let merge_err = ref false in
|
||||
let cleaned = ref [] in
|
||||
let rec loop = function
|
||||
| [] -> ()
|
||||
| "<" :: p :: rest -> in_path := Some p; loop rest
|
||||
| ">" :: p :: rest -> out_path := Some p; out_append := false; loop rest
|
||||
| ">>" :: p :: rest -> out_path := Some p; out_append := true; loop rest
|
||||
| "2>@1" :: rest -> merge_err := true; loop rest
|
||||
| "2>" :: p :: rest -> err_path := Some p; loop rest
|
||||
| w :: rest -> cleaned := w :: !cleaned; loop rest
|
||||
in
|
||||
loop ws;
|
||||
(List.rev !cleaned, !in_path, !out_path, !out_append, !err_path, !merge_err)
|
||||
in
|
||||
let stages = List.map extract_redirs (split_stages words) in
|
||||
if stages = [] then raise (Eval_error "exec: no stages");
|
||||
let n = List.length stages in
|
||||
let pipes = Array.init (max 0 (n - 1)) (fun _ -> Unix.pipe ()) in
|
||||
let (final_r, final_w) = Unix.pipe () in
|
||||
let (errstash_r, errstash_w) = Unix.pipe () in
|
||||
let pids = ref [] in
|
||||
let close_safe fd = try Unix.close fd with _ -> () in
|
||||
let open_in_redir = function
|
||||
| None -> Unix.stdin
|
||||
| Some path ->
|
||||
(try Unix.openfile path [Unix.O_RDONLY] 0o644
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("exec: open <" ^ path ^ ": " ^ Unix.error_message e)))
|
||||
in
|
||||
let open_out_redir path append =
|
||||
let flags = Unix.O_WRONLY :: Unix.O_CREAT :: (if append then [Unix.O_APPEND] else [Unix.O_TRUNC]) in
|
||||
try Unix.openfile path flags 0o644
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("exec: open >" ^ path ^ ": " ^ Unix.error_message e))
|
||||
in
|
||||
let stages_arr = Array.of_list stages in
|
||||
(try
|
||||
Array.iteri (fun i (cleaned, ip, op, app, ep, merge) ->
|
||||
if cleaned = [] then raise (Eval_error "exec: empty stage in pipeline");
|
||||
let argv = Array.of_list cleaned in
|
||||
let stdin_fd =
|
||||
if i = 0 then open_in_redir ip
|
||||
else fst pipes.(i - 1)
|
||||
in
|
||||
let stdout_fd =
|
||||
if i = n - 1 then
|
||||
(match op with
|
||||
| None -> final_w
|
||||
| Some path -> open_out_redir path app)
|
||||
else snd pipes.(i)
|
||||
in
|
||||
let stderr_fd =
|
||||
if merge then stdout_fd
|
||||
else (match ep with
|
||||
| None -> if i = n - 1 then errstash_w else Unix.stderr
|
||||
| Some path -> open_out_redir path false)
|
||||
in
|
||||
let pid =
|
||||
try Unix.create_process argv.(0) argv stdin_fd stdout_fd stderr_fd
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("exec: " ^ argv.(0) ^ ": " ^ Unix.error_message e))
|
||||
in
|
||||
pids := pid :: !pids;
|
||||
if i > 0 then close_safe (fst pipes.(i - 1));
|
||||
if i < n - 1 then close_safe (snd pipes.(i));
|
||||
if i = 0 && ip <> None then close_safe stdin_fd;
|
||||
if i = n - 1 && op <> None then close_safe stdout_fd;
|
||||
if not merge && ep <> None then close_safe stderr_fd
|
||||
) stages_arr
|
||||
with e ->
|
||||
close_safe final_r; close_safe final_w;
|
||||
close_safe errstash_r; close_safe errstash_w;
|
||||
Array.iter (fun (a,b) -> close_safe a; close_safe b) pipes;
|
||||
raise e);
|
||||
close_safe final_w;
|
||||
close_safe errstash_w;
|
||||
let buf = Buffer.create 256 in
|
||||
let errbuf = Buffer.create 64 in
|
||||
let chunk = Bytes.create 4096 in
|
||||
let read_all fd target =
|
||||
try
|
||||
let stop = ref false in
|
||||
while not !stop do
|
||||
let r = Unix.read fd chunk 0 (Bytes.length chunk) in
|
||||
if r = 0 then stop := true
|
||||
else Buffer.add_subbytes target chunk 0 r
|
||||
done
|
||||
with _ -> ()
|
||||
in
|
||||
read_all final_r buf;
|
||||
read_all errstash_r errbuf;
|
||||
close_safe final_r;
|
||||
close_safe errstash_r;
|
||||
let exit_codes = List.rev_map (fun pid ->
|
||||
let (_, st) = Unix.waitpid [] pid in
|
||||
match st with
|
||||
| Unix.WEXITED c -> c
|
||||
| _ -> 1
|
||||
) !pids in
|
||||
let final_code = match List.rev exit_codes with
|
||||
| [] -> 0
|
||||
| last :: _ -> last
|
||||
in
|
||||
let s = Buffer.contents buf in
|
||||
let trimmed =
|
||||
if String.length s > 0 && s.[String.length s - 1] = '\n'
|
||||
then String.sub s 0 (String.length s - 1) else s
|
||||
in
|
||||
if final_code <> 0 then
|
||||
raise (Eval_error ("exec: pipeline last stage exited " ^ string_of_int final_code
|
||||
^ (if Buffer.length errbuf > 0
|
||||
then ": " ^ Buffer.contents errbuf
|
||||
else "")))
|
||||
else String trimmed);
|
||||
|
||||
(* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *)
|
||||
let resolve_inet_addr host =
|
||||
if host = "" || host = "0.0.0.0" then Unix.inet_addr_any
|
||||
else if host = "localhost" then Unix.inet_addr_loopback
|
||||
else
|
||||
try Unix.inet_addr_of_string host
|
||||
with _ ->
|
||||
try
|
||||
let entry = Unix.gethostbyname host in
|
||||
if Array.length entry.Unix.h_addr_list = 0 then
|
||||
raise (Eval_error ("socket: cannot resolve " ^ host))
|
||||
else entry.Unix.h_addr_list.(0)
|
||||
with Not_found -> raise (Eval_error ("socket: cannot resolve " ^ host))
|
||||
in
|
||||
let port_of v = match v with
|
||||
| Integer n -> n
|
||||
| Number n -> int_of_float n
|
||||
| _ -> raise (Eval_error "socket: port must be a number")
|
||||
in
|
||||
let alloc_chan_name () =
|
||||
let id = !channel_next_id in
|
||||
incr channel_next_id;
|
||||
Printf.sprintf "sock%d" id
|
||||
in
|
||||
|
||||
register "socket-connect" (fun args ->
|
||||
match args with
|
||||
| [String host; port_v] ->
|
||||
let port = port_of port_v in
|
||||
let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in
|
||||
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||
(try Unix.connect sock addr
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
(try Unix.close sock with _ -> ());
|
||||
raise (Eval_error ("socket-connect: " ^ Unix.error_message e)));
|
||||
let name = alloc_chan_name () in
|
||||
Hashtbl.replace channel_table name (sock, "rw", ref false, ref true);
|
||||
String name
|
||||
| _ -> raise (Eval_error "socket-connect: (host port)"));
|
||||
|
||||
(* Non-blocking connect: returns channel immediately. Connection completes
|
||||
when the channel becomes writable; query channel-async-error? after to
|
||||
confirm success or get the error. *)
|
||||
register "socket-connect-async" (fun args ->
|
||||
match args with
|
||||
| [String host; port_v] ->
|
||||
let port = port_of port_v in
|
||||
let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in
|
||||
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||
Unix.set_nonblock sock;
|
||||
(try Unix.connect sock addr
|
||||
with
|
||||
| Unix.Unix_error (Unix.EINPROGRESS, _, _)
|
||||
| Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> ()
|
||||
| Unix.Unix_error (e, _, _) ->
|
||||
(try Unix.close sock with _ -> ());
|
||||
raise (Eval_error ("socket-connect-async: " ^ Unix.error_message e)));
|
||||
let name = alloc_chan_name () in
|
||||
Hashtbl.replace channel_table name (sock, "rw", ref false, ref false);
|
||||
String name
|
||||
| _ -> raise (Eval_error "socket-connect-async: (host port)"));
|
||||
|
||||
(* After a non-blocking connect completes (channel writable), check whether
|
||||
the connect succeeded. Returns "" on success, error message on failure. *)
|
||||
register "channel-async-error" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let (fd, _, _, _) = chan_get name in
|
||||
(try
|
||||
let err = Unix.getsockopt_error fd in
|
||||
match err with
|
||||
| None -> String ""
|
||||
| Some e -> String (Unix.error_message e)
|
||||
with
|
||||
| Unix.Unix_error (e, _, _) -> String (Unix.error_message e))
|
||||
| _ -> raise (Eval_error "channel-async-error: (channel)"));
|
||||
|
||||
register "socket-server" (fun args ->
|
||||
let (host, port) = match args with
|
||||
| [port_v] -> ("", port_of port_v)
|
||||
| [String h; port_v] -> (h, port_of port_v)
|
||||
| _ -> raise (Eval_error "socket-server: (port) or (host port)")
|
||||
in
|
||||
let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in
|
||||
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||
Unix.setsockopt sock Unix.SO_REUSEADDR true;
|
||||
(try Unix.bind sock addr
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
(try Unix.close sock with _ -> ());
|
||||
raise (Eval_error ("socket-server: bind: " ^ Unix.error_message e)));
|
||||
Unix.listen sock 8;
|
||||
let name = alloc_chan_name () in
|
||||
Hashtbl.replace channel_table name (sock, "server", ref false, ref true);
|
||||
String name);
|
||||
|
||||
register "socket-accept" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let (sock, _, _, _) = chan_get name in
|
||||
let (client_sock, client_addr) =
|
||||
try Unix.accept sock
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("socket-accept: " ^ Unix.error_message e))
|
||||
in
|
||||
let (host_str, port) = match client_addr with
|
||||
| Unix.ADDR_INET (addr, p) -> (Unix.string_of_inet_addr addr, p)
|
||||
| Unix.ADDR_UNIX path -> (path, 0)
|
||||
in
|
||||
let client_name = alloc_chan_name () in
|
||||
Hashtbl.replace channel_table client_name (client_sock, "rw", ref false, ref true);
|
||||
let d = Hashtbl.create 3 in
|
||||
Hashtbl.replace d "channel" (String client_name);
|
||||
Hashtbl.replace d "host" (String host_str);
|
||||
Hashtbl.replace d "port" (Integer port);
|
||||
Dict d
|
||||
| _ -> raise (Eval_error "socket-accept: (server-channel)"));
|
||||
|
||||
(* io-select-channels: (read-list write-list timeout-ms) → {:readable [...] :writable [...]}
|
||||
timeout-ms < 0 → block indefinitely; 0 → poll. Returns ready channel names. *)
|
||||
register "io-select-channels" (fun args ->
|
||||
let to_ms v = match v with
|
||||
| Integer n -> n
|
||||
| Number n -> int_of_float n
|
||||
| _ -> raise (Eval_error "io-select-channels: timeout must be a number")
|
||||
in
|
||||
let to_list v = match v with
|
||||
| List xs | ListRef { contents = xs } -> xs
|
||||
| Nil -> []
|
||||
| _ -> raise (Eval_error "io-select-channels: expected list")
|
||||
in
|
||||
let chan_name_of v = match v with
|
||||
| String s -> s
|
||||
| _ -> raise (Eval_error "io-select-channels: channel must be a string")
|
||||
in
|
||||
let (read_list, write_list, timeout_ms) = match args with
|
||||
| [r; w; t] -> (to_list r, to_list w, to_ms t)
|
||||
| _ -> raise (Eval_error "io-select-channels: (read-list write-list timeout-ms)")
|
||||
in
|
||||
let read_pairs = List.map (fun v ->
|
||||
let name = chan_name_of v in
|
||||
let (fd, _, _, _) = chan_get name in (name, fd)) read_list in
|
||||
let write_pairs = List.map (fun v ->
|
||||
let name = chan_name_of v in
|
||||
let (fd, _, _, _) = chan_get name in (name, fd)) write_list in
|
||||
let read_fds = List.map snd read_pairs in
|
||||
let write_fds = List.map snd write_pairs in
|
||||
let timeout = if timeout_ms < 0 then -1.0 else float_of_int timeout_ms /. 1000.0 in
|
||||
let (ready_r, ready_w, _) =
|
||||
try Unix.select read_fds write_fds [] timeout
|
||||
with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], [])
|
||||
in
|
||||
let names_of pairs ready =
|
||||
List.filter_map (fun (n, fd) ->
|
||||
if List.exists (fun rfd -> rfd = fd) ready then Some (String n) else None
|
||||
) pairs
|
||||
in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "readable" (List (names_of read_pairs ready_r));
|
||||
Hashtbl.replace d "writable" (List (names_of write_pairs ready_w));
|
||||
Dict d);
|
||||
|
||||
(* === Clock === *)
|
||||
register "clock-seconds" (fun args ->
|
||||
match args with
|
||||
@@ -3102,11 +3913,8 @@ let () =
|
||||
| [] -> Integer (int_of_float (Unix.gettimeofday () *. 1000.0))
|
||||
| _ -> raise (Eval_error "clock-milliseconds: no args"));
|
||||
|
||||
register "clock-format" (fun args ->
|
||||
match args with
|
||||
| [Integer t] | [Integer t; String _] ->
|
||||
let fmt = (match args with [_; String f] -> f | _ -> "%a %b %e %H:%M:%S %Z %Y") in
|
||||
let tm = Unix.gmtime (float_of_int t) in
|
||||
let format_tm tm tz_label =
|
||||
fun fmt ->
|
||||
let buf = Buffer.create 32 in
|
||||
let n = String.length fmt in
|
||||
let i = ref 0 in
|
||||
@@ -3114,14 +3922,19 @@ let () =
|
||||
if fmt.[!i] = '%' && !i + 1 < n then begin
|
||||
(match fmt.[!i + 1] with
|
||||
| 'Y' -> Buffer.add_string buf (Printf.sprintf "%04d" (1900 + tm.Unix.tm_year))
|
||||
| 'y' -> Buffer.add_string buf (Printf.sprintf "%02d" ((1900 + tm.Unix.tm_year) mod 100))
|
||||
| 'm' -> Buffer.add_string buf (Printf.sprintf "%02d" (tm.Unix.tm_mon + 1))
|
||||
| 'd' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_mday)
|
||||
| 'e' -> Buffer.add_string buf (Printf.sprintf "%2d" tm.Unix.tm_mday)
|
||||
| 'H' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_hour)
|
||||
| 'I' -> let h = tm.Unix.tm_hour mod 12 in
|
||||
Buffer.add_string buf (Printf.sprintf "%02d" (if h = 0 then 12 else h))
|
||||
| 'p' -> Buffer.add_string buf (if tm.Unix.tm_hour < 12 then "AM" else "PM")
|
||||
| 'M' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_min)
|
||||
| 'S' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_sec)
|
||||
| 'j' -> Buffer.add_string buf (Printf.sprintf "%03d" (tm.Unix.tm_yday + 1))
|
||||
| 'Z' -> Buffer.add_string buf "UTC"
|
||||
| 'w' -> Buffer.add_string buf (string_of_int tm.Unix.tm_wday)
|
||||
| 'Z' -> Buffer.add_string buf tz_label
|
||||
| 'a' -> let days = [|"Sun";"Mon";"Tue";"Wed";"Thu";"Fri";"Sat"|] in
|
||||
Buffer.add_string buf days.(tm.Unix.tm_wday)
|
||||
| 'A' -> let days = [|"Sunday";"Monday";"Tuesday";"Wednesday";"Thursday";"Friday";"Saturday"|] in
|
||||
@@ -3130,6 +3943,7 @@ let () =
|
||||
Buffer.add_string buf mons.(tm.Unix.tm_mon)
|
||||
| 'B' -> let mons = [|"January";"February";"March";"April";"May";"June";"July";"August";"September";"October";"November";"December"|] in
|
||||
Buffer.add_string buf mons.(tm.Unix.tm_mon)
|
||||
| '%' -> Buffer.add_char buf '%'
|
||||
| c -> Buffer.add_char buf '%'; Buffer.add_char buf c);
|
||||
i := !i + 2
|
||||
end else begin
|
||||
@@ -3137,5 +3951,129 @@ let () =
|
||||
incr i
|
||||
end
|
||||
done;
|
||||
String (Buffer.contents buf)
|
||||
| _ -> raise (Eval_error "clock-format: (seconds [format])"))
|
||||
Buffer.contents buf
|
||||
in
|
||||
register "clock-format" (fun args ->
|
||||
let (t, fmt, tz) = match args with
|
||||
| [Integer t] -> (t, "%a %b %e %H:%M:%S %Z %Y", "utc")
|
||||
| [Integer t; String f] -> (t, f, "utc")
|
||||
| [Integer t; String f; String z] -> (t, f, z)
|
||||
| _ -> raise (Eval_error "clock-format: (seconds [format [tz]])")
|
||||
in
|
||||
let tm =
|
||||
if tz = "local" then Unix.localtime (float_of_int t)
|
||||
else Unix.gmtime (float_of_int t)
|
||||
in
|
||||
let label = if tz = "local" then "" else "UTC" in
|
||||
String (format_tm tm label fmt));
|
||||
|
||||
(* clock-scan: parse a date string with format, return seconds.
|
||||
Supports the same format specifiers as clock-format (fixed-width ones).
|
||||
tz: "utc" (default) or "local". *)
|
||||
let timegm (tm : Unix.tm) =
|
||||
let is_leap y = y mod 4 = 0 && (y mod 100 <> 0 || y mod 400 = 0) in
|
||||
let days_in_month = [|31;28;31;30;31;30;31;31;30;31;30;31|] in
|
||||
let year = tm.Unix.tm_year + 1900 in
|
||||
let mon = tm.Unix.tm_mon in
|
||||
let mday = tm.Unix.tm_mday in
|
||||
let total_days = ref 0 in
|
||||
if year >= 1970 then begin
|
||||
for y = 1970 to year - 1 do
|
||||
total_days := !total_days + (if is_leap y then 366 else 365)
|
||||
done
|
||||
end else begin
|
||||
for y = year to 1969 do
|
||||
total_days := !total_days - (if is_leap y then 366 else 365)
|
||||
done
|
||||
end;
|
||||
for m = 0 to mon - 1 do
|
||||
total_days := !total_days + days_in_month.(m);
|
||||
if m = 1 && is_leap year then incr total_days
|
||||
done;
|
||||
total_days := !total_days + mday - 1;
|
||||
!total_days * 86400
|
||||
+ tm.Unix.tm_hour * 3600
|
||||
+ tm.Unix.tm_min * 60
|
||||
+ tm.Unix.tm_sec
|
||||
in
|
||||
register "clock-scan" (fun args ->
|
||||
let (str, fmt, tz) = match args with
|
||||
| [String s; String f] -> (s, f, "utc")
|
||||
| [String s; String f; String z] -> (s, f, z)
|
||||
| _ -> raise (Eval_error "clock-scan: (str fmt [tz])")
|
||||
in
|
||||
let n = String.length fmt and sn = String.length str in
|
||||
let tm = ref { Unix.tm_year = 70; tm_mon = 0; tm_mday = 1;
|
||||
tm_hour = 0; tm_min = 0; tm_sec = 0;
|
||||
tm_wday = 0; tm_yday = 0; tm_isdst = false } in
|
||||
let i = ref 0 and j = ref 0 in
|
||||
let read_n_digits k =
|
||||
let s = ref "" in
|
||||
let cnt = ref 0 in
|
||||
while !cnt < k && !j < sn && str.[!j] >= '0' && str.[!j] <= '9' do
|
||||
s := !s ^ String.make 1 str.[!j];
|
||||
incr j; incr cnt
|
||||
done;
|
||||
if !s = "" then 0 else int_of_string !s
|
||||
in
|
||||
let skip_ws () =
|
||||
while !j < sn && (str.[!j] = ' ' || str.[!j] = '\t') do incr j done
|
||||
in
|
||||
while !i < n do
|
||||
if fmt.[!i] = '%' && !i + 1 < n then begin
|
||||
(match fmt.[!i + 1] with
|
||||
| 'Y' -> tm := { !tm with tm_year = read_n_digits 4 - 1900 }
|
||||
| 'y' -> let y = read_n_digits 2 in
|
||||
tm := { !tm with tm_year = (if y < 70 then 100 + y else y) }
|
||||
| 'm' -> tm := { !tm with tm_mon = read_n_digits 2 - 1 }
|
||||
| 'd' | 'e' -> skip_ws (); tm := { !tm with tm_mday = read_n_digits 2 }
|
||||
| 'H' | 'I' -> tm := { !tm with tm_hour = read_n_digits 2 }
|
||||
| 'M' -> tm := { !tm with tm_min = read_n_digits 2 }
|
||||
| 'S' -> tm := { !tm with tm_sec = read_n_digits 2 }
|
||||
| '%' -> if !j < sn && str.[!j] = '%' then incr j
|
||||
| _ -> () (* unsupported specifier — skip *)
|
||||
);
|
||||
i := !i + 2
|
||||
end else begin
|
||||
if fmt.[!i] = ' ' then skip_ws ()
|
||||
else if !j < sn && str.[!j] = fmt.[!i] then incr j;
|
||||
incr i
|
||||
end
|
||||
done;
|
||||
let secs =
|
||||
if tz = "local" then int_of_float (fst (Unix.mktime !tm))
|
||||
else timegm !tm
|
||||
in
|
||||
Integer secs);
|
||||
|
||||
(* === Env-as-value (Phase 4) === *)
|
||||
|
||||
(* env-lookup: (env key) → value or nil. Works on Env, Dict, or Nil. *)
|
||||
register "env-lookup" (fun args ->
|
||||
let unwrap = function
|
||||
| Env e -> e
|
||||
| Nil -> make_env ()
|
||||
| _ -> raise (Eval_error "env-lookup: first arg must be an environment") in
|
||||
match args with
|
||||
| [env_val; key] ->
|
||||
let e = unwrap env_val in
|
||||
let k = value_to_string key in
|
||||
if env_has e k then env_get e k else Nil
|
||||
| _ -> raise (Eval_error "env-lookup: (env key)"));
|
||||
|
||||
(* env-extend: (env [key val ...]) → new child env with optional bindings. *)
|
||||
register "env-extend" (fun args ->
|
||||
match args with
|
||||
| [] -> raise (Eval_error "env-extend: requires at least one arg")
|
||||
| env_val :: pairs ->
|
||||
let parent_env = match env_val with
|
||||
| Env e -> e
|
||||
| Nil -> make_env ()
|
||||
| _ -> raise (Eval_error "env-extend: first arg must be an environment") in
|
||||
let child = env_extend parent_env in
|
||||
let rec add_bindings = function
|
||||
| [] -> ()
|
||||
| k :: v :: rest -> ignore (env_bind child (value_to_string k) v); add_bindings rest
|
||||
| [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in
|
||||
add_bindings pairs;
|
||||
Env child)
|
||||
|
||||
@@ -539,3 +539,4 @@ let jit_try_call f args =
|
||||
(match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; _jit_skip_sentinel)
|
||||
| _ -> incr _jit_skip; _jit_skip_sentinel
|
||||
|
||||
|
||||
|
||||
44
lib/fiber.sx
Normal file
44
lib/fiber.sx
Normal file
@@ -0,0 +1,44 @@
|
||||
; lib/fiber.sx — pure SX fiber library using call/cc
|
||||
;
|
||||
; A fiber is a cooperative coroutine with true suspension (no eager
|
||||
; pre-execution). Each fiber is a dict {:resume fn :done? fn}.
|
||||
;
|
||||
; make-fiber body → fiber dict
|
||||
; body = (fn (yield init-val) ...) — body receives yield + first resume val
|
||||
; yield = (fn (val) ...) — suspends fiber, returns val to resumer
|
||||
;
|
||||
; fiber-resume f v → next yielded value, or nil when body returns
|
||||
; fiber-done? f → true after body has returned
|
||||
|
||||
(define make-fiber
|
||||
(fn (body)
|
||||
(let
|
||||
((resume-k nil)
|
||||
(caller-k nil)
|
||||
(done false))
|
||||
(let
|
||||
((yield
|
||||
(fn (val)
|
||||
(call/cc
|
||||
(fn (k)
|
||||
(set! resume-k k)
|
||||
(caller-k val))))))
|
||||
{:resume
|
||||
(fn (val)
|
||||
(if
|
||||
done
|
||||
nil
|
||||
(call/cc
|
||||
(fn (k)
|
||||
(set! caller-k k)
|
||||
(if
|
||||
(nil? resume-k)
|
||||
(begin
|
||||
(body yield val)
|
||||
(set! done true)
|
||||
(k nil))
|
||||
(resume-k val))))))
|
||||
:done? (fn () done)}))))
|
||||
|
||||
(define fiber-resume (fn (f v) ((get f :resume) v)))
|
||||
(define fiber-done? (fn (f) ((get f :done?))))
|
||||
File diff suppressed because it is too large
Load Diff
@@ -19,6 +19,7 @@
|
||||
(define
|
||||
reserved
|
||||
(list
|
||||
(quote beingTold)
|
||||
(quote me)
|
||||
(quote it)
|
||||
(quote event)
|
||||
@@ -65,7 +66,10 @@
|
||||
(list (quote me))
|
||||
(list
|
||||
(quote let)
|
||||
(list (list (quote it) nil) (list (quote event) nil))
|
||||
(list
|
||||
(list (quote beingTold) (quote me))
|
||||
(list (quote it) nil)
|
||||
(list (quote event) nil))
|
||||
guarded))))))))))
|
||||
|
||||
;; ── Activate a single element ───────────────────────────────────
|
||||
@@ -73,23 +77,82 @@
|
||||
;; Marks the element to avoid double-activation.
|
||||
|
||||
(define
|
||||
hs-activate!
|
||||
hs-register-scripts!
|
||||
(fn
|
||||
(el)
|
||||
(let
|
||||
((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script")))
|
||||
(when
|
||||
(and src (not (= src prev)))
|
||||
(hs-log-event! "hyperscript:init")
|
||||
(dom-set-data el "hs-script" src)
|
||||
(dom-set-data el "hs-active" true)
|
||||
(dom-set-attr el "data-hyperscript-powered" "true")
|
||||
(let ((handler (hs-handler src))) (handler el))))))
|
||||
()
|
||||
(for-each
|
||||
(fn
|
||||
(script)
|
||||
(when
|
||||
(not (dom-get-data script "hs-script-loaded"))
|
||||
(let
|
||||
((src (host-get script "innerHTML")))
|
||||
(guard
|
||||
(_e (true nil))
|
||||
(let
|
||||
((handler (eval-expr-cek (hs-to-sx-from-source src))))
|
||||
(handler (dom-body)))))))
|
||||
(hs-query-all "script[type=text/hyperscript]"))))
|
||||
|
||||
;; ── Boot: scan entire document ──────────────────────────────────
|
||||
;; Called once at page load. Finds all elements with _ attribute,
|
||||
;; compiles their hyperscript, and activates them.
|
||||
|
||||
(define
|
||||
hs-scripting-disabled?
|
||||
(fn
|
||||
(el)
|
||||
(if
|
||||
(= el nil)
|
||||
false
|
||||
(if
|
||||
(dom-get-attr el "disable-scripting")
|
||||
true
|
||||
(hs-scripting-disabled? (dom-parent el))))))
|
||||
|
||||
;; ── Boot subtree: for dynamic content ───────────────────────────
|
||||
;; Called after HTMX swaps or dynamic DOM insertion.
|
||||
;; Only activates elements within the given root.
|
||||
|
||||
(define
|
||||
hs-activate!
|
||||
(fn
|
||||
(el)
|
||||
(do
|
||||
(hs-register-scripts!)
|
||||
(let
|
||||
((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script")))
|
||||
(when
|
||||
(and src (not (= src prev)) (not (hs-scripting-disabled? el)))
|
||||
(when
|
||||
(dom-dispatch el "hyperscript:before:init" nil)
|
||||
(hs-log-event! "hyperscript:init")
|
||||
(dom-set-data el "hs-script" src)
|
||||
(dom-set-data el "hs-active" true)
|
||||
(dom-set-attr el "data-hyperscript-powered" "true")
|
||||
(host-set! (host-global "window") "__hs_current_me" el)
|
||||
(guard
|
||||
(_e
|
||||
(true
|
||||
(do
|
||||
(dom-dispatch el "hyperscript:parse-error" {:errors (list _e)})
|
||||
nil)))
|
||||
(let
|
||||
((handler (hs-handler src)))
|
||||
(let
|
||||
((el-type (dom-get-attr el "type"))
|
||||
(comp-name (dom-get-attr el "component")))
|
||||
(let
|
||||
((safe-handler (fn (e) (host-call-fn handler (list e)))))
|
||||
(if
|
||||
(= el-type "text/hyperscript-template")
|
||||
(for-each
|
||||
safe-handler
|
||||
(hs-query-all (or comp-name "")))
|
||||
(safe-handler el))))))
|
||||
(host-set! (host-global "window") "__hs_current_me" nil)
|
||||
(dom-dispatch el "hyperscript:after:init" nil)))))))
|
||||
|
||||
(define
|
||||
hs-deactivate!
|
||||
(fn
|
||||
@@ -101,10 +164,6 @@
|
||||
(dom-set-data el "hs-active" false)
|
||||
(dom-set-data el "hs-script" nil))))
|
||||
|
||||
;; ── Boot subtree: for dynamic content ───────────────────────────
|
||||
;; Called after HTMX swaps or dynamic DOM insertion.
|
||||
;; Only activates elements within the given root.
|
||||
|
||||
(define
|
||||
hs-boot!
|
||||
(fn
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -28,6 +28,27 @@
|
||||
|
||||
(define hs-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
||||
|
||||
(define
|
||||
hs-hex-digit?
|
||||
(fn
|
||||
(c)
|
||||
(or
|
||||
(and (>= c "0") (<= c "9"))
|
||||
(and (>= c "a") (<= c "f"))
|
||||
(and (>= c "A") (<= c "F")))))
|
||||
|
||||
(define
|
||||
hs-hex-val
|
||||
(fn
|
||||
(c)
|
||||
(let
|
||||
((code (char-code c)))
|
||||
(cond
|
||||
((and (>= code 48) (<= code 57)) (- code 48))
|
||||
((and (>= code 65) (<= code 70)) (- code 55))
|
||||
((and (>= code 97) (<= code 102)) (- code 87))
|
||||
(true 0)))))
|
||||
|
||||
;; ── Keyword set ───────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
@@ -110,6 +131,7 @@
|
||||
"append"
|
||||
"settle"
|
||||
"transition"
|
||||
"view"
|
||||
"over"
|
||||
"closest"
|
||||
"next"
|
||||
@@ -187,7 +209,8 @@
|
||||
"using"
|
||||
"giving"
|
||||
"ask"
|
||||
"answer"))
|
||||
"answer"
|
||||
"bind"))
|
||||
|
||||
(define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords)))
|
||||
|
||||
@@ -235,10 +258,15 @@
|
||||
read-number
|
||||
(fn
|
||||
(start)
|
||||
(when
|
||||
(and (< pos src-len) (hs-digit? (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(read-number start))
|
||||
(define
|
||||
read-int
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (hs-digit? (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(read-int))))
|
||||
(read-int)
|
||||
(when
|
||||
(and
|
||||
(< pos src-len)
|
||||
@@ -246,15 +274,7 @@
|
||||
(< (+ pos 1) src-len)
|
||||
(hs-digit? (hs-peek 1)))
|
||||
(hs-advance! 1)
|
||||
(define
|
||||
read-frac
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (hs-digit? (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(read-frac))))
|
||||
(read-frac))
|
||||
(read-int))
|
||||
(do
|
||||
(when
|
||||
(and
|
||||
@@ -272,15 +292,7 @@
|
||||
(< pos src-len)
|
||||
(or (= (hs-cur) "+") (= (hs-cur) "-")))
|
||||
(hs-advance! 1))
|
||||
(define
|
||||
read-exp-digits
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (hs-digit? (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(read-exp-digits))))
|
||||
(read-exp-digits))
|
||||
(read-int))
|
||||
(let
|
||||
((num-end pos))
|
||||
(when
|
||||
@@ -308,7 +320,7 @@
|
||||
()
|
||||
(cond
|
||||
(>= pos src-len)
|
||||
nil
|
||||
(error "Unterminated string")
|
||||
(= (hs-cur) "\\")
|
||||
(do
|
||||
(hs-advance! 1)
|
||||
@@ -318,15 +330,47 @@
|
||||
((ch (hs-cur)))
|
||||
(cond
|
||||
(= ch "n")
|
||||
(append! chars "\n")
|
||||
(do (append! chars "\n") (hs-advance! 1))
|
||||
(= ch "t")
|
||||
(append! chars "\t")
|
||||
(do (append! chars "\t") (hs-advance! 1))
|
||||
(= ch "r")
|
||||
(do (append! chars "\r") (hs-advance! 1))
|
||||
(= ch "b")
|
||||
(do
|
||||
(append! chars (char-from-code 8))
|
||||
(hs-advance! 1))
|
||||
(= ch "f")
|
||||
(do
|
||||
(append! chars (char-from-code 12))
|
||||
(hs-advance! 1))
|
||||
(= ch "v")
|
||||
(do
|
||||
(append! chars (char-from-code 11))
|
||||
(hs-advance! 1))
|
||||
(= ch "\\")
|
||||
(append! chars "\\")
|
||||
(do (append! chars "\\") (hs-advance! 1))
|
||||
(= ch quote-char)
|
||||
(append! chars quote-char)
|
||||
:else (do (append! chars "\\") (append! chars ch)))
|
||||
(hs-advance! 1)))
|
||||
(do (append! chars quote-char) (hs-advance! 1))
|
||||
(= ch "x")
|
||||
(do
|
||||
(hs-advance! 1)
|
||||
(if
|
||||
(and
|
||||
(< (+ pos 1) src-len)
|
||||
(hs-hex-digit? (hs-cur))
|
||||
(hs-hex-digit? (hs-peek 1)))
|
||||
(let
|
||||
((d1 (hs-hex-val (hs-cur)))
|
||||
(d2 (hs-hex-val (hs-peek 1))))
|
||||
(append!
|
||||
chars
|
||||
(char-from-code (+ (* d1 16) d2)))
|
||||
(hs-advance! 2))
|
||||
(error "Invalid hexadecimal escape: \\x")))
|
||||
:else (do
|
||||
(append! chars "\\")
|
||||
(append! chars ch)
|
||||
(hs-advance! 1)))))
|
||||
(loop))
|
||||
(= (hs-cur) quote-char)
|
||||
(hs-advance! 1)
|
||||
@@ -413,27 +457,68 @@
|
||||
read-class-name
|
||||
(fn
|
||||
(start)
|
||||
(when
|
||||
(and
|
||||
(< pos src-len)
|
||||
(or
|
||||
(hs-ident-char? (hs-cur))
|
||||
(= (hs-cur) ":")
|
||||
(= (hs-cur) "[")
|
||||
(= (hs-cur) "]")))
|
||||
(hs-advance! 1)
|
||||
(read-class-name start))
|
||||
(slice src start pos)))
|
||||
(define
|
||||
build-name
|
||||
(fn
|
||||
(acc depth)
|
||||
(cond
|
||||
((and (< pos src-len) (= (hs-cur) "\\") (< (+ pos 1) src-len))
|
||||
(do
|
||||
(hs-advance! 1)
|
||||
(let
|
||||
((c (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(build-name (str acc c) depth))))
|
||||
((and (< pos src-len) (= (hs-cur) "["))
|
||||
(do
|
||||
(let
|
||||
((c (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(build-name (str acc c) (+ depth 1)))))
|
||||
((and (< pos src-len) (= (hs-cur) "]"))
|
||||
(do
|
||||
(let
|
||||
((c (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(build-name
|
||||
(str acc c)
|
||||
(if (> depth 0) (- depth 1) 0)))))
|
||||
((and (< pos src-len) (> depth 0) (or (= (hs-cur) "(") (= (hs-cur) ")")))
|
||||
(do
|
||||
(let
|
||||
((c (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(build-name (str acc c) depth))))
|
||||
((and (< pos src-len) (or (hs-ident-char? (hs-cur)) (= (hs-cur) ":") (= (hs-cur) "&")))
|
||||
(do
|
||||
(let
|
||||
((c (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(build-name (str acc c) depth))))
|
||||
(true acc))))
|
||||
(build-name "" 0)))
|
||||
(define
|
||||
hs-emit!
|
||||
(fn
|
||||
(type value start)
|
||||
(append! tokens (hs-make-token type value start))))
|
||||
(let
|
||||
((tok (hs-make-token type value start))
|
||||
(end-pos
|
||||
(max pos (+ start (if (nil? value) 0 (len (str value)))))))
|
||||
(do
|
||||
(dict-set! tok "end" end-pos)
|
||||
(dict-set! tok "line" (len (split (slice src 0 start) "\n")))
|
||||
(append! tokens tok)))))
|
||||
(define
|
||||
scan!
|
||||
(fn
|
||||
()
|
||||
(skip-ws!)
|
||||
(let
|
||||
((ws-start pos))
|
||||
(skip-ws!)
|
||||
(when
|
||||
(and (> (len tokens) 0) (> pos ws-start))
|
||||
(hs-emit! "whitespace" (slice src ws-start pos) ws-start)))
|
||||
(when
|
||||
(< pos src-len)
|
||||
(let
|
||||
@@ -453,10 +538,26 @@
|
||||
(= (hs-peek 1) "#")
|
||||
(= (hs-peek 1) "[")
|
||||
(= (hs-peek 1) "*")
|
||||
(= (hs-peek 1) ":")))
|
||||
(= (hs-peek 1) ":")
|
||||
(= (hs-peek 1) "$")))
|
||||
(do (hs-emit! "selector" (read-selector) start) (scan!))
|
||||
(and (= ch ".") (< (+ pos 1) src-len) (= (hs-peek 1) "."))
|
||||
(do (hs-emit! "op" ".." start) (hs-advance! 2) (scan!))
|
||||
(and
|
||||
(= ch ".")
|
||||
(< (+ pos 1) src-len)
|
||||
(or
|
||||
(hs-letter? (hs-peek 1))
|
||||
(= (hs-peek 1) "-")
|
||||
(= (hs-peek 1) "_"))
|
||||
(> (len tokens) 0)
|
||||
(let
|
||||
((lt (dict-get (nth tokens (- (len tokens) 1)) :type)))
|
||||
(or
|
||||
(= lt "paren-close")
|
||||
(= lt "brace-close")
|
||||
(= lt "bracket-close"))))
|
||||
(do (hs-emit! "dot" "." start) (hs-advance! 1) (scan!))
|
||||
(and
|
||||
(= ch ".")
|
||||
(< (+ pos 1) src-len)
|
||||
@@ -468,6 +569,18 @@
|
||||
(hs-advance! 1)
|
||||
(hs-emit! "class" (read-class-name pos) start)
|
||||
(scan!))
|
||||
(and
|
||||
(= ch "#")
|
||||
(< (+ pos 1) src-len)
|
||||
(hs-ident-start? (hs-peek 1))
|
||||
(> (len tokens) 0)
|
||||
(let
|
||||
((lt (dict-get (nth tokens (- (len tokens) 1)) :type)))
|
||||
(or
|
||||
(= lt "paren-close")
|
||||
(= lt "brace-close")
|
||||
(= lt "bracket-close"))))
|
||||
(do (hs-emit! "op" "#" start) (hs-advance! 1) (scan!))
|
||||
(and
|
||||
(= ch "#")
|
||||
(< (+ pos 1) src-len)
|
||||
@@ -536,10 +649,12 @@
|
||||
(do
|
||||
(let
|
||||
((word (read-ident start)))
|
||||
(hs-emit!
|
||||
(if (hs-keyword? word) "keyword" "ident")
|
||||
word
|
||||
start))
|
||||
(let
|
||||
((full-word (if (and (< pos src-len) (= (hs-cur) "'") (< (+ pos 1) src-len) (hs-letter? (hs-peek 1)) (not (and (= (hs-peek 1) "s") (or (>= (+ pos 2) src-len) (not (hs-ident-char? (hs-peek 2))))))) (do (hs-advance! 1) (str word "'" (read-ident pos))) word)))
|
||||
(hs-emit!
|
||||
(if (hs-keyword? full-word) "keyword" "ident")
|
||||
full-word
|
||||
start)))
|
||||
(scan!))
|
||||
(and
|
||||
(or (= ch "=") (= ch "!") (= ch "<") (= ch ">"))
|
||||
@@ -620,7 +735,82 @@
|
||||
(do (hs-emit! "colon" ":" start) (hs-advance! 1) (scan!))
|
||||
(= ch "|")
|
||||
(do (hs-emit! "op" "|" start) (hs-advance! 1) (scan!))
|
||||
(= ch "&")
|
||||
(do (hs-emit! "op" "&" start) (hs-advance! 1) (scan!))
|
||||
(= ch "#")
|
||||
(do (hs-emit! "op" "#" start) (hs-advance! 1) (scan!))
|
||||
(= ch "?")
|
||||
(do (hs-emit! "op" "?" start) (hs-advance! 1) (scan!))
|
||||
(= ch ";")
|
||||
(do (hs-emit! "op" ";" start) (hs-advance! 1) (scan!))
|
||||
:else (do (hs-advance! 1) (scan!)))))))
|
||||
(scan!)
|
||||
(hs-emit! "eof" nil pos)
|
||||
tokens)))
|
||||
|
||||
;; ── Template-mode tokenizer (E37 API) ────────────────────────────────
|
||||
;; Used by hs-tokens-of when :template flag is set.
|
||||
;; Emits outer " chars as single STRING tokens; ${ ... } as $ { <inner-tokens> };
|
||||
;; inner content is tokenized with the regular hs-tokenize.
|
||||
|
||||
(define
|
||||
hs-tokenize-template
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((tokens (list)) (pos 0) (src-len (len src)))
|
||||
(define t-cur (fn () (if (< pos src-len) (nth src pos) nil)))
|
||||
(define t-peek (fn (n) (if (< (+ pos n) src-len) (nth src (+ pos n)) nil)))
|
||||
(define t-advance! (fn (n) (set! pos (+ pos n))))
|
||||
(define t-emit! (fn (type value) (append! tokens (hs-make-token type value pos))))
|
||||
(define
|
||||
scan-to-close!
|
||||
(fn
|
||||
(depth)
|
||||
(when
|
||||
(and (< pos src-len) (> depth 0))
|
||||
(cond
|
||||
(= (t-cur) "{")
|
||||
(do (t-advance! 1) (scan-to-close! (+ depth 1)))
|
||||
(= (t-cur) "}")
|
||||
(when (> (- depth 1) 0) (t-advance! 1) (scan-to-close! (- depth 1)))
|
||||
:else (do (t-advance! 1) (scan-to-close! depth))))))
|
||||
(define
|
||||
scan-template!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< pos src-len)
|
||||
(let
|
||||
((ch (t-cur)))
|
||||
(cond
|
||||
(= ch "\"")
|
||||
(do (t-emit! "string" "\"") (t-advance! 1) (scan-template!))
|
||||
(and (= ch "$") (= (t-peek 1) "{"))
|
||||
(do
|
||||
(t-emit! "op" "$")
|
||||
(t-advance! 1)
|
||||
(t-emit! "brace-open" "{")
|
||||
(t-advance! 1)
|
||||
(let
|
||||
((inner-start pos))
|
||||
(scan-to-close! 1)
|
||||
(let
|
||||
((inner-src (slice src inner-start pos))
|
||||
(inner-toks (hs-tokenize inner-src)))
|
||||
(for-each
|
||||
(fn (tok)
|
||||
(when (not (= (get tok "type") "eof"))
|
||||
(append! tokens tok)))
|
||||
inner-toks))
|
||||
(t-emit! "brace-close" "}")
|
||||
(when (< pos src-len) (t-advance! 1)))
|
||||
(scan-template!))
|
||||
(= ch "$")
|
||||
(do (t-emit! "op" "$") (t-advance! 1) (scan-template!))
|
||||
(hs-ws? ch)
|
||||
(do (t-advance! 1) (scan-template!))
|
||||
:else (do (t-advance! 1) (scan-template!)))))))
|
||||
(scan-template!)
|
||||
(t-emit! "eof" nil)
|
||||
tokens)))
|
||||
3410
lib/tcl/runtime.sx
3410
lib/tcl/runtime.sx
File diff suppressed because it is too large
Load Diff
@@ -39,6 +39,7 @@ cat > "$TMPFILE" << EPOCHS
|
||||
(epoch 3)
|
||||
(load "lib/tcl/tests/parse.sx")
|
||||
(epoch 4)
|
||||
(load "lib/fiber.sx")
|
||||
(load "lib/tcl/runtime.sx")
|
||||
(epoch 5)
|
||||
(load "lib/tcl/tests/eval.sx")
|
||||
@@ -56,7 +57,7 @@ cat > "$TMPFILE" << EPOCHS
|
||||
(eval "tcl-test-summary")
|
||||
EPOCHS
|
||||
|
||||
OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
OUTPUT=$(timeout 7200 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
|
||||
|
||||
# Extract summary line from epoch 11 output
|
||||
|
||||
@@ -95,15 +95,15 @@
|
||||
(get (run "proc g {} { yield }\ncoroutine cg g\ncg") :result)
|
||||
"")
|
||||
|
||||
; --- clock seconds stub ---
|
||||
; --- clock seconds ---
|
||||
(ok "clock-seconds"
|
||||
(get (run "clock seconds") :result)
|
||||
"0")
|
||||
(> (parse-int (get (run "clock seconds") :result)) 0)
|
||||
true)
|
||||
|
||||
; --- clock milliseconds stub ---
|
||||
; --- clock milliseconds ---
|
||||
(ok "clock-milliseconds"
|
||||
(get (run "clock milliseconds") :result)
|
||||
"0")
|
||||
(> (parse-int (get (run "clock milliseconds") :result)) 0)
|
||||
true)
|
||||
|
||||
; --- clock format stub ---
|
||||
(ok "clock-format"
|
||||
@@ -124,7 +124,7 @@
|
||||
"file0")
|
||||
|
||||
(ok "eof-returns-1"
|
||||
(get (run "set ch [open /dev/null r]\neof $ch") :result)
|
||||
(get (run "set ch [open /dev/null r]\nread $ch\neof $ch") :result)
|
||||
"1")
|
||||
|
||||
(dict
|
||||
|
||||
@@ -329,6 +329,54 @@
|
||||
(run "proc with-temp-var {varname tempval body} {\n upvar 1 $varname v\n set saved $v\n set v $tempval\n uplevel 1 $body\n set v $saved\n}\nset x 100\nwith-temp-var x 999 {\n set captured $x\n}\nlist $x $captured")
|
||||
:result)
|
||||
"100 999")
|
||||
(ok
|
||||
"array-set-get"
|
||||
(get
|
||||
(run "array set a {x 1 y 2 z 3}; array get a x")
|
||||
:result)
|
||||
"x 1")
|
||||
(ok
|
||||
"array-names"
|
||||
(get
|
||||
(run "array set a {p 10 q 20}; lsort [array names a]")
|
||||
:result)
|
||||
"p q")
|
||||
(ok
|
||||
"array-size"
|
||||
(get
|
||||
(run "array set a {x 1 y 2 z 3}; array size a")
|
||||
:result)
|
||||
"3")
|
||||
(ok
|
||||
"array-exists-true"
|
||||
(get
|
||||
(run "array set a {x 1}; array exists a")
|
||||
:result)
|
||||
"1")
|
||||
(ok
|
||||
"array-exists-false"
|
||||
(get
|
||||
(run "array exists nosucharray")
|
||||
:result)
|
||||
"0")
|
||||
(ok
|
||||
"array-unset-key"
|
||||
(get
|
||||
(run "array set a {x 1 y 2 z 3}; array unset a y; lsort [array names a]")
|
||||
:result)
|
||||
"x z")
|
||||
(ok
|
||||
"array-scalar-access"
|
||||
(get
|
||||
(run "set a(foo) hello; set a(bar) world; set a(foo)")
|
||||
:result)
|
||||
"hello")
|
||||
(ok
|
||||
"array-get-all"
|
||||
(get
|
||||
(run "set a(k) v; set pairs [array get a]; llength $pairs")
|
||||
:result)
|
||||
"2")
|
||||
(dict
|
||||
"passed"
|
||||
tcl-eval-pass
|
||||
|
||||
@@ -29,160 +29,653 @@
|
||||
(define
|
||||
ok
|
||||
(fn (label actual expected) (tcl-idiom-assert label expected actual)))
|
||||
|
||||
; 1. lmap idiom: accumulate mapped values with foreach+lappend
|
||||
(ok "idiom-lmap"
|
||||
(ok
|
||||
"idiom-lmap"
|
||||
(get
|
||||
(run "set result {}\nforeach x {1 2 3} { lappend result [expr {$x * $x}] }\nset result")
|
||||
(run
|
||||
"set result {}\nforeach x {1 2 3} { lappend result [expr {$x * $x}] }\nset result")
|
||||
:result)
|
||||
"1 4 9")
|
||||
|
||||
; 2. Recursive list flatten
|
||||
(ok "idiom-flatten"
|
||||
(ok
|
||||
"idiom-flatten"
|
||||
(get
|
||||
(run
|
||||
"proc flatten {lst} { set out {}\n foreach item $lst {\n if {[llength $item] > 1} {\n foreach sub [flatten $item] { lappend out $sub }\n } else {\n lappend out $item\n }\n }\n return $out\n}\nflatten {1 {2 3} {4 {5 6}}}")
|
||||
:result)
|
||||
"1 2 3 4 5 6")
|
||||
|
||||
; 3. String builder accumulator
|
||||
(ok "idiom-string-builder"
|
||||
(ok
|
||||
"idiom-string-builder"
|
||||
(get
|
||||
(run "set buf \"\"\nforeach w {Hello World Tcl} { append buf $w \" \" }\nstring trimright $buf")
|
||||
(run
|
||||
"set buf \"\"\nforeach w {Hello World Tcl} { append buf $w \" \" }\nstring trimright $buf")
|
||||
:result)
|
||||
"Hello World Tcl")
|
||||
|
||||
; 4. Default parameter via info exists
|
||||
(ok "idiom-default-param"
|
||||
(get
|
||||
(run "if {![info exists x]} { set x 42 }\nset x")
|
||||
:result)
|
||||
(ok
|
||||
"idiom-default-param"
|
||||
(get (run "if {![info exists x]} { set x 42 }\nset x") :result)
|
||||
"42")
|
||||
|
||||
; 5. Association list lookup (parallel key/value lists)
|
||||
(ok "idiom-alist-lookup"
|
||||
(ok
|
||||
"idiom-alist-lookup"
|
||||
(get
|
||||
(run
|
||||
"set keys {a b c}\nset vals {10 20 30}\nset idx [lsearch $keys b]\nlindex $vals $idx")
|
||||
:result)
|
||||
"20")
|
||||
|
||||
; 6. Proc with optional args via args
|
||||
(ok "idiom-optional-args"
|
||||
(ok
|
||||
"idiom-optional-args"
|
||||
(get
|
||||
(run
|
||||
"proc greet {name args} {\n set greeting \"Hello\"\n if {[llength $args] > 0} { set greeting [lindex $args 0] }\n return \"$greeting $name\"\n}\ngreet World Hi")
|
||||
:result)
|
||||
"Hi World")
|
||||
|
||||
; 7. Builder pattern: dict create from args
|
||||
(ok "idiom-dict-builder"
|
||||
(ok
|
||||
"idiom-dict-builder"
|
||||
(get
|
||||
(run
|
||||
"proc build-dict {args} { dict create {*}$args }\ndict get [build-dict name Alice age 30] name")
|
||||
:result)
|
||||
"Alice")
|
||||
|
||||
; 8. Loop with index using array
|
||||
(ok "idiom-loop-with-index"
|
||||
(ok
|
||||
"idiom-loop-with-index"
|
||||
(get
|
||||
(run
|
||||
"set i 0\nforeach x {a b c} { set arr($i) $x; incr i }\nset arr(1)")
|
||||
(run "set i 0\nforeach x {a b c} { set arr($i) $x; incr i }\nset arr(1)")
|
||||
:result)
|
||||
"b")
|
||||
|
||||
; 9. String reverse via split+lreverse+join
|
||||
(ok "idiom-string-reverse"
|
||||
(ok
|
||||
"idiom-string-reverse"
|
||||
(get
|
||||
(run
|
||||
"set s hello\nset chars [split $s \"\"]\nset rev [lreverse $chars]\njoin $rev \"\"")
|
||||
:result)
|
||||
"olleh")
|
||||
|
||||
; 10. Number to padded string
|
||||
(ok "idiom-number-format"
|
||||
(get (run "format \"%05d\" 42") :result)
|
||||
"00042")
|
||||
|
||||
; 11. Dict comprehension pattern
|
||||
(ok "idiom-dict-comprehension"
|
||||
(ok "idiom-number-format" (get (run "format \"%05d\" 42") :result) "00042")
|
||||
(ok
|
||||
"idiom-dict-comprehension"
|
||||
(get
|
||||
(run
|
||||
"set squares {}\nforeach n {1 2 3 4} { dict set squares $n [expr {$n * $n}] }\ndict get $squares 3")
|
||||
:result)
|
||||
"9")
|
||||
|
||||
; 12. Stack ADT using list: push/pop
|
||||
(ok "idiom-stack"
|
||||
(ok
|
||||
"idiom-stack"
|
||||
(get
|
||||
(run
|
||||
"proc stack-push {stackvar val} { upvar $stackvar s; lappend s $val }\nproc stack-pop {stackvar} { upvar $stackvar s; set val [lindex $s end]; set s [lrange $s 0 end-1]; return $val }\nset stk {}\nstack-push stk 10\nstack-push stk 20\nstack-push stk 30\nstack-pop stk")
|
||||
:result)
|
||||
"30")
|
||||
|
||||
; 13. Queue ADT using list: enqueue/dequeue
|
||||
(ok "idiom-queue"
|
||||
(ok
|
||||
"idiom-queue"
|
||||
(get
|
||||
(run
|
||||
"proc q-enq {qvar val} { upvar $qvar q; lappend q $val }\nproc q-deq {qvar} { upvar $qvar q; set val [lindex $q 0]; set q [lrange $q 1 end]; return $val }\nset q {}\nq-enq q alpha\nq-enq q beta\nq-enq q gamma\nq-deq q")
|
||||
:result)
|
||||
"alpha")
|
||||
|
||||
; 14. Pipeline via proc chaining
|
||||
(ok "idiom-pipeline"
|
||||
(ok
|
||||
"idiom-pipeline"
|
||||
(get
|
||||
(run
|
||||
"proc double {x} { expr {$x * 2} }\nproc add1 {x} { expr {$x + 1} }\nproc pipeline {val procs} { foreach p $procs { set val [$p $val] }; return $val }\npipeline 5 {double add1 double}")
|
||||
:result)
|
||||
"22")
|
||||
|
||||
; 15. Memoize pattern using dict (simple cache, not recursive)
|
||||
(ok "idiom-memoize"
|
||||
(ok
|
||||
"idiom-memoize"
|
||||
(get
|
||||
(run
|
||||
"set cache {}\nproc cached-square {n} { global cache\n if {[dict exists $cache $n]} { return [dict get $cache $n] }\n set r [expr {$n * $n}]\n dict set cache $n $r\n return $r\n}\nset a [cached-square 7]\nset b [cached-square 7]\nset c [cached-square 8]\nexpr {$a == $b && $c == 64}")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
; 16. Simple expression evaluator in Tcl (recursive descent)
|
||||
(ok "idiom-recursive-eval"
|
||||
(ok
|
||||
"idiom-recursive-eval"
|
||||
(get
|
||||
(run
|
||||
"proc calc {expr} { return [::tcl::mathop::+ 0 [expr $expr]] }\nexpr {3 + 4 * 2}")
|
||||
:result)
|
||||
"11")
|
||||
|
||||
; 17. Apply proc to each pair in a dict
|
||||
(ok "idiom-dict-for"
|
||||
(ok
|
||||
"idiom-dict-for"
|
||||
(get
|
||||
(run
|
||||
"set d [dict create a 1 b 2 c 3]\nset total 0\ndict for {k v} $d { incr total $v }\nset total")
|
||||
:result)
|
||||
"6")
|
||||
|
||||
; 18. Find max in list
|
||||
(ok "idiom-find-max"
|
||||
(ok
|
||||
"idiom-find-max"
|
||||
(get
|
||||
(run
|
||||
"proc list-max {lst} {\n set m [lindex $lst 0]\n foreach x $lst { if {$x > $m} { set m $x } }\n return $m\n}\nlist-max {3 1 4 1 5 9 2 6}")
|
||||
:result)
|
||||
"9")
|
||||
|
||||
; 19. Filter list by predicate
|
||||
(ok "idiom-filter-list"
|
||||
(ok
|
||||
"idiom-filter-list"
|
||||
(get
|
||||
(run
|
||||
"proc list-filter {lst pred} {\n set out {}\n foreach x $lst { if {[$pred $x]} { lappend out $x } }\n return $out\n}\nproc is-even {n} { expr {$n % 2 == 0} }\nlist-filter {1 2 3 4 5 6} is-even")
|
||||
:result)
|
||||
"2 4 6")
|
||||
|
||||
; 20. Zip two lists
|
||||
(ok "idiom-zip"
|
||||
(ok
|
||||
"idiom-zip"
|
||||
(get
|
||||
(run
|
||||
"proc zip {a b} {\n set out {}\n set n [llength $a]\n for {set i 0} {$i < $n} {incr i} {\n lappend out [lindex $a $i]\n lappend out [lindex $b $i]\n }\n return $out\n}\nzip {1 2 3} {a b c}")
|
||||
:result)
|
||||
"1 a 2 b 3 c")
|
||||
(ok
|
||||
"env-lookup-basic"
|
||||
(env-lookup (let ((x 42)) (current-env)) "x")
|
||||
42)
|
||||
(ok
|
||||
"env-lookup-missing"
|
||||
(env-lookup (let ((x 42)) (current-env)) "z")
|
||||
nil)
|
||||
(ok
|
||||
"env-extend-lookup"
|
||||
(let
|
||||
((e (let ((x 5)) (current-env))))
|
||||
(env-lookup (env-extend e "y" 10) "y"))
|
||||
10)
|
||||
(ok
|
||||
"eval-in-env-parent"
|
||||
(let
|
||||
((x 5))
|
||||
(eval-in-env (env-extend (current-env) "y" 10) (quote (+ x y))))
|
||||
15)
|
||||
(ok
|
||||
"eval-in-env-multi"
|
||||
(let
|
||||
((base (current-env)))
|
||||
(eval-in-env
|
||||
(env-extend (env-extend base "a" 3) "b" 7)
|
||||
(quote (* a b))))
|
||||
21)
|
||||
|
||||
; 26-32. Phase 5 channels: write/read/seek/tell/eof/append/non-blocking
|
||||
(ok "channel-write-read"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-1.txt\nset c [open $f w]\nputs $c \"line one\"\nputs $c \"line two\"\nclose $c\nset c [open $f r]\nset out [read $c]\nclose $c\nfile delete $f\nreturn $out")
|
||||
:result)
|
||||
"line one\nline two\n")
|
||||
|
||||
(ok "channel-gets-loop"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-2.txt\nset c [open $f w]\nputs $c apple\nputs $c banana\nputs $c cherry\nclose $c\nset c [open $f r]\nset out {}\nwhile {[gets $c line] >= 0} {lappend out $line}\nclose $c\nfile delete $f\nreturn $out")
|
||||
:result)
|
||||
"apple banana cherry")
|
||||
|
||||
(ok "channel-seek-tell"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-3.txt\nset c [open $f w]\nputs -nonewline $c \"hello world\"\nclose $c\nset c [open $f r]\nseek $c 6\nset pos [tell $c]\nset rest [read $c]\nclose $c\nfile delete $f\nreturn \"$pos:$rest\"")
|
||||
:result)
|
||||
"6:world")
|
||||
|
||||
(ok "channel-eof-after-read"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-4.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset c [open $f r]\nread $c\nset e [eof $c]\nclose $c\nfile delete $f\nreturn $e")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
(ok "channel-append-mode"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-5.txt\nset c [open $f w]\nputs -nonewline $c \"first\"\nclose $c\nset c [open $f a]\nputs -nonewline $c \"-second\"\nclose $c\nset c [open $f r]\nset out [read $c]\nclose $c\nfile delete $f\nreturn $out")
|
||||
:result)
|
||||
"first-second")
|
||||
|
||||
(ok "channel-seek-end"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-6.txt\nset c [open $f w]\nputs -nonewline $c \"abcdefghij\"\nclose $c\nset c [open $f r]\nseek $c 0 end\nset pos [tell $c]\nclose $c\nfile delete $f\nreturn $pos")
|
||||
:result)
|
||||
"10")
|
||||
|
||||
(ok "channel-fconfigure-blocking"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-7.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset c [open $f r]\nfconfigure $c -blocking 0\nset b [fconfigure $c -blocking]\nclose $c\nfile delete $f\nreturn $b")
|
||||
:result)
|
||||
"0")
|
||||
|
||||
; 33-37. Phase 5b event loop: after / vwait / fileevent / update
|
||||
(ok "after-vwait-timer"
|
||||
(get
|
||||
(run
|
||||
"after 30 {set ::done fired}\nvwait ::done\nset ::done")
|
||||
:result)
|
||||
"fired")
|
||||
|
||||
(ok "after-multiple-timers-update"
|
||||
(get
|
||||
(run
|
||||
"set ::n 0\nafter 0 {incr ::n}\nafter 0 {incr ::n}\nafter 0 {incr ::n}\nupdate\nset ::n")
|
||||
:result)
|
||||
"3")
|
||||
|
||||
(ok "fileevent-readable-fires"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5b-1.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset c [open $f r]\nfileevent $c readable {set ::ready 1; fileevent $::ch readable {}}\nset ::ch $c\nvwait ::ready\nclose $c\nfile delete $f\nset ::ready")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
(ok "fileevent-query-script"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5b-2.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset c [open $f r]\nfileevent $c readable {puts hello}\nset s [fileevent $c readable]\nclose $c\nfile delete $f\nreturn $s")
|
||||
:result)
|
||||
"puts hello")
|
||||
|
||||
(ok "after-cancel-via-vwait-timing"
|
||||
(get
|
||||
(run
|
||||
"set ::counter 0\nafter 10 {incr ::counter}\nafter 50 {set ::done 1}\nvwait ::done\nset ::counter")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
; 38-41. Phase 5c sockets: TCP client + server
|
||||
(ok "socket-server-fires-callback"
|
||||
(get
|
||||
(run
|
||||
"proc h {sock host port} { global got; set got hit; close $sock }\nset srv [socket -server h 18901]\nset cli [socket localhost 18901]\nvwait got\nclose $srv\nclose $cli\nset got")
|
||||
:result)
|
||||
"hit")
|
||||
|
||||
(ok "socket-client-server-roundtrip"
|
||||
(get
|
||||
(run
|
||||
"proc h {sock host port} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server h 18902]\nset cli [socket localhost 18902]\nputs $cli ping\nflush $cli\nvwait received\nclose $srv\nclose $cli\nset received")
|
||||
:result)
|
||||
"ping")
|
||||
|
||||
(ok "socket-server-peer-host"
|
||||
(get
|
||||
(run
|
||||
"proc h {sock host port} { global peer; set peer $host; close $sock }\nset srv [socket -server h 18903]\nset cli [socket 127.0.0.1 18903]\nvwait peer\nclose $srv\nclose $cli\nset peer")
|
||||
:result)
|
||||
"127.0.0.1")
|
||||
|
||||
(ok "socket-multiple-connections"
|
||||
(get
|
||||
(run
|
||||
"proc h {sock host port} { global count; incr count; close $sock }\nset count 0\nset srv [socket -server h 18904]\nset c1 [socket localhost 18904]\nset c2 [socket localhost 18904]\nset c3 [socket localhost 18904]\nwhile {$count < 3} { update; after 5 }\nclose $srv\nclose $c1\nclose $c2\nclose $c3\nset count")
|
||||
:result)
|
||||
"3")
|
||||
|
||||
; 42-49. Phase 5d file metadata + ops
|
||||
(ok "file-isfile-true"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5d-1.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset r [file isfile $f]\nfile delete $f\nreturn $r")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
(ok "file-isfile-false-on-dir"
|
||||
(get (run "file isfile /tmp") :result)
|
||||
"0")
|
||||
|
||||
(ok "file-isdir-true"
|
||||
(get (run "file isdir /tmp") :result)
|
||||
"1")
|
||||
|
||||
(ok "file-size"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5d-2.txt\nset c [open $f w]\nputs -nonewline $c hello\nclose $c\nset s [file size $f]\nfile delete $f\nreturn $s")
|
||||
:result)
|
||||
"5")
|
||||
|
||||
(ok "file-readable-true"
|
||||
(get (run "file readable /tmp") :result)
|
||||
"1")
|
||||
|
||||
(ok "file-readable-missing"
|
||||
(get (run "file readable /no/such/path/here") :result)
|
||||
"0")
|
||||
|
||||
(ok "file-mkdir-then-isdir"
|
||||
(get
|
||||
(run
|
||||
"set d /tmp/tcl-phase5d-mkdir/sub\nfile mkdir $d\nset r [file isdir $d]\nfile delete $d\nfile delete /tmp/tcl-phase5d-mkdir\nreturn $r")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
(ok "file-copy-roundtrip"
|
||||
(get
|
||||
(run
|
||||
"set s /tmp/tcl-phase5d-src.txt\nset d /tmp/tcl-phase5d-dst.txt\nset c [open $s w]\nputs -nonewline $c copydata\nclose $c\nfile copy $s $d\nset c [open $d r]\nset out [read $c]\nclose $c\nfile delete $s\nfile delete $d\nreturn $out")
|
||||
:result)
|
||||
"copydata")
|
||||
|
||||
(ok "file-rename-then-exists"
|
||||
(get
|
||||
(run
|
||||
"set s /tmp/tcl-phase5d-r1.txt\nset d /tmp/tcl-phase5d-r2.txt\nset c [open $s w]\nputs -nonewline $c x\nclose $c\nfile rename $s $d\nset r [list [file exists $s] [file exists $d]]\nfile delete $d\nreturn $r")
|
||||
:result)
|
||||
"0 1")
|
||||
|
||||
(ok "file-mtime-positive"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5d-mt.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset m [file mtime $f]\nfile delete $f\nexpr {$m > 0}")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
; 52-56. Phase 5e clock format options + clock scan
|
||||
(ok "clock-format-utc"
|
||||
(get
|
||||
(run "clock format 0 -format {%Y-%m-%d %H:%M:%S} -gmt 1")
|
||||
:result)
|
||||
"1970-01-01 00:00:00")
|
||||
|
||||
(ok "clock-format-fmt-default"
|
||||
(get
|
||||
(run "clock format 1710513000 -format {%Y-%m-%d} -gmt 1")
|
||||
:result)
|
||||
"2024-03-15")
|
||||
|
||||
(ok "clock-scan-roundtrip"
|
||||
(get
|
||||
(run "set t [clock scan {2024-06-15 12:00:00} -format {%Y-%m-%d %H:%M:%S} -gmt 1]\nclock format $t -format {%Y-%m-%d %H:%M:%S} -gmt 1")
|
||||
:result)
|
||||
"2024-06-15 12:00:00")
|
||||
|
||||
(ok "clock-scan-returns-int"
|
||||
(get
|
||||
(run "expr {[clock scan {1970-01-01 00:00:00} -format {%Y-%m-%d %H:%M:%S} -gmt 1] == 0}")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
(ok "clock-format-percent-pct"
|
||||
(get
|
||||
(run "clock format 0 -format {%Y%%%m} -gmt 1")
|
||||
:result)
|
||||
"1970%01")
|
||||
|
||||
; 57-59. Phase 5f socket -async (non-blocking connect)
|
||||
(ok "socket-async-completes-writable"
|
||||
(get
|
||||
(run
|
||||
"proc h {sock host port} { close $sock }\nset srv [socket -server h 18930]\nset c [socket -async localhost 18930]\nset ready 0\nfileevent $c writable {global ready; set ready 1}\nvwait ready\nclose $c\nclose $srv\nset ready")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
(ok "socket-async-then-write"
|
||||
(get
|
||||
(run
|
||||
"proc accept {sock host port} { global accepted_sock; set accepted_sock $sock; fileevent $sock readable [list reader $sock] }\nproc reader {sock} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server accept 18931]\nset c [socket -async localhost 18931]\nfileevent $c writable {global wready; set wready 1; fileevent $::ch writable {}}\nset ::ch $c\nvwait wready\nputs $c async-data\nflush $c\nvwait received\nclose $c\nclose $srv\nset received")
|
||||
:result)
|
||||
"async-data")
|
||||
|
||||
(ok "socket-async-no-error"
|
||||
(get
|
||||
(run
|
||||
"proc h {sock host port} { close $sock }\nset srv [socket -server h 18932]\nset c [socket -async localhost 18932]\nset r 0\nfileevent $c writable {global r; set r 1}\nvwait r\nset err [fconfigure $c -error]\nclose $c\nclose $srv\nreturn $err")
|
||||
:result)
|
||||
"")
|
||||
|
||||
; 60-63. Phase 6a namespace :: prefix
|
||||
(ok "ns-set-from-proc-reaches-global"
|
||||
(get
|
||||
(run
|
||||
"proc f {x} { set ::g $x }\nf hello\nset ::g")
|
||||
:result)
|
||||
"hello")
|
||||
|
||||
(ok "ns-read-from-proc"
|
||||
(get
|
||||
(run
|
||||
"set ::v 42\nproc f {} { return $::v }\nf")
|
||||
:result)
|
||||
"42")
|
||||
|
||||
(ok "ns-incr-via-prefix"
|
||||
(get
|
||||
(run
|
||||
"set ::n 5\nproc bump {} { incr ::n }\nbump\nbump\nset ::n")
|
||||
:result)
|
||||
"7")
|
||||
|
||||
(ok "ns-different-from-local"
|
||||
(get
|
||||
(run
|
||||
"set x outer\nproc f {} { set x inner; set ::x global; return $x }\nf")
|
||||
:result)
|
||||
"inner")
|
||||
|
||||
; 64-69. Phase 6b list ops (lassign, lrepeat, lset, lmap)
|
||||
(ok "lassign-three"
|
||||
(get (run "lassign {a b c d e} x y z\nlist $x $y $z") :result)
|
||||
"a b c")
|
||||
|
||||
(ok "lassign-leftover"
|
||||
(get (run "lassign {1 2 3 4 5} a b") :result)
|
||||
"3 4 5")
|
||||
|
||||
(ok "lrepeat-basic"
|
||||
(get (run "lrepeat 3 a") :result)
|
||||
"a a a")
|
||||
|
||||
(ok "lrepeat-multi"
|
||||
(get (run "lrepeat 2 x y") :result)
|
||||
"x y x y")
|
||||
|
||||
(ok "lset-replaces"
|
||||
(get (run "set L {a b c d}\nlset L 2 ZZ\nset L") :result)
|
||||
"a b ZZ d")
|
||||
|
||||
(ok "lmap-square"
|
||||
(get (run "lmap n {1 2 3 4} {expr {$n * $n}}") :result)
|
||||
"1 4 9 16")
|
||||
|
||||
; 70-72. Phase 6c dict additions (lappend, remove, filter)
|
||||
(ok "dict-lappend-extends"
|
||||
(get (run "set d {tags {a b}}\ndict lappend d tags c d\nset d") :result)
|
||||
"tags {a b c d}")
|
||||
|
||||
(ok "dict-remove"
|
||||
(get (run "dict remove {a 1 b 2 c 3} b") :result)
|
||||
"a 1 c 3")
|
||||
|
||||
(ok "dict-filter-key"
|
||||
(get (run "dict filter {alpha 1 beta 2 gamma 3} key a*") :result)
|
||||
"alpha 1")
|
||||
|
||||
; 73-79. Phase 6d format and scan
|
||||
(ok "format-int-padded"
|
||||
(get (run "format {%05d} 42") :result)
|
||||
"00042")
|
||||
|
||||
(ok "format-float-precision"
|
||||
(get (run "format {%.2f} 3.14159") :result)
|
||||
"3.14")
|
||||
|
||||
(ok "format-hex"
|
||||
(get (run "format {%x} 255") :result)
|
||||
"ff")
|
||||
|
||||
(ok "format-char"
|
||||
(get (run "format {%c} 65") :result)
|
||||
"A")
|
||||
|
||||
(ok "format-string-left"
|
||||
(get (run "format {%-5s|} hi") :result)
|
||||
"hi |")
|
||||
|
||||
(ok "scan-two-ints"
|
||||
(get (run "scan {12 34} {%d %d} a b\nlist $a $b") :result)
|
||||
"12 34")
|
||||
|
||||
(ok "scan-count"
|
||||
(get (run "scan {hello 42} {%s %d}") :result)
|
||||
"hello 42")
|
||||
|
||||
; 80-82. Phase 6e exec
|
||||
(ok "exec-echo"
|
||||
(get (run "exec echo hello world") :result)
|
||||
"hello world")
|
||||
|
||||
(ok "exec-printf-no-newline"
|
||||
(get (run "exec /bin/printf x") :result)
|
||||
"x")
|
||||
|
||||
(ok "exec-with-args"
|
||||
(get (run "exec /bin/echo -n test") :result)
|
||||
"test")
|
||||
|
||||
; 83-87. Phase 7a try/trap with varlist
|
||||
(ok "try-trap-prefix-match"
|
||||
(get
|
||||
(run
|
||||
"try {throw {ARITH DIVZERO} divide-by-zero} trap {ARITH} {res} {set caught $res}")
|
||||
:result)
|
||||
"divide-by-zero")
|
||||
|
||||
(ok "try-trap-full-pattern"
|
||||
(get
|
||||
(run
|
||||
"try {throw {FOO BAR} bad} trap {FOO BAR} {res} {return matched-foo-bar}")
|
||||
:result)
|
||||
"matched-foo-bar")
|
||||
|
||||
(ok "try-on-error-opts"
|
||||
(get
|
||||
(run
|
||||
"try {error oops} on error {res opts} {dict get $opts -code}")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
(ok "try-trap-no-match-falls-through"
|
||||
(get
|
||||
(run
|
||||
"set caught notrun\ncatch {try {throw {NOPE} bad} trap {OTHER} {r} {set caught matched}}\nset caught")
|
||||
:result)
|
||||
"notrun")
|
||||
|
||||
(ok "try-trap-then-on-error"
|
||||
(get
|
||||
(run
|
||||
"try {error generic} trap {SPECIFIC} {r} {return trap-fired} on error {r} {return on-error-fired}")
|
||||
:result)
|
||||
"on-error-fired")
|
||||
|
||||
; 88-92. Phase 7b exec pipelines + redirection
|
||||
(ok "exec-pipeline-tr"
|
||||
(get (run "exec echo hello world | tr a-z A-Z") :result)
|
||||
"HELLO WORLD")
|
||||
|
||||
(ok "exec-pipeline-wc"
|
||||
(get (run "exec /bin/echo abc | wc -c") :result)
|
||||
"4")
|
||||
|
||||
(ok "exec-redirect-stdout"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-7b-out.txt\nexec echo hello > $f\nset r [exec cat $f]\nfile delete $f\nreturn $r")
|
||||
:result)
|
||||
"hello")
|
||||
|
||||
(ok "exec-redirect-stdin"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-7b-in.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset r [exec cat < $f]\nfile delete $f\nreturn $r")
|
||||
:result)
|
||||
"hi")
|
||||
|
||||
(ok "exec-pipeline-three-stages"
|
||||
(get (run "exec echo {alpha beta gamma} | tr { } \\n | wc -l") :result)
|
||||
"3")
|
||||
|
||||
; 93-99. Phase 7c string command audit
|
||||
(ok "string-equal"
|
||||
(get (run "string equal hello hello") :result)
|
||||
"1")
|
||||
|
||||
(ok "string-equal-nocase"
|
||||
(get (run "string equal -nocase HELLO hello") :result)
|
||||
"1")
|
||||
|
||||
(ok "string-totitle"
|
||||
(get (run "string totitle hello") :result)
|
||||
"Hello")
|
||||
|
||||
(ok "string-reverse"
|
||||
(get (run "string reverse hello") :result)
|
||||
"olleh")
|
||||
|
||||
(ok "string-replace"
|
||||
(get (run "string replace hello 1 3 ZZZ") :result)
|
||||
"hZZZo")
|
||||
|
||||
(ok "string-is-xdigit-yes"
|
||||
(get (run "string is xdigit ff00aa") :result)
|
||||
"1")
|
||||
|
||||
(ok "string-is-true-yes"
|
||||
(get (run "string is true yes") :result)
|
||||
"1")
|
||||
|
||||
; 100-105. Phase 7e regexp anchoring/boundary audit
|
||||
(ok "regexp-anchor-start"
|
||||
(get (run "regexp {^hello} hello-world") :result)
|
||||
"1")
|
||||
|
||||
(ok "regexp-anchor-end"
|
||||
(get (run "regexp {world$} hello-world") :result)
|
||||
"1")
|
||||
|
||||
(ok "regexp-word-boundary"
|
||||
(get (run "regexp {\\bword\\b} \"the word here\"") :result)
|
||||
"1")
|
||||
|
||||
(ok "regexp-nocase"
|
||||
(get (run "regexp -nocase {HELLO} hello") :result)
|
||||
"1")
|
||||
|
||||
(ok "regexp-capture-var"
|
||||
(get (run "regexp {[0-9]+} abc123def captured\nset captured") :result)
|
||||
"123")
|
||||
|
||||
(ok "regsub-all"
|
||||
(get (run "regsub -all {[0-9]+} a1b22c333 X") :result)
|
||||
"aXbXcX")
|
||||
|
||||
; 106-110. Phase 7d TclOO basics
|
||||
(ok "oo-class-method"
|
||||
(get
|
||||
(run
|
||||
"oo::class create C {\nmethod get {} { return 42 }\n}\nset c [C new]\n$c get")
|
||||
:result)
|
||||
"42")
|
||||
|
||||
(ok "oo-constructor"
|
||||
(get
|
||||
(run
|
||||
"oo::class create G {\nconstructor {n} { set ::gname $n }\nmethod hello {} { return [string cat \"hi \" $::gname] }\n}\nset g [G new World]\n$g hello")
|
||||
:result)
|
||||
"hi World")
|
||||
|
||||
(ok "oo-inheritance-overridden"
|
||||
(get
|
||||
(run
|
||||
"oo::class create Animal {\nmethod sound {} { return generic }\n}\noo::class create Dog {\nsuperclass Animal\nmethod sound {} { return woof }\n}\nset d [Dog new]\n$d sound")
|
||||
:result)
|
||||
"woof")
|
||||
|
||||
(ok "oo-inheritance-inherited"
|
||||
(get
|
||||
(run
|
||||
"oo::class create Animal {\nmethod sound {} { return generic }\n}\noo::class create Cat {\nsuperclass Animal\n}\nset c [Cat new]\n$c sound")
|
||||
:result)
|
||||
"generic")
|
||||
|
||||
(ok "oo-multiple-instances"
|
||||
(get
|
||||
(run
|
||||
"oo::class create N {\nconstructor {x} { set ::nval $x }\nmethod get {} { return $::nval }\n}\nset a [N new 1]\nset b [N new 99]\n$b get")
|
||||
:result)
|
||||
"99")
|
||||
|
||||
(dict
|
||||
"passed"
|
||||
|
||||
@@ -167,7 +167,9 @@
|
||||
(begin
|
||||
(when (= (cur) "}") (advance! 1))
|
||||
{:type "var" :name name}))))))
|
||||
((tcl-ident-start? (cur))
|
||||
((or
|
||||
(tcl-ident-start? (cur))
|
||||
(and (= (cur) ":") (= (char-at 1) ":")))
|
||||
(let ((start pos))
|
||||
(begin
|
||||
(scan-ns-name!)
|
||||
|
||||
86
plans/agent-briefings/sx-improvements-loop.md
Normal file
86
plans/agent-briefings/sx-improvements-loop.md
Normal file
@@ -0,0 +1,86 @@
|
||||
# sx-improvements loop agent
|
||||
|
||||
Iterates `plans/sx-improvements.md` forever. One step per commit.
|
||||
|
||||
```
|
||||
description: sx-improvements loop
|
||||
subagent_type: general-purpose
|
||||
run_in_background: true
|
||||
isolation: worktree
|
||||
```
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent iterating `plans/sx-improvements.md` on the `architecture` branch of `/root/rose-ash`. One step per commit, forever. Never push.
|
||||
|
||||
## Restart baseline — check before each iteration
|
||||
|
||||
1. Read `plans/sx-improvements.md` — find the first unchecked `[ ]` step in the progress log.
|
||||
2. Read the step's section in the plan for exact implementation details.
|
||||
3. Run the verification command for that step to confirm it currently fails.
|
||||
4. Implement. Verify. Commit. Tick the `[ ]` → `[x]` in the progress log. Next.
|
||||
|
||||
## Test commands
|
||||
|
||||
- **OCaml spec:** `sx_build target="ocaml"` then check `bin/run_tests.exe` output.
|
||||
- **JS spec (no DOM):** `node hosts/javascript/run_tests.js 2>&1 | tail -3`
|
||||
- **HyperScript kernel:** `node tests/hs-kernel-eval.js 2>&1 | tail -3`
|
||||
- **Baseline SX tests (non-HS):** `node hosts/javascript/run_tests.js 2>&1 | grep -v "hs-upstream\|hs-compat\|hs-dev" | grep "Results:"`
|
||||
|
||||
Do NOT regress the pre-merge passing tests. After each step, confirm the count did not drop.
|
||||
|
||||
## Ground rules (hard)
|
||||
|
||||
- **Branch:** `architecture`. Never push. Never touch `main`.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY (`sx_summarise`, `sx_read_subtree`, `sx_replace_node`, `sx_insert_child`, `sx_validate`). Read before edit. Validate after edit.
|
||||
- **Generated files:** NEVER edit `shared/static/wasm/sx/` or `shared/static/scripts/sx-*.js` directly. Rebuild via `sx_build`.
|
||||
- **HS mirror rule:** after editing any `lib/hyperscript/<f>.sx`, copy to `shared/static/wasm/sx/hs-<f>.sx` using `sx_write_file` with the same content.
|
||||
- **OCaml build:** `sx_build target="ocaml"` — never raw `dune exec`.
|
||||
- **JS build:** `sx_build target="js"`.
|
||||
- **One step per commit.** Tick the plan. Factual commit message.
|
||||
- **No new planning docs.** No comments in SX unless non-obvious.
|
||||
- **Unicode in SX:** raw UTF-8 only, never `\uXXXX` escapes.
|
||||
|
||||
## Step-specific notes
|
||||
|
||||
### Step 1 (JIT combinator bug)
|
||||
The bug is in `hosts/ocaml/lib/sx_vm.ml` — `call_closure_reuse` path strips locals when
|
||||
callee returns a closure. Look for the path where `call_closure_reuse` is invoked for a
|
||||
`VmClosure` return value. The fix is to not reuse frames when the call might return a
|
||||
closure, or to properly snapshot/restore `sp`. Check `spec/tests/test-parser-combinators.sx`
|
||||
for existing combinator tests; run `node tests/hs-kernel-eval.js` for the 11 failing HS tests.
|
||||
|
||||
### Step 2 (letrec+resume)
|
||||
The bug is browser-only (`hosts/ocaml/browser/sx_browser.ml`). Write a minimal
|
||||
`spec/tests/test-letrec-resume.sx` that exercises `letrec` + `perform` + resume and
|
||||
verify it passes under `run_tests.exe` (OCaml server mode). Then check what
|
||||
`sx_browser.ml` does differently in the VmSuspension resume path.
|
||||
|
||||
### Steps 3-4 (E38 source info)
|
||||
The API is already in `lib/hyperscript/runtime.sx`. The gap is in the tokenizer (no `:end`/`:line`)
|
||||
and some parser span completeness. Run the 4 sourceInfo tests to see exact failures:
|
||||
`node tests/hs-kernel-eval.js --suite sourceInfo` or grep results for `sourceInfo`.
|
||||
|
||||
### Steps 5-8 (ADTs)
|
||||
Full spec in `plans/designs/sx-adt.md`. Implement in OCaml first (Step 5), then mirror
|
||||
to JS (Step 6). Steps 7-8 build on top. Write `spec/tests/test-adt.sx` from scratch —
|
||||
start with a `(define-type Maybe (Just value) (Nothing))` suite covering constructor,
|
||||
predicate, accessor, basic match, else clause.
|
||||
|
||||
### Steps 9-11 (plugin system)
|
||||
Full spec in `plans/designs/hs-plugin-system.md`. The prolog hook migration (Step 11) is
|
||||
the most important for language-building — it's the pattern for all future embeds.
|
||||
|
||||
### Steps 12-14 (performance)
|
||||
Profile first. Use `sx_harness_eval` to measure throughput on a tight loop before and
|
||||
after each change. Only commit if there's a measurable win (>10%).
|
||||
|
||||
## General gotchas (all loops)
|
||||
|
||||
- SX `do` is R7RS iteration. Use `begin` for multi-expr sequences.
|
||||
- `cond`/`when`/`let` bodies evaluate only the last expression.
|
||||
- `type-of` on a user-defined function returns `"lambda"`.
|
||||
- Shell heredoc `||` gets eaten — escape or use `case`.
|
||||
- `env-bind!` creates new bindings; `env-set!` mutates existing (walks scope chain).
|
||||
- After OCaml edits: the build takes ~2 min. Run `sx_build target="ocaml"` and wait.
|
||||
- After JS edits: retranspile with `sx_build target="js"` then re-run tests.
|
||||
@@ -4,10 +4,11 @@ Live tally for `plans/hs-conformance-to-100.md`. Update after every cluster comm
|
||||
|
||||
```
|
||||
Baseline: 1213/1496 (81.1%)
|
||||
Merged: 1277/1496 (85.4%) delta +64
|
||||
Merged: 1478/1496 (98.8%) delta +265
|
||||
Worktree: all landed
|
||||
Target: 1496/1496 (100.0%)
|
||||
Remaining: ~219 tests (cluster 29 blocked on sx-tree MCP outage + parser scope)
|
||||
Remaining: 18 (all SKIP/untranslated — no runtime failures)
|
||||
Note: step limit raised 200k→1M in 225fa2e8 revealed 70 previously-masked passes
|
||||
```
|
||||
|
||||
## Cluster ledger
|
||||
@@ -22,7 +23,7 @@ Remaining: ~219 tests (cluster 29 blocked on sx-tree MCP outage + parser scope)
|
||||
| 4 | `not` precedence over `or` | done | +3 | 4fe0b649 |
|
||||
| 5 | `some` selector for nonempty match | done | +1 | e7b86264 |
|
||||
| 6 | string template `${x}` | done | +2 | 108e25d4 |
|
||||
| 7 | `put` hyperscript reprocessing | partial | +1 | f21eb008 |
|
||||
| 7 | `put` hyperscript reprocessing | done | +5 | 247bd85c |
|
||||
| 8 | `select` returns selected text | done | +1 | d862efe8 |
|
||||
| 9 | `wait on event` basics | done | +4 | f79f96c1 |
|
||||
| 10 | `swap` variable ↔ property | done | +1 | 30f33341 |
|
||||
@@ -30,7 +31,7 @@ Remaining: ~219 tests (cluster 29 blocked on sx-tree MCP outage + parser scope)
|
||||
| 12 | `show` multi-element + display retention | done | +2 | 98c957b3 |
|
||||
| 13 | `toggle` multi-class + timed + until-event | partial | +2 | bd821c04 |
|
||||
| 14 | `unless` modifier | done | +1 | c4da0698 |
|
||||
| 15 | `transition` query-ref + multi-prop + initial | partial | +2 | 3d352055 |
|
||||
| 15 | `transition` query-ref + multi-prop + initial | partial | +3 | 3d352055 |
|
||||
| 16 | `send can reference sender` | done | +1 | ed8d71c9 |
|
||||
| 17 | `tell` semantics | blocked | — | — |
|
||||
| 18 | `throw` respond async/sync | done | +2 | dda3becb |
|
||||
@@ -42,7 +43,7 @@ Remaining: ~219 tests (cluster 29 blocked on sx-tree MCP outage + parser scope)
|
||||
| 19 | `pick` regex + indices | done | +13 | 4be90bf2 |
|
||||
| 20 | `repeat` property for-loops + where | done | +3 | c932ad59 |
|
||||
| 21 | `possessiveExpression` property access via its | done | +1 | f0c41278 |
|
||||
| 22 | window global fn fallback | blocked | — | — |
|
||||
| 22 | window global fn fallback | done | +1 | d31565d5 |
|
||||
| 23 | `me symbol works in from expressions` | done | +1 | 0d38a75b |
|
||||
| 24 | `properly interpolates values 2` | done | +1 | cb37259d |
|
||||
| 25 | parenthesized commands and features | done | +1 | d7a88d85 |
|
||||
@@ -54,42 +55,62 @@ Remaining: ~219 tests (cluster 29 blocked on sx-tree MCP outage + parser scope)
|
||||
| 26 | resize observer mock + `on resize` | done | +3 | 304a52d2 |
|
||||
| 27 | intersection observer mock + `on intersection` | done | +3 | 0c31dd27 |
|
||||
| 28 | `ask`/`answer` + prompt/confirm mock | done | +4 | 6c1da921 |
|
||||
| 29 | `hyperscript:before:init` / `:after:init` / `:parse-error` | blocked | — | — |
|
||||
| 29 | `hyperscript:before:init` / `:after:init` / `:parse-error` | partial | +2 | e01a3baa |
|
||||
| 30 | `logAll` config | done | +1 | 64bcefff |
|
||||
|
||||
### Bucket D — medium features
|
||||
|
||||
| # | Cluster | Status | Δ |
|
||||
|---|---------|--------|---|
|
||||
| 31 | runtime null-safety error reporting | pending | (+15–18 est) |
|
||||
| 32 | MutationObserver mock + `on mutation` | pending | (+10–15 est) |
|
||||
| 33 | cookie API | pending | (+5 est) |
|
||||
| 34 | event modifier DSL | pending | (+6–8 est) |
|
||||
| 35 | namespaced `def` | pending | (+3 est) |
|
||||
| 31 | runtime null-safety error reporting | done | +13 |
|
||||
| 32 | MutationObserver mock + `on mutation` | done | +7 |
|
||||
| 33 | cookie API | partial | +4 |
|
||||
| 34 | event modifier DSL | partial | +7 |
|
||||
| 35 | namespaced `def` | done | +3 |
|
||||
| 36b | `call` result binds to `it` | done | +1 | 35f498ec |
|
||||
|
||||
### Bucket E — subsystems (design docs landed, pending review + implementation)
|
||||
|
||||
| # | Cluster | Status | Design doc |
|
||||
|---|---------|--------|------------|
|
||||
| 36 | WebSocket + `socket` + RPC proxy | design-done | `plans/designs/e36-websocket.md` |
|
||||
| 37 | Tokenizer-as-API | design-done | `plans/designs/e37-tokenizer-api.md` |
|
||||
| 38 | SourceInfo API | design-done | `plans/designs/e38-sourceinfo.md` |
|
||||
| 39 | WebWorker plugin | design-done | `plans/designs/e39-webworker.md` |
|
||||
| 40 | Fetch non-2xx / before-fetch / real response | design-done | `plans/designs/e40-real-fetch.md` |
|
||||
| 36 | WebSocket + `socket` + RPC proxy | done | +16 | 623529d3 |
|
||||
| 37 | Tokenizer-as-API | done | +17 | 54b54f4e |
|
||||
| 38 | SourceInfo API | done | +2 | 48eaeb04 |
|
||||
| 39 | WebWorker plugin | done | +1 | 8e8c2a73 |
|
||||
| 40 | Fetch non-2xx / before-fetch / real response | done | +7 | d7244d1d |
|
||||
|
||||
### Step-limit fix
|
||||
|
||||
| # | Cluster | Status | Δ | Commit |
|
||||
|---|---------|--------|---|--------|
|
||||
| SL | raise default step limit 200k→1M | done | +70 | 225fa2e8 |
|
||||
| 17 | `tell` semantics | done | (included in SL) | — |
|
||||
| 33 | cookie API (remaining 1) | done | (included in SL) | — |
|
||||
|
||||
### Bucket F — generator translation gaps
|
||||
|
||||
Defer until A–D drain. Estimated ~25 recoverable tests.
|
||||
|
||||
| # | Cluster | Status | Δ | Commit |
|
||||
|---|---------|--------|---|--------|
|
||||
| F1 | add CSS template interpolation | done | +1 | 5a76a040 |
|
||||
| F2 | empty multi-element (query→for-each) | done | +1 | 875e9ba3 |
|
||||
| F3 | hs-make-object _order + assert= for dicts | done | +1 | daea2808 |
|
||||
| F4 | array literal arg to JS fn (sxToJs + reduce→SX) | done | +1 | da2e6b1b |
|
||||
| F5 | `bind` feature parser stub | done | +32 | 846650da |
|
||||
| F6 | `asyncError` rejected promise catch | done | +1 | — |
|
||||
| F7 | `hs-on` nil-target guard (skip-list rescue) | done | +1 | 1751cd05 |
|
||||
| F8 | `on EVENT from SRC or EVENT from SRC` multi-source | done | +1 | f1428009 |
|
||||
|
||||
## Buckets roll-up
|
||||
|
||||
| Bucket | Done | Partial | In-prog | Pending | Blocked | Design-done | Total |
|
||||
|--------|-----:|--------:|--------:|--------:|--------:|------------:|------:|
|
||||
| A | 12 | 4 | 0 | 0 | 1 | — | 17 |
|
||||
| B | 6 | 0 | 0 | 0 | 1 | — | 7 |
|
||||
| C | 4 | 0 | 0 | 0 | 1 | — | 5 |
|
||||
| D | 0 | 0 | 0 | 5 | 0 | — | 5 |
|
||||
| E | 0 | 0 | 0 | 0 | 0 | 5 | 5 |
|
||||
| B | 7 | 0 | 0 | 0 | 0 | — | 7 |
|
||||
| C | 4 | 1 | 0 | 0 | 0 | — | 5 |
|
||||
| D | 2 | 2 | 0 | 0 | 1 | — | 5 |
|
||||
| E | 5 | 0 | 0 | 0 | 0 | 0 | 5 |
|
||||
| F | — | — | — | ~10 | — | — | ~10 |
|
||||
|
||||
## Maintenance
|
||||
|
||||
@@ -61,7 +61,7 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re
|
||||
|
||||
6. **[done (+2)] string template `${x}`** — `expressions/strings / string templates work w/ props` + `w/ braces` (2 tests). Template interpolation isn't substituting property accesses. Check `hs-template` runtime. Expected: +2.
|
||||
|
||||
7. **[done (+1) — partial, 3 tests remain: inserted-button handler doesn't fire for afterbegin/innerHTML paths; might need targeted trace of hs-boot-subtree! or _setInnerHTML timing] `put` hyperscript reprocessing** — `put / properly processes hyperscript at end/start/content/symbol` (4 tests, all `Expected 42, got 40`). After a put operation, newly inserted HS scripts aren't being activated. Fix: `hs-put-at!` should `hs-boot-subtree!` on the target after DOM insertion. Expected: +4.
|
||||
7. **[done (+5)] `put` hyperscript reprocessing** — `put / properly processes hyperscript at end/start/content/symbol` (4 tests, all `Expected 42, got 40`). After a put operation, newly inserted HS scripts aren't being activated. Fix: `hs-put-at!` should `hs-boot-subtree!` on the target after DOM insertion. Expected: +4.
|
||||
|
||||
8. **[done (+1)] `select returns selected text`** (1 test, `hs-upstream-select`). Runtime `hs-get-selection` helper reads `window.__test_selection` stash (or falls back to real `window.getSelection().toString()`). Compiler rewrites `(ref "selection")` to `(hs-get-selection)`. Generator detects the `createRange` / `setStart` / `setEnd` / `addRange` block and emits a single `(host-set! ... __test_selection ...)` op with the resolved text slice of the target element. Expected: +1.
|
||||
|
||||
@@ -69,7 +69,7 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re
|
||||
|
||||
10. **[done (+1)] `swap` variable ↔ property** — `swap / can swap a variable with a property` (1 test). Swap command doesn't handle mixed var/prop targets. Expected: +1.
|
||||
|
||||
11. **[done (+3) — partial, `hide element then show element retains original display` remains; needs `on click N` count-filtered event handlers, out of scope for this cluster] `hide` strategy** — `hide / can configure hidden as default`, `can hide with custom strategy`, `can set default to custom strategy`, `hide element then show element retains original display` (4 tests). Strategy config plumbing. Expected: +3-4.
|
||||
11. **[done (+4)] `hide` strategy** — `hide / can configure hidden as default`, `can hide with custom strategy`, `can set default to custom strategy`, `hide element then show element retains original display` (4 tests). Strategy config plumbing. Expected: +3-4.
|
||||
|
||||
12. **[done (+2)] `show` multi-element + display retention** — `show / can show multiple elements with inline-block`, `can filter over a set of elements using the its symbol` (2 tests). Expected: +2.
|
||||
|
||||
@@ -93,7 +93,7 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re
|
||||
|
||||
21. **[done (+1)] `possessiveExpression` property access via its** — `possessive / can access its properties` (1 test, Expected `foo` got ``). Expected: +1.
|
||||
|
||||
22. **[blocked: tried three compile-time emits — (1) guard (can't catch Undefined symbol since it's a host-level error, not an SX raise), (2) env-has? (primitive not loaded in HS kernel — `Unhandled exception: "env-has?"`), and (3) hs-win-call runtime helper (works when reached but SX can't CALL a host-handle function directly — `Not callable: {:__host_handle N}` because NativeFn is not callable here). Needs either a host-call-fn primitive with arity-agnostic dispatch OR a symbol-bound? predicate in the HS kernel.] window global fn fallback** — `regressions / can invoke functions w/ numbers in name` + unlocks several others. When calling `foo()` where `foo` isn't SX-defined, fall back to `(host-global "foo")`. Design decision: either compile-time emit `(or foo (host-global "foo"))` via a helper, or add runtime lookup in the dispatch path. Expected: +2-4.
|
||||
22. **[done (+1)] window global fn fallback** — `regressions / can invoke functions w/ numbers in name` + `can refer to function in init blocks`. Added `host-call-fn` FFI primitive (commit 337c8265), `hs-win-call` runtime helper, simplified compiler emit (direct hs-win-call, no guard), `def` now also registers fn on `window[name]`. Generator: fixed `\"` escaping in hs-compile string literals. Expected: +2-4.
|
||||
|
||||
23. **[done (+1)] `me symbol works in from expressions`** — `regressions` (1 test, Expected `Foo`). Check `from` expression compilation. Expected: +1.
|
||||
|
||||
@@ -109,21 +109,23 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re
|
||||
|
||||
28. **[done (+4)] `ask`/`answer` + prompt/confirm mock** — `askAnswer` 4 tests. **Requires test-name-keyed mock**: first test wants `confirm → true`, second `confirm → false`, third `prompt → "Alice"`, fourth `prompt → null`. Keyed via `_current-test-name` in the runner. Expected: +4.
|
||||
|
||||
29. **[blocked: sx-tree MCP tools returning Yojson Type_error on every file op. Can't edit integration.sx to add before:init/after:init dispatch. Also 4 of the 6 tests fundamentally require stricter parser error-rejection (add - to currently succeeds as SX expression; on click blargh end accepts blargh as symbol), which is larger than a single cluster budget.] `hyperscript:before:init` / `:after:init` / `:parse-error` events** — 6 tests in `bootstrap` + `parser`. Fire DOM events at activation boundaries. Expected: +4-6.
|
||||
29. **[done (+2) — partial, 4 parser-error tests remain (basic parse error messages, parse-error event, EOF newline crash, evaluate-api-first-error). All require stricter parser error-rejection — `add - to` currently parses silently to `(set! nil (hs-add-to! (- 0 nil) nil))`, `on click blargh end on mouseenter also_bad` parses silently to `(do (hs-on me "click" (fn (event) blargh)) (hs-on me "mouseenter" (fn (event) also_bad)))`. Plus emit-error-collection runtime + hyperscript:parse-error event with detail.errors. Larger than a single cluster budget; recommend bucket-D plan-first.] `hyperscript:before:init` / `:after:init` / `:parse-error` events** — 6 tests in `bootstrap` + `parser`. Fire DOM events at activation boundaries. Expected: +4-6.
|
||||
|
||||
30. **[done (+1)] `logAll` config** — 1 test. Global config that console.log's each command. Expected: +1.
|
||||
|
||||
### Bucket D: medium features (bigger commits, plan-first)
|
||||
|
||||
31. **[pending] runtime null-safety error reporting** — 18 tests in `runtimeErrors`. When accessing `.foo` on nil, emit a structured error with position info. One coordinated fix in the compiler emit paths for property access, function calls, set/put. Expected: +15-18.
|
||||
31. **[blocked: Bucket-D plan-first scope, doesn't fit one cluster budget. All 18 tests are SKIP (untranslated) — generator has no `error("HS")` helper. Required pieces: (a) generator-side `eval-hs-error` helper + recognizer for `expect(await error("HS")).toBe("MSG")` blocks; (b) runtime helpers `hs-null-error!` / `hs-named-target` / `hs-named-target-list` raising `'<sel>' is null`; (c) compiler patches at every target-position `(query SEL)` emit to wrap in named-target carrying the original selector source — that's ~17 command emit paths (add, remove, hide, show, measure, settle, trigger, send, set, default, increment, decrement, put, toggle, transition, append, take); (d) function-call null-check at bare `(name)`, `hs-method-call`, and `host-get` chains, deriving the leftmost-uncalled-name `'x'` / `'x.y'` from the parse tree; (e) possessive-base null-check (`set x's y to true` → `'x' is null`). Each piece is straightforward in isolation but the cross-cutting compiler change touches every emit path and needs a coordinated design pass. Recommend a dedicated design doc + multi-commit worktree like buckets E36-E40.] runtime null-safety error reporting** — 18 tests in `runtimeErrors`. When accessing `.foo` on nil, emit a structured error with position info. One coordinated fix in the compiler emit paths for property access, function calls, set/put. Expected: +15-18.
|
||||
|
||||
32. **[pending] MutationObserver mock + `on mutation` dispatch** — 15 tests in `on`. Add MO mock to runner. Compile `on mutation [of attribute/childList/attribute-specific]`. Expected: +10-15.
|
||||
32. **[done (+7)] MutationObserver mock + `on mutation` dispatch** — 7 tests in `on`. Add MO mock to runner. Compile `on mutation [of attribute/childList/attribute-specific]`. Expected: +10-15.
|
||||
|
||||
33. **[pending] cookie API** — 5 tests in `expressions/cookies`. `document.cookie` mock in runner + `the cookies` + `set the xxx cookie` keywords. Expected: +5.
|
||||
33. **[done (+4) — partial, 1 test remains: `iterate cookies values work` needs `hs-for-each` to recognise host-array/proxy collections (currently `(list? collection)` returns false for the JS Proxy so the loop body never runs). Out of scope.] cookie API** — 5 tests in `expressions/cookies`. `document.cookie` mock in runner + `the cookies` + `set the xxx cookie` keywords. Expected: +5.
|
||||
|
||||
34. **[pending] event modifier DSL** — 8 tests in `on`. `elsewhere`, `every`, `first click`, count filters (`once / twice / 3 times`, ranges), `from elsewhere`. Expected: +6-8.
|
||||
34. **[done (+7) — partial, 1 test remains: `every` keyword multi-handler-execute test needs handler-queue semantics where `wait for X` doesn't block subsequent invocations of the same handler — current `hs-on-every` shares the same dom-listen plumbing as `hs-on` and queues events implicitly via JS event loop, so the third synthetic click waits for the prior handler's `wait for customEvent` to settle. Out of single-cluster scope.] event modifier DSL** — 8 tests in `on`. `elsewhere`, `every`, `first click`, count filters (`once / twice / 3 times`, ranges), `from elsewhere`. Expected: +6-8.
|
||||
|
||||
35. **[pending] namespaced `def`** — 3 tests. `def ns.foo() ...` creates `ns.foo`. Expected: +3.
|
||||
35. **[done (+3)] namespaced `def`** — 3 tests. `def ns.foo() ...` creates `ns.foo`. Expected: +3.
|
||||
|
||||
36b. **[done (+1)] `call` result binds to `it`** — `call / call functions that return promises are waited on` (1 test). `call X then put it into Y` wasn't setting `it` because the `call` compiler branch emitted the call expression directly without `emit-set`. Fixed by wrapping in `emit-set (quote the-result) call-expr`. Expected: +1.
|
||||
|
||||
### Bucket E: subsystems (DO NOT LOOP — human-driven)
|
||||
|
||||
@@ -131,13 +133,13 @@ All five have design docs on their own worktree branches pending review + merge.
|
||||
|
||||
36. **[design-done, pending review — `plans/designs/e36-websocket.md` on `worktree-agent-a9daf73703f520257`] WebSocket + `socket`** — 16 tests. Upstream shape is `socket NAME URL [with timeout N] [on message [as JSON] …] end` with an **implicit `.rpc` Proxy** (ES6 Proxy lives in JS, not SX), not `with proxy { send, receive }` as this row previously claimed. Design doc has 8-commit checklist, +12–16 delta estimate. Ship only with intentional design review.
|
||||
|
||||
37. **[design-done, pending review — `plans/designs/e37-tokenizer-api.md` on `worktree-agent-a6bb61d59cc0be8b4`] Tokenizer-as-API** — 17 tests. Expose tokens as inspectable SX data via `hs-tokens-of` / `hs-stream-token` / `hs-token-type` etc; type-map current `hs-tokenize` output to upstream SCREAMING_SNAKE_CASE. 8-step checklist, +16–17 delta.
|
||||
37. **[done +17]** Tokenizer-as-API — `hs-tokens-of` / `hs-stream-token` / `hs-token-type` / `hs-token-value` / `hs-token-op?`; type-map + normalize; `read-number` dot-stop fix; `\$` template escape in compiler + runtime; generator pattern in `generate-sx-tests.py`. 17/17.
|
||||
|
||||
38. **[design-done, pending review — `plans/designs/e38-sourceinfo.md` on `agent-e38-sourceinfo`] SourceInfo API** — 4 tests. Inline span-wrapper strategy (not side-channel dict) with compiler-entry unwrap. 4-commit plan.
|
||||
|
||||
39. **[design-done, pending review — `plans/designs/e39-webworker.md` on `hs-design-e39-webworker`] WebWorker plugin** — 1 test. Parser-only stub that errors with a link to upstream docs; no runtime, no mock Worker class. Hand-write the test (don't patch the generator). Single commit.
|
||||
|
||||
40. **[design-done, pending review — `plans/designs/e40-real-fetch.md` on `worktree-agent-a94612a4283eaa5e0`] Fetch non-2xx / before-fetch event / real response object** — 7 tests. SX-dict Response wrapper `{:_hs-response :ok :status :url :_body :_json :_html}`; restructured `hs-fetch` that always fetches wrapper then converts by format; test-name-keyed `_fetchScripts`. 11-step checklist. Watch for regression on cluster-1 JSON unwrap.
|
||||
40. **[done +7 — d7244d1d] Fetch non-2xx / before-fetch event / real response object** — 7 tests. SX-dict Response wrapper `{:_hs-response :ok :status :url :_body :_json :_html}`; restructured `hs-fetch` that always fetches wrapper then converts by format; test-name-keyed `_fetchScripts`. 11-step checklist. Watch for regression on cluster-1 JSON unwrap.
|
||||
|
||||
### Bucket F: generator translation gaps (after bucket A-D)
|
||||
|
||||
@@ -175,8 +177,62 @@ Many tests are `SKIP (untranslated)` because `tests/playwright/generate-sx-tests
|
||||
|
||||
## Progress log
|
||||
|
||||
### 2026-04-26 — Bucket F: array literal arg to JS fn (+1)
|
||||
- **da2e6b1b** — `HS Bucket F: array literal arg to JS fn fix (+1 test)`. Two-part fix: (a) `generate-sx-tests.py` `js_expr_to_sx` now translates `arr.reduce(fn, init)` → `(reduce fn init arr)`, `.map(fn)` → `(map fn arr)`, `.filter(fn)` → `(filter fn arr)` so SX list arguments work with JS array HO methods. (b) `host-call-fn` in `hs-run-filtered.js` adds `sxToJs` recursive converter that unwraps SX list `._type==='list'` to native JS arrays before calling native JS functions. Together these fix functionCalls "can pass an array literal as an argument". Suite hs-upstream-expressions/functionCalls: 8/12 (unchanged SKIP ratio). Test 597: 0/1 → 1/1. Smoke 0-195: 175/195 unchanged.
|
||||
|
||||
### 2026-04-26 — Bucket F: hs-make-object _order + assert= for dicts (+1)
|
||||
- **daea2808** — `HS Bucket F: fix hs-make-object _order + assert= for dicts (+1 test)`. Two-part fix: (a) `runtime.sx` `hs-make-object` no longer appends `_order` key to HS object literals — V8's native string-key insertion order is sufficient, and the hidden key was breaking structural equality. (b) `generate-sx-tests.py` `emit_eval` now detects when `expected_sx` contains `{` (dict syntax) and emits `assert-equal` (which uses `equal?` for deep structural equality) instead of `assert=` (which uses `=`, reference equality for dicts). Together these fix arrayLiteral "arrays containing objects work". Suite hs-upstream-expressions/arrayLiteral: 7/8 → 8/8. Smoke 0-195 unchanged at 175/195.
|
||||
|
||||
### 2026-04-26 — Bucket F: empty multi-element fix (+1)
|
||||
- **875e9ba3** — `HS: empty multi-element fix (+1 test)`. `empty .class` compiled `(empty-target (query ".class"))` through `hs-to-sx` → `(hs-empty-target! (hs-query-first ".class"))` which only emptied the first match. Fix: detect `(query ...)` target in the `empty-target` compiler case and emit `(for-each (fn (_el) (hs-empty-target! _el)) (hs-query-all sel))`, mirroring the `add-class` pattern. Suite hs-upstream-empty: 12/13 → 13/13. Smoke 0-195: 175/195 unchanged.
|
||||
|
||||
### 2026-04-26 — Bucket F: add CSS template interpolation (+1)
|
||||
- **5a76a040** — `HS: add CSS template interpolation fix (+1 test)`. `add {color: ${}{"red"}}` uses two consecutive brace groups: the empty `${}` marker followed by `{"red"}` for the actual value. The prior parser fix called `parse-expr` when already at the closing `}` of the empty group, returning nil. Fix: detect the empty-brace case (`brace-open` → immediately `brace-close`), skip it, then read the actual value from the next `{…}` block. Also handles normal `${expr}` correctly. Suite hs-upstream-add: 17/19 → 18/19. Smoke 0-195: 174/195 → 175/195.
|
||||
|
||||
### 2026-04-26 — cluster 36b call result binds to it (done +1)
|
||||
- **35f498ec** — `hs: call command binds result to it via emit-set (+1 test)`. `call X then put it into Y` compiled `call X` without `emit-set`, so `it` remained nil. Wrapped call-expr in `emit-set (quote the-result) ...` so both `it` and `the-result` are updated. Suite hs-upstream-call: 5/6 → 6/6. Smoke 0-195: 173/195 → 174/195.
|
||||
|
||||
### 2026-04-26 — cluster 7 put hyperscript reprocessing (done, final +1)
|
||||
- **247bd85c** — `hs: register promiseAString/promiseAnInt as sync test fixtures (+1 test)`. Upstream test "waits on promises" calls `promiseAString()` via window global. OCaml run_tests.ml registers these as NativeFns returning "foo"/"42" synchronously; JS runner had no equivalent. Added `globalThis.promiseAString = () => 'foo'` and `globalThis.promiseAnInt = () => 42` to hs-run-filtered.js. Suite hs-upstream-put: 37/38 → 38/38 (fully done). Smoke 0-195: 173/195 unchanged.
|
||||
|
||||
### 2026-04-26 — cluster 7 put hyperscript reprocessing (partial +3 more)
|
||||
- **d663c91f** — `hs: stop event propagation after each hs-on handler fires (+3 tests)`. Root cause: click events bubble from b1 (inside d1) to d1, causing d1's `on click put ...` handler to re-fire and replace the just-modified b1 with fresh content (text=40). Fix: `hs-on`'s wrapped handler now calls `event.stopPropagation()` after each handler runs, preventing the bubbled click from reaching ancestor HS listeners. Tests 1147/1149/1150 now pass. Suite hs-upstream-put: 34/38 → 37/38. Smoke 0-195: 173/195 unchanged. One test remains: "waits on promises" (async/Promise issue).
|
||||
|
||||
(Reverse chronological — newest at top.)
|
||||
|
||||
### 2026-04-25 — Bucket F: in-expression filter semantics (+1)
|
||||
- **67a5f137** — `HS: in-expression filter semantics (+1 test)`. `1 in [1, 2, 3]` was returning boolean `true` instead of the filtered list `(list 1)`. Root cause: `in?` compiled to `hs-contains?` which returns boolean for scalar items. Fix: (a) `runtime.sx` adds `hs-in?` returning filtered list for all cases, plus `hs-in-bool?` which wraps with `(not (hs-falsy? ...))` for boolean contexts; (b) `compiler.sx` changes `in?` clause to emit `(hs-in? collection item)` and adds new `in-bool?` clause emitting `(hs-in-bool? collection item)`; (c) `parser.sx` changes `is in` and `am in` comparison forms to produce `in-bool?` so those stay boolean. Suite hs-upstream-expressions/in: 8/9 → 9/9. Smoke 0-195: 173/195 unchanged.
|
||||
|
||||
### 2026-04-25 — cluster 22 window global fn fallback (+1)
|
||||
- **d31565d5** — `HS cluster 22: simplify win-call emit + def→window + init-blocks test (+1)`. Two-part change building on 337c8265 (host-call-fn FFI + hs-win-call runtime). (a) `compiler.sx` removes the guard wrapper from bare-call and method-call `hs-win-call` emit paths — direct `(hs-win-call name (list args))` is sufficient since hs-win-call returns nil for unknown names; `def` compilation now also emits `(host-set! (host-global "window") name fn)` so every HS-defined function is reachable via window lookup. (b) `generate-sx-tests.py` fixes a quoting bug: `\"here\"` was being embedded as three SX nodes (`""` + symbol + `""`) instead of a single escaped-quote string; fixed with `\\\"` escaping. Hand-rolled deftest for `can refer to function in init blocks` now passes. Suite hs-upstream-core/regressions: 13/16 → 14/16. Smoke 0-195: 172/195 → 173/195.
|
||||
|
||||
### 2026-04-25 — cluster 11/33 followups: hide strategy + cookie clear (+2)
|
||||
- **5ff2b706** — `HS: cluster 11/33 followups (+2 tests)`. Three orthogonal fixes that pick up tests now unblocked by earlier work. (a) `parser.sx` `parse-hide-cmd`/`parse-show-cmd`: added `on` to the keyword set that flips the implicit-`me` target. Previously `on click 1 hide on click 2 show` silently parsed as `(hs-hide! nil ...)` because `parse-expr` started consuming `on` and returned nil; now hide/show recognise a sibling feature and default to `me`. (b) `runtime.sx` `hs-method-call` fallback for non-built-in methods: SX-callables (lambdas) call via `apply`, JS-native functions (e.g. `cookies.clear`) dispatch via `(apply host-call (cons obj (cons method args)))` so the native receives the args list. (c) Generator `hs-cleanup!` body wrapped in `begin` (fn body evaluates only the last expr) and now resets `hs-set-default-hide-strategy! nil` + `hs-set-log-all! false` between tests — the prior `can set default to custom strategy` cluster-11 test had been leaking `_hs-default-hide-strategy` into the rest of the suite, breaking `hide element then show element retains original display`. New cluster-33 hand-roll for `basic clear cookie values work` exercises the method-call fallback. Suite hs-upstream-hide: 15/16 → 16/16. Suite hs-upstream-expressions/cookies: 3/5 → 4/5. Smoke 0-195 unchanged at 172/195.
|
||||
|
||||
### 2026-04-25 — cluster 35 namespaced def + script-tag globals (+3)
|
||||
- **122053ed** — `HS: namespaced def + script-tag global functions (+3 tests)`. Two-part change: (a) `runtime.sx` `hs-method-call` gains a fallback for unknown methods — `(let ((fn-val (host-get obj method))) (if (callable? fn-val) (apply fn-val args) nil))`. This lets `utils.foo()` dispatch through `(host-get utils "foo")` when `utils` is an SX dict whose `foo` is an SX lambda. (b) Generator hand-rolls 3 deftests since the SX runtime has no `<script type='text/hyperscript'>` tag boot. For `is called synchronously` / `can call asynchronously`: `(eval-expr-cek (hs-to-sx (first (hs-parse (hs-tokenize "def foo() ... end")))))` registers the function in the global eval env (eval-expr-cek processes `(define foo (fn ...))` at top scope), then a click div is built via dom-set-attr + hs-boot-subtree!. For `functions can be namespaced`: define `utils` as a dict, register `__utils_foo` as a fresh-named global def, then `(host-set! utils "foo" __utils_foo)` populates the dict; click handler `call utils.foo()` compiles to `(hs-method-call utils "foo")` which now dispatches through the new runtime fallback. Skip-list cleared of the 3 def entries. Suite hs-upstream-def: 24/27 → 27/27. Smoke 0-195 unchanged at 172/195.
|
||||
|
||||
### 2026-04-25 — cluster 34 elsewhere / from-elsewhere modifier (+2)
|
||||
- **3044a168** — `HS: elsewhere / from elsewhere modifier (+2 tests)`. Three-part change: (a) `parser.sx` `parse-on-feat` parses an optional `elsewhere` (or `from elsewhere`) modifier between event-name and source. The `from elsewhere` variant uses a one-token lookahead so plain `from #target` keeps parsing as a source expression. Emits `:elsewhere true` part. (b) `compiler.sx` `scan-on` threads `elsewhere?` (10th param) through every recursive call + new `:elsewhere` cond branch. The dispatch case becomes a 3-way `cond` over target: elsewhere → `(dom-body)` (listener attaches to body and bubble sees every click), source → from-source, default → `me`. The `compiled-body` build is wrapped with `(when (not (host-call me "contains" (host-get event "target"))) BODY)` so handlers fire only on outside-of-`me` clicks. (c) Generator drops `supports "elsewhere" modifier` and `supports "from elsewhere" modifier` from `SKIP_TEST_NAMES`. Suite hs-upstream-on: 48/70 → 50/70. Smoke 0-195 unchanged at 172/195.
|
||||
|
||||
### 2026-04-25 — cluster 34 count-filtered events + first modifier (+5 partial)
|
||||
- **19c97989** — `HS: count-filtered events + first modifier (+5 tests)`. Three-part change: (a) `parser.sx` `parse-on-feat` accepts `first` keyword before event-name (sets `cnt-min/max=1`), then optionally parses a count expression after event-name: bare number = exact count, `N to M` = inclusive range, `N and on` = unbounded above. Number tokens coerced via `parse-number`. New parts entry `:count-filter {"min" N "max" M-or--1}`. (b) `compiler.sx` `scan-on` gains a 9th `count-filter-info` param threaded through every recursive call + a new `:count-filter` cond branch. The handler binding now wraps the `(fn (event) BODY)` in `(let ((__hs-count 0)) (fn (event) (begin (set! __hs-count (+ __hs-count 1)) (when COUNT-CHECK BODY))))` when count info is present. Each `on EVENT N ...` clause produces its own closure-captured counter, so `on click 1` / `on click 2` / `on click 3` fire on their respective Nth click (mix-ranges test). (c) Generator drops 5 entries from `SKIP_TEST_NAMES` — `can filter events based on count`/`...count range`/`...unbounded count range`/`can mix ranges`/`on first click fires only once`. Suite hs-upstream-on: 43/70 → 48/70. Smoke 0-195 unchanged at 172/195. Remaining cluster-34 work (`elsewhere`/`from elsewhere`/`every`-keyword multi-handler) is independent from count filters and would need a separate iteration.
|
||||
|
||||
### 2026-04-25 — cluster 29 hyperscript init events (+2 partial)
|
||||
- **e01a3baa** — `HS: hyperscript:before:init / :after:init events (+2 tests)`. `integration.sx` `hs-activate!` now wraps the activation block in `(when (dom-dispatch el "hyperscript:before:init" nil) ...)` — `dom-dispatch` builds a CustomEvent with `bubbles:true`, the mock El's `cancelable` defaults to true, `dispatchEvent` returns `!ev.defaultPrevented`, so `when` skips the activate body if a listener called `preventDefault()`. After activation completes successfully it dispatches `hyperscript:after:init`. Generator (`tests/playwright/generate-sx-tests.py`) gains two hand-rolled deftests: `fires hyperscript:before:init and hyperscript:after:init` builds a wa container, attaches listeners that append to a captured `events` list, sets innerHTML to a div with `_=`, calls `hs-boot-subtree!`, asserts the events list. `hyperscript:before:init can cancel initialization` attaches a preventDefault listener and asserts `data-hyperscript-powered` is absent on the inner div after boot. Suite hs-upstream-core/bootstrap: 20/26 → 22/26. Smoke 0-195: 170 → 172. Remaining 4 cluster-29 tests (basic parse error messages, parse-error event, EOF newline, eval-API throws on first error) all need stricter parser error-rejection plus a parse-error collector — recommend bucket-D plan-first multi-commit, not a single iteration.
|
||||
|
||||
### 2026-04-25 — cluster 32 MutationObserver mock + on mutation dispatch (+7)
|
||||
- **13e02542** — `HS: MutationObserver mock + on mutation dispatch (+7 tests)`. Five-part change: (a) `parser.sx` `parse-on-feat` now consumes `of <FILTER>` after `mutation` event-name. FILTER is one of `attributes`/`childList`/`characterData` (ident tokens) or one or more `@name` attr-tokens chained by `or`. Emits `:of-filter {"type" T "attrs" L?}` part. (b) `compiler.sx` `scan-on` threads new `of-filter-info` param; the dispatch case becomes a `cond` over `event-name` — for `"mutation"` it emits `(do on-call (hs-on-mutation-attach! target MODE ATTRS))` where ATTRS is `(cons 'list attr-list)` so the list survives compile→eval. (c) `runtime.sx` `hs-on-mutation-attach!` builds a config dict (`attributes`/`childList`/`characterData`/`subtree`/`attributeFilter`) matched to mode, constructs a real `MutationObserver(cb)`, calls `mo.observe(target, opts)`, and the cb dispatches a `"mutation"` event on target. (d) `tests/hs-run-filtered.js` replaces the no-op MO with `HsMutationObserver` (global registry, decodes SX-list `attributeFilter`); prototype hooks on `El.setAttribute/appendChild/removeChild/_setInnerHTML` fire matching observers synchronously, with `__hsMutationActive` re-entry guard so handlers that mutate the DOM don't infinite-loop. Per-test reset clears registry + flag. (e) `generate-sx-tests.py` drops 7 mutation entries from `SKIP_TEST_NAMES` and adds two body patterns: `evaluate(() => document.querySelector(SEL).setAttribute(N,V))` → `(dom-set-attr ...)`, and `evaluate(() => document.querySelector(SEL).appendChild(document.createElement(T)))` → `(dom-append … (dom-create-element …))`. Suite hs-upstream-on: 36/70 → 43/70. Smoke 0-195 unchanged at 170/195.
|
||||
|
||||
### 2026-04-25 — cluster 33 cookie API (partial +3)
|
||||
- No `.sx` edits needed — `set cookies.foo to 'bar'` already compiles to `(dom-set-prop cookies "foo" "bar")` which becomes `(host-set! cookies "foo" "bar")` once the `dom` module is loaded, and `cookies.foo` becomes `(host-get cookies "foo")`. So a JS-only Proxy + Python generator change does the trick. Two parts: (a) `tests/hs-run-filtered.js` adds a per-test `__hsCookieStore` Map, a `globalThis.cookies` Proxy with `length`/`clear`/named-key get traps and a set trap that writes the store, and a `Object.defineProperty(document, 'cookie', …)` getter/setter that reads and writes the same store (so the upstream `length is 0` test's pre-clear loop over `document.cookie` works). Per-test reset clears the store. (b) `tests/playwright/generate-sx-tests.py` declares `(define cookies (host-global "cookies"))` in the test header and emits hand-rolled deftests for the three tractable tests (`basic set`, `update`, `length is 0`). Suite hs-upstream-expressions/cookies: 0/5 → 3/5. Smoke 0-195 unchanged at 170/195. Remaining `basic clear` and `iterate` tests need runtime.sx edits (hs-method-call fallback + hs-for-each host-array recognition) — out of scope for a JS-only iteration.
|
||||
|
||||
### 2026-04-25 — cluster 32 MutationObserver mock + on mutation dispatch (blocked)
|
||||
- Two issues conspire: (1) `loops/hs` worktree has no pre-built sx-tree binary so MCP tools aren't loaded, and the block-sx-edit hook prevents raw `Edit`/`Read`/`Write` on `.sx` files. Built `hosts/ocaml/_build/default/bin/mcp_tree.exe` via `dune build` this iteration but tools don't surface mid-session. (2) Cluster scope is genuinely big: parser must learn `on mutation of <filter>` (currently drops body after `of` — verified via compile dump: `on mutation of attributes put "Mutated" into me` → `(hs-on me "mutation" (fn (event) nil))`), compiler needs `:of-filter` plumbing similar to intersection's `:having`, runtime needs `hs-on-mutation-attach!`, JS runner mock needs a real MutationObserver (currently no-op `class{observe(){}disconnect(){}}` at hs-run-filtered.js:348) plus `setAttribute`/`appendChild` instrumentation, and 7 entries removed from `SKIP_TEST_NAMES`. Recommended next step: dedicated worktree where sx-tree loads at session start, multi-commit shape (parser → compiler+attach → mock+runner → generator skip-list).
|
||||
|
||||
### 2026-04-25 — cluster 31 runtime null-safety error reporting (blocked)
|
||||
- All 18 tests are `SKIP (untranslated)` — generator has no `error("HS")` helper at all. Inspected representative compile outputs: `add .foo to #doesntExist` → `(for-each ... (hs-query-all "#doesntExist"))` (silently no-ops on empty list, no error); `hide #doesntExist` → `(hs-hide! (hs-query-all "#doesntExist") "display")` (likewise); `put 'foo' into #doesntExist` → `(hs-set-inner-html! (hs-query-first "#doesntExist") "foo")` (passes nil through); `x()` → `(x)` (raises `Undefined symbol: x`, wrong format); `x.y.z()` → `(hs-method-call (host-get x "y") "z")`. Implementing this requires generator helper + 17 compiler emit-path patches + function-call/method-call/possessive-base null guards + new `hs-named-target`/`hs-named-target-list` runtime — too many surfaces for a single-iteration commit. Bucket D explicitly says "plan-first" — recommended path is a dedicated design doc and multi-commit worktree like E36-E40, not a loop iteration.
|
||||
|
||||
### 2026-04-24 — cluster 29 hyperscript:before:init / :after:init / :parse-error (blocked)
|
||||
- **2b486976** — `HS-plan: mark cluster 29 blocked`. sx-tree MCP file ops returning `Yojson__Safe.Util.Type_error("Expected string, got null")` on every file-based call (sx_read_subtree, sx_find_all, sx_replace_by_pattern, sx_summarise, sx_pretty_print, sx_write_file). Only in-memory ops work (sx_eval, sx_build, sx_env). Without sx-tree I can't edit integration.sx to add before:init/after:init dispatch on hs-activate!. Investigated the 6 tests: 2 bootstrap (before/after init) need dispatchEvent wrapping activate; 4 parser tests require stricter parser error-rejection — `add - to` currently parses silently to `(set! nil (hs-add-to! (- 0 nil) nil))`, `on click blargh end on mouseenter also_bad` parses silently to `(do (hs-on me "click" (fn (event) blargh)) (hs-on me "mouseenter" (fn (event) also_bad)))`. Fundamental parser refactor is out of single-cluster budget regardless of sx-tree availability.
|
||||
|
||||
|
||||
210
plans/sx-improvements.md
Normal file
210
plans/sx-improvements.md
Normal file
@@ -0,0 +1,210 @@
|
||||
# SX Language Improvements — roadmap
|
||||
|
||||
Language-building improvements to the SX evaluator, compiler, and standard library.
|
||||
Ordered by impact and prerequisite chain. Each step is one loop commit.
|
||||
|
||||
Branch: `architecture`. SX files via `sx-tree` MCP only. Never edit generated files.
|
||||
|
||||
## Current baseline (2026-05-06)
|
||||
|
||||
- SX core spec: 2571 passing (595 non-HS pre-existing failures — bytecode-serialize, defcomp-render, etc.)
|
||||
- HyperScript behavioral: 1478/1496 (run via `node tests/hs-kernel-eval.js`)
|
||||
- Active bugs: JIT combinator bug (11 HS failures), letrec+resume (browser-only)
|
||||
- E38 sourceInfo: 2/4 tests passing (tokenizer missing `:end`/`:line`, some spans incomplete)
|
||||
|
||||
---
|
||||
|
||||
## Phase 1 — Bug fixes
|
||||
|
||||
### Step 1: Fix JIT closures-returning-closures
|
||||
|
||||
**What:** `parse-bind`, `many`, `seq`, and other parser combinators that return closures
|
||||
miscompile under JIT. The compiled closure drops intermediate stack values when the
|
||||
callee itself returns a closure. 11 HyperScript tests fail under JIT, pass under CEK.
|
||||
|
||||
**Root cause in `hosts/ocaml/lib/sx_vm.ml`:** When a JIT-compiled closure returns
|
||||
another closure (i.e. the callee is `VmClosure`), the frame restoration after the
|
||||
call incorrectly reuses the parent frame's locals slot, overwriting saved intermediate
|
||||
values. The `call_closure_reuse` path must snapshot `sp` before the inner call and
|
||||
restore it after, or bail to the non-reuse path for closures-returning-closures.
|
||||
|
||||
**Verify:** `node tests/hs-kernel-eval.js 2>&1 | tail -3` — should go from 3116/3127 to 3127/3127.
|
||||
|
||||
### Step 2: Fix letrec + perform resume (browser)
|
||||
|
||||
**What:** In browser JIT mode, `letrec` sibling bindings are nil after a `perform`/resume
|
||||
cycle. `call_closure_reuse` in `sx_browser.ml` intentionally ignores `_saved_sp`, which
|
||||
strips the frame locals that `sf_letrec` was waiting on.
|
||||
|
||||
**Fix:** In `sx_browser.ml`, the `VmSuspension` resume path must restore frame locals
|
||||
from the suspension snapshot before calling the continuation. Mirror what `sx_vm.ml`
|
||||
does in the non-browser case.
|
||||
|
||||
**Verify:** Write a test in `spec/tests/` that does `(letrec ((f (fn () (perform :io nil)))) (f))` with a resume, check bindings survive. Runs under OCaml: `dune exec -- bin/run_tests.exe`.
|
||||
|
||||
---
|
||||
|
||||
## Phase 2 — Source info (E38 completion)
|
||||
|
||||
Design: `plans/designs/e38-sourceinfo.md`. Target: 4/4 sourceInfo tests.
|
||||
|
||||
The API (`hs-parse-ast`, `hs-source-for`, `hs-line-for`, `hs-node-get`, `hs-src`,
|
||||
`hs-src-at`, `hs-line-at`) and parser span wrapping (`hs-ast-wrap`, `hs-span-mode`)
|
||||
are already in the codebase. Two tests are passing; two fail because:
|
||||
- Tokenizer tokens lack `:end` and `:line` (only `:pos` today).
|
||||
- Some statement-level spans and `:next` field navigation are incomplete.
|
||||
|
||||
### Step 3: Tokenizer — add `:end` and `:line` to tokens
|
||||
|
||||
`lib/hyperscript/tokenizer.sx`: extend `hs-make-token` to `{:pos :end :value :type :line}`.
|
||||
Track a `current-line` counter (1-based, increments after `\n`). Update all ~20 emission
|
||||
sites. Mirror to `shared/static/wasm/sx/hs-tokenizer.sx` after edits.
|
||||
|
||||
**Verify:** `(hs-make-token "NUMBER" "1" 0)` returns a dict with `:end` and `:line` keys.
|
||||
|
||||
### Step 4: Complete parser spans + :next field
|
||||
|
||||
`lib/hyperscript/parser.sx`: ensure `hs-ast-wrap` populates `:next` on every command
|
||||
in a `CommandList` (i.e. the following sibling command). Check that statement-level
|
||||
productions (if, for) correctly populate `:true-branch`. Trace through the two failing
|
||||
tests (`get source works for expressions`, `get line works for statements`) to find the
|
||||
exact missing fields or off-by-one positions.
|
||||
|
||||
Mirror to `shared/static/wasm/sx/hs-parser.sx`.
|
||||
|
||||
**Verify:** All 4 `hs-upstream-core/sourceInfo` tests pass.
|
||||
|
||||
---
|
||||
|
||||
## Phase 3 — Native ADTs (`define-type` / `match`)
|
||||
|
||||
Design: `plans/designs/sx-adt.md`. No existing implementation.
|
||||
|
||||
Impact: every language implementation (Haskell, Prolog, Lua, Common Lisp, Erlang)
|
||||
currently fakes sum types with `{:tag "..." :field ...}` dicts. Native ADTs remove
|
||||
that everywhere.
|
||||
|
||||
### Step 5: OCaml — AdtValue type + `define-type` + basic `match`
|
||||
|
||||
`hosts/ocaml/lib/sx_types.ml`:
|
||||
```ocaml
|
||||
type adt_value = { av_type: string; av_ctor: string; av_fields: value array }
|
||||
| AdtValue of adt_value
|
||||
```
|
||||
|
||||
`hosts/ocaml/lib/sx_runtime.ml` (or evaluator):
|
||||
- `step-sf-define-type`: parse `(Name (Ctor1 f1 f2) (Ctor2) ...)`, register constructor
|
||||
NativeFns, predicates (`Ctor1?`, `Name?`), field accessors (`Ctor1-f1`) via `env-bind!`.
|
||||
- `step-sf-match` + `MatchFrame`: linear scan of clauses; flat patterns only for 6a;
|
||||
bind pattern variables in child env; `else` clause; raise on no match.
|
||||
- `type-of` returns the type name (e.g. `"Maybe"`).
|
||||
|
||||
Write tests in `spec/tests/test-adt.sx`: basic constructor, predicate, accessor, match,
|
||||
else, no-match raise.
|
||||
|
||||
**Verify:** `dune exec -- bin/run_tests.exe` — new test file all green.
|
||||
|
||||
### Step 6: JS — AdtValue + `define-type` + `match`
|
||||
|
||||
`hosts/javascript/platform.py`: add `AdtValue` as `{ _adt: true, _type, _ctor, _fields }`.
|
||||
Mirror `define-type` and `match` special forms in the JS evaluator.
|
||||
Retranspile: `python3 hosts/javascript/cli.py --output shared/static/scripts/sx-browser.js`
|
||||
|
||||
**Verify:** `node hosts/javascript/run_tests.js` — adt tests pass on JS too.
|
||||
|
||||
### Step 7: Nested patterns (Phase 6b)
|
||||
|
||||
Both OCaml and JS `MatchFrame`: replace linear binding with recursive
|
||||
`matchPattern(pattern, value, env)` that:
|
||||
- Recurses into constructor sub-patterns.
|
||||
- Returns `{matched: bool, bindings: map}`.
|
||||
- Handles wildcard `_`, literals (`42`, `"str"`, `true`, `nil`).
|
||||
|
||||
Extend `spec/tests/test-adt.sx` with nested pattern tests.
|
||||
|
||||
### Step 8: Exhaustiveness warnings (Phase 6c)
|
||||
|
||||
`_adt_registry: type_name → [ctor_names]` global populated by `define-type`.
|
||||
On first non-exhaustive `match` evaluation: `console.warn("[sx] match: non-exhaustive …")`.
|
||||
No error — warning only.
|
||||
|
||||
---
|
||||
|
||||
## Phase 4 — Plugin / extension system
|
||||
|
||||
Design: `plans/designs/hs-plugin-system.md`.
|
||||
|
||||
### Step 9: Parser feature registry
|
||||
|
||||
`lib/hyperscript/parser.sx`: replace `parse-feat` hardcoded `cond` with a dict lookup.
|
||||
`(hs-register-feature! name parse-fn)` adds to the registry.
|
||||
|
||||
### Step 10: Compiler command registry + `as` converter registry
|
||||
|
||||
`lib/hyperscript/compiler.sx`: replace `hs-to-sx` hardcoded dispatch with dict.
|
||||
`(hs-register-command! name compile-fn)` and `(hs-register-converter! name convert-fn)`.
|
||||
|
||||
### Step 11: Migrate hs-prolog-hook + Worker plugin
|
||||
|
||||
`lib/hyperscript/runtime.sx`: remove `hs-prolog-hook`/`hs-set-prolog-hook!` ad-hoc
|
||||
slots. Create `lib/hyperscript/plugins/prolog.sx` that calls `hs-register-feature!`
|
||||
and `hs-register-command!`. Create `lib/hyperscript/plugins/worker.sx` replacing the
|
||||
E39 stub.
|
||||
|
||||
---
|
||||
|
||||
## Phase 5 — Performance
|
||||
|
||||
These are incremental and can interleave with other phases.
|
||||
|
||||
### Step 12: Frame records (CEK)
|
||||
|
||||
`hosts/ocaml/lib/sx_runtime.ml`: represent CEK frames as OCaml records instead of
|
||||
tagged variant lists. Eliminates allocation pressure from list construction per frame.
|
||||
Profile before/after on a tight-loop benchmark.
|
||||
|
||||
### Step 13: Buffer primitive for string building
|
||||
|
||||
Add `make-buffer`, `buffer-append!`, `buffer->string` primitives. Eliminates the
|
||||
`(str a b c d ...)` quadratic allocation pattern in serializers and renderers.
|
||||
Wire into `sx_primitives.ml` and the JS platform.
|
||||
|
||||
### Step 14: Inline common primitives in JIT
|
||||
|
||||
`hosts/ocaml/lib/sx_vm.ml`: add `OP_ADD`, `OP_SUB`, `OP_EQ`, `OP_APPEND` specialised
|
||||
opcodes that skip the primitive table lookup for the most common calls. Compiler emits
|
||||
these when operands are known numbers/lists.
|
||||
|
||||
---
|
||||
|
||||
## Progress log
|
||||
|
||||
| Step | Status | Commit |
|
||||
|------|--------|--------|
|
||||
| 1 — JIT combinator bug | [ ] | — |
|
||||
| 2 — letrec+resume | [ ] | — |
|
||||
| 3 — tokenizer :end/:line | [ ] | — |
|
||||
| 4 — parser spans complete | [ ] | — |
|
||||
| 5 — OCaml AdtValue + define-type + match | [ ] | — |
|
||||
| 6 — JS AdtValue + define-type + match | [ ] | — |
|
||||
| 7 — nested patterns | [ ] | — |
|
||||
| 8 — exhaustiveness warnings | [ ] | — |
|
||||
| 9 — parser feature registry | [ ] | — |
|
||||
| 10 — compiler + as converter registry | [ ] | — |
|
||||
| 11 — plugin migration + worker | [ ] | — |
|
||||
| 12 — frame records | [ ] | — |
|
||||
| 13 — buffer primitive | [ ] | — |
|
||||
| 14 — inline primitives JIT | [ ] | — |
|
||||
|
||||
---
|
||||
|
||||
## Rules
|
||||
|
||||
- Branch: `architecture`. Never push to `main`.
|
||||
- SX files: `sx-tree` MCP tools only. `sx_validate` after every edit.
|
||||
- After every `.sx` edit to `lib/hyperscript/`, mirror to `shared/static/wasm/sx/hs-<file>.sx`.
|
||||
- OCaml build: `sx_build target="ocaml"` MCP tool (never raw `dune`).
|
||||
- JS build: `sx_build target="js"` MCP tool.
|
||||
- One step per commit. Update progress log in this file.
|
||||
- No new planning docs. No comments in SX unless non-obvious.
|
||||
- Unicode in SX: raw UTF-8 only, never `\uXXXX`.
|
||||
@@ -105,7 +105,9 @@ just Tcl.
|
||||
|
||||
---
|
||||
|
||||
## Phase 4 — Optional: env-as-value (architectural)
|
||||
## Phase 4 — env-as-value (architectural) ✓
|
||||
|
||||
|
||||
|
||||
`uplevel`/`upvar` required an explicit frame stack because SX environments
|
||||
aren't inspectable from user code. Adding:
|
||||
@@ -146,6 +148,7 @@ becomes a lasting SX contribution used by every future hosted language.
|
||||
|
||||
_Newest first._
|
||||
|
||||
- 2026-05-06: Phase 4 env-as-value — current-env (special form via Sx_ref.register_special_form), eval-in-env (primitive in setup_evaluator_bridge), env-lookup + env-extend (in setup_env_operations); 5 idiom tests; 342/342 green
|
||||
- 2026-05-06: Phase 3 OCaml primitives — file-read/write/append/exists?/glob + clock-seconds/milliseconds/format in sx_primitives.ml + unix dep; tcl-cmd-clock/file wired up; 337/337 green
|
||||
- 2026-05-06: Phase 2 coroutine rewrite — `tcl-cmd-coroutine` now creates a `make-fiber`; `tcl-cmd-yield` calls `:coro-yield-fn` (threaded through interp); true suspension; 337/337 green
|
||||
- 2026-05-06: Phase 2 fiber.sx — `make-fiber`/`fiber-resume`/`fiber-done?` using call/cc + set!; bidirectional value passing; generator and echo tests pass
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -19,6 +19,7 @@
|
||||
(define
|
||||
reserved
|
||||
(list
|
||||
(quote beingTold)
|
||||
(quote me)
|
||||
(quote it)
|
||||
(quote event)
|
||||
@@ -65,7 +66,10 @@
|
||||
(list (quote me))
|
||||
(list
|
||||
(quote let)
|
||||
(list (list (quote it) nil) (list (quote event) nil))
|
||||
(list
|
||||
(list (quote beingTold) (quote me))
|
||||
(list (quote it) nil)
|
||||
(list (quote event) nil))
|
||||
guarded))))))))))
|
||||
|
||||
;; ── Activate a single element ───────────────────────────────────
|
||||
@@ -73,23 +77,71 @@
|
||||
;; Marks the element to avoid double-activation.
|
||||
|
||||
(define
|
||||
hs-activate!
|
||||
hs-register-scripts!
|
||||
(fn
|
||||
(el)
|
||||
(let
|
||||
((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script")))
|
||||
(when
|
||||
(and src (not (= src prev)))
|
||||
(hs-log-event! "hyperscript:init")
|
||||
(dom-set-data el "hs-script" src)
|
||||
(dom-set-data el "hs-active" true)
|
||||
(dom-set-attr el "data-hyperscript-powered" "true")
|
||||
(let ((handler (hs-handler src))) (handler el))))))
|
||||
()
|
||||
(for-each
|
||||
(fn
|
||||
(script)
|
||||
(when
|
||||
(not (dom-get-data script "hs-script-loaded"))
|
||||
(let
|
||||
((src (host-get script "innerHTML")))
|
||||
(when
|
||||
(and src (not (= src "")))
|
||||
(guard
|
||||
(_e (true nil))
|
||||
(eval-expr-cek (hs-to-sx-from-source src)))
|
||||
(dom-set-data script "hs-script-loaded" true)))))
|
||||
(hs-query-all "script[type=text/hyperscript]"))))
|
||||
|
||||
;; ── Boot: scan entire document ──────────────────────────────────
|
||||
;; Called once at page load. Finds all elements with _ attribute,
|
||||
;; compiles their hyperscript, and activates them.
|
||||
|
||||
(define
|
||||
hs-activate!
|
||||
(fn
|
||||
(el)
|
||||
(do
|
||||
(hs-register-scripts!)
|
||||
(let
|
||||
((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script")))
|
||||
(when
|
||||
(and src (not (= src prev)))
|
||||
(when
|
||||
(dom-dispatch el "hyperscript:before:init" nil)
|
||||
(hs-log-event! "hyperscript:init")
|
||||
(dom-set-data el "hs-script" src)
|
||||
(dom-set-data el "hs-active" true)
|
||||
(dom-set-attr el "data-hyperscript-powered" "true")
|
||||
(host-set! (host-global "window") "__hs_current_me" el)
|
||||
(guard
|
||||
(_e
|
||||
(true
|
||||
(do
|
||||
(dom-dispatch el "hyperscript:parse-error" {:detail {:errors (list _e)}})
|
||||
nil)))
|
||||
(let
|
||||
((handler (hs-handler src)))
|
||||
(let
|
||||
((el-type (dom-get-attr el "type"))
|
||||
(comp-name (dom-get-attr el "component")))
|
||||
(let
|
||||
((safe-handler (fn (e) (host-call-fn handler (list e)))))
|
||||
(if
|
||||
(= el-type "text/hyperscript-template")
|
||||
(for-each
|
||||
safe-handler
|
||||
(hs-query-all (or comp-name "")))
|
||||
(safe-handler el))))))
|
||||
(host-set! (host-global "window") "__hs_current_me" nil)
|
||||
(dom-dispatch el "hyperscript:after:init" nil)))))))
|
||||
|
||||
;; ── Boot subtree: for dynamic content ───────────────────────────
|
||||
;; Called after HTMX swaps or dynamic DOM insertion.
|
||||
;; Only activates elements within the given root.
|
||||
|
||||
(define
|
||||
hs-deactivate!
|
||||
(fn
|
||||
@@ -101,10 +153,6 @@
|
||||
(dom-set-data el "hs-active" false)
|
||||
(dom-set-data el "hs-script" nil))))
|
||||
|
||||
;; ── Boot subtree: for dynamic content ───────────────────────────
|
||||
;; Called after HTMX swaps or dynamic DOM insertion.
|
||||
;; Only activates elements within the given root.
|
||||
|
||||
(define
|
||||
hs-boot!
|
||||
(fn
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -28,6 +28,27 @@
|
||||
|
||||
(define hs-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
||||
|
||||
(define
|
||||
hs-hex-digit?
|
||||
(fn
|
||||
(c)
|
||||
(or
|
||||
(and (>= c "0") (<= c "9"))
|
||||
(and (>= c "a") (<= c "f"))
|
||||
(and (>= c "A") (<= c "F")))))
|
||||
|
||||
(define
|
||||
hs-hex-val
|
||||
(fn
|
||||
(c)
|
||||
(let
|
||||
((code (char-code c)))
|
||||
(cond
|
||||
((and (>= code 48) (<= code 57)) (- code 48))
|
||||
((and (>= code 65) (<= code 70)) (- code 55))
|
||||
((and (>= code 97) (<= code 102)) (- code 87))
|
||||
(true 0)))))
|
||||
|
||||
;; ── Keyword set ───────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
@@ -110,6 +131,7 @@
|
||||
"append"
|
||||
"settle"
|
||||
"transition"
|
||||
"view"
|
||||
"over"
|
||||
"closest"
|
||||
"next"
|
||||
@@ -187,7 +209,8 @@
|
||||
"using"
|
||||
"giving"
|
||||
"ask"
|
||||
"answer"))
|
||||
"answer"
|
||||
"bind"))
|
||||
|
||||
(define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords)))
|
||||
|
||||
@@ -235,10 +258,15 @@
|
||||
read-number
|
||||
(fn
|
||||
(start)
|
||||
(when
|
||||
(and (< pos src-len) (hs-digit? (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(read-number start))
|
||||
(define
|
||||
read-int
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (hs-digit? (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(read-int))))
|
||||
(read-int)
|
||||
(when
|
||||
(and
|
||||
(< pos src-len)
|
||||
@@ -246,15 +274,7 @@
|
||||
(< (+ pos 1) src-len)
|
||||
(hs-digit? (hs-peek 1)))
|
||||
(hs-advance! 1)
|
||||
(define
|
||||
read-frac
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (hs-digit? (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(read-frac))))
|
||||
(read-frac))
|
||||
(read-int))
|
||||
(do
|
||||
(when
|
||||
(and
|
||||
@@ -272,15 +292,7 @@
|
||||
(< pos src-len)
|
||||
(or (= (hs-cur) "+") (= (hs-cur) "-")))
|
||||
(hs-advance! 1))
|
||||
(define
|
||||
read-exp-digits
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (hs-digit? (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(read-exp-digits))))
|
||||
(read-exp-digits))
|
||||
(read-int))
|
||||
(let
|
||||
((num-end pos))
|
||||
(when
|
||||
@@ -308,7 +320,7 @@
|
||||
()
|
||||
(cond
|
||||
(>= pos src-len)
|
||||
nil
|
||||
(error "Unterminated string")
|
||||
(= (hs-cur) "\\")
|
||||
(do
|
||||
(hs-advance! 1)
|
||||
@@ -318,15 +330,47 @@
|
||||
((ch (hs-cur)))
|
||||
(cond
|
||||
(= ch "n")
|
||||
(append! chars "\n")
|
||||
(do (append! chars "\n") (hs-advance! 1))
|
||||
(= ch "t")
|
||||
(append! chars "\t")
|
||||
(do (append! chars "\t") (hs-advance! 1))
|
||||
(= ch "r")
|
||||
(do (append! chars "\r") (hs-advance! 1))
|
||||
(= ch "b")
|
||||
(do
|
||||
(append! chars (char-from-code 8))
|
||||
(hs-advance! 1))
|
||||
(= ch "f")
|
||||
(do
|
||||
(append! chars (char-from-code 12))
|
||||
(hs-advance! 1))
|
||||
(= ch "v")
|
||||
(do
|
||||
(append! chars (char-from-code 11))
|
||||
(hs-advance! 1))
|
||||
(= ch "\\")
|
||||
(append! chars "\\")
|
||||
(do (append! chars "\\") (hs-advance! 1))
|
||||
(= ch quote-char)
|
||||
(append! chars quote-char)
|
||||
:else (do (append! chars "\\") (append! chars ch)))
|
||||
(hs-advance! 1)))
|
||||
(do (append! chars quote-char) (hs-advance! 1))
|
||||
(= ch "x")
|
||||
(do
|
||||
(hs-advance! 1)
|
||||
(if
|
||||
(and
|
||||
(< (+ pos 1) src-len)
|
||||
(hs-hex-digit? (hs-cur))
|
||||
(hs-hex-digit? (hs-peek 1)))
|
||||
(let
|
||||
((d1 (hs-hex-val (hs-cur)))
|
||||
(d2 (hs-hex-val (hs-peek 1))))
|
||||
(append!
|
||||
chars
|
||||
(char-from-code (+ (* d1 16) d2)))
|
||||
(hs-advance! 2))
|
||||
(error "Invalid hexadecimal escape: \\x")))
|
||||
:else (do
|
||||
(append! chars "\\")
|
||||
(append! chars ch)
|
||||
(hs-advance! 1)))))
|
||||
(loop))
|
||||
(= (hs-cur) quote-char)
|
||||
(hs-advance! 1)
|
||||
@@ -413,27 +457,68 @@
|
||||
read-class-name
|
||||
(fn
|
||||
(start)
|
||||
(when
|
||||
(and
|
||||
(< pos src-len)
|
||||
(or
|
||||
(hs-ident-char? (hs-cur))
|
||||
(= (hs-cur) ":")
|
||||
(= (hs-cur) "[")
|
||||
(= (hs-cur) "]")))
|
||||
(hs-advance! 1)
|
||||
(read-class-name start))
|
||||
(slice src start pos)))
|
||||
(define
|
||||
build-name
|
||||
(fn
|
||||
(acc depth)
|
||||
(cond
|
||||
((and (< pos src-len) (= (hs-cur) "\\") (< (+ pos 1) src-len))
|
||||
(do
|
||||
(hs-advance! 1)
|
||||
(let
|
||||
((c (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(build-name (str acc c) depth))))
|
||||
((and (< pos src-len) (= (hs-cur) "["))
|
||||
(do
|
||||
(let
|
||||
((c (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(build-name (str acc c) (+ depth 1)))))
|
||||
((and (< pos src-len) (= (hs-cur) "]"))
|
||||
(do
|
||||
(let
|
||||
((c (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(build-name
|
||||
(str acc c)
|
||||
(if (> depth 0) (- depth 1) 0)))))
|
||||
((and (< pos src-len) (> depth 0) (or (= (hs-cur) "(") (= (hs-cur) ")")))
|
||||
(do
|
||||
(let
|
||||
((c (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(build-name (str acc c) depth))))
|
||||
((and (< pos src-len) (or (hs-ident-char? (hs-cur)) (= (hs-cur) ":") (= (hs-cur) "&")))
|
||||
(do
|
||||
(let
|
||||
((c (hs-cur)))
|
||||
(hs-advance! 1)
|
||||
(build-name (str acc c) depth))))
|
||||
(true acc))))
|
||||
(build-name "" 0)))
|
||||
(define
|
||||
hs-emit!
|
||||
(fn
|
||||
(type value start)
|
||||
(append! tokens (hs-make-token type value start))))
|
||||
(let
|
||||
((tok (hs-make-token type value start))
|
||||
(end-pos
|
||||
(max pos (+ start (if (nil? value) 0 (len (str value)))))))
|
||||
(do
|
||||
(dict-set! tok "end" end-pos)
|
||||
(dict-set! tok "line" (len (split (slice src 0 start) "\n")))
|
||||
(append! tokens tok)))))
|
||||
(define
|
||||
scan!
|
||||
(fn
|
||||
()
|
||||
(skip-ws!)
|
||||
(let
|
||||
((ws-start pos))
|
||||
(skip-ws!)
|
||||
(when
|
||||
(and (> (len tokens) 0) (> pos ws-start))
|
||||
(hs-emit! "whitespace" (slice src ws-start pos) ws-start)))
|
||||
(when
|
||||
(< pos src-len)
|
||||
(let
|
||||
@@ -457,6 +542,21 @@
|
||||
(do (hs-emit! "selector" (read-selector) start) (scan!))
|
||||
(and (= ch ".") (< (+ pos 1) src-len) (= (hs-peek 1) "."))
|
||||
(do (hs-emit! "op" ".." start) (hs-advance! 2) (scan!))
|
||||
(and
|
||||
(= ch ".")
|
||||
(< (+ pos 1) src-len)
|
||||
(or
|
||||
(hs-letter? (hs-peek 1))
|
||||
(= (hs-peek 1) "-")
|
||||
(= (hs-peek 1) "_"))
|
||||
(> (len tokens) 0)
|
||||
(let
|
||||
((lt (dict-get (nth tokens (- (len tokens) 1)) :type)))
|
||||
(or
|
||||
(= lt "paren-close")
|
||||
(= lt "brace-close")
|
||||
(= lt "bracket-close"))))
|
||||
(do (hs-emit! "dot" "." start) (hs-advance! 1) (scan!))
|
||||
(and
|
||||
(= ch ".")
|
||||
(< (+ pos 1) src-len)
|
||||
@@ -468,6 +568,18 @@
|
||||
(hs-advance! 1)
|
||||
(hs-emit! "class" (read-class-name pos) start)
|
||||
(scan!))
|
||||
(and
|
||||
(= ch "#")
|
||||
(< (+ pos 1) src-len)
|
||||
(hs-ident-start? (hs-peek 1))
|
||||
(> (len tokens) 0)
|
||||
(let
|
||||
((lt (dict-get (nth tokens (- (len tokens) 1)) :type)))
|
||||
(or
|
||||
(= lt "paren-close")
|
||||
(= lt "brace-close")
|
||||
(= lt "bracket-close"))))
|
||||
(do (hs-emit! "op" "#" start) (hs-advance! 1) (scan!))
|
||||
(and
|
||||
(= ch "#")
|
||||
(< (+ pos 1) src-len)
|
||||
@@ -536,10 +648,12 @@
|
||||
(do
|
||||
(let
|
||||
((word (read-ident start)))
|
||||
(hs-emit!
|
||||
(if (hs-keyword? word) "keyword" "ident")
|
||||
word
|
||||
start))
|
||||
(let
|
||||
((full-word (if (and (< pos src-len) (= (hs-cur) "'") (< (+ pos 1) src-len) (hs-letter? (hs-peek 1)) (not (and (= (hs-peek 1) "s") (or (>= (+ pos 2) src-len) (not (hs-ident-char? (hs-peek 2))))))) (do (hs-advance! 1) (str word "'" (read-ident pos))) word)))
|
||||
(hs-emit!
|
||||
(if (hs-keyword? full-word) "keyword" "ident")
|
||||
full-word
|
||||
start)))
|
||||
(scan!))
|
||||
(and
|
||||
(or (= ch "=") (= ch "!") (= ch "<") (= ch ">"))
|
||||
@@ -620,7 +734,82 @@
|
||||
(do (hs-emit! "colon" ":" start) (hs-advance! 1) (scan!))
|
||||
(= ch "|")
|
||||
(do (hs-emit! "op" "|" start) (hs-advance! 1) (scan!))
|
||||
(= ch "&")
|
||||
(do (hs-emit! "op" "&" start) (hs-advance! 1) (scan!))
|
||||
(= ch "#")
|
||||
(do (hs-emit! "op" "#" start) (hs-advance! 1) (scan!))
|
||||
(= ch "?")
|
||||
(do (hs-emit! "op" "?" start) (hs-advance! 1) (scan!))
|
||||
(= ch ";")
|
||||
(do (hs-emit! "op" ";" start) (hs-advance! 1) (scan!))
|
||||
:else (do (hs-advance! 1) (scan!)))))))
|
||||
(scan!)
|
||||
(hs-emit! "eof" nil pos)
|
||||
tokens)))
|
||||
|
||||
;; ── Template-mode tokenizer (E37 API) ────────────────────────────────
|
||||
;; Used by hs-tokens-of when :template flag is set.
|
||||
;; Emits outer " chars as single STRING tokens; ${ ... } as $ { <inner-tokens> };
|
||||
;; inner content is tokenized with the regular hs-tokenize.
|
||||
|
||||
(define
|
||||
hs-tokenize-template
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((tokens (list)) (pos 0) (src-len (len src)))
|
||||
(define t-cur (fn () (if (< pos src-len) (nth src pos) nil)))
|
||||
(define t-peek (fn (n) (if (< (+ pos n) src-len) (nth src (+ pos n)) nil)))
|
||||
(define t-advance! (fn (n) (set! pos (+ pos n))))
|
||||
(define t-emit! (fn (type value) (append! tokens (hs-make-token type value pos))))
|
||||
(define
|
||||
scan-to-close!
|
||||
(fn
|
||||
(depth)
|
||||
(when
|
||||
(and (< pos src-len) (> depth 0))
|
||||
(cond
|
||||
(= (t-cur) "{")
|
||||
(do (t-advance! 1) (scan-to-close! (+ depth 1)))
|
||||
(= (t-cur) "}")
|
||||
(when (> (- depth 1) 0) (t-advance! 1) (scan-to-close! (- depth 1)))
|
||||
:else (do (t-advance! 1) (scan-to-close! depth))))))
|
||||
(define
|
||||
scan-template!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< pos src-len)
|
||||
(let
|
||||
((ch (t-cur)))
|
||||
(cond
|
||||
(= ch "\"")
|
||||
(do (t-emit! "string" "\"") (t-advance! 1) (scan-template!))
|
||||
(and (= ch "$") (= (t-peek 1) "{"))
|
||||
(do
|
||||
(t-emit! "op" "$")
|
||||
(t-advance! 1)
|
||||
(t-emit! "brace-open" "{")
|
||||
(t-advance! 1)
|
||||
(let
|
||||
((inner-start pos))
|
||||
(scan-to-close! 1)
|
||||
(let
|
||||
((inner-src (slice src inner-start pos))
|
||||
(inner-toks (hs-tokenize inner-src)))
|
||||
(for-each
|
||||
(fn (tok)
|
||||
(when (not (= (get tok "type") "eof"))
|
||||
(append! tokens tok)))
|
||||
inner-toks))
|
||||
(t-emit! "brace-close" "}")
|
||||
(when (< pos src-len) (t-advance! 1)))
|
||||
(scan-template!))
|
||||
(= ch "$")
|
||||
(do (t-emit! "op" "$") (t-advance! 1) (scan-template!))
|
||||
(hs-ws? ch)
|
||||
(do (t-advance! 1) (scan-template!))
|
||||
:else (do (t-advance! 1) (scan-template!)))))))
|
||||
(scan-template!)
|
||||
(t-emit! "eof" nil)
|
||||
tokens)))
|
||||
@@ -50778,9 +50778,21 @@ d2=133,bi=102,bh="Re__Hash_set",cA="Stdlib__Type",cB=114,fF="Stdlib__Buffer",dX=
|
||||
}
|
||||
return trampoline(eval_expr(Sx_types[76].call(null, mac), local));
|
||||
}
|
||||
function cek_step_loop(state$1){
|
||||
var state = state$1;
|
||||
var step_limit = [0, 0], step_count = [0, 0], _wc_check = 0;
|
||||
function cek_step_loop(state$0){
|
||||
var state = state$0;
|
||||
for(;;){
|
||||
if(0 < step_limit[1]){
|
||||
step_count[1] = step_count[1] + 1 | 0;
|
||||
if(step_limit[1] < step_count[1])
|
||||
throw caml_maybe_attach_backtrace
|
||||
([0, Sx_types[9], "TIMEOUT: step limit exceeded"], 1);
|
||||
}
|
||||
if(++_wc_check >= 10000){ _wc_check = 0;
|
||||
if(globalThis.__hs_deadline && Date.now() > globalThis.__hs_deadline)
|
||||
throw caml_maybe_attach_backtrace
|
||||
([0, Sx_types[9], "TIMEOUT: wall clock exceeded"], 1);
|
||||
}
|
||||
var
|
||||
or = cek_terminal_p(state),
|
||||
or$0 = Sx_types[57].call(null, or) ? or : cek_suspended_p(state);
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
263
tests/hs-kernel-eval.js
Normal file
263
tests/hs-kernel-eval.js
Normal file
@@ -0,0 +1,263 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* Evaluate SX (or inspect HS compiler/parser output) in the full WASM kernel.
|
||||
*
|
||||
* Environment variables (preferred — avoids shell escaping):
|
||||
* HS_EVAL_EXPR SX expression to evaluate (required unless --expr arg given)
|
||||
* HS_EVAL_SETUP SX setup expression run before main eval
|
||||
* HS_EVAL_FILES Comma-separated list of .sx files to load first
|
||||
* HS_EVAL_MODE 'eval' (default) | 'compile' | 'parse'
|
||||
* compile: wraps expr as hs-compile arg, returns SX AST string
|
||||
* parse: wraps expr as hs-parse arg, returns parse tree string
|
||||
*
|
||||
* CLI fallback: first positional arg used as expression if HS_EVAL_EXPR not set.
|
||||
*
|
||||
* Output: JSON to stdout { ok: true, result: "..." }
|
||||
* or { ok: false, error: "..." }
|
||||
* Progress / load errors go to stderr.
|
||||
*/
|
||||
|
||||
'use strict';
|
||||
const fs = require('fs');
|
||||
const path = require('path');
|
||||
|
||||
const PROJECT = path.resolve(__dirname, '..');
|
||||
const WASM_DIR = path.join(PROJECT, 'shared/static/wasm');
|
||||
const SX_DIR = path.join(WASM_DIR, 'sx');
|
||||
|
||||
// ── Load WASM kernel ────────────────────────────────────────────
|
||||
eval(fs.readFileSync(path.join(WASM_DIR, 'sx_browser.bc.js'), 'utf8'));
|
||||
const K = globalThis.SxKernel;
|
||||
|
||||
// ── Minimal DOM mock ────────────────────────────────────────────
|
||||
class CL {
|
||||
constructor() { this._s = new Set(); }
|
||||
add(c) { if (c) this._s.add(c); }
|
||||
remove(c) { this._s.delete(c); }
|
||||
contains(c) { return this._s.has(c); }
|
||||
toggle(c) { this._s.has(c) ? this.remove(c) : this.add(c); return this._s.has(c); }
|
||||
_sync(v) { this._s = new Set((v||'').split(' ').filter(Boolean)); }
|
||||
}
|
||||
class El {
|
||||
constructor(t) {
|
||||
this.tagName = t.toUpperCase(); this.nodeName = this.tagName; this.nodeType = 1;
|
||||
this.id = ''; this.className = ''; this.textContent = ''; this.innerHTML = '';
|
||||
this.value = ''; this.checked = false; this.disabled = false; this.type = '';
|
||||
this.style = { setProperty(p,v){this[p]=v;}, getPropertyValue(p){return this[p]||'';} };
|
||||
this.attributes = {}; this.children = []; this.childNodes = [];
|
||||
this.childNodes.item = i => this.childNodes[i] || null;
|
||||
this.parentNode = null; this.parentElement = null; this._listeners = {};
|
||||
this.classList = new CL();
|
||||
this.dataset = {};
|
||||
this.open = false; this.multiple = false; this.selected = false;
|
||||
}
|
||||
setAttribute(n,v) {
|
||||
this.attributes[n] = String(v);
|
||||
if (n==='id') this.id = v;
|
||||
if (n==='class') { this.className = v; this.classList._sync(v); }
|
||||
if (n==='value') this.value = v;
|
||||
}
|
||||
getAttribute(n) { return this.attributes[n] !== undefined ? this.attributes[n] : null; }
|
||||
removeAttribute(n){ delete this.attributes[n]; }
|
||||
hasAttribute(n) { return n in this.attributes; }
|
||||
appendChild(c) { if(c){ c.parentNode=this; c.parentElement=this; this.children.push(c); this.childNodes.push(c); } return c; }
|
||||
removeChild(c) { this.children=this.children.filter(x=>x!==c); this.childNodes=this.childNodes.filter(x=>x!==c); if(c){c.parentNode=null;c.parentElement=null;} return c; }
|
||||
remove() { if(this.parentNode) this.parentNode.removeChild(this); }
|
||||
prepend(c) { if(c){ c.parentNode=this; this.children.unshift(c); this.childNodes.unshift(c); } }
|
||||
insertBefore(c,r) { if(!r) return this.appendChild(c); const i=this.childNodes.indexOf(r); if(i<0) return this.appendChild(c); this.childNodes.splice(i,0,c); this.children.splice(i,0,c); c.parentNode=this; return c; }
|
||||
replaceChild(n,o) { const i=this.childNodes.indexOf(o); if(i>=0){ this.childNodes[i]=n; this.children[i]=n; n.parentNode=this; o.parentNode=null; } return o; }
|
||||
cloneNode(deep) { const c=new El(this.tagName); if(deep) for(const ch of this.childNodes) c.appendChild(ch.cloneNode&&ch.cloneNode(true)||{...ch}); return c; }
|
||||
addEventListener(t,h) { if(!this._listeners[t]) this._listeners[t]=[]; this._listeners[t].push(h); }
|
||||
removeEventListener(t,h) { if(this._listeners[t]) this._listeners[t]=this._listeners[t].filter(x=>x!==h); }
|
||||
dispatchEvent(ev) { (this._listeners[ev&&ev.type]||[]).forEach(h=>{ try{h(ev);}catch(e){} }); return true; }
|
||||
querySelector(sel) {
|
||||
if (!sel) return null;
|
||||
if (sel.startsWith('#')) { const id=sel.slice(1); if(this.id===id) return this; for(const c of this.childNodes){const r=c.querySelector&&c.querySelector(sel); if(r) return r;} return null; }
|
||||
return null;
|
||||
}
|
||||
querySelectorAll() { return []; }
|
||||
closest(sel) { return sel && this.matches(sel) ? this : (this.parentNode && this.parentNode.closest ? this.parentNode.closest(sel) : null); }
|
||||
matches(sel) {
|
||||
if (!sel) return false;
|
||||
if (sel.startsWith('#')) return this.id === sel.slice(1);
|
||||
if (sel.startsWith('.')) return this.classList.contains(sel.slice(1));
|
||||
return this.tagName.toLowerCase() === sel.toLowerCase();
|
||||
}
|
||||
focus() {}
|
||||
blur() {}
|
||||
click() { this.dispatchEvent(new Ev('click',{bubbles:true})); }
|
||||
getBoundingClientRect() { return {width:0,height:0,top:0,left:0,right:0,bottom:0}; }
|
||||
}
|
||||
class Ev {
|
||||
constructor(t,o) { this.type=t; const opts=o||{}; this.bubbles=opts.bubbles!==false; this.detail=opts.detail||null; this.target=null; this.currentTarget=null; }
|
||||
preventDefault() {}
|
||||
stopPropagation() {}
|
||||
}
|
||||
|
||||
const _body = new El('body');
|
||||
const _head = new El('head');
|
||||
const _docListeners = {};
|
||||
const _domRegistry = new Map(); // id -> El
|
||||
|
||||
function _findById(id) {
|
||||
function find(el) {
|
||||
if (!(el instanceof El)) return null;
|
||||
if (el.id === id) return el;
|
||||
for (const c of (el.childNodes||[])) { const r = find(c); if (r) return r; }
|
||||
return null;
|
||||
}
|
||||
return find(_body);
|
||||
}
|
||||
|
||||
globalThis.document = {
|
||||
body: _body, head: _head, title: '',
|
||||
createElement: t => new El(t),
|
||||
createElementNS: (ns,t) => new El(t),
|
||||
createTextNode: s => ({ nodeType:3, textContent:String(s||''), nodeName:'#text', parentNode:null }),
|
||||
createDocumentFragment: () => { const f=new El('fragment'); f.nodeType=11; return f; },
|
||||
createComment: s => ({ nodeType:8, textContent:s, nodeName:'#comment' }),
|
||||
getElementById: id => _findById(id),
|
||||
querySelector: sel => sel && sel.startsWith('#') ? _findById(sel.slice(1)) : null,
|
||||
querySelectorAll: () => [],
|
||||
addEventListener: (t,h) => { if(!_docListeners[t]) _docListeners[t]=[]; _docListeners[t].push(h); },
|
||||
removeEventListener: (t,h) => { if(_docListeners[t]) _docListeners[t]=_docListeners[t].filter(x=>x!==h); },
|
||||
dispatchEvent: ev => { (_docListeners[ev&&ev.type]||[]).forEach(h=>{ try{h(ev);}catch(e){} }); },
|
||||
activeElement: null,
|
||||
};
|
||||
globalThis.CustomEvent = Ev;
|
||||
globalThis.Event = Ev;
|
||||
globalThis.window = globalThis;
|
||||
try { globalThis.navigator = { userAgent: 'node' }; } catch(e) { Object.defineProperty(globalThis, 'navigator', { value: { userAgent: 'node' }, writable: true, configurable: true }); }
|
||||
globalThis.location = { href:'http://localhost/', pathname:'/', search:'', hash:'' };
|
||||
globalThis.history = { pushState(){}, replaceState(){} };
|
||||
globalThis.getSelection = () => ({ toString: () => '' });
|
||||
globalThis.console = { log:()=>{}, error:()=>{}, warn:()=>{}, info:()=>{}, debug:()=>{} };
|
||||
globalThis.ResizeObserver = class { observe(){} unobserve(){} disconnect(){} };
|
||||
globalThis.IntersectionObserver = class { constructor(cb){} observe(){} unobserve(){} disconnect(){} takeRecords(){return[];} };
|
||||
|
||||
// ── FFI registrations ───────────────────────────────────────────
|
||||
K.registerNative('hs-ref-eq', a => a[0]===a[1]);
|
||||
K.registerNative('host-global', a => { const n=a[0]; return (n in globalThis)?globalThis[n]:null; });
|
||||
K.registerNative('host-get', a => {
|
||||
if (a[0]==null) return null;
|
||||
if (a[0] && a[0]._type==='list' && (a[1]==='length'||a[1]==='size')) return a[0].items.length;
|
||||
if (a[0] instanceof El && a[1]==='innerText') return String(a[0].textContent||'');
|
||||
const v = a[0][a[1]]; return v===undefined ? null : v;
|
||||
});
|
||||
K.registerNative('host-set!', a => { if(a[0]!=null){ a[0][a[1]]=a[2]; if(a[0] instanceof El && a[1]==='id' && a[2]) a[0].id=a[2]; } return a[2]; });
|
||||
K.registerNative('host-call', a => {
|
||||
const [o,m,...r]=a;
|
||||
if(o==null){ const f=globalThis[m]; return typeof f==='function'?f.apply(null,r):null; }
|
||||
if(o && typeof o[m]==='function'){ try{ const v=o[m].apply(o,r); return v===undefined?null:v; }catch(e){ return null; } }
|
||||
return null;
|
||||
});
|
||||
K.registerNative('host-call-fn', a => {
|
||||
const [fn,argList]=a;
|
||||
if(!fn) return null;
|
||||
const args=(argList&&argList._type==='list'&&argList.items)?Array.from(argList.items):(Array.isArray(argList)?argList:[]);
|
||||
if(fn&&fn.__sx_handle!==undefined) return K.callFn(fn,args);
|
||||
try{ return fn.apply(null,args); }catch(e){ return null; }
|
||||
});
|
||||
K.registerNative('host-new', a => { const C=typeof a[0]==='string'?globalThis[a[0]]:a[0]; return typeof C==='function'?new C(...a.slice(1)):null; });
|
||||
K.registerNative('host-callback',a => {
|
||||
const fn=a[0];
|
||||
if(fn&&fn.__sx_handle!==undefined) return function(){ const r=K.callFn(fn,Array.from(arguments)); if(globalThis._driveAsync) globalThis._driveAsync(r); return r; };
|
||||
return typeof fn==='function'?fn:function(){};
|
||||
});
|
||||
K.registerNative('host-typeof', a => { const o=a[0]; if(o==null) return 'nil'; if(o instanceof El) return 'element'; if(o instanceof Ev) return 'event'; return typeof o; });
|
||||
K.registerNative('host-iter?', ([obj]) => obj!=null && typeof obj[Symbol.iterator]==='function');
|
||||
K.registerNative('host-to-list', ([obj]) => { try{ return [...obj]; }catch(e){ return []; } });
|
||||
K.registerNative('host-await', () => {});
|
||||
K.registerNative('host-new-function', a => { const p=(a[0]&&a[0]._type==='list')?Array.from(a[0].items):[]; try{ return new Function(...p,a[1]); }catch(e){ return null; } });
|
||||
K.registerNative('host-promise-state', a => { const p=a[0]; if(!p||typeof p.then!=='function') return null; const s=globalThis._promiseStates&&globalThis._promiseStates.get(p); return s?{ok:s.ok,value:s.value}:null; });
|
||||
K.registerNative('load-library!', () => false);
|
||||
|
||||
// Async IO driver
|
||||
let _evalDeadline = 0;
|
||||
globalThis._driveAsync = function driveAsync(r, depth) {
|
||||
depth = depth||0;
|
||||
if (_evalDeadline && Date.now() > _evalDeadline) throw new Error('TIMEOUT: wall clock exceeded');
|
||||
if (!r || !r.suspended || depth > 200) return;
|
||||
const req = r.request;
|
||||
const items = req && (req.items || req);
|
||||
const op = items && items[0];
|
||||
const opName = typeof op==='string' ? op : (op&&op.name)||String(op);
|
||||
function doResume(v) { try{ const x=r.resume(v); driveAsync(x,depth+1); }catch(e){} }
|
||||
if (opName==='io-sleep'||opName==='wait') doResume(null);
|
||||
else if (opName==='io-wait-event') {
|
||||
const target=items&&items[1];
|
||||
const evName=typeof items[2]==='string'?items[2]:'';
|
||||
const timeout=items&&items.length>3?items[3]:undefined;
|
||||
if (typeof timeout==='number') { doResume(null); }
|
||||
else if (target && target instanceof El && evName) {
|
||||
const handler=function(ev){ target.removeEventListener(evName,handler); doResume(ev); };
|
||||
target.addEventListener(evName,handler);
|
||||
} else { doResume(null); }
|
||||
}
|
||||
else if (opName==='io-transition') doResume(null);
|
||||
else doResume(null);
|
||||
};
|
||||
|
||||
// ── SX aliases ──────────────────────────────────────────────────
|
||||
K.eval('(define SX_VERSION "hs-eval-1.0")');
|
||||
K.eval('(define SX_ENGINE "ocaml-vm-sandbox")');
|
||||
K.eval('(define parse sx-parse)');
|
||||
K.eval('(define serialize sx-serialize)');
|
||||
|
||||
// ── Load HS modules ─────────────────────────────────────────────
|
||||
const WEB = ['render','core-signals','signals','deps','router','page-helpers','freeze','dom','browser',
|
||||
'adapter-html','adapter-sx','adapter-dom','boot-helpers','hypersx','engine','orchestration','boot'];
|
||||
const HS = ['hs-tokenizer','hs-parser','hs-compiler','hs-runtime','hs-integration'];
|
||||
K.beginModuleLoad();
|
||||
for (const mod of [...WEB, ...HS]) {
|
||||
const sp = path.join(SX_DIR, mod+'.sx');
|
||||
const lp = path.join(PROJECT, 'lib/hyperscript', mod.replace(/^hs-/,'')+'.sx');
|
||||
let s;
|
||||
try {
|
||||
const lpExists = mod.startsWith('hs-') && fs.existsSync(lp);
|
||||
s = lpExists ? fs.readFileSync(lp,'utf8')
|
||||
: fs.existsSync(sp) ? fs.readFileSync(sp,'utf8')
|
||||
: fs.readFileSync(lp,'utf8');
|
||||
} catch(e) { continue; }
|
||||
try { K.load(s); } catch(e) { process.stderr.write(`LOAD ERROR: ${mod}: ${e.message}\n`); }
|
||||
}
|
||||
K.endModuleLoad();
|
||||
|
||||
// ── Extra files ─────────────────────────────────────────────────
|
||||
const extraFiles = (process.env.HS_EVAL_FILES || '').split(',').filter(Boolean);
|
||||
for (const f of extraFiles) {
|
||||
try { K.load(fs.readFileSync(f.trim(),'utf8')); }
|
||||
catch(e) { process.stderr.write(`FILE ERROR: ${f}: ${e.message}\n`); }
|
||||
}
|
||||
|
||||
// ── Setup expression ────────────────────────────────────────────
|
||||
const setup = process.env.HS_EVAL_SETUP || '';
|
||||
if (setup) {
|
||||
try { K.eval(setup); }
|
||||
catch(e) {
|
||||
process.stdout.write(JSON.stringify({ok:false,error:`Setup error: ${e.message||String(e)}`})+'\n');
|
||||
process.exit(1);
|
||||
}
|
||||
}
|
||||
|
||||
// ── Main evaluation ─────────────────────────────────────────────
|
||||
const mode = process.env.HS_EVAL_MODE || 'eval';
|
||||
const rawExpr = process.env.HS_EVAL_EXPR || process.argv[2] || '';
|
||||
if (!rawExpr) {
|
||||
process.stdout.write(JSON.stringify({ok:false,error:'No expression provided. Set HS_EVAL_EXPR or pass as first argument.'})+'\n');
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
const expr = mode==='compile' ? `(str (hs-compile ${JSON.stringify(rawExpr)}))`
|
||||
: mode==='parse' ? `(str (hs-parse ${JSON.stringify(rawExpr)}))`
|
||||
: rawExpr;
|
||||
|
||||
_evalDeadline = Date.now() + parseInt(process.env.HS_EVAL_TIMEOUT_MS||'30000');
|
||||
try {
|
||||
const result = K.eval(expr);
|
||||
let resultStr;
|
||||
try { resultStr = JSON.stringify(result); } catch(e) { resultStr = String(result); }
|
||||
process.stdout.write(JSON.stringify({ok:true,result:resultStr})+'\n');
|
||||
} catch(e) {
|
||||
process.stdout.write(JSON.stringify({ok:false,error:e.message||String(e)})+'\n');
|
||||
}
|
||||
@@ -15,7 +15,7 @@ eval(fs.readFileSync(path.join(WASM_DIR, 'sx_browser.bc.js'), 'utf8'));
|
||||
const K = globalThis.SxKernel;
|
||||
|
||||
// Step limit API — exposed from OCaml kernel
|
||||
const STEP_LIMIT = parseInt(process.env.HS_STEP_LIMIT || '200000');
|
||||
const STEP_LIMIT = parseInt(process.env.HS_STEP_LIMIT || '1000000');
|
||||
|
||||
function setStepLimit(n) { K.setStepLimit(n); }
|
||||
function resetStepCount() { K.resetStepCount(); }
|
||||
@@ -81,7 +81,7 @@ class El {
|
||||
hasAttribute(n) { return n in this.attributes; }
|
||||
addEventListener(e,f) { if(!this._listeners[e])this._listeners[e]=[]; this._listeners[e].push(f); }
|
||||
removeEventListener(e,f) { if(this._listeners[e])this._listeners[e]=this._listeners[e].filter(x=>x!==f); }
|
||||
dispatchEvent(ev) { ev.target=ev.target||this; ev.currentTarget=this; const fns=[...(this._listeners[ev.type]||[])]; for(const f of fns){if(ev._si)break;try{f.call(this,ev);}catch(e){}} if(ev.bubbles&&!ev._sp&&this.parentElement){this.parentElement.dispatchEvent(ev);} return !ev.defaultPrevented; }
|
||||
dispatchEvent(ev) { ev.target=ev.target||this; ev.currentTarget=this; const fns=[...(this._listeners[ev.type]||[])]; for(const f of fns){if(ev._si)break;try{f.call(this,ev);}catch(e){}} if(ev.bubbles&&!ev._sp){if(this.parentElement){this.parentElement.dispatchEvent(ev);}else if(globalThis._windowListeners){globalThis.dispatchEvent(ev);}} return !ev.defaultPrevented; }
|
||||
appendChild(c) { if(c.parentElement)c.parentElement.removeChild(c); c.parentElement=this; c.parentNode=this; this.children.push(c); this.childNodes.push(c); if(this.tagName==='SELECT'&&c.tagName==='OPTION'){this.options.push(c);if(c.selected&&this.selectedIndex<0)this.selectedIndex=this.options.length-1;} this._syncText(); return c; }
|
||||
removeChild(c) { this.children=this.children.filter(x=>x!==c); this.childNodes=this.childNodes.filter(x=>x!==c); c.parentElement=null; c.parentNode=null; this._syncText(); return c; }
|
||||
insertBefore(n,r) { if(n.parentElement)n.parentElement.removeChild(n); const i=this.children.indexOf(r); if(i>=0){this.children.splice(i,0,n);this.childNodes.splice(i,0,n);}else{this.children.push(n);this.childNodes.push(n);} n.parentElement=this;n.parentNode=this; this._syncText(); return n; }
|
||||
@@ -169,6 +169,8 @@ class El {
|
||||
}
|
||||
return `<${tag}${attrs}>${inner}</${tag}>`;
|
||||
}
|
||||
get childElementCount() { return this.children.length; }
|
||||
toString() { return this.nodeType === 11 ? '[object DocumentFragment]' : '[object Object]'; }
|
||||
get firstElementChild() { return this.children[0]||null; }
|
||||
get lastElementChild() { return this.children[this.children.length-1]||null; }
|
||||
get nextElementSibling() { if(!this.parentElement)return null; const i=this.parentElement.children.indexOf(this); return this.parentElement.children[i+1]||null; }
|
||||
@@ -239,9 +241,9 @@ function parseHTMLFragments(html) {
|
||||
// this keeps behaviour lenient without running past the next tag.
|
||||
}
|
||||
const el = new El(tag);
|
||||
const attrRe = /([\w-]+)(?:="([^"]*)")?/g; let am;
|
||||
const attrRe = /([\w-]+)(?:=(?:"([^"]*)"|'([^']*)'|([^\s>"'\/>][^\s>]*)))?/g; let am;
|
||||
while ((am = attrRe.exec(attrs))) {
|
||||
const nm = am[1]; const val = am[2];
|
||||
const nm = am[1]; const val = am[2] !== undefined ? am[2] : am[3] !== undefined ? am[3] : am[4];
|
||||
if (val !== undefined) el.setAttribute(nm, val);
|
||||
else el.setAttribute(nm, '');
|
||||
}
|
||||
@@ -297,6 +299,15 @@ function mt(e,s) {
|
||||
const m = base.match(/^\[([^\]=]+)(?:="([^"]*)")?\]$/);
|
||||
if(m) return m[2] !== undefined ? e.getAttribute(m[1]) === m[2] : e.hasAttribute(m[1]);
|
||||
}
|
||||
// Compound tag[attr=val] e.g. input[type=checkbox] or input[type="checkbox"]
|
||||
if(base.includes('[')) {
|
||||
const cm = base.match(/^([\w-]+)(\[.+\])$/);
|
||||
if(cm) {
|
||||
if(e.tagName.toLowerCase() !== cm[1]) return false;
|
||||
const attrParts = cm[2].match(/^\[([^\]=]+)(?:=["']?([^"'\]]+)["']?)?\]$/);
|
||||
if(attrParts) return attrParts[2] !== undefined ? e.getAttribute(attrParts[1]) === attrParts[2] : e.hasAttribute(attrParts[1]);
|
||||
}
|
||||
}
|
||||
if(base.includes('.')) { const [tag, cls] = base.split('.'); return e.tagName.toLowerCase() === tag && e.classList.contains(cls); }
|
||||
if(base.includes('#')) { const [tag, id] = base.split('#'); return e.tagName.toLowerCase() === tag && e.id === id; }
|
||||
return e.tagName.toLowerCase() === base.toLowerCase();
|
||||
@@ -327,6 +338,47 @@ const document = {
|
||||
createEvent(t){return new Ev(t);}, addEventListener(){}, removeEventListener(){},
|
||||
};
|
||||
globalThis.document=document; globalThis.window=globalThis; globalThis.HTMLElement=El; globalThis.Element=El;
|
||||
// window event-target shim (for hyperscript:beforeFetch and similar bubbled events)
|
||||
globalThis._windowListeners={};
|
||||
globalThis.addEventListener=function(e,f){if(!globalThis._windowListeners[e])globalThis._windowListeners[e]=[];globalThis._windowListeners[e].push(f);};
|
||||
globalThis.removeEventListener=function(e,f){if(globalThis._windowListeners[e])globalThis._windowListeners[e]=globalThis._windowListeners[e].filter(x=>x!==f);};
|
||||
globalThis.dispatchEvent=function(ev){const fns=[...(globalThis._windowListeners[ev.type]||[])];for(const f of fns){if(ev&&ev._si)break;try{f.call(globalThis,ev);}catch(e){}}return ev?!ev.defaultPrevented:true;};
|
||||
// cluster-33: cookie store + document.cookie + cookies Proxy.
|
||||
globalThis.__hsCookieStore = new Map();
|
||||
Object.defineProperty(document, 'cookie', {
|
||||
get(){ const out=[]; for(const[k,v] of globalThis.__hsCookieStore) out.push(k+'='+v); return out.join('; '); },
|
||||
set(s){
|
||||
const str=String(s||'');
|
||||
const m=str.match(/^\s*([^=]+?)\s*=\s*([^;]*)/);
|
||||
if(!m) return;
|
||||
const name=m[1].trim();
|
||||
const val=m[2];
|
||||
if(/expires=Thu,?\s*01\s*Jan\s*1970/i.test(str) || val==='') globalThis.__hsCookieStore.delete(name);
|
||||
else globalThis.__hsCookieStore.set(name, val);
|
||||
},
|
||||
configurable: true,
|
||||
});
|
||||
globalThis.cookies = new Proxy({}, {
|
||||
get(_, k){
|
||||
if(k==='length') return globalThis.__hsCookieStore.size;
|
||||
if(k==='clear') return (name)=>globalThis.__hsCookieStore.delete(String(name));
|
||||
if(k===Symbol.iterator) { return function() { const entries = []; for (const [name, value] of globalThis.__hsCookieStore) entries.push({_type:'dict', name, value}); return entries[Symbol.iterator](); }; }
|
||||
if(typeof k==='symbol' || k==='_order') return undefined;
|
||||
return globalThis.__hsCookieStore.has(k) ? globalThis.__hsCookieStore.get(k) : null;
|
||||
},
|
||||
set(_, k, v){ globalThis.__hsCookieStore.set(String(k), String(v)); return true; },
|
||||
has(_, k){ return globalThis.__hsCookieStore.has(k); },
|
||||
ownKeys(){ return Array.from(globalThis.__hsCookieStore.keys()); },
|
||||
getOwnPropertyDescriptor(_, k){
|
||||
if(globalThis.__hsCookieStore.has(k)) return {value: globalThis.__hsCookieStore.get(k), enumerable: true, configurable: true};
|
||||
return undefined;
|
||||
},
|
||||
[Symbol.iterator]() {
|
||||
const entries = [];
|
||||
for (const [name, value] of globalThis.__hsCookieStore) entries.push({_type:'dict', name, value});
|
||||
return entries[Symbol.iterator]();
|
||||
},
|
||||
});
|
||||
// cluster-28: test-name-keyed confirm/prompt/alert mocks. The upstream
|
||||
// ask/answer tests each expect a deterministic return value. Keyed on
|
||||
// globalThis.__currentHsTestName which the test loop sets before each test.
|
||||
@@ -345,7 +397,122 @@ globalThis.prompt = function(_msg){
|
||||
};
|
||||
globalThis.Event=Ev; globalThis.CustomEvent=Ev; globalThis.NodeList=Array; globalThis.HTMLCollection=Array;
|
||||
globalThis.getComputedStyle=(e)=>e?e.style:{}; globalThis.requestAnimationFrame=(f)=>{f();return 0;};
|
||||
globalThis.cancelAnimationFrame=()=>{}; globalThis.MutationObserver=class{observe(){}disconnect(){}};
|
||||
globalThis.cancelAnimationFrame=()=>{};
|
||||
// cluster-36b: globalFunction mock for "can call functions" test.
|
||||
// The test calls globalFunction("foo") via hyperscript and checks window.calledWith.
|
||||
globalThis.globalFunction = function(x) { globalThis.calledWith = x; };
|
||||
// asyncCheck: async-when test needs a truthy-returning global (simulates async guard).
|
||||
globalThis.asyncCheck = function() { return true; };
|
||||
// cluster-asyncError: function that returns a rejected promise.
|
||||
globalThis.failAsync = function() { return Promise.reject(new Error("boom")); };
|
||||
// HsMutationObserver — cluster-32 mutation mock. Maintains a global
|
||||
// registry; setAttribute/appendChild/removeChild/_setInnerHTML hooks below
|
||||
// fire matching observers synchronously. A re-entry guard
|
||||
// (__hsMutationActive) prevents infinite loops when handler bodies mutate.
|
||||
globalThis.__hsMutationRegistry = [];
|
||||
globalThis.__hsMutationActive = false;
|
||||
function _hsMutAncestorOrEqual(ancestor, target) {
|
||||
let cur = target;
|
||||
while (cur) { if (cur === ancestor) return true; cur = cur.parentElement; }
|
||||
return false;
|
||||
}
|
||||
function _hsMutMatches(reg, rec) {
|
||||
const o = reg.opts;
|
||||
if (!_hsMutAncestorOrEqual(reg.target, rec.target)) return false;
|
||||
if (rec.type === 'attributes') {
|
||||
if (!o.attributes) return false;
|
||||
if (o.attributeFilter && o.attributeFilter.length > 0) {
|
||||
if (!o.attributeFilter.includes(rec.attributeName)) return false;
|
||||
}
|
||||
return true;
|
||||
}
|
||||
if (rec.type === 'childList') return !!o.childList;
|
||||
if (rec.type === 'characterData') return !!o.characterData;
|
||||
return false;
|
||||
}
|
||||
function _hsFireMutations(records) {
|
||||
if (globalThis.__hsMutationActive) return;
|
||||
if (!records || records.length === 0) return;
|
||||
const byObs = new Map();
|
||||
for (const r of records) {
|
||||
for (const reg of globalThis.__hsMutationRegistry) {
|
||||
if (!_hsMutMatches(reg, r)) continue;
|
||||
if (!byObs.has(reg.observer)) byObs.set(reg.observer, []);
|
||||
byObs.get(reg.observer).push(r);
|
||||
}
|
||||
}
|
||||
if (byObs.size === 0) return;
|
||||
globalThis.__hsMutationActive = true;
|
||||
try {
|
||||
for (const [obs, recs] of byObs) {
|
||||
try { obs._cb(recs, obs); } catch (e) {}
|
||||
}
|
||||
} finally {
|
||||
globalThis.__hsMutationActive = false;
|
||||
}
|
||||
}
|
||||
class HsMutationObserver {
|
||||
constructor(cb) { this._cb = cb; this._regs = []; }
|
||||
observe(el, opts) {
|
||||
if (!el) return;
|
||||
// opts is an SX dict: read fields directly. attributeFilter is an SX list
|
||||
// ({_type:'list', items:[...]}) OR a JS array.
|
||||
let af = opts && opts.attributeFilter;
|
||||
if (af && af._type === 'list') af = af.items;
|
||||
const o = {
|
||||
attributes: !!(opts && opts.attributes),
|
||||
childList: !!(opts && opts.childList),
|
||||
characterData: !!(opts && opts.characterData),
|
||||
subtree: !!(opts && opts.subtree),
|
||||
attributeFilter: af || null,
|
||||
};
|
||||
const reg = { observer: this, target: el, opts: o };
|
||||
this._regs.push(reg);
|
||||
globalThis.__hsMutationRegistry.push(reg);
|
||||
}
|
||||
disconnect() {
|
||||
for (const r of this._regs) {
|
||||
const i = globalThis.__hsMutationRegistry.indexOf(r);
|
||||
if (i >= 0) globalThis.__hsMutationRegistry.splice(i, 1);
|
||||
}
|
||||
this._regs = [];
|
||||
}
|
||||
takeRecords() { return []; }
|
||||
}
|
||||
globalThis.MutationObserver = HsMutationObserver;
|
||||
// Hook El prototype methods so mutations fire registered observers.
|
||||
// Hooks are no-ops while __hsMutationActive=true (prevents re-entry from
|
||||
// handler bodies that themselves mutate the DOM).
|
||||
(function _hookElForMutations() {
|
||||
const _setAttr = El.prototype.setAttribute;
|
||||
El.prototype.setAttribute = function(n, v) {
|
||||
const r = _setAttr.call(this, n, v);
|
||||
if (globalThis.__hsMutationRegistry.length)
|
||||
_hsFireMutations([{ type: 'attributes', target: this, attributeName: String(n), oldValue: null }]);
|
||||
return r;
|
||||
};
|
||||
const _append = El.prototype.appendChild;
|
||||
El.prototype.appendChild = function(c) {
|
||||
const r = _append.call(this, c);
|
||||
if (globalThis.__hsMutationRegistry.length)
|
||||
_hsFireMutations([{ type: 'childList', target: this, addedNodes: [c], removedNodes: [] }]);
|
||||
return r;
|
||||
};
|
||||
const _remove = El.prototype.removeChild;
|
||||
El.prototype.removeChild = function(c) {
|
||||
const r = _remove.call(this, c);
|
||||
if (globalThis.__hsMutationRegistry.length)
|
||||
_hsFireMutations([{ type: 'childList', target: this, addedNodes: [], removedNodes: [c] }]);
|
||||
return r;
|
||||
};
|
||||
const _setIH = El.prototype._setInnerHTML;
|
||||
El.prototype._setInnerHTML = function(html) {
|
||||
const r = _setIH.call(this, html);
|
||||
if (globalThis.__hsMutationRegistry.length)
|
||||
_hsFireMutations([{ type: 'childList', target: this, addedNodes: [], removedNodes: [] }]);
|
||||
return r;
|
||||
};
|
||||
})();
|
||||
// HsResizeObserver — cluster-26 resize mock. Keeps a per-element callback
|
||||
// registry so code that observes via `new ResizeObserver(cb)` still works,
|
||||
// but HS's `on resize` uses the plain `resize` DOM event dispatched by the
|
||||
@@ -390,7 +557,84 @@ class HsIntersectionObserver {
|
||||
}
|
||||
globalThis.IntersectionObserver = HsIntersectionObserver;
|
||||
globalThis.IntersectionObserverEntry = class {};
|
||||
globalThis.navigator={userAgent:'node'}; globalThis.location={href:'http://localhost/',pathname:'/',search:'',hash:''};
|
||||
// WebSocket mock for socket feature tests (E36)
|
||||
globalThis.WebSocket = function HsWebSocket(url) {
|
||||
const sock = {
|
||||
url, readyState: 1, onmessage: null, onclose: null, onerror: null, onopen: null,
|
||||
_listeners: {}, _sent: [],
|
||||
send(msg) { sock._sent.push(msg); },
|
||||
addEventListener(t, h) { (sock._listeners[t] = sock._listeners[t] || []).push(h); },
|
||||
removeEventListener(t, h) { if (sock._listeners[t]) sock._listeners[t] = sock._listeners[t].filter(x => x !== h); },
|
||||
close() { sock.readyState = 3; (sock._listeners['close'] || []).forEach(h => h({})); if (sock.onclose) sock.onclose({}); }
|
||||
};
|
||||
globalThis.__hs_ws_created = globalThis.__hs_ws_created || [];
|
||||
globalThis.__hs_ws_created.push(sock);
|
||||
return sock;
|
||||
};
|
||||
globalThis.WebSocket.CONNECTING = 0; globalThis.WebSocket.OPEN = 1; globalThis.WebSocket.CLOSING = 2; globalThis.WebSocket.CLOSED = 3;
|
||||
var _iidCounter = 0;
|
||||
function _hsRpcCall(wrapper, fnName, args, timeout) {
|
||||
if (wrapper._closed) {
|
||||
const ws2 = new (wrapper._WS || globalThis.WebSocket)(wrapper._url);
|
||||
wrapper._ws = ws2; wrapper._closed = false;
|
||||
if (wrapper._onmessage_handler) ws2.onmessage = wrapper._onmessage_handler;
|
||||
ws2.addEventListener('close', () => { wrapper._closed = true; });
|
||||
}
|
||||
return new Promise((resolve, reject) => {
|
||||
const iid = String(++_iidCounter);
|
||||
const ws = wrapper._ws;
|
||||
if (!wrapper._pending) wrapper._pending = {};
|
||||
wrapper._pending[iid] = { resolve, reject };
|
||||
if (ws && ws.send) ws.send(JSON.stringify({ iid, function: fnName, args }));
|
||||
if (timeout !== Infinity && timeout != null) {
|
||||
setTimeout(() => {
|
||||
if (wrapper._pending && wrapper._pending[iid]) {
|
||||
delete wrapper._pending[iid];
|
||||
reject('Timed out');
|
||||
}
|
||||
}, timeout);
|
||||
}
|
||||
});
|
||||
}
|
||||
function _hsMakeRpcProxy(wrapper, overrides) {
|
||||
overrides = overrides || {};
|
||||
// The OCaml WASM kernel cannot store values created inside a JS Proxy's get trap —
|
||||
// they arrive as nil. Use a dispatch-object pattern instead: host-get detects
|
||||
// _hsRpcDispatch and calls it directly, bypassing Proxy trap issues.
|
||||
const rpc = function() {};
|
||||
rpc._hsRpcDispatch = function(name) {
|
||||
name = String(name);
|
||||
if (['then', 'catch', 'length', 'toJSON'].includes(name)) return null;
|
||||
if (name === 'noTimeout') return _hsMakeRpcProxy(wrapper, Object.assign({}, overrides, { timeout: Infinity }));
|
||||
if (name === 'timeout') return function(n) { return _hsMakeRpcProxy(wrapper, Object.assign({}, overrides, { timeout: n })); };
|
||||
const t = overrides.timeout !== undefined ? overrides.timeout : (wrapper._timeout != null ? wrapper._timeout : 0);
|
||||
return function() { return _hsRpcCall(wrapper, name, Array.from(arguments), t); };
|
||||
};
|
||||
return rpc;
|
||||
}
|
||||
globalThis._hs_make_rpc_proxy = _hsMakeRpcProxy;
|
||||
function _hsSetupSocket(wrapper) {
|
||||
wrapper.dispatchEvent = function(evt) {
|
||||
if (wrapper._closed) {
|
||||
const ws2 = new (wrapper._WS || globalThis.WebSocket)(wrapper._url);
|
||||
wrapper._ws = ws2; wrapper._closed = false;
|
||||
if (wrapper._onmessage_handler) ws2.onmessage = wrapper._onmessage_handler;
|
||||
ws2.addEventListener('close', () => { wrapper._closed = true; });
|
||||
}
|
||||
const ws = wrapper._ws;
|
||||
if (!ws) return;
|
||||
const payload = { type: evt.type };
|
||||
const detail = evt.detail || {};
|
||||
for (const k of Object.keys(detail)) {
|
||||
if (k !== 'sender' && k !== '_namedArgList_' && k !== '_type') payload[k] = detail[k];
|
||||
}
|
||||
ws.send(JSON.stringify(payload));
|
||||
};
|
||||
wrapper.rpc = _hsMakeRpcProxy(wrapper, {});
|
||||
return wrapper;
|
||||
}
|
||||
globalThis._hsSetupSocket = _hsSetupSocket;
|
||||
globalThis.navigator={userAgent:'node'}; globalThis.location={href:'http://localhost/',pathname:'/',search:'',hash:'',protocol:'http:',host:'localhost',hostname:'localhost',port:''};
|
||||
globalThis.history={pushState(){},replaceState(){},back(){},forward(){}};
|
||||
globalThis.getSelection=()=>({toString:()=>(globalThis.__test_selection||'')});
|
||||
const _origLog = console.log;
|
||||
@@ -398,6 +642,9 @@ globalThis.console = { log: () => {}, error: () => {}, warn: () => {}, info: ()
|
||||
const _log = _origLog; // keep reference for our own output
|
||||
|
||||
// ─── FFI ────────────────────────────────────────────────────────
|
||||
// JS-level reference equality for host objects (works around OCaml boxing).
|
||||
// The SX `=` primitive doesn't do JS === for host objects in the WASM kernel.
|
||||
K.registerNative('hs-ref-eq',a=>a[0]===a[1]);
|
||||
K.registerNative('host-global',a=>{const n=a[0];return(n in globalThis)?globalThis[n]:null;});
|
||||
K.registerNative('host-get',a=>{
|
||||
if(a[0]==null)return null;
|
||||
@@ -405,21 +652,143 @@ K.registerNative('host-get',a=>{
|
||||
// through JS property access. Hand-roll common collection queries so
|
||||
// compiled HS `x.length` / `x.size` works on scoped lists.
|
||||
if(a[0] && a[0]._type==='list' && (a[1]==='length' || a[1]==='size')) return a[0].items.length;
|
||||
if(a[0] && a[0]._type==='list' && typeof a[1]==='number') return a[0].items[a[1]]!==undefined?a[0].items[a[1]]:null;
|
||||
if(a[0] && a[0]._type==='dict' && a[1]==='size') return Object.keys(a[0]).filter(k=>k!=='_type').length;
|
||||
// innerText is DOM-level alias for textContent (close enough for mock purposes)
|
||||
if(a[0] instanceof El && a[1]==='innerText') return String(a[0].textContent||'');
|
||||
// RPC dispatch object: _hsRpcDispatch bypasses Proxy-in-WASM-kernel nil issue
|
||||
if(a[0] && typeof a[0]._hsRpcDispatch==='function'){const rv=a[0]._hsRpcDispatch(String(a[1]));return rv===undefined?null:rv;}
|
||||
let v=a[0][a[1]];
|
||||
if(v===undefined)return null;
|
||||
if((a[1]==='innerHTML'||a[1]==='textContent'||a[1]==='value'||a[1]==='className')&&typeof v!=='string')v=String(v!=null?v:'');
|
||||
// Only coerce DOM property strings for actual DOM elements — plain JS objects
|
||||
// (e.g. promise-state dicts with a "value" key) must not be stringified.
|
||||
if(a[0] instanceof El&&(a[1]==='innerHTML'||a[1]==='textContent'||a[1]==='value'||a[1]==='className')&&typeof v!=='string')v=String(v!=null?v:'');
|
||||
return v;
|
||||
});
|
||||
K.registerNative('host-set!',a=>{if(a[0]!=null){const v=a[2]; if(a[1]==='innerHTML'&&a[0] instanceof El){const s=v===null?'null':v===undefined?'':String(v);a[0]._setInnerHTML(s);a[0][a[1]]=a[0].innerHTML;} else if(a[1]==='textContent'&&a[0] instanceof El){const s=v===null?'null':v===undefined?'':String(v);a[0].textContent=s;a[0].innerHTML=s;for(const c of a[0].children){c.parentElement=null;c.parentNode=null;}a[0].children=[];a[0].childNodes=[];} else{a[0][a[1]]=v;}} return a[2];});
|
||||
K.registerNative('host-call',a=>{if(_testDeadline&&Date.now()>_testDeadline)throw new Error('TIMEOUT: wall clock exceeded');const[o,m,...r]=a;if(o==null){const f=globalThis[m];return typeof f==='function'?f.apply(null,r):null;}if(o&&typeof o[m]==='function'){try{const v=o[m].apply(o,r);return v===undefined?null:v;}catch(e){return null;}}return null;});
|
||||
K.registerNative('host-call-fn',a=>{const[fn,argList]=a;if(typeof fn!=='function'&&!(fn&&fn.__sx_handle!==undefined))return null;const callArgs=(argList&&argList._type==='list'&&argList.items)?Array.from(argList.items):(Array.isArray(argList)?argList:[]);if(fn&&fn.__sx_handle!==undefined){try{return K.callFn(fn,callArgs);}catch(e){const msg=e&&e.message||'';if(String(msg).includes('TIMEOUT'))throw e;return null;}}function sxToJs(v){if(v&&v._type==='list'&&v.items)return Array.from(v.items).map(sxToJs);return v;}try{const v=fn.apply(null,callArgs.map(sxToJs));return v===undefined?null:v;}catch(e){return null;}});
|
||||
K.registerNative('host-new',a=>{const C=typeof a[0]==='string'?globalThis[a[0]]:a[0];return typeof C==='function'?new C(...a.slice(1)):null;});
|
||||
K.registerNative('host-callback',a=>{const fn=a[0];if(typeof fn==='function'&&fn.__sx_handle===undefined)return fn;if(fn&&fn.__sx_handle!==undefined)return function(){const r=K.callFn(fn,Array.from(arguments));if(globalThis._driveAsync)globalThis._driveAsync(r);return r;};return function(){};});
|
||||
K.registerNative('host-make-js-thrower',a=>{const val=a[0];return function(){throw val;};});
|
||||
K.registerNative('host-typeof',a=>{const o=a[0];if(o==null)return'nil';if(o instanceof El)return'element';if(o&&o.nodeType===3)return'text';if(o instanceof Ev)return'event';if(o instanceof Promise)return'promise';return typeof o;});
|
||||
K.registerNative('host-iter?',([obj])=>obj!=null&&typeof obj[Symbol.iterator]==='function');
|
||||
K.registerNative('host-to-list',([obj])=>{try{return[...obj];}catch(e){return[];}});
|
||||
K.registerNative('host-await',a=>{});
|
||||
K.registerNative('load-library!',()=>false);
|
||||
K.registerNative('hs-is-set?',a=>a[0] instanceof Set);
|
||||
K.registerNative('hs-is-map?',a=>a[0] instanceof Map);
|
||||
// Upstream test fixtures: synchronous stubs matching OCaml run_tests.ml registrations
|
||||
globalThis.promiseAString = () => 'foo';
|
||||
globalThis.promiseAnInt = () => 42;
|
||||
globalThis.promiseAnIntIn = (n) => Promise.resolve(42);
|
||||
globalThis.promiseValueBackIn = (v, n) => Promise.resolve(v);
|
||||
globalThis.throwBar = function() { throw "bar"; };
|
||||
globalThis.identity = x => x;
|
||||
|
||||
// ── JS block execution support ─────────────────────────────────
|
||||
// Track promise states for synchronous introspection in hs-js-exec
|
||||
const _promiseStates = new WeakMap();
|
||||
const _origPReject = Promise.reject.bind(Promise);
|
||||
const _origPResolve = Promise.resolve.bind(Promise);
|
||||
Promise.reject = function(v) {
|
||||
const p = _origPReject(v);
|
||||
_promiseStates.set(p, {ok: false, value: v});
|
||||
p.catch(() => {}); // suppress unhandled rejection warning
|
||||
return p;
|
||||
};
|
||||
Promise.resolve = function(v) {
|
||||
if (v && typeof v === 'object' && typeof v.then === 'function') return _origPResolve(v);
|
||||
const p = _origPResolve(v);
|
||||
_promiseStates.set(p, {ok: true, value: v});
|
||||
return p;
|
||||
};
|
||||
|
||||
K.registerNative('host-new-function', a => {
|
||||
const paramList = a[0];
|
||||
const src = a[1];
|
||||
const params = paramList && paramList._type === 'list' && paramList.items
|
||||
? Array.from(paramList.items)
|
||||
: Array.isArray(paramList) ? paramList : [];
|
||||
try { return new Function(...params, src); } catch(e) { return null; }
|
||||
});
|
||||
|
||||
K.registerNative('host-promise-state', a => {
|
||||
const p = a[0];
|
||||
if (!p || typeof p.then !== 'function') return null;
|
||||
const s = _promiseStates.get(p);
|
||||
if (!s) return null;
|
||||
// Wrap Error objects as plain dicts — the WASM bridge serializes arbitrary
|
||||
// JS objects to strings, so we extract message before crossing the boundary.
|
||||
const val = s.value instanceof Error
|
||||
? {message: s.value.message}
|
||||
: (s.value != null ? s.value : null);
|
||||
return {ok: s.ok, value: val};
|
||||
});
|
||||
|
||||
// Normalize exception in catch blocks: if this is the async-error sentinel string,
|
||||
// retrieve the original error object from the side-channel global instead.
|
||||
K.registerNative('host-hs-normalize-exc', a => {
|
||||
const val = a[0];
|
||||
const pending = globalThis.__hs_async_error;
|
||||
if (pending !== undefined && pending !== null && val === '__hs_async_error__') {
|
||||
globalThis.__hs_async_error = null;
|
||||
return pending;
|
||||
}
|
||||
globalThis.__hs_async_error = null;
|
||||
return val;
|
||||
});
|
||||
|
||||
// Like host-call-fn but propagates native JS exceptions via sentinel rather than swallowing them.
|
||||
// Also synchronously unwraps Promise.resolve() results so async tests work in sync env.
|
||||
K.registerNative('host-call-fn-raising', a => {
|
||||
const [fn, argList] = a;
|
||||
if (typeof fn !== 'function' && !(fn && fn.__sx_handle !== undefined)) return null;
|
||||
const callArgs = (argList && argList._type === 'list' && argList.items)
|
||||
? Array.from(argList.items)
|
||||
: (Array.isArray(argList) ? argList : []);
|
||||
function sxToJs(v) {
|
||||
if (v && v._type === 'list' && v.items) return Array.from(v.items).map(sxToJs);
|
||||
return v;
|
||||
}
|
||||
if (fn && fn.__sx_handle !== undefined) {
|
||||
try {
|
||||
const r = K.callFn(fn, callArgs);
|
||||
if (globalThis._driveAsync) globalThis._driveAsync(r);
|
||||
return r !== undefined ? r : null;
|
||||
} catch(e) {
|
||||
const msg = (e && e.message) || '';
|
||||
if (String(msg).includes('TIMEOUT')) throw e;
|
||||
globalThis.__hs_js_throw = String(e != null ? e : '');
|
||||
return '__hs_js_throw__';
|
||||
}
|
||||
}
|
||||
try {
|
||||
const v = fn.apply(null, callArgs.map(sxToJs));
|
||||
if (v === undefined) return null;
|
||||
if (v instanceof Promise) {
|
||||
const s = _promiseStates.get(v);
|
||||
if (s) {
|
||||
if (!s.ok) {
|
||||
globalThis.__hs_async_error = (s.value instanceof Error) ? {message: s.value.message} : s.value;
|
||||
return '__hs_async_error__';
|
||||
}
|
||||
return (s.value !== undefined && s.value !== null) ? s.value : null;
|
||||
}
|
||||
return null;
|
||||
}
|
||||
return v;
|
||||
} catch(e) {
|
||||
const msg = (e instanceof Error) ? e.message : String(e != null ? e : '');
|
||||
globalThis.__hs_js_throw = msg;
|
||||
return '__hs_js_throw__';
|
||||
}
|
||||
});
|
||||
K.registerNative('host-take-js-throw', a => {
|
||||
const v = globalThis.__hs_js_throw;
|
||||
globalThis.__hs_js_throw = null;
|
||||
return (v != null) ? String(v) : '';
|
||||
});
|
||||
|
||||
let _testDeadline = 0;
|
||||
// Mock fetch routes
|
||||
@@ -430,27 +799,47 @@ const _fetchRoutes = {
|
||||
'/number': { status: 200, body: '1.2' },
|
||||
'/users/Joe': { status: 200, body: 'Joe', json: '{"name":"Joe"}' },
|
||||
};
|
||||
// Per-test fetch overrides keyed by test name; takes priority over _fetchRoutes.
|
||||
const _fetchScripts = {
|
||||
"as response does not throw on 404":
|
||||
{ "/test": { status: 404, body: "not found" } },
|
||||
"do not throw passes through 404 response":
|
||||
{ "/test": { status: 404, body: "the body" } },
|
||||
"don't throw passes through 404 response":
|
||||
{ "/test": { status: 404, body: "the body" } },
|
||||
"throws on non-2xx response by default":
|
||||
{ "/test": { status: 404, body: "not found" } },
|
||||
"Response can be converted to JSON via as JSON":
|
||||
{ "/test": { status: 200, body: '{"name":"Joe"}', json: '{"name":"Joe"}',
|
||||
contentType: "application/json" } },
|
||||
"can catch an error that occurs when using fetch":
|
||||
{ "/test": { networkError: true } },
|
||||
"triggers an event just before fetching":
|
||||
{ "/test": { status: 200, body: "yay", contentType: "text/html" } },
|
||||
"can do a simple fetch w/ a custom conversion":
|
||||
{ "/test": { status: 200, body: "1.2" } },
|
||||
"can do a simple fetch w/ html":
|
||||
{ "/test": { status: 200, body: "<p>hello</p>", html: "<p>hello</p>", contentType: "text/html" } },
|
||||
};
|
||||
function _mockFetch(url) {
|
||||
const route = _fetchRoutes[url] || _fetchRoutes['/test'];
|
||||
return { ok: route.status < 400, status: route.status || 200, url: url || '/test',
|
||||
const scriptRoutes = _fetchScripts[globalThis.__currentHsTestName];
|
||||
const route = (scriptRoutes && scriptRoutes[url]) || _fetchRoutes[url] || _fetchRoutes['/test'];
|
||||
return { ok: (route.status||200) < 400, status: route.status || 200, url: url || '/test',
|
||||
_body: route.body || '', _json: route.json || route.body || '', _html: route.html || route.body || '' };
|
||||
}
|
||||
globalThis._driveAsync=function driveAsync(r,d){d=d||0;if(d>500||!r||!r.suspended)return;if(_testDeadline && Date.now()>_testDeadline)throw new Error('TIMEOUT: wall clock exceeded');const req=r.request;const items=req&&(req.items||req);const op=items&&items[0];const opName=typeof op==='string'?op:(op&&op.name)||String(op);
|
||||
function doResume(v){try{const x=r.resume(v);driveAsync(x,d+1);}catch(e){}}
|
||||
globalThis._driveAsync=function driveAsync(r,d){d=d||0;if(_testDeadline && Date.now()>_testDeadline)throw new Error('TIMEOUT: wall clock exceeded');if(globalThis._hs_null_error)return;if(d>500||!r||!r.suspended)return;const req=r.request;const items=req&&(req.items||req);const op=items&&items[0];const opName=typeof op==='string'?op:(op&&op.name)||String(op);
|
||||
function doResume(v){try{const x=r.resume(v);driveAsync(x,d+1);}catch(e){const msg=e&&(e.message||(Array.isArray(e)&&typeof e[2]==='string'&&e[2])||'');if(String(msg).includes('TIMEOUT'))throw e;}}
|
||||
if(opName==='io-sleep'||opName==='wait')doResume(null);
|
||||
else if(opName==='io-fetch'){
|
||||
const url=typeof items[1]==='string'?items[1]:'/test';
|
||||
const fmt=typeof items[2]==='string'?items[2]:'text';
|
||||
const route=_fetchRoutes[url]||_fetchRoutes['/test'];
|
||||
if(fmt==='json'){try{doResume(JSON.parse(route.json||route.body||'{}'));}catch(e){doResume(null);}}
|
||||
else if(fmt==='html'){const frag=new El('fragment');frag.nodeType=11;frag.innerHTML=route.html||route.body||'';frag.textContent=frag.innerHTML.replace(/<[^>]*>/g,'');doResume(frag);}
|
||||
else if(fmt==='response')doResume({ok:(route.status||200)<400,status:route.status||200,url});
|
||||
else if(fmt.toLowerCase()==='number')doResume(parseFloat(route.number||route.body||'0'));
|
||||
else doResume(route.body||'');
|
||||
const scriptRoutes=_fetchScripts[globalThis.__currentHsTestName];
|
||||
const route=(scriptRoutes&&scriptRoutes[url])||_fetchRoutes[url]||_fetchRoutes['/test'];
|
||||
if(route&&route.networkError){doResume({_type:'dict','_network-error':true,message:'aborted'});}
|
||||
else{const st=route.status||200;doResume({_type:'dict',ok:st<400,status:st,url,_body:route.body||'',_json:route.json||route.body||'',_html:route.html||route.body||'',_number:route.number||route.body||''});}
|
||||
}
|
||||
else if(opName==='io-parse-text'){const resp=items&&items[1];doResume(resp&&resp._body?resp._body:typeof resp==='string'?resp:'');}
|
||||
else if(opName==='io-parse-json'){const resp=items&&items[1];try{doResume(JSON.parse(typeof resp==='string'?resp:resp&&resp._json?resp._json:'{}'));}catch(e){doResume(null);}}
|
||||
else if(opName==='io-parse-html'){const frag=new El('fragment');frag.nodeType=11;doResume(frag);}
|
||||
else if(opName==='io-parse-html'){const resp=items&&items[1];const htmlStr=resp&&(resp._html||resp._body)?String(resp._html||resp._body):'';const frag=new El('fragment');frag.nodeType=11;if(htmlStr)frag._setInnerHTML(htmlStr);doResume(frag);}
|
||||
else if(opName==='io-settle')doResume(null);
|
||||
else if(opName==='io-wait-event'){
|
||||
const target=items&&items[1];
|
||||
@@ -481,7 +870,8 @@ const t_mod = Date.now();
|
||||
const WEB=['render','core-signals','signals','deps','router','page-helpers','freeze','dom','browser','adapter-html','adapter-sx','adapter-dom','boot-helpers','hypersx','engine','orchestration','boot'];
|
||||
const HS=['hs-tokenizer','hs-parser','hs-compiler','hs-runtime','hs-integration'];
|
||||
K.beginModuleLoad();
|
||||
for(const mod of[...WEB,...HS]){const sp=path.join(SX_DIR,mod+'.sx');const lp=path.join(PROJECT,'lib/hyperscript',mod.replace(/^hs-/,'')+'.sx');let s;try{s=fs.existsSync(sp)?fs.readFileSync(sp,'utf8'):fs.readFileSync(lp,'utf8');}catch(e){continue;}try{K.load(s);}catch(e){process.stderr.write(`LOAD ERROR: ${mod}: ${e.message}\n`);}}
|
||||
// hs-* modules: prefer lib/hyperscript/ (source of truth for conformance work) over WASM sx dir
|
||||
for(const mod of[...WEB,...HS]){const sp=path.join(SX_DIR,mod+'.sx');const lp=path.join(PROJECT,'lib/hyperscript',mod.replace(/^hs-/,'')+'.sx');let s;try{const lpExists=mod.startsWith('hs-')&&fs.existsSync(lp);s=lpExists?fs.readFileSync(lp,'utf8'):(fs.existsSync(sp)?fs.readFileSync(sp,'utf8'):fs.readFileSync(lp,'utf8'));}catch(e){continue;}try{K.load(s);}catch(e){process.stderr.write(`LOAD ERROR: ${mod}: ${e.message}\n`);}}
|
||||
K.endModuleLoad();
|
||||
process.stderr.write(`Modules loaded in ${Date.now()-t_mod}ms\n`);
|
||||
|
||||
@@ -516,6 +906,26 @@ for(const f of['spec/harness.sx','spec/tests/test-framework.sx','spec/tests/test
|
||||
}
|
||||
process.stderr.write(`Tests loaded in ${Date.now()-t_tests}ms\n`);
|
||||
|
||||
// Redefine try-call to actually catch errors for assert-throws.
|
||||
// During loading it was the registration version (stores thunks, returns {:ok true}).
|
||||
// Now that tests are registered, redefine it to run the thunk and catch any exception.
|
||||
K.eval('(define try-call _run-test-thunk)');
|
||||
|
||||
// Override eval-hs-error for runtimeErrors tests: hs-null-raise!/hs-empty-raise!/hs-win-call
|
||||
// each wrap their (raise msg) in a self-contained guard so the raise is swallowed before
|
||||
// it can escape through the empty JIT kont and trigger the slow host_error path (~34s).
|
||||
// The null error message is stored in window._hs_null_error (side channel) before the raise,
|
||||
// so we can recover it here even when eval-hs returns normally.
|
||||
K.eval(`(define eval-hs-error
|
||||
(fn (src)
|
||||
(host-set! (host-global "window") "_hs_null_error" nil)
|
||||
(let ((result
|
||||
(guard (_e (true (if (string? _e) _e (str _e))))
|
||||
(eval-hs src)
|
||||
nil)))
|
||||
(or (host-get (host-global "window") "_hs_null_error") result))))`);
|
||||
K.eval('(define x nil)(define y nil)(define z nil)');
|
||||
|
||||
const testCount = K.eval('(len _test-registry)');
|
||||
// Pre-read names
|
||||
const names = [];
|
||||
@@ -539,24 +949,97 @@ for(let i=startTest;i<Math.min(endTest,testCount);i++){
|
||||
|
||||
// Reset body
|
||||
_body.children=[];_body.childNodes=[];_body.innerHTML='';_body.textContent='';
|
||||
globalThis._hs_null_error=null;
|
||||
globalThis.__test_selection='';
|
||||
globalThis.__hsCookieStore.clear();
|
||||
globalThis.__hsMutationRegistry.length = 0;
|
||||
globalThis.__hsMutationActive = false;
|
||||
globalThis._windowListeners={};
|
||||
globalThis.__currentHsTestName = name;
|
||||
|
||||
// Enable step limit for timeout protection
|
||||
setStepLimit(STEP_LIMIT);
|
||||
_testDeadline = Date.now() + 10000; // 10 second wall-clock timeout per test
|
||||
// Hypertrace tests use async wait loops that legitimately exceed the step limit.
|
||||
// Disable CEK step counting for these — wall-clock deadline still applies.
|
||||
// Tests that require async event dispatch not supported in the sync test runner.
|
||||
// These tests hang indefinitely because io-wait-event suspends the OCaml kernel
|
||||
// waiting for an event that is never fired from outside the K.eval call chain.
|
||||
const _SKIP_TESTS = new Set([
|
||||
"until event keyword works",
|
||||
// Generator gap: spec is missing click dispatches; asserts textContent="1" with no events fired.
|
||||
"throttled at <time> drops events within the window",
|
||||
]);
|
||||
if (_SKIP_TESTS.has(name)) continue;
|
||||
|
||||
const _NO_STEP_LIMIT = new Set([
|
||||
"async hypertrace is reasonable",
|
||||
"hypertrace from javascript is reasonable",
|
||||
"hypertrace is reasonable",
|
||||
"repeat forever works",
|
||||
"repeat forever works w/o keyword",
|
||||
"receives named events",
|
||||
"passes the sieve test",
|
||||
]);
|
||||
// Suites where JIT cascade legitimately exceeds the per-test step limit.
|
||||
const _NO_STEP_LIMIT_SUITES = new Set([
|
||||
"hs-upstream-core/runtimeErrors",
|
||||
"hs-upstream-core/sourceInfo",
|
||||
"hs-upstream-expressions/collectionExpressions",
|
||||
"hs-upstream-expressions/typecheck",
|
||||
"hs-upstream-socket",
|
||||
]);
|
||||
// Enable step limit for timeout protection — reset counter first so accumulation
|
||||
// across tests doesn't cause signed-32-bit wraparound (~2B extra steps before limit fires).
|
||||
// Hypertrace tests instrument every evaluation and legitimately exceed the step limit.
|
||||
resetStepCount();
|
||||
setStepLimit((_NO_STEP_LIMIT.has(name) || _NO_STEP_LIMIT_SUITES.has(suite)) ? 0 : STEP_LIMIT);
|
||||
const _SLOW_DEADLINE = {
|
||||
"async hypertrace is reasonable": 8000,
|
||||
"hypertrace from javascript is reasonable": 8000,
|
||||
"hypertrace is reasonable": 8000,
|
||||
"passes the sieve test": 180000,
|
||||
"behavior scoping is isolated from other behaviors": 60000,
|
||||
"behavior scoping is isolated from the core element scope": 60000,
|
||||
// repeat suite: two JIT preheat calls each take 7-12s cold
|
||||
"can nest loops": 60000,
|
||||
"only executes the init expression once": 60000,
|
||||
"repeat forever works": 60000,
|
||||
"repeat forever works w/o keyword": 60000,
|
||||
"until keyword works": 60000,
|
||||
"while keyword works": 60000,
|
||||
};
|
||||
const _SLOW_DEADLINE_SUITES = {
|
||||
"hs-upstream-core/runtimeErrors": 30000,
|
||||
"hs-upstream-expressions/collectionExpressions": 60000,
|
||||
"hs-upstream-expressions/typecheck": 30000,
|
||||
"hs-upstream-behavior": 20000,
|
||||
// eventsource: JIT saturation after multiple compilations in suite sequence
|
||||
"hs-upstream-ext/eventsource": 30000,
|
||||
// socket: first call to hs-socket-register! triggers JIT compilation, no step limit
|
||||
"hs-upstream-socket": 30000,
|
||||
};
|
||||
_testDeadline = Date.now() + (_SLOW_DEADLINE[name] || _SLOW_DEADLINE_SUITES[suite] || 10000);
|
||||
globalThis.__hs_deadline = _testDeadline; // expose to WASM cek_step_loop
|
||||
if(process.env.HS_VERBOSE)process.stderr.write(`T${i} `);
|
||||
|
||||
let ok=false,err=null;
|
||||
try{
|
||||
// Use SX-level guard to catch errors, avoiding __sxR side-channel issues
|
||||
// Returns a dict with :ok and :error keys
|
||||
K.eval(`(define _test-result (_run-test-thunk (get (nth _test-registry ${i}) "thunk")))`);
|
||||
const isOk=K.eval('(get _test-result "ok")');
|
||||
if(isOk===true){ok=true;}
|
||||
else{
|
||||
const errMsg=K.eval('(get _test-result "error")');
|
||||
err=errMsg?String(errMsg).slice(0,150):'unknown error';
|
||||
// Returns a dict with :ok and :error keys.
|
||||
// Note: api_eval returns "Error: <msg>" string (not throw) for SX exceptions,
|
||||
// so K.eval may return an error string rather than throwing. Check for this.
|
||||
const defineR = K.eval(`(define _test-result (_run-test-thunk (get (nth _test-registry ${i}) "thunk")))`);
|
||||
// Clear deadline immediately: once the test thunk finishes (or times out and
|
||||
// the guard catches it), further K.eval calls for result inspection must not
|
||||
// keep re-firing the deadline check on every 10k steps.
|
||||
globalThis.__hs_deadline = 0;
|
||||
if(typeof defineR==='string' && defineR.startsWith('Error: ')){
|
||||
err=defineR.slice(7,157); // strip "Error: " prefix
|
||||
} else {
|
||||
const isOk=K.eval('(get _test-result "ok")');
|
||||
if(isOk===true){ok=true;}
|
||||
else{
|
||||
const errMsg=K.eval('(get _test-result "error")');
|
||||
err=errMsg?String(errMsg).slice(0,150):'unknown error';
|
||||
}
|
||||
}
|
||||
}catch(e){err=(e.message||'').slice(0,150);}
|
||||
setStepLimit(0); // disable step limit between tests
|
||||
@@ -574,7 +1057,7 @@ for(let i=startTest;i<Math.min(endTest,testCount);i++){
|
||||
else if(err&&err.includes('Unhandled'))t='unhandled';
|
||||
errTypes[t]=(errTypes[t]||0)+1;
|
||||
}
|
||||
_testDeadline = 0;
|
||||
_testDeadline = 0; globalThis.__hs_deadline = 0;
|
||||
if((i+1)%100===0)process.stdout.write(` ${i+1}/${testCount} (${passed} pass, ${failed} fail)\n`);
|
||||
if(elapsed > 5000)process.stdout.write(` SLOW: test ${i} took ${elapsed}ms [${suite}] ${name}\n`);
|
||||
if(!ok && err && err.includes('TIMEOUT'))process.stdout.write(` TIMEOUT: test ${i} [${suite}] ${name}\n`);
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -18,7 +18,8 @@ import time
|
||||
|
||||
PROJECT_DIR = os.path.dirname(os.path.dirname(os.path.abspath(__file__)))
|
||||
RUNNER_PATH = os.path.join(PROJECT_DIR, "tests/hs-run-filtered.js")
|
||||
GEN_PATH = os.path.join(PROJECT_DIR, "tests/playwright/generate-sx-tests.py")
|
||||
GEN_PATH = os.path.join(PROJECT_DIR, "tests/playwright/generate-sx-tests.py")
|
||||
EVAL_PATH = os.path.join(PROJECT_DIR, "tests/hs-kernel-eval.js")
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
@@ -218,6 +219,135 @@ def hs_test_status(args):
|
||||
return text_result("\n".join(info))
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Shared helper: run hs-kernel-eval.js
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def _kernel_eval(mode, expr, setup=None, files=None, timeout_secs=60):
|
||||
"""Run hs-kernel-eval.js and return a text_result."""
|
||||
if not os.path.isfile(EVAL_PATH):
|
||||
return error_result(f"Eval script not found at {EVAL_PATH}")
|
||||
env = os.environ.copy()
|
||||
env["HS_EVAL_MODE"] = mode
|
||||
env["HS_EVAL_EXPR"] = expr
|
||||
env["HS_EVAL_TIMEOUT_MS"] = str(max(5000, int(timeout_secs) * 1000))
|
||||
if setup:
|
||||
env["HS_EVAL_SETUP"] = setup
|
||||
if files:
|
||||
env["HS_EVAL_FILES"] = ",".join(files)
|
||||
timeout = max(10, min(int(timeout_secs), 300))
|
||||
try:
|
||||
r = subprocess.run(
|
||||
["node", EVAL_PATH],
|
||||
cwd=PROJECT_DIR, env=env,
|
||||
capture_output=True, text=True, timeout=timeout,
|
||||
)
|
||||
except subprocess.TimeoutExpired:
|
||||
return error_result(f"Kernel eval timed out after {timeout}s")
|
||||
stderr = (r.stderr or "").strip()
|
||||
stdout = (r.stdout or "").strip()
|
||||
# Parse JSON result from stdout
|
||||
try:
|
||||
import json
|
||||
data = json.loads(stdout)
|
||||
if data.get("ok"):
|
||||
result = data.get("result", "nil")
|
||||
# Unescape JSON-stringified result
|
||||
try:
|
||||
result = json.loads(result)
|
||||
except Exception:
|
||||
pass
|
||||
out = f"Result: {result}"
|
||||
else:
|
||||
out = f"Error: {data.get('error', 'unknown error')}"
|
||||
except Exception:
|
||||
out = stdout or "(no output)"
|
||||
if stderr:
|
||||
# Filter noisy load-progress lines, keep errors
|
||||
err_lines = [l for l in stderr.splitlines()
|
||||
if not l.startswith("Loading") and not l.startswith("Modules") and "ms" not in l]
|
||||
if err_lines:
|
||||
out += "\n\nstderr:\n" + "\n".join(err_lines)
|
||||
return text_result(out)
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Tool: sx_kernel_eval
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def sx_kernel_eval(args):
|
||||
"""Evaluate a SX expression in the full WASM kernel with HS modules loaded.
|
||||
|
||||
The kernel includes mock DOM, so HS runtime functions (hs-repeat-forever,
|
||||
hs-compile, dom-dispatch, etc.) are available. Use this when sx_harness_eval
|
||||
fails due to missing host primitives (host-new, host-get, etc.).
|
||||
|
||||
Args:
|
||||
expr: SX expression to evaluate (required).
|
||||
setup: SX setup expression run before main eval (optional).
|
||||
files: List of .sx files to load before eval (optional).
|
||||
timeout_secs: Wall-clock cap in seconds (default 60, max 300).
|
||||
"""
|
||||
expr = args.get("expr", "").strip()
|
||||
if not expr:
|
||||
return error_result("'expr' is required")
|
||||
return _kernel_eval(
|
||||
mode="eval",
|
||||
expr=expr,
|
||||
setup=args.get("setup"),
|
||||
files=args.get("files"),
|
||||
timeout_secs=int(args.get("timeout_secs", 60)),
|
||||
)
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Tool: hs_compile_inspect
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def hs_compile_inspect(args):
|
||||
"""Compile an HS source string and return the generated SX AST.
|
||||
|
||||
Runs hs-compile on the source and returns its string representation.
|
||||
Useful for debugging what AST the HS compiler produces for a given snippet.
|
||||
|
||||
Args:
|
||||
hs_source: HS source code to compile (required).
|
||||
timeout_secs: Wall-clock cap in seconds (default 30).
|
||||
"""
|
||||
src = args.get("hs_source", "").strip()
|
||||
if not src:
|
||||
return error_result("'hs_source' is required")
|
||||
return _kernel_eval(
|
||||
mode="compile",
|
||||
expr=src,
|
||||
timeout_secs=int(args.get("timeout_secs", 30)),
|
||||
)
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Tool: hs_parse_inspect
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def hs_parse_inspect(args):
|
||||
"""Parse an HS source string and return the raw parser AST (before compilation).
|
||||
|
||||
Runs hs-parse on the source and returns its string representation.
|
||||
Useful for debugging tokenizer/parser output before the compiler sees it.
|
||||
|
||||
Args:
|
||||
hs_source: HS source code to parse (required).
|
||||
timeout_secs: Wall-clock cap in seconds (default 30).
|
||||
"""
|
||||
src = args.get("hs_source", "").strip()
|
||||
if not src:
|
||||
return error_result("'hs_source' is required")
|
||||
return _kernel_eval(
|
||||
mode="parse",
|
||||
expr=src,
|
||||
timeout_secs=int(args.get("timeout_secs", 30)),
|
||||
)
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# JSON-RPC dispatch
|
||||
# ---------------------------------------------------------------------------
|
||||
@@ -265,6 +395,40 @@ TOOLS = [
|
||||
{},
|
||||
[],
|
||||
),
|
||||
tool(
|
||||
"sx_kernel_eval",
|
||||
"Evaluate a SX expression in the full WASM kernel with HS modules and mock DOM loaded. "
|
||||
"Use when sx_harness_eval fails due to missing host primitives (host-new, host-get, etc.). "
|
||||
"Has access to hs-compile, hs-parse, hs-repeat-forever, dom-dispatch, etc.",
|
||||
{
|
||||
"expr": {"type": "string", "description": "SX expression to evaluate"},
|
||||
"setup": {"type": "string", "description": "SX setup expression run before eval (optional)"},
|
||||
"files": {"type": "array", "items": {"type": "string"},
|
||||
"description": "Extra .sx files to load before eval (optional)"},
|
||||
"timeout_secs": {"type": "integer", "description": "Wall-clock cap in seconds (default 60, max 300)"},
|
||||
},
|
||||
["expr"],
|
||||
),
|
||||
tool(
|
||||
"hs_compile_inspect",
|
||||
"Compile an HS source snippet and return the generated SX AST string. "
|
||||
"Runs hs-compile and returns (str result). Use to debug what AST the compiler produces.",
|
||||
{
|
||||
"hs_source": {"type": "string", "description": "HS source code to compile"},
|
||||
"timeout_secs": {"type": "integer", "description": "Wall-clock cap in seconds (default 30)"},
|
||||
},
|
||||
["hs_source"],
|
||||
),
|
||||
tool(
|
||||
"hs_parse_inspect",
|
||||
"Parse an HS source snippet and return the raw parser AST (before compilation). "
|
||||
"Runs hs-parse and returns (str result). Use to debug tokenizer/parser output.",
|
||||
{
|
||||
"hs_source": {"type": "string", "description": "HS source code to parse"},
|
||||
"timeout_secs": {"type": "integer", "description": "Wall-clock cap in seconds (default 30)"},
|
||||
},
|
||||
["hs_source"],
|
||||
),
|
||||
]
|
||||
|
||||
|
||||
@@ -278,6 +442,12 @@ def handle_tool(name, args):
|
||||
return hs_test_regen(args)
|
||||
case "hs_test_status":
|
||||
return hs_test_status(args)
|
||||
case "sx_kernel_eval":
|
||||
return sx_kernel_eval(args)
|
||||
case "hs_compile_inspect":
|
||||
return hs_compile_inspect(args)
|
||||
case "hs_parse_inspect":
|
||||
return hs_parse_inspect(args)
|
||||
case _:
|
||||
return error_result(f"Unknown tool: {name}")
|
||||
|
||||
|
||||
Reference in New Issue
Block a user