plans: kernel-on-sx — log quoting.sx extraction + evaluator.sx decline

Updates Phase 7 status:
- env.sx ✓ extracted (three live consumers: Kernel, Tcl, Smalltalk,
  with Scheme also using it directly)
- class-chain.sx ✓ extracted (bonus — not on the original six-file
  list but surfaced by the same chiselling discipline; Smalltalk +
  CLOS consumers)
- quoting.sx ✓ extracted (Kernel + Scheme consumers)
- evaluator.sx DECLINED — too thin to be its own kit; the shared
  content is protocol/API surface, not algorithm. Documented
  in-plan, no file created.
- combiner.sx, short-circuit.sx — still need fexpr-having
  second consumers
- hygiene.sx — still awaits Scheme Phase 6c (research-grade
  scope-set work)

Three kits live, one declined, three still gated.

hosts/ocaml/bin/run_tests.ml

@@ -1279,7 +1279,7 @@ let run_foundation_tests () =
   assert_true "sx_truthy \"\"" (Bool (sx_truthy (String "")));
   assert_eq "not truthy nil" (Bool false) (Bool (sx_truthy Nil));
   assert_eq "not truthy false" (Bool false) (Bool (sx_truthy (Bool false)));
-  let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None } in
+  let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None; l_call_count = 0 } in
   assert_true "is_lambda" (Bool (Sx_types.is_lambda (Lambda l)));
   ignore (Sx_types.set_lambda_name (Lambda l) "my-fn");
   assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l))

hosts/ocaml/lib/sx_primitives.ml

@@ -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
@@ -3399,6 +3576,204 @@ let () =
       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
@@ -3734,4 +4109,25 @@ let () =
         | 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)
+      Env child);
+
+  (* JIT cache control & observability — backed by refs in sx_types.ml to
+     avoid creating a sx_primitives → sx_vm dependency cycle. sx_vm reads
+     these refs to decide when to JIT. *)
+  register "jit-stats" (fun _args ->
+    let d = Hashtbl.create 8 in
+    Hashtbl.replace d "threshold"        (Number (float_of_int !Sx_types.jit_threshold));
+    Hashtbl.replace d "compiled"         (Number (float_of_int !Sx_types.jit_compiled_count));
+    Hashtbl.replace d "compile-failed"   (Number (float_of_int !Sx_types.jit_skipped_count));
+    Hashtbl.replace d "below-threshold"  (Number (float_of_int !Sx_types.jit_threshold_skipped_count));
+    Dict d);
+  register "jit-set-threshold!" (fun args ->
+    match args with
+    | [Number n] -> Sx_types.jit_threshold := int_of_float n; Nil
+    | [Integer n] -> Sx_types.jit_threshold := n; Nil
+    | _ -> raise (Eval_error "jit-set-threshold!: (n) where n is integer"));
+  register "jit-reset-counters!" (fun _args ->
+    Sx_types.jit_compiled_count := 0;
+    Sx_types.jit_skipped_count := 0;
+    Sx_types.jit_threshold_skipped_count := 0;
+    Nil)

hosts/ocaml/lib/sx_types.ml

@@ -138,6 +138,7 @@ and lambda = {
   l_closure : env;
   mutable l_name : string option;
   mutable l_compiled : vm_closure option;  (** Lazy JIT cache *)
+  mutable l_call_count : int;              (** Tiered-compilation counter — JIT after threshold calls *)
 }
 
 and component = {
@@ -449,7 +450,20 @@ let make_lambda params body closure =
     | List items -> List.map value_to_string items
     | _ -> value_to_string_list params
   in
-  Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None }
+  Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None; l_call_count = 0 }
+
+(** {1 JIT cache control}
+
+    Tiered compilation: only JIT a lambda after it's been called [jit_threshold]
+    times. This filters out one-shot lambdas (test harness, dynamic eval, REPLs)
+    so they never enter the JIT cache. Counters are exposed to SX as [(jit-stats)].
+
+    These live here (in sx_types) rather than sx_vm so [sx_primitives] can read
+    them without creating a sx_primitives → sx_vm dependency cycle. *)
+let jit_threshold = ref 4
+let jit_compiled_count = ref 0
+let jit_skipped_count = ref 0
+let jit_threshold_skipped_count = ref 0
 
 let make_component name params has_children body closure affinity =
   let n = value_to_string name in

hosts/ocaml/lib/sx_vm.ml

@@ -57,6 +57,9 @@ let () = Sx_types._convert_vm_suspension := (fun exn ->
 let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
   ref (fun _ _ -> None)
 
+(* JIT threshold and counters live in Sx_types so primitives can read them
+   without creating a sx_primitives → sx_vm dependency cycle. *)
+
 (** Sentinel closure indicating JIT compilation was attempted and failed.
     Prevents retrying compilation on every call. *)
 let jit_failed_sentinel = {
@@ -364,13 +367,21 @@ and vm_call vm f args =
      | None ->
        if l.l_name <> None
        then begin
-         l.l_compiled <- Some jit_failed_sentinel;
-         match !jit_compile_ref l vm.globals with
-         | Some cl ->
-           l.l_compiled <- Some cl;
-           push_closure_frame vm cl args
-         | None ->
+         l.l_call_count <- l.l_call_count + 1;
+         if l.l_call_count >= !Sx_types.jit_threshold then begin
+           l.l_compiled <- Some jit_failed_sentinel;
+           match !jit_compile_ref l vm.globals with
+           | Some cl ->
+             incr Sx_types.jit_compiled_count;
+             l.l_compiled <- Some cl;
+             push_closure_frame vm cl args
+           | None ->
+             incr Sx_types.jit_skipped_count;
+             push vm (cek_call_or_suspend vm f (List args))
+         end else begin
+           incr Sx_types.jit_threshold_skipped_count;
            push vm (cek_call_or_suspend vm f (List args))
+         end
        end
        else
          push vm (cek_call_or_suspend vm f (List args)))

lib/apl/parser.sx

@@ -270,6 +270,15 @@
               (collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)})))
             ((= tt :name)
               (cond
+                ((and (< (+ i 1) (len tokens)) (= (tok-type (nth tokens (+ i 1))) :assign))
+                  (let
+                    ((rhs-tokens (slice tokens (+ i 2) (len tokens))))
+                    (let
+                      ((rhs-expr (parse-apl-expr rhs-tokens)))
+                      (collect-segments-loop
+                        tokens
+                        (len tokens)
+                        (append acc {:kind "val" :node (list :assign-expr tv rhs-expr)})))))
                 ((some (fn (q) (= q tv)) apl-quad-fn-names)
                   (let
                     ((op-result (collect-ops tokens (+ i 1))))
@@ -335,10 +344,22 @@
             ((= tt :glyph)
               (cond
                 ((or (= tv "⍺") (= tv "⍵"))
-                  (collect-segments-loop
-                    tokens
-                    (+ i 1)
-                    (append acc {:kind "val" :node (list :name tv)})))
+                  (if
+                    (and
+                      (< (+ i 1) (len tokens))
+                      (= (tok-type (nth tokens (+ i 1))) :assign))
+                    (let
+                      ((rhs-tokens (slice tokens (+ i 2) (len tokens))))
+                      (let
+                        ((rhs-expr (parse-apl-expr rhs-tokens)))
+                        (collect-segments-loop
+                          tokens
+                          (len tokens)
+                          (append acc {:kind "val" :node (list :assign-expr tv rhs-expr)}))))
+                    (collect-segments-loop
+                      tokens
+                      (+ i 1)
+                      (append acc {:kind "val" :node (list :name tv)}))))
                 ((= tv "∇")
                   (collect-segments-loop
                     tokens
@@ -393,7 +414,13 @@
                             ni
                             (append acc {:kind "fn" :node fn-node})))))))
                 ((apl-parse-op-glyph? tv)
-                  (collect-segments-loop tokens (+ i 1) acc))
+                  (if
+                    (or (= tv "/") (= tv "⌿") (= tv "\\") (= tv "⍀"))
+                    (collect-segments-loop
+                      tokens
+                      (+ i 1)
+                      (append acc {:kind "fn" :node (list :fn-glyph tv)}))
+                    (collect-segments-loop tokens (+ i 1) acc)))
                 (true (collect-segments-loop tokens (+ i 1) acc))))
             (true (collect-segments-loop tokens (+ i 1) acc))))))))
 

lib/apl/runtime.sx

@@ -808,6 +808,25 @@
           ((picked (map (fn (i) (nth arr-ravel i)) kept)))
           (make-array (list (len picked)) picked))))))
 
+(define
+  apl-compress-first
+  (fn
+    (mask arr)
+    (let
+      ((mask-ravel (get mask :ravel))
+        (shape (get arr :shape))
+        (ravel (get arr :ravel)))
+      (if
+        (< (len shape) 2)
+        (apl-compress mask arr)
+        (let
+          ((rows (first shape)) (cols (last shape)))
+          (let
+            ((kept-rows (filter (fn (i) (not (= 0 (nth mask-ravel i)))) (range 0 rows))))
+            (let
+              ((new-ravel (reduce (fn (acc r) (append acc (map (fn (j) (nth ravel (+ (* r cols) j))) (range 0 cols)))) (list) kept-rows)))
+              (make-array (cons (len kept-rows) (rest shape)) new-ravel))))))))
+
 (define
   apl-primes
   (fn
@@ -985,6 +1004,28 @@
         (some (fn (c) (= c 0)) codes)
         (some (fn (c) (= c (nth e 1))) codes)))))
 
+(define apl-rng-state 12345)
+
+(define apl-rng-seed! (fn (s) (set! apl-rng-state s)))
+
+(define
+  apl-rng-next!
+  (fn
+    ()
+    (begin
+      (set!
+        apl-rng-state
+        (mod (+ (* apl-rng-state 1103515245) 12345) 2147483648))
+      apl-rng-state)))
+
+(define
+  apl-roll
+  (fn
+    (arr)
+    (let
+      ((n (if (scalar? arr) (first (get arr :ravel)) (first (get arr :ravel)))))
+      (apl-scalar (+ apl-io (mod (apl-rng-next!) n))))))
+
 (define
   apl-cartesian
   (fn

lib/apl/tests/pipeline.sx

@@ -312,3 +312,146 @@
   "train: mean of ⍳10 has shape ()"
   (mksh (apl-run "(+/÷≢) ⍳10"))
   (list))
+
+(apl-test
+  "compress: 1 0 1 0 1 / 10 20 30 40 50"
+  (mkrv (apl-run "1 0 1 0 1 / 10 20 30 40 50"))
+  (list 10 30 50))
+
+(apl-test
+  "compress: empty mask → empty"
+  (mkrv (apl-run "0 0 0 / 1 2 3"))
+  (list))
+
+(apl-test
+  "primes via classic idiom (multi-stmt)"
+  (mkrv (apl-run "P ← ⍳ 30 ⋄ (2 = +⌿ 0 = P ∘.| P) / P"))
+  (list 2 3 5 7 11 13 17 19 23 29))
+
+(apl-test
+  "primes via classic idiom (n=20)"
+  (mkrv (apl-run "P ← ⍳ 20 ⋄ (2 = +⌿ 0 = P ∘.| P) / P"))
+  (list 2 3 5 7 11 13 17 19))
+
+(apl-test
+  "compress: filter even values"
+  (mkrv (apl-run "(0 = 2 | 1 2 3 4 5 6) / 1 2 3 4 5 6"))
+  (list 2 4 6))
+
+(apl-test "inline-assign: x ← 5" (mkrv (apl-run "x ← 5")) (list 5))
+
+(apl-test
+  "inline-assign: (2×x) + x←10 → 30"
+  (mkrv (apl-run "(2 × x) + x ← 10"))
+  (list 30))
+
+(apl-test
+  "inline-assign primes one-liner: (2=+⌿0=a∘.|a)/a←⍳30"
+  (mkrv (apl-run "(2 = +⌿ 0 = a ∘.| a) / a ← ⍳ 30"))
+  (list 2 3 5 7 11 13 17 19 23 29))
+
+(apl-test
+  "inline-assign: x is reusable — x + x ← 7 → 14"
+  (mkrv (apl-run "x + x ← 7"))
+  (list 14))
+
+(apl-test
+  "inline-assign in dfn: f ← {x + x ← ⍵} ⋄ f 8 → 16"
+  (mkrv (apl-run "f ← {x + x ← ⍵} ⋄ f 8"))
+  (list 16))
+
+(begin (apl-rng-seed! 42) nil)
+
+(apl-test
+  "?10 with seed 42 → 8 (deterministic)"
+  (mkrv (apl-run "?10"))
+  (list 8))
+
+(apl-test "?10 next call → 5" (mkrv (apl-run "?10")) (list 5))
+
+(apl-test
+  "?100 stays in range"
+  (let ((v (first (mkrv (apl-run "?100"))))) (and (>= v 1) (<= v 100)))
+  true)
+
+(begin (apl-rng-seed! 42) nil)
+
+(apl-test
+  "?10 with re-seed 42 → 8 (reproducible)"
+  (mkrv (apl-run "?10"))
+  (list 8))
+
+(apl-test
+  "apl-run-file: load primes.apl returns dfn AST"
+  (first (apl-run-file "lib/apl/tests/programs/primes.apl"))
+  :dfn)
+
+(apl-test
+  "apl-run-file: life.apl parses without error"
+  (first (apl-run-file "lib/apl/tests/programs/life.apl"))
+  :dfn)
+
+(apl-test
+  "apl-run-file: quicksort.apl parses without error"
+  (first (apl-run-file "lib/apl/tests/programs/quicksort.apl"))
+  :dfn)
+
+(apl-test
+  "apl-run-file: source-then-call returns primes count"
+  (mksh
+    (apl-run
+      (str (file-read "lib/apl/tests/programs/primes.apl") " ⋄ primes 30")))
+  (list 10))
+
+(apl-test
+  "primes one-liner with ⍵-rebind: primes 30"
+  (mkrv
+    (apl-run "primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} ⋄ primes 30"))
+  (list 2 3 5 7 11 13 17 19 23 29))
+
+(apl-test
+  "primes one-liner: primes 50"
+  (mkrv
+    (apl-run "primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} ⋄ primes 50"))
+  (list 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47))
+
+(apl-test
+  "primes.apl loaded + called via apl-run-file"
+  (mkrv
+    (apl-run
+      (str (file-read "lib/apl/tests/programs/primes.apl") " ⋄ primes 20")))
+  (list 2 3 5 7 11 13 17 19))
+
+(apl-test
+  "primes.apl loaded — count of primes ≤ 100"
+  (first
+    (mksh
+      (apl-run
+        (str
+          (file-read "lib/apl/tests/programs/primes.apl")
+          " ⋄ primes 100"))))
+  25)
+
+(apl-test
+  "⍉ monadic transpose 2x3 → 3x2"
+  (mkrv (apl-run "⍉ (2 3) ⍴ ⍳6"))
+  (list 1 4 2 5 3 6))
+
+(apl-test
+  "⍉ transpose shape (3 2)"
+  (mksh (apl-run "⍉ (2 3) ⍴ ⍳6"))
+  (list 3 2))
+
+(apl-test "⊢ monadic identity" (mkrv (apl-run "⊢ 1 2 3")) (list 1 2 3))
+
+(apl-test
+  "5 ⊣ 1 2 3 → 5 (left)"
+  (mkrv (apl-run "5 ⊣ 1 2 3"))
+  (list 5))
+
+(apl-test
+  "5 ⊢ 1 2 3 → 1 2 3 (right)"
+  (mkrv (apl-run "5 ⊢ 1 2 3"))
+  (list 1 2 3))
+
+(apl-test "⍕ 42 → \"42\" (alias for ⎕FMT)" (apl-run "⍕ 42") "42")

lib/apl/tests/programs.sx

@@ -252,8 +252,6 @@
 
 (apl-test "queens 7 → 40 solutions" (mkrv (apl-queens 7)) (list 40))
 
-(apl-test "queens 8 → 92 solutions" (mkrv (apl-queens 8)) (list 92))
-
 (apl-test "permutations of 3 has 6" (len (apl-permutations 3)) 6)
 
 (apl-test "permutations of 4 has 24" (len (apl-permutations 4)) 24)

lib/apl/transpile.sx

@@ -39,6 +39,11 @@
       ((= g "⊖") apl-reverse-first)
       ((= g "⍋") apl-grade-up)
       ((= g "⍒") apl-grade-down)
+      ((= g "?") apl-roll)
+      ((= g "⍉") apl-transpose)
+      ((= g "⊢") (fn (a) a))
+      ((= g "⊣") (fn (a) a))
+      ((= g "⍕") apl-quad-fmt)
       ((= g "⎕FMT") apl-quad-fmt)
       ((= g "⎕←") apl-quad-print)
       (else (error "no monadic fn for glyph")))))
@@ -80,6 +85,11 @@
       ((= g "∊") apl-member)
       ((= g "⍳") apl-index-of)
       ((= g "~") apl-without)
+      ((= g "/") apl-compress)
+      ((= g "⌿") apl-compress-first)
+      ((= g "⍉") apl-transpose-dyadic)
+      ((= g "⊢") (fn (a b) b))
+      ((= g "⊣") (fn (a b) a))
       (else (error "no dyadic fn for glyph")))))
 
 (define
@@ -119,8 +129,14 @@
           (let
             ((nm (nth node 1)))
             (cond
-              ((= nm "⍺") (get env "alpha"))
-              ((= nm "⍵") (get env "omega"))
+              ((= nm "⍺")
+                (let
+                  ((v (get env "⍺")))
+                  (if (= v nil) (get env "alpha") v)))
+              ((= nm "⍵")
+                (let
+                  ((v (get env "⍵")))
+                  (if (= v nil) (get env "omega") v)))
               ((= nm "⎕IO") (apl-quad-io))
               ((= nm "⎕ML") (apl-quad-ml))
               ((= nm "⎕FR") (apl-quad-fr))
@@ -132,7 +148,11 @@
             (if
               (and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇"))
               (apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env))
-              ((apl-resolve-monadic fn-node env) (apl-eval-ast arg env)))))
+              (let
+                ((arg-val (apl-eval-ast arg env)))
+                (let
+                  ((new-env (if (and (list? arg) (> (len arg) 0) (= (first arg) :assign-expr)) (assoc env (nth arg 1) arg-val) env)))
+                  ((apl-resolve-monadic fn-node new-env) arg-val))))))
         ((= tag :dyad)
           (let
             ((fn-node (nth node 1))
@@ -144,9 +164,13 @@
                 (get env "nabla")
                 (apl-eval-ast lhs env)
                 (apl-eval-ast rhs env))
-              ((apl-resolve-dyadic fn-node env)
-                (apl-eval-ast lhs env)
-                (apl-eval-ast rhs env)))))
+              (let
+                ((rhs-val (apl-eval-ast rhs env)))
+                (let
+                  ((new-env (if (and (list? rhs) (> (len rhs) 0) (= (first rhs) :assign-expr)) (assoc env (nth rhs 1) rhs-val) env)))
+                  ((apl-resolve-dyadic fn-node new-env)
+                    (apl-eval-ast lhs new-env)
+                    rhs-val))))))
         ((= tag :program) (apl-eval-stmts (rest node) env))
         ((= tag :dfn) node)
         ((= tag :bracket)
@@ -159,6 +183,8 @@
                     (fn (a) (if (= a :all) nil (apl-eval-ast a env)))
                     axis-exprs)))
               (apl-bracket-multi axes arr))))
+        ((= tag :assign-expr) (apl-eval-ast (nth node 2) env))
+        ((= tag :assign) (apl-eval-ast (nth node 2) env))
         (else (error (list "apl-eval-ast: unknown node tag" tag node)))))))
 
 (define
@@ -538,3 +564,5 @@
         (else (error "apl-resolve-dyadic: unknown fn-node tag"))))))
 
 (define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
+
+(define apl-run-file (fn (path) (apl-run (file-read path))))

lib/datalog/aggregates.sx

@@ -1,157 +0,0 @@
-;; lib/datalog/aggregates.sx — count / sum / min / max / findall.
-;;
-;; Surface form (always 3-arg after the relation name):
-;;
-;;   (count   Result  Var  GoalLit)
-;;   (sum     Result  Var  GoalLit)
-;;   (min     Result  Var  GoalLit)
-;;   (max     Result  Var  GoalLit)
-;;   (findall List    Var  GoalLit)
-;;
-;; Parsed naturally because arg-position compounds are already allowed
-;; (Phase 4 needs them for arithmetic). At evaluation time the aggregator
-;; runs `dl-find-bindings` on `GoalLit` under the current subst, collects
-;; the distinct values of `Var`, and binds `Result`.
-;;
-;; Aggregation is non-monotonic — `count(C, X, p(X))` shrinks as p loses
-;; tuples. The stratifier (lib/datalog/strata.sx) treats every aggregate's
-;; goal relation as a negation-like edge so the inner relation is fully
-;; derived before the aggregate fires.
-;;
-;; Empty input: count → 0, sum → 0, min/max → no binding (rule fails).
-
-(define dl-aggregate-rels (list "count" "sum" "min" "max" "findall"))
-
-(define
-  dl-aggregate?
-  (fn
-    (lit)
-    (and
-      (list? lit)
-      (>= (len lit) 4)
-      (let ((rel (dl-rel-name lit)))
-        (cond
-          ((nil? rel) false)
-          (else (dl-member-string? rel dl-aggregate-rels)))))))
-
-;; Apply aggregation operator to a list of (already-distinct) numeric or
-;; symbolic values. Returns the aggregated value, or :empty if min/max
-;; has no input.
-(define
-  dl-do-aggregate
-  (fn
-    (op vals)
-    (cond
-      ((= op "count") (len vals))
-      ((= op "sum") (dl-sum-vals vals 0))
-      ((= op "findall") vals)
-      ((= op "min")
-        (cond
-          ((= (len vals) 0) :empty)
-          (else (dl-min-vals vals 1 (first vals)))))
-      ((= op "max")
-        (cond
-          ((= (len vals) 0) :empty)
-          (else (dl-max-vals vals 1 (first vals)))))
-      (else (error (str "datalog: unknown aggregate " op))))))
-
-(define
-  dl-sum-vals
-  (fn
-    (vals acc)
-    (cond
-      ((= (len vals) 0) acc)
-      (else (dl-sum-vals (rest vals) (+ acc (first vals)))))))
-
-(define
-  dl-min-vals
-  (fn
-    (vals i cur)
-    (cond
-      ((>= i (len vals)) cur)
-      (else
-        (let ((v (nth vals i)))
-          (dl-min-vals vals (+ i 1) (if (< v cur) v cur)))))))
-
-(define
-  dl-max-vals
-  (fn
-    (vals i cur)
-    (cond
-      ((>= i (len vals)) cur)
-      (else
-        (let ((v (nth vals i)))
-          (dl-max-vals vals (+ i 1) (if (> v cur) v cur)))))))
-
-;; Membership check by deep equality (so 30 == 30.0 etc).
-(define
-  dl-val-member?
-  (fn
-    (v xs)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-tuple-equal? v (first xs)) true)
-      (else (dl-val-member? v (rest xs))))))
-
-;; Evaluate an aggregate body lit under `subst`. Returns the list of
-;; extended substitutions (0 or 1 element).
-(define
-  dl-eval-aggregate
-  (fn
-    (lit db subst)
-    (let
-      ((op (dl-rel-name lit))
-        (result-var (nth lit 1))
-        (agg-var (nth lit 2))
-        (goal (nth lit 3)))
-      (cond
-        ((not (dl-var? agg-var))
-          (error (str "datalog aggregate (" op
-                      "): second arg must be a variable, got " agg-var)))
-        ((not (and (list? goal) (> (len goal) 0)
-                   (symbol? (first goal))))
-          (error (str "datalog aggregate (" op
-                      "): third arg must be a positive literal, got "
-                      goal)))
-        ((not (dl-member-string?
-                (symbol->string agg-var)
-                (dl-vars-of goal)))
-          (error (str "datalog aggregate (" op
-                      "): aggregation variable " agg-var
-                      " does not appear in the goal " goal
-                      " — without it every match contributes the same "
-                      "(unbound) value and the result is meaningless")))
-        (else
-          (let ((vals (list)))
-            (do
-              (for-each
-                (fn
-                  (s)
-                  (let ((v (dl-apply-subst agg-var s)))
-                    (when (not (dl-val-member? v vals))
-                      (append! vals v))))
-                (dl-find-bindings (list goal) db subst))
-              (let ((agg-val (dl-do-aggregate op vals)))
-                (cond
-                  ((= agg-val :empty) (list))
-                  (else
-                    (let ((s2 (dl-unify result-var agg-val subst)))
-                      (if (nil? s2) (list) (list s2)))))))))))))
-
-
-;; Stratification edges from aggregates: like negation, the goal's
-;; relation must be in a strictly lower stratum so that the aggregate
-;; fires only after the underlying tuples are settled.
-(define
-  dl-aggregate-dep-edge
-  (fn
-    (lit)
-    (cond
-      ((dl-aggregate? lit)
-        (let ((goal (nth lit 3)))
-          (cond
-            ((and (list? goal) (> (len goal) 0))
-              (let ((rel (dl-rel-name goal)))
-                (if (nil? rel) nil {:rel rel :neg true})))
-            (else nil))))
-      (else nil))))

lib/datalog/api.sx

@@ -1,303 +0,0 @@
-;; lib/datalog/api.sx — SX-data embedding API.
-;;
-;; Where Phase 1's `dl-program` takes a Datalog source string,
-;; this module exposes a parser-free API that consumes SX data
-;; directly. Two rule shapes are accepted:
-;;
-;;   - dict:   {:head <literal> :body (<literal> ...)}
-;;   - list:   (<head-elements...> <- <body-literal> ...)
-;;             — `<-` is an SX symbol used as the rule arrow.
-;;
-;; Examples:
-;;
-;;   (dl-program-data
-;;     '((parent tom bob) (parent tom liz) (parent bob ann))
-;;     '((ancestor X Y <- (parent X Y))
-;;       (ancestor X Z <- (parent X Y) (ancestor Y Z))))
-;;
-;;   (dl-query db '(ancestor tom X))   ; same query API as before
-;;
-;; Variables follow the parser convention: SX symbols whose first
-;; character is uppercase or `_` are variables.
-
-(define
-  dl-rule
-  (fn (head body) {:head head :body body}))
-
-(define
-  dl-rule-arrow?
-  (fn
-    (x)
-    (and (symbol? x) (= (symbol->string x) "<-"))))
-
-(define
-  dl-find-arrow
-  (fn
-    (rl i n)
-    (cond
-      ((>= i n) nil)
-      ((dl-rule-arrow? (nth rl i)) i)
-      (else (dl-find-arrow rl (+ i 1) n)))))
-
-;; Given a list of the form (head-elt ... <- body-lit ...) returns
-;; {:head (head-elt ...) :body (body-lit ...)}. If no arrow is
-;; present, the whole list is treated as the head and the body is
-;; empty (i.e. a fact written rule-style).
-(define
-  dl-rule-from-list
-  (fn
-    (rl)
-    (let ((n (len rl)))
-      (let ((idx (dl-find-arrow rl 0 n)))
-        (cond
-          ((nil? idx) {:head rl :body (list)})
-          (else
-            (let
-              ((head (slice rl 0 idx))
-                (body (slice rl (+ idx 1) n)))
-              {:head head :body body})))))))
-
-;; Coerce a rule given as either a dict or a list-with-arrow to a dict.
-(define
-  dl-coerce-rule
-  (fn
-    (r)
-    (cond
-      ((dict? r) r)
-      ((list? r) (dl-rule-from-list r))
-      (else (error (str "dl-coerce-rule: expected dict or list, got " r))))))
-
-;; Build a db from SX data lists.
-(define
-  dl-program-data
-  (fn
-    (facts rules)
-    (let ((db (dl-make-db)))
-      (do
-        (for-each (fn (lit) (dl-add-fact! db lit)) facts)
-        (for-each
-          (fn (r) (dl-add-rule! db (dl-coerce-rule r)))
-          rules)
-        db))))
-
-;; Add a single fact at runtime, then re-saturate the db so derived
-;; tuples reflect the change. Returns the db.
-(define
-  dl-assert!
-  (fn
-    (db lit)
-    (do
-      (dl-add-fact! db lit)
-      (dl-saturate! db)
-      db)))
-
-;; Remove a fact and re-saturate. Mixed relations (which have BOTH
-;; user-asserted facts AND rules) are supported via :edb-keys provenance
-;; — explicit facts are marked at dl-add-fact! time, the saturator uses
-;; dl-add-derived! which doesn't mark them, so the retract pass can
-;; safely wipe IDB-derived tuples while preserving the user's EDB.
-;;
-;; Effect:
-;;   - remove tuples matching `lit` from :facts and :edb-keys
-;;   - for every relation that has a rule (i.e. potentially IDB or
-;;     mixed), drop the IDB-derived portion (anything not in :edb-keys)
-;;     so the saturator can re-derive cleanly
-;;   - re-saturate
-(define
-  dl-retract!
-  (fn
-    (db lit)
-    (let
-      ((rel-key (dl-rel-name lit)))
-      (do
-        ;; Drop the matching tuple from its relation list, its facts-keys,
-        ;; its first-arg index, AND from :edb-keys (if present).
-        (when
-          (has-key? (get db :facts) rel-key)
-          (let
-            ((existing (get (get db :facts) rel-key))
-              (kept (list))
-              (kept-keys {})
-              (kept-index {})
-              (edb-rel (cond
-                         ((has-key? (get db :edb-keys) rel-key)
-                           (get (get db :edb-keys) rel-key))
-                         (else nil)))
-              (kept-edb {}))
-            (do
-              (for-each
-                (fn
-                  (t)
-                  (when
-                    (not (dl-tuple-equal? t lit))
-                    (do
-                      (append! kept t)
-                      (let ((tk (dl-tuple-key t)))
-                        (do
-                          (dict-set! kept-keys tk true)
-                          (when
-                            (and (not (nil? edb-rel))
-                                 (has-key? edb-rel tk))
-                            (dict-set! kept-edb tk true))))
-                      (when
-                        (>= (len t) 2)
-                        (let ((k (dl-arg-key (nth t 1))))
-                          (do
-                            (when
-                              (not (has-key? kept-index k))
-                              (dict-set! kept-index k (list)))
-                            (append! (get kept-index k) t)))))))
-                existing)
-              (dict-set! (get db :facts) rel-key kept)
-              (dict-set! (get db :facts-keys) rel-key kept-keys)
-              (dict-set! (get db :facts-index) rel-key kept-index)
-              (when
-                (not (nil? edb-rel))
-                (dict-set! (get db :edb-keys) rel-key kept-edb)))))
-        ;; For each rule-head relation, strip the IDB-derived tuples
-        ;; (anything not marked in :edb-keys) so the saturator can
-        ;; cleanly re-derive without leaving stale tuples that depended
-        ;; on the now-removed fact.
-        (let ((rule-heads (dl-rule-head-rels db)))
-          (for-each
-            (fn
-              (k)
-              (when
-                (has-key? (get db :facts) k)
-                (let
-                  ((existing (get (get db :facts) k))
-                    (kept (list))
-                    (kept-keys {})
-                    (kept-index {})
-                    (edb-rel (cond
-                               ((has-key? (get db :edb-keys) k)
-                                 (get (get db :edb-keys) k))
-                               (else {}))))
-                  (do
-                    (for-each
-                      (fn
-                        (t)
-                        (let ((tk (dl-tuple-key t)))
-                          (when
-                            (has-key? edb-rel tk)
-                            (do
-                              (append! kept t)
-                              (dict-set! kept-keys tk true)
-                              (when
-                                (>= (len t) 2)
-                                (let ((kk (dl-arg-key (nth t 1))))
-                                  (do
-                                    (when
-                                      (not (has-key? kept-index kk))
-                                      (dict-set! kept-index kk (list)))
-                                    (append! (get kept-index kk) t))))))))
-                      existing)
-                    (dict-set! (get db :facts) k kept)
-                    (dict-set! (get db :facts-keys) k kept-keys)
-                    (dict-set! (get db :facts-index) k kept-index)))))
-            rule-heads))
-        (dl-saturate! db)
-        db))))
-
-;; ── Convenience: single-call source + query ───────────────────
-;; (dl-eval source query-source) parses both, builds a db, saturates,
-;; runs the query, returns the substitution list. The query source
-;; should be `?- goal[, goal ...].` — the parser produces a clause
-;; with :query containing a list of literals which is fed straight
-;; to dl-query.
-(define
-  dl-eval
-  (fn
-    (source query-source)
-    (let
-      ((db (dl-program source))
-        (queries (dl-parse query-source)))
-      (cond
-        ((= (len queries) 0) (error "dl-eval: query string is empty"))
-        ((not (has-key? (first queries) :query))
-          (error "dl-eval: second arg must be a `?- ...` query clause"))
-        (else
-          (dl-query db (get (first queries) :query)))))))
-
-;; (dl-eval-magic source query-source) — like dl-eval but routes a
-;; single-positive-literal query through `dl-magic-query` for goal-
-;; directed evaluation. Multi-literal query bodies fall back to the
-;; standard dl-query path (magic-sets is currently only wired for
-;; single-positive goals). The caller's source is parsed afresh
-;; each call so successive invocations are independent.
-(define
-  dl-eval-magic
-  (fn
-    (source query-source)
-    (let
-      ((db (dl-program source))
-        (queries (dl-parse query-source)))
-      (cond
-        ((= (len queries) 0) (error "dl-eval-magic: query string is empty"))
-        ((not (has-key? (first queries) :query))
-          (error
-            "dl-eval-magic: second arg must be a `?- ...` query clause"))
-        (else
-          (let
-            ((qbody (get (first queries) :query)))
-            (cond
-              ((and (= (len qbody) 1)
-                    (list? (first qbody))
-                    (> (len (first qbody)) 0)
-                    (symbol? (first (first qbody))))
-                (dl-magic-query db (first qbody)))
-              (else (dl-query db qbody)))))))))
-
-;; List rules whose head's relation matches `rel-name`. Useful for
-;; inspection ("show me how this relation is derived") without
-;; exposing the internal `:rules` list.
-(define
-  dl-rules-of
-  (fn
-    (db rel-name)
-    (let ((out (list)))
-      (do
-        (for-each
-          (fn
-            (rule)
-            (when
-              (= (dl-rel-name (get rule :head)) rel-name)
-              (append! out rule)))
-          (dl-rules db))
-        out))))
-
-(define
-  dl-rule-head-rels
-  (fn
-    (db)
-    (let ((seen (list)))
-      (do
-        (for-each
-          (fn
-            (rule)
-            (let ((h (dl-rel-name (get rule :head))))
-              (when
-                (and (not (nil? h)) (not (dl-member-string? h seen)))
-                (append! seen h))))
-          (dl-rules db))
-        seen))))
-
-;; Wipe every relation that has at least one rule (i.e. every IDB
-;; relation) — leaves EDB facts and rule definitions intact. Useful
-;; before a follow-up `dl-saturate!` if you want a clean restart, or
-;; for inspection of the EDB-only baseline.
-(define
-  dl-clear-idb!
-  (fn
-    (db)
-    (let ((rule-heads (dl-rule-head-rels db)))
-      (do
-        (for-each
-          (fn
-            (k)
-            (do
-              (dict-set! (get db :facts) k (list))
-              (dict-set! (get db :facts-keys) k {})
-              (dict-set! (get db :facts-index) k {})))
-          rule-heads)
-        db))))

lib/datalog/builtins.sx

@@ -1,406 +0,0 @@
-;; lib/datalog/builtins.sx — comparison + arithmetic body literals.
-;;
-;; Built-in predicates filter / extend candidate substitutions during
-;; rule evaluation. They are not stored facts and do not participate in
-;; the Herbrand base.
-;;
-;;   (< a b)  (<= a b)  (> a b)  (>= a b)   ; numeric (or string) compare
-;;   (= a b)                                  ; unify (binds vars)
-;;   (!= a b)                                ; ground-only inequality
-;;   (is X expr)                              ; bind X to expr's value
-;;
-;; Arithmetic expressions are SX-list compounds:
-;;   (+ a b)  (- a b)  (* a b)  (/ a b)
-;; or numbers / variables (must be bound at evaluation time).
-
-(define
-  dl-comparison?
-  (fn
-    (lit)
-    (and
-      (list? lit)
-      (> (len lit) 0)
-      (let
-        ((rel (dl-rel-name lit)))
-        (cond
-          ((nil? rel) false)
-          (else (dl-member-string? rel (list "<" "<=" ">" ">=" "!="))))))))
-
-(define
-  dl-eq?
-  (fn
-    (lit)
-    (and
-      (list? lit)
-      (> (len lit) 0)
-      (let ((rel (dl-rel-name lit))) (and (not (nil? rel)) (= rel "=")))))) 
-
-(define
-  dl-is?
-  (fn
-    (lit)
-    (and
-      (list? lit)
-      (> (len lit) 0)
-      (let
-        ((rel (dl-rel-name lit)))
-        (and (not (nil? rel)) (= rel "is")))))) 
-
-;; Evaluate an arithmetic expression under subst. Returns the numeric
-;; result, or raises if any operand is unbound or non-numeric.
-(define
-  dl-eval-arith
-  (fn
-    (expr subst)
-    (let
-      ((w (dl-walk expr subst)))
-      (cond
-        ((number? w) w)
-        ((dl-var? w)
-          (error (str "datalog arith: unbound variable " (symbol->string w))))
-        ((list? w)
-          (let
-            ((rel (dl-rel-name w)) (args (rest w)))
-            (cond
-              ((not (= (len args) 2))
-                (error (str "datalog arith: need 2 args, got " w)))
-              (else
-                (let
-                  ((a (dl-eval-arith (first args) subst))
-                    (b (dl-eval-arith (nth args 1) subst)))
-                  (cond
-                    ((= rel "+") (+ a b))
-                    ((= rel "-") (- a b))
-                    ((= rel "*") (* a b))
-                    ((= rel "/")
-                      (cond
-                        ((= b 0)
-                          (error
-                            (str "datalog arith: division by zero in "
-                                 w)))
-                        (else (/ a b))))
-                    (else (error (str "datalog arith: unknown op " rel)))))))))
-        (else (error (str "datalog arith: not a number — " w)))))))
-
-;; Comparable types — both operands must be the same primitive type
-;; (both numbers, both strings). `!=` is the exception: it's defined
-;; for any pair (returns true iff not equal) since dl-tuple-equal?
-;; handles type-mixed comparisons.
-(define
-  dl-compare-typeok?
-  (fn
-    (rel a b)
-    (cond
-      ((= rel "!=") true)
-      ((and (number? a) (number? b)) true)
-      ((and (string? a) (string? b)) true)
-      (else false))))
-
-(define
-  dl-eval-compare
-  (fn
-    (lit subst)
-    (let
-      ((rel (dl-rel-name lit))
-        (a (dl-walk (nth lit 1) subst))
-        (b (dl-walk (nth lit 2) subst)))
-      (cond
-        ((or (dl-var? a) (dl-var? b))
-          (error
-            (str
-              "datalog: comparison "
-              rel
-              " has unbound argument; "
-              "ensure prior body literal binds the variable")))
-        ((not (dl-compare-typeok? rel a b))
-          (error
-            (str "datalog: comparison " rel " requires same-type "
-                 "operands (both numbers or both strings), got "
-                 a " and " b)))
-        (else
-          (let
-            ((ok (cond ((= rel "<") (< a b)) ((= rel "<=") (<= a b)) ((= rel ">") (> a b)) ((= rel ">=") (>= a b)) ((= rel "!=") (not (dl-tuple-equal? a b))) (else (error (str "datalog: unknown compare " rel))))))
-            (if ok subst nil)))))))
-
-(define
-  dl-eval-eq
-  (fn
-    (lit subst)
-    (dl-unify (nth lit 1) (nth lit 2) subst)))
-
-(define
-  dl-eval-is
-  (fn
-    (lit subst)
-    (let
-      ((target (nth lit 1)) (expr (nth lit 2)))
-      (let
-        ((value (dl-eval-arith expr subst)))
-        (dl-unify target value subst)))))
-
-(define
-  dl-eval-builtin
-  (fn
-    (lit subst)
-    (cond
-      ((dl-comparison? lit) (dl-eval-compare lit subst))
-      ((dl-eq? lit) (dl-eval-eq lit subst))
-      ((dl-is? lit) (dl-eval-is lit subst))
-      (else (error (str "dl-eval-builtin: not a built-in: " lit))))))
-
-;; ── Safety analysis ──────────────────────────────────────────────
-;;
-;; Walks body literals left-to-right tracking a "bound" set. The check
-;; understands these literal kinds:
-;;
-;;   positive non-built-in    → adds its vars to bound
-;;   (is X expr)              → vars(expr) ⊆ bound, then add X (if var)
-;;   <,<=,>,>=,!=             → all vars ⊆ bound (no binding)
-;;   (= a b) where:
-;;       both non-vars        → constraint check, no binding
-;;       a var, b not         → bind a
-;;       b var, a not         → bind b
-;;       both vars            → at least one in bound; bind the other
-;;   {:neg lit}               → all vars ⊆ bound (Phase 7 enforces fully)
-;;
-;; At end, head vars (minus `_`) must be ⊆ bound.
-
-(define
-  dl-vars-not-in
-  (fn
-    (vs bound)
-    (let
-      ((out (list)))
-      (do
-        (for-each
-          (fn
-            (v)
-            (when (not (dl-member-string? v bound)) (append! out v)))
-          vs)
-        out))))
-
-;; Filter a list of variable-name strings to exclude anonymous-renamed
-;; vars (`_` in source → `_anon*` by dl-rename-anon-term). Used by
-;; the negation safety check, where anonymous vars are existential
-;; within the negated literal.
-(define
-  dl-non-anon-vars
-  (fn
-    (vs)
-    (let
-      ((out (list)))
-      (do
-        (for-each
-          (fn
-            (v)
-            (when
-              (not (and (>= (len v) 5)
-                        (= (slice v 0 5) "_anon")))
-              (append! out v)))
-          vs)
-        out))))
-
-(define
-  dl-rule-check-safety
-  (fn
-    (rule)
-    (let
-      ((head (get rule :head))
-        (body (get rule :body))
-        (bound (list))
-        (err nil))
-      (do
-        (define
-          dl-add-bound!
-          (fn
-            (vs)
-            (for-each
-              (fn
-                (v)
-                (when (not (dl-member-string? v bound)) (append! bound v)))
-              vs)))
-        (define
-          dl-process-eq!
-          (fn
-            (lit)
-            (let
-              ((a (nth lit 1)) (b (nth lit 2)))
-              (let
-                ((va (dl-var? a)) (vb (dl-var? b)))
-                (cond
-                  ((and (not va) (not vb)) nil)
-                  ((and va (not vb))
-                    (dl-add-bound! (list (symbol->string a))))
-                  ((and (not va) vb)
-                    (dl-add-bound! (list (symbol->string b))))
-                  (else
-                    (let
-                      ((sa (symbol->string a)) (sb (symbol->string b)))
-                      (cond
-                        ((dl-member-string? sa bound)
-                          (dl-add-bound! (list sb)))
-                        ((dl-member-string? sb bound)
-                          (dl-add-bound! (list sa)))
-                        (else
-                          (set!
-                            err
-                            (str
-                              "= between two unbound variables "
-                              (list sa sb)
-                              " — at least one must be bound by an "
-                              "earlier positive body literal")))))))))))
-        (define
-          dl-process-cmp!
-          (fn
-            (lit)
-            (let
-              ((needed (dl-vars-of (list (nth lit 1) (nth lit 2)))))
-              (let
-                ((missing (dl-vars-not-in needed bound)))
-                (when
-                  (> (len missing) 0)
-                  (set!
-                    err
-                    (str
-                      "comparison "
-                      (dl-rel-name lit)
-                      " requires bound variable(s) "
-                      missing
-                      " (must be bound by an earlier positive "
-                      "body literal)")))))))
-        (define
-          dl-process-is!
-          (fn
-            (lit)
-            (let
-              ((tgt (nth lit 1)) (expr (nth lit 2)))
-              (let
-                ((needed (dl-vars-of expr)))
-                (let
-                  ((missing (dl-vars-not-in needed bound)))
-                  (cond
-                    ((> (len missing) 0)
-                      (set!
-                        err
-                        (str
-                          "is RHS uses unbound variable(s) "
-                          missing
-                          " — bind them via a prior positive body "
-                          "literal")))
-                    (else
-                      (when
-                        (dl-var? tgt)
-                        (dl-add-bound! (list (symbol->string tgt)))))))))))
-        (define
-          dl-process-neg!
-          (fn
-            (lit)
-            (let
-              ((inner (get lit :neg)))
-              (let
-                ((inner-rn
-                   (cond
-                     ((and (list? inner) (> (len inner) 0))
-                       (dl-rel-name inner))
-                     (else nil)))
-                  ;; Anonymous variables (`_` in source → `_anon*` after
-                  ;; renaming) are existentially quantified within the
-                  ;; negated literal — they don't need to be bound by
-                  ;; an earlier body lit, since `not p(X, _)` is a
-                  ;; valid idiom for "no Y exists s.t. p(X, Y)". Filter
-                  ;; them out of the safety check.
-                  (needed (dl-non-anon-vars (dl-vars-of inner)))
-                  (missing (dl-vars-not-in needed bound)))
-                (cond
-                  ((and (not (nil? inner-rn)) (dl-reserved-rel? inner-rn))
-                    (set! err
-                      (str "negated literal uses reserved name '"
-                           inner-rn
-                           "' — nested `not(...)` / negated built-ins are "
-                           "not supported; introduce an intermediate "
-                           "relation and negate that")))
-                  ((> (len missing) 0)
-                    (set! err
-                      (str "negation refers to unbound variable(s) "
-                           missing
-                           " — they must be bound by an earlier "
-                           "positive body literal"))))))))
-        (define
-          dl-process-agg!
-          (fn
-            (lit)
-            (let
-              ((result-var (nth lit 1)))
-              ;; Aggregate goal vars are existentially quantified within
-              ;; the aggregate; nothing required from outer context. The
-              ;; result var becomes bound after the aggregate fires.
-              (when
-                (dl-var? result-var)
-                (dl-add-bound! (list (symbol->string result-var)))))))
-
-        (define
-          dl-process-lit!
-          (fn
-            (lit)
-            (when
-              (nil? err)
-              (cond
-                ((and (dict? lit) (has-key? lit :neg))
-                  (dl-process-neg! lit))
-                ;; A bare dict that is not a recognised negation is
-                ;; almost certainly a typo (e.g. `{:negs ...}` instead
-                ;; of `{:neg ...}`). Without this guard the dict would
-                ;; silently fall through every clause; the head safety
-                ;; check would then flag the head variables as unbound
-                ;; even though the real bug is the malformed body lit.
-                ((dict? lit)
-                  (set! err
-                    (str "body literal is a dict but lacks :neg — "
-                         "the only dict-shaped body lit recognised is "
-                         "{:neg <positive-lit>} for stratified "
-                         "negation, got " lit)))
-                ((dl-aggregate? lit) (dl-process-agg! lit))
-                ((dl-eq? lit) (dl-process-eq! lit))
-                ((dl-is? lit) (dl-process-is! lit))
-                ((dl-comparison? lit) (dl-process-cmp! lit))
-                ((and (list? lit) (> (len lit) 0))
-                  (let ((rn (dl-rel-name lit)))
-                    (cond
-                      ((and (not (nil? rn)) (dl-reserved-rel? rn))
-                        (set! err
-                          (str "body literal uses reserved name '" rn
-                               "' — built-ins / aggregates have their own "
-                               "syntax; nested `not(...)` is not supported "
-                               "(use stratified negation via an "
-                               "intermediate relation)")))
-                      (else (dl-add-bound! (dl-vars-of lit))))))
-                (else
-                  ;; Anything that's not a dict, not a list, or an
-                  ;; empty list. Numbers / strings / symbols as body
-                  ;; lits don't make sense — surface the type.
-                  (set! err
-                    (str "body literal must be a positive lit, "
-                         "built-in, aggregate, or {:neg ...} dict, "
-                         "got " lit)))))))
-        (for-each dl-process-lit! body)
-        (when
-          (nil? err)
-          (let
-            ((head-vars (dl-vars-of head)) (missing (list)))
-            (do
-              (for-each
-                (fn
-                  (v)
-                  (when
-                    (and (not (dl-member-string? v bound)) (not (= v "_")))
-                    (append! missing v)))
-                head-vars)
-              (when
-                (> (len missing) 0)
-                (set!
-                  err
-                  (str
-                    "head variable(s) "
-                    missing
-                    " do not appear in any positive body literal"))))))
-        err))))

lib/datalog/conformance.conf

@@ -1,32 +0,0 @@
-# Datalog conformance config — sourced by lib/guest/conformance.sh.
-
-LANG_NAME=datalog
-MODE=dict
-
-PRELOADS=(
-  lib/datalog/tokenizer.sx
-  lib/datalog/parser.sx
-  lib/datalog/unify.sx
-  lib/datalog/db.sx
-  lib/datalog/builtins.sx
-  lib/datalog/aggregates.sx
-  lib/datalog/strata.sx
-  lib/datalog/eval.sx
-  lib/datalog/api.sx
-  lib/datalog/magic.sx
-  lib/datalog/demo.sx
-)
-
-SUITES=(
-  "tokenize:lib/datalog/tests/tokenize.sx:(dl-tokenize-tests-run!)"
-  "parse:lib/datalog/tests/parse.sx:(dl-parse-tests-run!)"
-  "unify:lib/datalog/tests/unify.sx:(dl-unify-tests-run!)"
-  "eval:lib/datalog/tests/eval.sx:(dl-eval-tests-run!)"
-  "builtins:lib/datalog/tests/builtins.sx:(dl-builtins-tests-run!)"
-  "semi_naive:lib/datalog/tests/semi_naive.sx:(dl-semi-naive-tests-run!)"
-  "negation:lib/datalog/tests/negation.sx:(dl-negation-tests-run!)"
-  "aggregates:lib/datalog/tests/aggregates.sx:(dl-aggregates-tests-run!)"
-  "api:lib/datalog/tests/api.sx:(dl-api-tests-run!)"
-  "magic:lib/datalog/tests/magic.sx:(dl-magic-tests-run!)"
-  "demo:lib/datalog/tests/demo.sx:(dl-demo-tests-run!)"
-)

lib/datalog/conformance.sh

@@ -1,3 +0,0 @@
-#!/usr/bin/env bash
-# Thin wrapper — see lib/guest/conformance.sh and lib/datalog/conformance.conf.
-exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"

lib/datalog/datalog.sx

@@ -1,97 +0,0 @@
-;; lib/datalog/datalog.sx — public API documentation index.
-;;
-;; This file is reference-only — `load` is an epoch-protocol command,
-;; not an SX function, so it cannot reload a list of files from inside
-;; another `.sx` file. To set up a fresh sx_server session with all
-;; modules in scope, issue these loads in order:
-;;
-;;   (load "lib/datalog/tokenizer.sx")
-;;   (load "lib/datalog/parser.sx")
-;;   (load "lib/datalog/unify.sx")
-;;   (load "lib/datalog/db.sx")
-;;   (load "lib/datalog/builtins.sx")
-;;   (load "lib/datalog/aggregates.sx")
-;;   (load "lib/datalog/strata.sx")
-;;   (load "lib/datalog/eval.sx")
-;;   (load "lib/datalog/api.sx")
-;;   (load "lib/datalog/magic.sx")
-;;   (load "lib/datalog/demo.sx")
-;;
-;; (lib/datalog/conformance.sh runs this load list automatically.)
-;;
-;; ── Public API surface ─────────────────────────────────────────────
-;;
-;;   Source / data:
-;;     (dl-tokenize "src")              → token list
-;;     (dl-parse "src")                 → parsed clauses
-;;     (dl-program "src")               → db built from a source string
-;;     (dl-program-data facts rules)    → db from SX data lists; rules
-;;                                        accept either dict form or
-;;                                        list form with `<-` arrow
-;;
-;;   Construction (mutates db):
-;;     (dl-make-db)                     empty db
-;;     (dl-add-fact! db lit)            rejects non-ground
-;;     (dl-add-rule! db rule)           rejects unsafe rules
-;;     (dl-rule head body)              dict-rule constructor
-;;     (dl-add-clause! db clause)       parser output → fact or rule
-;;     (dl-load-program! db src)        string source
-;;     (dl-set-strategy! db strategy)   :semi-naive default; :magic
-;;                                        is informational, use
-;;                                        dl-magic-query for actual
-;;                                        magic-sets evaluation
-;;
-;;   Mutation:
-;;     (dl-assert! db lit)              add + re-saturate
-;;     (dl-retract! db lit)             drop EDB, wipe IDB, re-saturate
-;;     (dl-clear-idb! db)               wipe rule-headed relations
-;;
-;;   Query / inspection:
-;;     (dl-saturate! db)                stratified semi-naive default
-;;     (dl-saturate-naive! db)          reference (slow on chains)
-;;     (dl-saturate-rules! db rules)    per-rule-set semi-naive worker
-;;     (dl-query db goal)               list of substitution dicts
-;;     (dl-relation db rel-name)        tuple list for a relation
-;;     (dl-rules db)                    rule list
-;;     (dl-fact-count db)               total ground tuples
-;;     (dl-summary db)                  {<rel>: count} for inspection
-;;
-;;   Single-call convenience:
-;;     (dl-eval source query-source)         parse, run, return substs
-;;     (dl-eval-magic source query-source)   single-goal → magic-sets
-;;
-;;   Magic-sets (lib/datalog/magic.sx):
-;;     (dl-adorn-goal goal)             "b/f" adornment string
-;;     (dl-rule-sips rule head-adn)     SIPS analysis per body lit
-;;     (dl-magic-rewrite rules rel adn args)
-;;                                       rewritten rule list + seed
-;;     (dl-magic-query db query-goal)    end-to-end magic-sets query
-;;
-;; ── Body literal kinds ─────────────────────────────────────────────
-;;
-;;   Positive             (rel arg ... arg)
-;;   Negation             {:neg (rel arg ...)}
-;;   Comparison           (< X Y), (<= X Y), (> X Y), (>= X Y),
-;;                        (= X Y), (!= X Y)
-;;   Arithmetic           (is Z (+ X Y)) and (- * /)
-;;   Aggregation          (count R V Goal),  (sum R V Goal),
-;;                        (min R V Goal),    (max R V Goal),
-;;                        (findall L V Goal)
-;;
-;; ── Variable conventions ───────────────────────────────────────────
-;;
-;;   Variables: SX symbols whose first char is uppercase A–Z or '_'.
-;;   Anonymous '_' is renamed to a fresh _anon<N> per occurrence at
-;;   rule/query load time so multiple '_' don't unify.
-;;
-;; ── Demo programs ──────────────────────────────────────────────────
-;;
-;;   See lib/datalog/demo.sx — federation, content, permissions, and
-;;   the canonical "cooking posts by people I follow (transitively)"
-;;   example.
-;;
-;; ── Status ─────────────────────────────────────────────────────────
-;;
-;;   See plans/datalog-on-sx.md — phase-by-phase progress log and
-;;   roadmap. Run `bash lib/datalog/conformance.sh` to refresh
-;;   `lib/datalog/scoreboard.{json,md}`.

lib/datalog/db.sx

@@ -1,575 +0,0 @@
-;; lib/datalog/db.sx — Datalog database (EDB + IDB + rules) + safety hook.
-;;
-;; A db is a mutable dict:
-;;   {:facts {<rel-name-string> -> (literal ...)}
-;;    :rules ({:head literal :body (literal ...)} ...)}
-;;
-;; Facts are stored as full literals `(rel arg ... arg)` so they unify
-;; directly against rule body literals. Each relation's tuple list is
-;; deduplicated on insert.
-;;
-;; Phase 3 introduced safety analysis for head variables; Phase 4 (in
-;; lib/datalog/builtins.sx) swaps in the real `dl-rule-check-safety`,
-;; which is order-aware and understands built-in predicates.
-
-(define
-  dl-make-db
-  (fn ()
-    {:facts {}
-     :facts-keys {}
-     :facts-index {}
-     :edb-keys {}
-     :rules (list)
-     :strategy :semi-naive}))
-
-;; Record (rel-key, tuple-key) as user-asserted EDB. dl-add-fact! calls
-;; this when an explicit fact is added; the saturator (which uses
-;; dl-add-derived!) does NOT, so derived tuples never appear here.
-;; dl-retract! consults :edb-keys to know which tuples must survive
-;; the wipe-and-resaturate round-trip.
-(define
-  dl-mark-edb!
-  (fn
-    (db rel-key tk)
-    (let
-      ((edb (get db :edb-keys)))
-      (do
-        (when
-          (not (has-key? edb rel-key))
-          (dict-set! edb rel-key {}))
-        (dict-set! (get edb rel-key) tk true)))))
-
-(define
-  dl-edb-fact?
-  (fn
-    (db rel-key tk)
-    (let
-      ((edb (get db :edb-keys)))
-      (and (has-key? edb rel-key)
-           (has-key? (get edb rel-key) tk)))))
-
-;; Evaluation strategy. Default :semi-naive (used by dl-saturate!).
-;; :naive selects dl-saturate-naive! (slower but easier to reason
-;; about). :magic is a marker — goal-directed magic-sets evaluation
-;; is invoked separately via `dl-magic-query`; setting :magic here
-;; is purely informational. Any other value is rejected so typos
-;; don't silently fall back to the default.
-(define
-  dl-strategy-values
-  (list :semi-naive :naive :magic))
-
-(define
-  dl-set-strategy!
-  (fn
-    (db strategy)
-    (cond
-      ((not (dl-keyword-member? strategy dl-strategy-values))
-        (error (str "dl-set-strategy!: unknown strategy " strategy
-                    " — must be one of " dl-strategy-values)))
-      (else
-        (do
-          (dict-set! db :strategy strategy)
-          db)))))
-
-(define
-  dl-keyword-member?
-  (fn
-    (k xs)
-    (cond
-      ((= (len xs) 0) false)
-      ((= k (first xs)) true)
-      (else (dl-keyword-member? k (rest xs))))))
-
-(define
-  dl-get-strategy
-  (fn
-    (db)
-    (if (has-key? db :strategy) (get db :strategy) :semi-naive)))
-
-(define
-  dl-rel-name
-  (fn
-    (lit)
-    (cond
-      ((and (dict? lit) (has-key? lit :neg)) (dl-rel-name (get lit :neg)))
-      ((and (list? lit) (> (len lit) 0) (symbol? (first lit)))
-        (symbol->string (first lit)))
-      (else nil))))
-
-(define dl-builtin-rels (list "<" "<=" ">" ">=" "=" "!=" "is"))
-
-(define
-  dl-member-string?
-  (fn
-    (s xs)
-    (cond
-      ((= (len xs) 0) false)
-      ((= (first xs) s) true)
-      (else (dl-member-string? s (rest xs))))))
-
-(define
-  dl-builtin?
-  (fn
-    (lit)
-    (and
-      (list? lit)
-      (> (len lit) 0)
-      (let
-        ((rel (dl-rel-name lit)))
-        (cond
-          ((nil? rel) false)
-          (else (dl-member-string? rel dl-builtin-rels)))))))
-
-(define
-  dl-positive-lit?
-  (fn
-    (lit)
-    (cond
-      ((and (dict? lit) (has-key? lit :neg)) false)
-      ((dl-builtin? lit) false)
-      ((and (list? lit) (> (len lit) 0)) true)
-      (else false))))
-
-(define
-  dl-tuple-equal?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-tuple-equal-list? a b 0)))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-tuple-equal-list?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-tuple-equal? (nth a i) (nth b i))) false)
-      (else (dl-tuple-equal-list? a b (+ i 1))))))
-
-(define
-  dl-tuple-member?
-  (fn
-    (lit lits)
-    (dl-tuple-member-aux? lit lits 0 (len lits))))
-
-(define
-  dl-tuple-member-aux?
-  (fn
-    (lit lits i n)
-    (cond
-      ((>= i n) false)
-      ((dl-tuple-equal? lit (nth lits i)) true)
-      (else (dl-tuple-member-aux? lit lits (+ i 1) n)))))
-
-(define
-  dl-ensure-rel!
-  (fn
-    (db rel-key)
-    (let
-      ((facts (get db :facts))
-        (fk (get db :facts-keys))
-        (fi (get db :facts-index)))
-      (do
-        (when
-          (not (has-key? facts rel-key))
-          (dict-set! facts rel-key (list)))
-        (when
-          (not (has-key? fk rel-key))
-          (dict-set! fk rel-key {}))
-        (when
-          (not (has-key? fi rel-key))
-          (dict-set! fi rel-key {}))
-        (get facts rel-key)))))
-
-;; First-arg index helpers. Tuples are keyed by their first-after-rel
-;; arg's `(str ...)`; when that arg is a constant, dl-match-positive
-;; uses the index instead of scanning the full relation.
-(define
-  dl-arg-key
-  (fn
-    (v)
-    (str v)))
-
-(define
-  dl-index-add!
-  (fn
-    (db rel-key lit)
-    (let
-      ((idx (get db :facts-index))
-        (n (len lit)))
-      (when
-        (and (>= n 2) (has-key? idx rel-key))
-        (let
-          ((rel-idx (get idx rel-key))
-            (k (dl-arg-key (nth lit 1))))
-          (do
-            (when
-              (not (has-key? rel-idx k))
-              (dict-set! rel-idx k (list)))
-            (append! (get rel-idx k) lit)))))))
-
-(define
-  dl-index-lookup
-  (fn
-    (db rel-key arg-val)
-    (let
-      ((idx (get db :facts-index)))
-      (cond
-        ((not (has-key? idx rel-key)) (list))
-        (else
-          (let ((rel-idx (get idx rel-key))
-                (k (dl-arg-key arg-val)))
-            (if (has-key? rel-idx k) (get rel-idx k) (list))))))))
-
-(define dl-tuple-key (fn (lit) (str lit)))
-
-(define
-  dl-rel-tuples
-  (fn
-    (db rel-key)
-    (let
-      ((facts (get db :facts)))
-      (if (has-key? facts rel-key) (get facts rel-key) (list)))))
-
-;; Reserved relation names: built-in / aggregate / negation / arrow.
-;; Rules and facts may not have these as their head's relation, since
-;; the saturator treats them specially or they are not relation names
-;; at all.
-(define
-  dl-reserved-rel-names
-  (list "not" "count" "sum" "min" "max" "findall" "is"
-        "<" "<=" ">" ">=" "=" "!=" "+" "-" "*" "/" ":-" "?-"))
-
-(define
-  dl-reserved-rel?
-  (fn
-    (name) (dl-member-string? name dl-reserved-rel-names)))
-
-;; Internal: append a derived tuple to :facts without the public
-;; validation pass and without marking :edb-keys. Used by the saturator
-;; (eval.sx) and magic-sets (magic.sx). Returns true if the tuple was
-;; new, false if already present.
-(define
-  dl-add-derived!
-  (fn
-    (db lit)
-    (let
-      ((rel-key (dl-rel-name lit)))
-      (let
-        ((tuples (dl-ensure-rel! db rel-key))
-          (key-dict (get (get db :facts-keys) rel-key))
-          (tk (dl-tuple-key lit)))
-        (cond
-          ((has-key? key-dict tk) false)
-          (else
-            (do
-              (dict-set! key-dict tk true)
-              (append! tuples lit)
-              (dl-index-add! db rel-key lit)
-              true)))))))
-
-;; A simple term — number, string, or symbol — i.e. anything legal
-;; as an EDB fact arg. Compound (list) args belong only in body
-;; literals where they encode arithmetic / aggregate sub-goals.
-(define
-  dl-simple-term?
-  (fn
-    (term)
-    (or (number? term) (string? term) (symbol? term))))
-
-(define
-  dl-args-simple?
-  (fn
-    (lit i n)
-    (cond
-      ((>= i n) true)
-      ((not (dl-simple-term? (nth lit i))) false)
-      (else (dl-args-simple? lit (+ i 1) n)))))
-
-(define
-  dl-add-fact!
-  (fn
-    (db lit)
-    (cond
-      ((not (and (list? lit) (> (len lit) 0)))
-        (error (str "dl-add-fact!: expected literal list, got " lit)))
-      ((dl-reserved-rel? (dl-rel-name lit))
-        (error (str "dl-add-fact!: '" (dl-rel-name lit)
-                    "' is a reserved name (built-in / aggregate / negation)")))
-      ((not (dl-args-simple? lit 1 (len lit)))
-        (error (str "dl-add-fact!: fact args must be numbers, strings, "
-                    "or symbols — compound args (e.g. arithmetic "
-                    "expressions) are body-only and aren't evaluated "
-                    "in fact position. got " lit)))
-      ((not (dl-ground? lit (dl-empty-subst)))
-        (error (str "dl-add-fact!: expected ground literal, got " lit)))
-      (else
-        (let
-          ((rel-key (dl-rel-name lit)) (tk (dl-tuple-key lit)))
-          (do
-            ;; Always mark EDB origin — even if the tuple key was already
-            ;; present (e.g. previously derived), so an explicit assert
-            ;; promotes it to EDB and protects it from the IDB wipe.
-            (dl-mark-edb! db rel-key tk)
-            (dl-add-derived! db lit)))))))
-
-;; The full safety check lives in builtins.sx (it has to know which
-;; predicates are built-ins). dl-add-rule! calls it via forward
-;; reference; load builtins.sx alongside db.sx in any setup that
-;; adds rules. The fallback below is used if builtins.sx isn't loaded.
-(define
-  dl-rule-check-safety
-  (fn
-    (rule)
-    (let
-      ((head-vars (dl-vars-of (get rule :head))) (body-vars (list)))
-      (do
-        (for-each
-          (fn
-            (lit)
-            (when
-              (and
-                (list? lit)
-                (> (len lit) 0)
-                (not (and (dict? lit) (has-key? lit :neg))))
-              (for-each
-                (fn
-                  (v)
-                  (when
-                    (not (dl-member-string? v body-vars))
-                    (append! body-vars v)))
-                (dl-vars-of lit))))
-          (get rule :body))
-        (let
-          ((missing (list)))
-          (do
-            (for-each
-              (fn
-                (v)
-                (when
-                  (and
-                    (not (dl-member-string? v body-vars))
-                    (not (= v "_")))
-                  (append! missing v)))
-              head-vars)
-            (cond
-              ((> (len missing) 0)
-                (str
-                  "head variable(s) "
-                  missing
-                  " do not appear in any body literal"))
-              (else nil))))))))
-
-(define
-  dl-rename-anon-term
-  (fn
-    (term next-name)
-    (cond
-      ((and (symbol? term) (= (symbol->string term) "_"))
-        (next-name))
-      ((list? term)
-        (map (fn (x) (dl-rename-anon-term x next-name)) term))
-      (else term))))
-
-(define
-  dl-rename-anon-lit
-  (fn
-    (lit next-name)
-    (cond
-      ((and (dict? lit) (has-key? lit :neg))
-        {:neg (dl-rename-anon-term (get lit :neg) next-name)})
-      ((list? lit) (dl-rename-anon-term lit next-name))
-      (else lit))))
-
-(define
-  dl-make-anon-renamer
-  (fn
-    (start)
-    (let ((counter start))
-      (fn () (do (set! counter (+ counter 1))
-                 (string->symbol (str "_anon" counter)))))))
-
-;; Scan a rule for variables already named `_anon<N>` (which would
-;; otherwise collide with the renamer's output). Returns the max N
-;; seen, or 0 if none. The renamer then starts at that max + 1, so
-;; freshly-introduced anonymous names can't shadow a user-written
-;; `_anon<N>` symbol.
-(define
-  dl-max-anon-num
-  (fn
-    (term acc)
-    (cond
-      ((symbol? term)
-        (let ((s (symbol->string term)))
-          (cond
-            ((and (>= (len s) 6) (= (slice s 0 5) "_anon"))
-              (let ((n (dl-try-parse-int (slice s 5 (len s)))))
-                (cond
-                  ((nil? n) acc)
-                  ((> n acc) n)
-                  (else acc))))
-            (else acc))))
-      ((dict? term)
-        (cond
-          ((has-key? term :neg)
-            (dl-max-anon-num (get term :neg) acc))
-          (else acc)))
-      ((list? term) (dl-max-anon-num-list term acc 0))
-      (else acc))))
-
-(define
-  dl-max-anon-num-list
-  (fn
-    (xs acc i)
-    (cond
-      ((>= i (len xs)) acc)
-      (else
-        (dl-max-anon-num-list xs (dl-max-anon-num (nth xs i) acc) (+ i 1))))))
-
-;; Cheap "is this string a decimal int" check. Returns the number or
-;; nil. Avoids relying on host parse-number, which on non-int strings
-;; might raise rather than return nil.
-(define
-  dl-try-parse-int
-  (fn
-    (s)
-    (cond
-      ((= (len s) 0) nil)
-      ((not (dl-all-digits? s 0 (len s))) nil)
-      (else (parse-number s)))))
-
-(define
-  dl-all-digits?
-  (fn
-    (s i n)
-    (cond
-      ((>= i n) true)
-      ((let ((c (slice s i (+ i 1))))
-         (not (and (>= c "0") (<= c "9"))))
-        false)
-      (else (dl-all-digits? s (+ i 1) n)))))
-
-(define
-  dl-rename-anon-rule
-  (fn
-    (rule)
-    (let
-      ((start (dl-max-anon-num (get rule :head)
-                (dl-max-anon-num-list (get rule :body) 0 0))))
-      (let ((next-name (dl-make-anon-renamer start)))
-        {:head (dl-rename-anon-term (get rule :head) next-name)
-         :body (map (fn (lit) (dl-rename-anon-lit lit next-name))
-                    (get rule :body))}))))
-
-(define
-  dl-add-rule!
-  (fn
-    (db rule)
-    (cond
-      ((not (dict? rule))
-        (error (str "dl-add-rule!: expected rule dict, got " rule)))
-      ((not (has-key? rule :head))
-        (error (str "dl-add-rule!: rule missing :head, got " rule)))
-      ((not (and (list? (get rule :head))
-                 (> (len (get rule :head)) 0)
-                 (symbol? (first (get rule :head)))))
-        (error (str "dl-add-rule!: head must be a non-empty list "
-                    "starting with a relation-name symbol, got "
-                    (get rule :head))))
-      ((not (dl-args-simple? (get rule :head) 1 (len (get rule :head))))
-        (error (str "dl-add-rule!: rule head args must be variables or "
-                    "constants — compound terms (e.g. `(*(X, 2))`) are "
-                    "not legal in head position; introduce an `is`-bound "
-                    "intermediate in the body. got " (get rule :head))))
-      ((not (list? (if (has-key? rule :body) (get rule :body) (list))))
-        (error (str "dl-add-rule!: body must be a list of literals, got "
-                    (get rule :body))))
-      ((dl-reserved-rel? (dl-rel-name (get rule :head)))
-        (error (str "dl-add-rule!: '" (dl-rel-name (get rule :head))
-                    "' is a reserved name (built-in / aggregate / negation)")))
-      (else
-        (let ((rule (dl-rename-anon-rule rule)))
-          (let
-            ((err (dl-rule-check-safety rule)))
-            (cond
-              ((not (nil? err)) (error (str "dl-add-rule!: " err)))
-              (else
-                (let
-                  ((rules (get db :rules)))
-                  (do (append! rules rule) true))))))))))
-
-(define
-  dl-add-clause!
-  (fn
-    (db clause)
-    (cond
-      ((has-key? clause :query) false)
-      ((and (has-key? clause :body) (= (len (get clause :body)) 0))
-        (dl-add-fact! db (get clause :head)))
-      (else (dl-add-rule! db clause)))))
-
-(define
-  dl-load-program!
-  (fn
-    (db source)
-    (let
-      ((clauses (dl-parse source)))
-      (do (for-each (fn (c) (dl-add-clause! db c)) clauses) db))))
-
-(define
-  dl-program
-  (fn (source) (let ((db (dl-make-db))) (dl-load-program! db source))))
-
-(define dl-rules (fn (db) (get db :rules)))
-
-(define
-  dl-fact-count
-  (fn
-    (db)
-    (let
-      ((facts (get db :facts)) (total 0))
-      (do
-        (for-each
-          (fn (k) (set! total (+ total (len (get facts k)))))
-          (keys facts))
-        total))))
-
-;; Returns {<rel-name>: tuple-count} for debugging. Includes
-;; relations with any tuples plus all rule-head relations (so empty
-;; IDB shows as 0). Skips empty EDB-only entries that are placeholders
-;; from internal `dl-ensure-rel!` calls.
-(define
-  dl-summary
-  (fn
-    (db)
-    (let
-      ((facts (get db :facts))
-        (out {})
-        (rule-heads (list)))
-      (do
-        (for-each
-          (fn
-            (rule)
-            (let ((h (dl-rel-name (get rule :head))))
-              (when
-                (and (not (nil? h)) (not (dl-member-string? h rule-heads)))
-                (append! rule-heads h))))
-          (dl-rules db))
-        (for-each
-          (fn
-            (k)
-            (let ((c (len (get facts k))))
-              (when
-                (or (> c 0) (dl-member-string? k rule-heads))
-                (dict-set! out k c))))
-          (keys facts))
-        ;; Add rule heads that have no facts (yet).
-        (for-each
-          (fn
-            (k)
-            (when (not (has-key? out k)) (dict-set! out k 0)))
-          rule-heads)
-        out))))

lib/datalog/demo.sx

@@ -1,162 +0,0 @@
-;; lib/datalog/demo.sx — example programs over rose-ash-shaped data.
-;;
-;; Phase 10 prototypes Datalog as a rose-ash query language. Wiring
-;; the EDB to actual PostgreSQL is out of scope for this loop (it
-;; would touch service code outside lib/datalog/), but the programs
-;; below show the shape of queries we want, and the test suite runs
-;; them against synthetic in-memory tuples loaded via dl-program-data.
-;;
-;; Seven thematic demos:
-;;
-;;   1. Federation — follow graph, transitive reach, mutuals, FOAF.
-;;   2. Content    — posts, tags, likes, popularity, "for you" feed.
-;;   3. Permissions — group membership and resource access.
-;;   4. Cooking-posts — canonical "posts about cooking by people I
-;;                      follow (transitively)" multi-domain query.
-;;   5. Tag co-occurrence — distinct (T1, T2) pairs with counts.
-;;   6. Shortest path  — weighted-DAG path enumeration + min agg.
-;;   7. Org chart      — transitive subordinate + headcount per mgr.
-
-;; ── Demo 1: federation follow graph ─────────────────────────────
-;; EDB: (follows ACTOR-A ACTOR-B) — A follows B.
-;; IDB:
-;;   (mutual A B)            — A follows B and B follows A
-;;   (reachable A B)         — transitive follow closure
-;;   (foaf A C)              — friend of a friend (mutual filter)
-(define
-  dl-demo-federation-rules
-  (quote
-    ((mutual A B <- (follows A B) (follows B A))
-     (reachable A B <- (follows A B))
-     (reachable A C <- (follows A B) (reachable B C))
-     (foaf A C <- (follows A B) (follows B C) (!= A C)))))
-
-;; ── Demo 2: content recommendation ──────────────────────────────
-;; EDB:
-;;   (authored ACTOR POST)
-;;   (tagged POST TAG)
-;;   (liked ACTOR POST)
-;; IDB:
-;;   (post-likes POST N)            — count of likes per post
-;;   (popular POST)                 — posts with >= 3 likes
-;;   (tagged-by-mutual ACTOR POST)  — post tagged TOPIC by someone
-;;                                    A's mutuals follow.
-(define
-  dl-demo-content-rules
-  (quote
-    ((post-likes P N <- (authored Author P) (count N L (liked L P)))
-     (popular P <- (authored Author P) (post-likes P N) (>= N 3))
-     (interesting Me P
-       <-
-       (follows Me Buddy)
-       (authored Buddy P)
-       (popular P)))))
-
-;; ── Demo 3: role-based permissions ──────────────────────────────
-;; EDB:
-;;   (member ACTOR GROUP)
-;;   (subgroup CHILD PARENT)
-;;   (allowed GROUP RESOURCE)
-;; IDB:
-;;   (in-group ACTOR GROUP)         — direct or via subgroup chain
-;;   (can-access ACTOR RESOURCE)    — actor inherits group permission
-(define
-  dl-demo-perm-rules
-  (quote
-    ((in-group A G <- (member A G))
-     (in-group A G <- (member A H) (subgroup-trans H G))
-     (subgroup-trans X Y <- (subgroup X Y))
-     (subgroup-trans X Z <- (subgroup X Y) (subgroup-trans Y Z))
-     (can-access A R <- (in-group A G) (allowed G R)))))
-
-;; ── Demo 4: cooking-posts (the canonical Phase 10 query) ────────
-;; "Posts about cooking by people I follow (transitively)."
-;; Combines federation (follows + transitive reach), authoring,
-;; tagging — the rose-ash multi-domain join.
-;;
-;; EDB:
-;;   (follows ACTOR-A ACTOR-B)
-;;   (authored ACTOR POST)
-;;   (tagged POST TAG)
-(define
-  dl-demo-cooking-rules
-  (quote
-    ((reach Me Them <- (follows Me Them))
-     (reach Me Them <- (follows Me X) (reach X Them))
-     (cooking-post-by-network Me P
-       <-
-       (reach Me Author)
-       (authored Author P)
-       (tagged P cooking)))))
-
-;; ── Demo 5: tag co-occurrence ───────────────────────────────────
-;; "Posts tagged with both T1 AND T2." Useful for narrowed-down
-;; recommendations like "vegetarian cooking" posts.
-;;
-;; EDB:
-;;   (tagged POST TAG)
-;; IDB:
-;;   (cotagged POST T1 T2)        — post has both T1 and T2 (T1 != T2)
-;;   (popular-pair T1 T2 N)       — count of posts cotagged (T1, T2)
-(define
-  dl-demo-tag-cooccur-rules
-  (quote
-    ((cotagged P T1 T2 <- (tagged P T1) (tagged P T2) (!= T1 T2))
-     ;; Distinct (T1, T2) pairs that occur somewhere.
-     (tag-pair T1 T2 <- (cotagged P T1 T2))
-     (tag-pair-count T1 T2 N
-       <-
-       (tag-pair T1 T2)
-       (count N P (cotagged P T1 T2))))))
-
-;; ── Demo 6: weighted-DAG shortest path ─────────────────────────
-;; "What's the cheapest way from X to Y?" Edge weights with `is`
-;; arithmetic to sum costs, then `min` aggregation to pick the
-;; shortest. Termination requires the graph to be a DAG (cycles
-;; would produce infinite distances without a bound; programs
-;; built on this should add a depth filter `(<, D, MAX)` if cycles
-;; are possible).
-;;
-;; EDB:
-;;   (edge FROM TO COST)
-;; IDB:
-;;   (path FROM TO COST)            — any path
-;;   (shortest FROM TO COST)        — minimum cost path
-(define
-  dl-demo-shortest-path-rules
-  (quote
-    ((path X Y W <- (edge X Y W))
-     (path X Z W
-       <-
-       (edge X Y W1)
-       (path Y Z W2)
-       (is W (+ W1 W2)))
-     (shortest X Y W <- (path X Y _) (min W C (path X Y C))))))
-
-;; ── Demo 7: org chart + transitive headcount ───────────────────
-;; Manager graph: each employee has a single manager. Compute the
-;; transitive subordinate set and headcount per manager.
-;;
-;; EDB:
-;;   (manager EMP MGR)            — EMP reports directly to MGR
-;; IDB:
-;;   (subordinate MGR EMP)        — EMP is in MGR's subtree
-;;   (headcount MGR N)            — number of subordinates under MGR
-(define
-  dl-demo-org-rules
-  (quote
-    ((subordinate Mgr Emp <- (manager Emp Mgr))
-     (subordinate Mgr Emp
-       <- (manager Mid Mgr) (subordinate Mid Emp))
-     (headcount Mgr N
-       <- (subordinate Mgr Anyone) (count N E (subordinate Mgr E))))))
-
-;; ── Loader stub ──────────────────────────────────────────────────
-;; Wiring to PostgreSQL would replace these helpers with calls into
-;; rose-ash's internal HTTP RPC (fetch_data → /internal/data/...).
-;; The shape returned by dl-load-from-edb! is the same in either case.
-(define
-  dl-demo-make
-  (fn
-    (facts rules)
-    (dl-program-data facts rules)))

lib/datalog/eval.sx

@@ -1,512 +0,0 @@
-;; lib/datalog/eval.sx — fixpoint evaluator (naive + semi-naive).
-;;
-;; Two saturators are exposed:
-;;   `dl-saturate-naive!` — re-joins each rule against the full DB every
-;;     iteration. Reference implementation; useful for differential tests.
-;;   `dl-saturate!`       — semi-naive default. Tracks per-relation delta
-;;     sets and substitutes one positive body literal per rule with the
-;;     delta of its relation, joining the rest against the previous-
-;;     iteration DB. Same fixpoint, dramatically less work on recursive
-;;     rules.
-;;
-;; Body literal kinds:
-;;   positive (rel arg ... arg)  → match against EDB+IDB tuples
-;;   built-in (< X Y), (is X e)  → constraint via dl-eval-builtin
-;;   negation {:neg lit}         → Phase 7
-
-(define
-  dl-match-positive
-  (fn
-    (lit db subst)
-    (let
-      ((rel (dl-rel-name lit)) (results (list)))
-      (cond
-        ((nil? rel) (error (str "dl-match-positive: bad literal " lit)))
-        (else
-          (let
-            ;; If the first argument walks to a non-variable (constant
-            ;; or already-bound var), use the first-arg index for
-            ;; this relation. Otherwise scan the full tuple list.
-            ((tuples
-               (cond
-                 ((>= (len lit) 2)
-                   (let ((walked (dl-walk (nth lit 1) subst)))
-                     (cond
-                       ((dl-var? walked) (dl-rel-tuples db rel))
-                       (else (dl-index-lookup db rel walked)))))
-                 (else (dl-rel-tuples db rel)))))
-            (do
-              (for-each
-                (fn
-                  (tuple)
-                  (let
-                    ((s (dl-unify lit tuple subst)))
-                    (when (not (nil? s)) (append! results s))))
-                tuples)
-              results)))))))
-
-;; Match a positive literal against the delta set for its relation only.
-(define
-  dl-match-positive-delta
-  (fn
-    (lit delta subst)
-    (let
-      ((rel (dl-rel-name lit)) (results (list)))
-      (let
-        ((tuples (if (has-key? delta rel) (get delta rel) (list))))
-        (do
-          (for-each
-            (fn
-              (tuple)
-              (let
-                ((s (dl-unify lit tuple subst)))
-                (when (not (nil? s)) (append! results s))))
-            tuples)
-          results)))))
-
-;; Naive matcher (for dl-saturate-naive! and dl-query post-saturation).
-(define
-  dl-match-negation
-  (fn
-    (inner db subst)
-    (let
-      ((walked (dl-apply-subst inner subst))
-        (matches (dl-match-positive inner db subst)))
-      (cond
-        ((= (len matches) 0) (list subst))
-        (else (list))))))
-
-(define
-  dl-match-lit
-  (fn
-    (lit db subst)
-    (cond
-      ((and (dict? lit) (has-key? lit :neg))
-        (dl-match-negation (get lit :neg) db subst))
-      ((dl-aggregate? lit) (dl-eval-aggregate lit db subst))
-      ((dl-builtin? lit)
-        (let
-          ((s (dl-eval-builtin lit subst)))
-          (if (nil? s) (list) (list s))))
-      ((and (list? lit) (> (len lit) 0))
-        (dl-match-positive lit db subst))
-      (else (error (str "datalog: unknown body-literal shape: " lit))))))
-
-(define
-  dl-find-bindings
-  (fn (lits db subst) (dl-fb-aux lits db subst 0 (len lits))))
-
-(define
-  dl-fb-aux
-  (fn
-    (lits db subst i n)
-    (cond
-      ((nil? subst) (list))
-      ((>= i n) (list subst))
-      (else
-        (let
-          ((options (dl-match-lit (nth lits i) db subst))
-            (results (list)))
-          (do
-            (for-each
-              (fn
-                (s)
-                (for-each
-                  (fn (s2) (append! results s2))
-                  (dl-fb-aux lits db s (+ i 1) n)))
-              options)
-            results))))))
-
-;; Naive: apply each rule against full DB until no new tuples.
-(define
-  dl-apply-rule!
-  (fn
-    (db rule)
-    (let
-      ((head (get rule :head)) (body (get rule :body)) (new? false))
-      (do
-        (for-each
-          (fn
-            (s)
-            (let
-              ((derived (dl-apply-subst head s)))
-              (when (dl-add-derived! db derived) (set! new? true))))
-          (dl-find-bindings body db (dl-empty-subst)))
-        new?))))
-
-;; Returns true iff one more saturation step would derive no new
-;; tuples (i.e. the db is at fixpoint). Useful in tests that want
-;; to assert "no work left" after a saturation call. Works under
-;; either saturator since both compute the same fixpoint.
-(define
-  dl-saturated?
-  (fn
-    (db)
-    (let ((any-new false))
-      (do
-        (for-each
-          (fn
-            (rule)
-            (when (not any-new)
-              (for-each
-                (fn
-                  (s)
-                  (let ((derived (dl-apply-subst (get rule :head) s)))
-                    (when
-                      (and (not any-new)
-                           (not (dl-tuple-member?
-                                  derived
-                                  (dl-rel-tuples
-                                    db (dl-rel-name derived)))))
-                      (set! any-new true))))
-                (dl-find-bindings (get rule :body) db (dl-empty-subst)))))
-          (dl-rules db))
-        (not any-new)))))
-
-(define
-  dl-saturate-naive!
-  (fn
-    (db)
-    (let
-      ((changed true))
-      (do
-        (define
-          dl-snloop
-          (fn
-            ()
-            (when
-              changed
-              (do
-                (set! changed false)
-                (for-each
-                  (fn (r) (when (dl-apply-rule! db r) (set! changed true)))
-                  (dl-rules db))
-                (dl-snloop)))))
-        (dl-snloop)
-        db))))
-
-;; ── Semi-naive ───────────────────────────────────────────────────
-
-;; Take a snapshot dict {rel -> tuples} of every relation currently in
-;; the DB. Used as initial delta for the first iteration.
-(define
-  dl-snapshot-facts
-  (fn
-    (db)
-    (let
-      ((facts (get db :facts)) (out {}))
-      (do
-        (for-each
-          (fn (k) (dict-set! out k (dl-copy-list (get facts k))))
-          (keys facts))
-        out))))
-
-(define
-  dl-copy-list
-  (fn
-    (xs)
-    (let
-      ((out (list)))
-      (do (for-each (fn (x) (append! out x)) xs) out))))
-
-;; Does any relation in `delta` have ≥1 tuple?
-(define
-  dl-delta-empty?
-  (fn
-    (delta)
-    (let
-      ((ks (keys delta)) (any-non-empty false))
-      (do
-        (for-each
-          (fn
-            (k)
-            (when
-              (> (len (get delta k)) 0)
-              (set! any-non-empty true)))
-          ks)
-        (not any-non-empty)))))
-
-;; Find substitutions such that `lits` are all satisfied AND `delta-idx`
-;; is matched against the per-relation delta only. The other positive
-;; literals match against the snapshot DB (db.facts read at iteration
-;; start). Built-ins and negations behave as in `dl-match-lit`.
-(define
-  dl-find-bindings-semi
-  (fn
-    (lits db delta delta-idx subst)
-    (dl-fbs-aux lits db delta delta-idx 0 subst)))
-
-(define
-  dl-fbs-aux
-  (fn
-    (lits db delta delta-idx i subst)
-    (cond
-      ((nil? subst) (list))
-      ((>= i (len lits)) (list subst))
-      (else
-        (let
-          ((lit (nth lits i))
-            (options
-              (cond
-                ((and (dict? lit) (has-key? lit :neg))
-                  (dl-match-negation (get lit :neg) db subst))
-                ((dl-aggregate? lit) (dl-eval-aggregate lit db subst))
-                ((dl-builtin? lit)
-                  (let
-                    ((s (dl-eval-builtin lit subst)))
-                    (if (nil? s) (list) (list s))))
-                ((and (list? lit) (> (len lit) 0))
-                  (if
-                    (= i delta-idx)
-                    (dl-match-positive-delta lit delta subst)
-                    (dl-match-positive lit db subst)))
-                (else (error (str "datalog: unknown body-lit: " lit)))))
-            (results (list)))
-          (do
-            (for-each
-              (fn
-                (s)
-                (for-each
-                  (fn (s2) (append! results s2))
-                  (dl-fbs-aux lits db delta delta-idx (+ i 1) s)))
-              options)
-            results))))))
-
-;; Collect candidate head tuples from a rule using delta. Walks every
-;; positive body position and unions the resulting heads. For rules
-;; with no positive body literal, falls back to a naive single-pass
-;; (so static facts like `(p X) :- (= X 5).` derive on iteration 1).
-(define
-  dl-collect-rule-candidates
-  (fn
-    (rule db delta)
-    (let
-      ((head (get rule :head))
-        (body (get rule :body))
-        (out (list))
-        (saw-pos false))
-      (do
-        (define
-          dl-cri
-          (fn
-            (i)
-            (when
-              (< i (len body))
-              (do
-                (let
-                  ((lit (nth body i)))
-                  (when
-                    (dl-positive-lit? lit)
-                    (do
-                      (set! saw-pos true)
-                      (for-each
-                        (fn (s) (append! out (dl-apply-subst head s)))
-                        (dl-find-bindings-semi
-                          body
-                          db
-                          delta
-                          i
-                          (dl-empty-subst))))))
-                (dl-cri (+ i 1))))))
-        (dl-cri 0)
-        (when
-          (not saw-pos)
-          (for-each
-            (fn (s) (append! out (dl-apply-subst head s)))
-            (dl-find-bindings body db (dl-empty-subst))))
-        out))))
-
-;; Add a list of candidate tuples to db; collect newly-added ones into
-;; the new-delta dict (keyed by relation name).
-(define
-  dl-commit-candidates!
-  (fn
-    (db candidates new-delta)
-    (for-each
-      (fn
-        (lit)
-        (when
-          (dl-add-derived! db lit)
-          (let
-            ((rel (dl-rel-name lit)))
-            (do
-              (when
-                (not (has-key? new-delta rel))
-                (dict-set! new-delta rel (list)))
-              (append! (get new-delta rel) lit)))))
-      candidates)))
-
-(define
-  dl-saturate-rules!
-  (fn
-    (db rules)
-    (let
-      ((delta (dl-snapshot-facts db)))
-      (do
-        (define
-          dl-sr-step
-          (fn
-            ()
-            (let
-              ((pending (list)) (new-delta {}))
-              (do
-                (for-each
-                  (fn
-                    (rule)
-                    (for-each
-                      (fn (cand) (append! pending cand))
-                      (dl-collect-rule-candidates rule db delta)))
-                  rules)
-                (dl-commit-candidates! db pending new-delta)
-                (cond
-                  ((dl-delta-empty? new-delta) nil)
-                  (else (do (set! delta new-delta) (dl-sr-step))))))))
-        (dl-sr-step)
-        db))))
-
-;; Stratified driver: rejects non-stratifiable programs at saturation
-;; time, then iterates strata in increasing order, running semi-naive on
-;; the rules whose head sits in that stratum.
-(define
-  dl-saturate!
-  (fn
-    (db)
-    (let
-      ((err (dl-check-stratifiable db)))
-      (cond
-        ((not (nil? err)) (error (str "dl-saturate!: " err)))
-        (else
-          (let
-            ((strata (dl-compute-strata db)))
-            (let
-              ((grouped (dl-group-rules-by-stratum db strata)))
-              (let
-                ((groups (get grouped :groups))
-                  (max-s (get grouped :max)))
-                (do
-                  (define
-                    dl-strat-loop
-                    (fn
-                      (s)
-                      (when
-                        (<= s max-s)
-                        (let
-                          ((sk (str s)))
-                          (do
-                            (when
-                              (has-key? groups sk)
-                              (dl-saturate-rules! db (get groups sk)))
-                            (dl-strat-loop (+ s 1)))))))
-                  (dl-strat-loop 0)
-                  db)))))))))
-
-;; ── Querying ─────────────────────────────────────────────────────
-
-;; Coerce a query argument to a list of body literals. A single literal
-;; like `(p X)` (positive — head is a symbol) or `{:neg ...}` becomes
-;; `((p X))`. A list of literals like `((p X) (q X))` is returned as-is.
-(define
-  dl-query-coerce
-  (fn
-    (goal)
-    (cond
-      ((and (dict? goal) (has-key? goal :neg)) (list goal))
-      ((and (list? goal) (> (len goal) 0) (symbol? (first goal)))
-        (list goal))
-      ((list? goal) goal)
-      (else (error (str "dl-query: unrecognised goal shape: " goal))))))
-
-(define
-  dl-query
-  (fn
-    (db goal)
-    (do
-      (dl-saturate! db)
-      ;; Rename anonymous '_' vars in each goal literal so multiple
-      ;; occurrences do not unify together. Keep the user-facing var
-      ;; list (taken before renaming) so projected results retain user
-      ;; names.
-      (let
-        ((goals (dl-query-coerce goal))
-          ;; Start the renamer past any `_anon<N>` symbols the user
-          ;; may have written in the query — avoids collision.
-          (renamer
-            (dl-make-anon-renamer (dl-max-anon-num-list goal 0 0))))
-        (let
-          ((user-vars (dl-query-user-vars goals))
-            (renamed (map (fn (g) (dl-rename-anon-lit g renamer)) goals)))
-          (let
-            ((substs (dl-find-bindings renamed db (dl-empty-subst)))
-              (results (list)))
-            (do
-              (for-each
-                (fn
-                  (s)
-                  (let
-                    ((proj (dl-project-subst s user-vars)))
-                    (when
-                      (not (dl-tuple-member? proj results))
-                      (append! results proj))))
-                substs)
-              results)))))))
-
-(define
-  dl-query-user-vars
-  (fn
-    (goals)
-    (let ((seen (list)))
-      (do
-        (for-each
-          (fn
-            (g)
-            (cond
-              ((and (dict? g) (has-key? g :neg))
-                (for-each
-                  (fn
-                    (v)
-                    (when
-                      (and (not (= v "_")) (not (dl-member-string? v seen)))
-                      (append! seen v)))
-                  (dl-vars-of (get g :neg))))
-              ((dl-aggregate? g)
-                ;; Only the result var (first arg of the aggregate
-                ;; literal) is user-facing. The aggregated var and
-                ;; any vars in the inner goal are internal.
-                (let ((r (nth g 1)))
-                  (when
-                    (dl-var? r)
-                    (let ((rn (symbol->string r)))
-                      (when
-                        (and (not (= rn "_"))
-                             (not (dl-member-string? rn seen)))
-                        (append! seen rn))))))
-              (else
-                (for-each
-                  (fn
-                    (v)
-                    (when
-                      (and (not (= v "_")) (not (dl-member-string? v seen)))
-                      (append! seen v)))
-                  (dl-vars-of g)))))
-          goals)
-        seen))))
-
-(define
-  dl-project-subst
-  (fn
-    (subst names)
-    (let
-      ((out {}))
-      (do
-        (for-each
-          (fn
-            (n)
-            (let
-              ((sym (string->symbol n)))
-              (let
-                ((v (dl-walk sym subst)))
-                (dict-set! out n (dl-apply-subst v subst)))))
-          names)
-        out))))
-
-(define dl-relation (fn (db name) (dl-rel-tuples db name)))

lib/datalog/magic.sx

@@ -1,464 +0,0 @@
-;; lib/datalog/magic.sx — adornment analysis + sideways info passing.
-;;
-;; First step of the magic-sets transformation (Phase 6). Right now
-;; the saturator does not consume these — they are introspection
-;; helpers that future magic-set rewriting will build on top of.
-;;
-;; Definitions:
-;;   - An *adornment* of an n-ary literal is an n-character string
-;;     of "b" (bound — value already known at the call site) and
-;;     "f" (free — to be derived).
-;;   - SIPS (Sideways Information Passing Strategy) walks the body
-;;     of an adorned rule left-to-right tracking which variables
-;;     have been bound so far, computing each body literal's
-;;     adornment in turn.
-;;
-;; Usage:
-;;
-;;   (dl-adorn-goal '(ancestor tom X))
-;;     => "bf"
-;;
-;;   (dl-rule-sips
-;;     {:head (ancestor X Z)
-;;      :body ((parent X Y) (ancestor Y Z))}
-;;     "bf")
-;;   => ({:lit (parent X Y) :adornment "bf"}
-;;       {:lit (ancestor Y Z) :adornment "bf"})
-
-;; Per-arg adornment under the current bound-var name set.
-(define
-  dl-adorn-arg
-  (fn
-    (arg bound)
-    (cond
-      ((dl-var? arg)
-        (if (dl-member-string? (symbol->string arg) bound) "b" "f"))
-      (else "b"))))
-
-;; Adornment for the args of a literal (after the relation name).
-(define
-  dl-adorn-args
-  (fn
-    (args bound)
-    (cond
-      ((= (len args) 0) "")
-      (else
-        (str
-          (dl-adorn-arg (first args) bound)
-          (dl-adorn-args (rest args) bound))))))
-
-;; Adornment of a top-level goal under the empty bound-var set.
-(define
-  dl-adorn-goal
-  (fn (goal) (dl-adorn-args (rest goal) (list))))
-
-;; Adornment of a literal under an explicit bound set.
-(define
-  dl-adorn-lit
-  (fn (lit bound) (dl-adorn-args (rest lit) bound)))
-
-;; The set of variable names made bound by walking a positive
-;; literal whose adornment is known. Free positions add their
-;; vars to the bound set.
-(define
-  dl-vars-bound-by-lit
-  (fn
-    (lit bound)
-    (let ((args (rest lit)) (out (list)))
-      (do
-        (for-each
-          (fn (a)
-            (when
-              (and (dl-var? a)
-                   (not (dl-member-string? (symbol->string a) bound))
-                   (not (dl-member-string? (symbol->string a) out)))
-              (append! out (symbol->string a))))
-          args)
-        out))))
-
-;; Walk the rule body left-to-right tracking bound vars seeded by the
-;; head adornment. Returns a list of {:lit :adornment} entries.
-;;
-;; Negation, comparison, and built-ins are passed through with their
-;; adornment computed from the current bound set; they don't add new
-;; bindings (except `is`, which binds its left arg if a var). Aggregates
-;; are treated like is — the result var becomes bound.
-(define
-  dl-init-head-bound
-  (fn
-    (head adornment)
-    (let ((args (rest head)) (out (list)))
-      (do
-        (define
-          dl-ihb-loop
-          (fn
-            (i)
-            (when
-              (< i (len args))
-              (do
-                (let
-                  ((c (slice adornment i (+ i 1)))
-                    (a (nth args i)))
-                  (when
-                    (and (= c "b") (dl-var? a))
-                    (let ((n (symbol->string a)))
-                      (when
-                        (not (dl-member-string? n out))
-                        (append! out n)))))
-                (dl-ihb-loop (+ i 1))))))
-        (dl-ihb-loop 0)
-        out))))
-
-(define
-  dl-rule-sips
-  (fn
-    (rule head-adornment)
-    (let
-      ((bound (dl-init-head-bound (get rule :head) head-adornment))
-        (out (list)))
-      (do
-        (for-each
-          (fn
-            (lit)
-            (cond
-              ((and (dict? lit) (has-key? lit :neg))
-                (let ((target (get lit :neg)))
-                  (append!
-                    out
-                    {:lit lit :adornment (dl-adorn-lit target bound)})))
-              ((dl-builtin? lit)
-                (let ((adn (dl-adorn-lit lit bound)))
-                  (do
-                    (append! out {:lit lit :adornment adn})
-                    ;; `is` binds its left arg (if var) once RHS is ground.
-                    (when
-                      (and (= (dl-rel-name lit) "is") (dl-var? (nth lit 1)))
-                      (let ((n (symbol->string (nth lit 1))))
-                        (when
-                          (not (dl-member-string? n bound))
-                          (append! bound n)))))))
-              ((and (list? lit) (dl-aggregate? lit))
-                (let ((adn (dl-adorn-lit lit bound)))
-                  (do
-                    (append! out {:lit lit :adornment adn})
-                    ;; Result var (first arg) becomes bound.
-                    (when (dl-var? (nth lit 1))
-                      (let ((n (symbol->string (nth lit 1))))
-                        (when
-                          (not (dl-member-string? n bound))
-                          (append! bound n)))))))
-              ((and (list? lit) (> (len lit) 0))
-                (let ((adn (dl-adorn-lit lit bound)))
-                  (do
-                    (append! out {:lit lit :adornment adn})
-                    (for-each
-                      (fn (n)
-                        (when (not (dl-member-string? n bound))
-                          (append! bound n)))
-                      (dl-vars-bound-by-lit lit bound)))))))
-          (get rule :body))
-        out))))
-
-;; ── Magic predicate naming + bound-args extraction ─────────────
-;; These are building blocks for the magic-sets *transformation*
-;; itself. The transformation (which generates rewritten rules
-;; with magic_<rel>^<adornment> filters) is future work — for now
-;; these helpers can be used to inspect what such a transformation
-;; would produce.
-
-;; "magic_p^bf" given relation "p" and adornment "bf".
-(define
-  dl-magic-rel-name
-  (fn (rel adornment) (str "magic_" rel "^" adornment)))
-
-;; A magic predicate literal:
-;;   (magic_<rel>^<adornment> arg1 arg2 ...)
-(define
-  dl-magic-lit
-  (fn
-    (rel adornment bound-args)
-    (cons (string->symbol (dl-magic-rel-name rel adornment)) bound-args)))
-
-;; Extract bound args (those at "b" positions in `adornment`) from a
-;; literal `(rel arg1 arg2 ... argN)`. Returns the list of arg values.
-(define
-  dl-bound-args
-  (fn
-    (lit adornment)
-    (let ((args (rest lit)) (out (list)))
-      (do
-        (define
-          dl-ba-loop
-          (fn
-            (i)
-            (when
-              (< i (len args))
-              (do
-                (when
-                  (= (slice adornment i (+ i 1)) "b")
-                  (append! out (nth args i)))
-                (dl-ba-loop (+ i 1))))))
-        (dl-ba-loop 0)
-        out))))
-
-;; ── Magic-sets rewriter ─────────────────────────────────────────
-;;
-;; Given the original rule list and a query (rel, adornment) pair,
-;; generates the magic-rewritten program: a list of rules that
-;; (a) gate each original rule with a `magic_<rel>^<adn>` filter and
-;; (b) propagate the magic relation through SIPS so that only
-;; query-relevant tuples are derived. Seed facts are returned
-;; separately and must be added to the db at evaluation time.
-;;
-;; Output: {:rules <rewritten-rules> :seed <magic-seed-literal>}
-;;
-;; The rewriter only rewrites IDB rules; EDB facts pass through.
-;; Built-in predicates and negation in body literals are kept in
-;; place but do not generate propagation rules of their own.
-
-(define
-  dl-magic-pair-key
-  (fn (rel adornment) (str rel "^" adornment)))
-
-(define
-  dl-magic-rewrite
-  (fn
-    (rules query-rel query-adornment query-args)
-    (let
-      ((seen (list))
-        (queue (list))
-        (out (list)))
-      (do
-        (define
-          dl-mq-mark!
-          (fn
-            (rel adornment)
-            (let ((k (dl-magic-pair-key rel adornment)))
-              (when
-                (not (dl-member-string? k seen))
-                (do
-                  (append! seen k)
-                  (append! queue {:rel rel :adn adornment}))))))
-
-        (define
-          dl-mq-rewrite-rule!
-          (fn
-            (rule adn)
-            (let
-              ((head (get rule :head))
-                (body (get rule :body))
-                (sips (dl-rule-sips rule adn)))
-              (let
-                ((magic-filter
-                   (dl-magic-lit
-                     (dl-rel-name head)
-                     adn
-                     (dl-bound-args head adn))))
-                (do
-                  ;; Adorned rule: head :- magic-filter, body...
-                  (let ((new-body (list)))
-                    (do
-                      (append! new-body magic-filter)
-                      (for-each
-                        (fn (lit) (append! new-body lit))
-                        body)
-                      (append! out {:head head :body new-body})))
-                  ;; Propagation rules for each positive non-builtin
-                  ;; body literal at position i.
-                  (define
-                    dl-mq-prop-loop
-                    (fn
-                      (i)
-                      (when
-                        (< i (len body))
-                        (do
-                          (let
-                            ((lit (nth body i))
-                              (sip-entry (nth sips i)))
-                            (when
-                              (and (list? lit)
-                                   (> (len lit) 0)
-                                   (not (and (dict? lit) (has-key? lit :neg)))
-                                   (not (dl-builtin? lit))
-                                   (not (dl-aggregate? lit)))
-                              (let
-                                ((lit-adn (get sip-entry :adornment))
-                                  (lit-rel (dl-rel-name lit)))
-                                (let
-                                  ((prop-head
-                                     (dl-magic-lit
-                                       lit-rel
-                                       lit-adn
-                                       (dl-bound-args lit lit-adn))))
-                                  (let ((prop-body (list)))
-                                    (do
-                                      (append! prop-body magic-filter)
-                                      (define
-                                        dl-mq-prefix-loop
-                                        (fn
-                                          (j)
-                                          (when
-                                            (< j i)
-                                            (do
-                                              (append!
-                                                prop-body
-                                                (nth body j))
-                                              (dl-mq-prefix-loop (+ j 1))))))
-                                      (dl-mq-prefix-loop 0)
-                                      (append!
-                                        out
-                                        {:head prop-head :body prop-body})
-                                      (dl-mq-mark! lit-rel lit-adn)))))))
-                          (dl-mq-prop-loop (+ i 1))))))
-                  (dl-mq-prop-loop 0))))))
-
-        (dl-mq-mark! query-rel query-adornment)
-
-        (let ((idx 0))
-          (define
-            dl-mq-process
-            (fn
-              ()
-              (when
-                (< idx (len queue))
-                (let ((item (nth queue idx)))
-                  (do
-                    (set! idx (+ idx 1))
-                    (let
-                      ((rel (get item :rel)) (adn (get item :adn)))
-                      (for-each
-                        (fn
-                          (rule)
-                          (when
-                            (= (dl-rel-name (get rule :head)) rel)
-                            (dl-mq-rewrite-rule! rule adn)))
-                        rules))
-                    (dl-mq-process))))))
-          (dl-mq-process))
-
-        {:rules out
-         :seed
-         (dl-magic-lit
-           query-rel
-           query-adornment
-           query-args)}))))
-
-;; ── Top-level magic-sets driver ─────────────────────────────────
-;;
-;; (dl-magic-query db query-goal) — run `query-goal` under magic-sets
-;; evaluation. Builds a fresh internal db with:
-;;   - the caller's EDB facts (relations not headed by any rule),
-;;   - the magic seed fact, and
-;;   - the rewritten rules.
-;; Saturates and queries, returning the substitution list. The
-;; caller's db is untouched.
-;;
-;; Useful primarily as a perf alternative for queries that only
-;; need a small slice of a recursive relation. Equivalent to
-;; dl-query for any single fully-stratifiable program.
-
-(define
-  dl-magic-rule-heads
-  (fn
-    (rules)
-    (let ((seen (list)))
-      (do
-        (for-each
-          (fn
-            (r)
-            (let ((h (dl-rel-name (get r :head))))
-              (when
-                (and (not (nil? h)) (not (dl-member-string? h seen)))
-                (append! seen h))))
-          rules)
-        seen))))
-
-;; True iff any rule's body contains a literal kind that the magic
-;; rewriter doesn't propagate magic to — i.e. an aggregate or a
-;; negation. Used by dl-magic-query to decide whether to pre-saturate
-;; the source db (for correctness on stratified programs) or skip
-;; that step (preserving full magic-sets efficiency for pure
-;; positive programs).
-(define
-  dl-rule-has-nonprop-lit?
-  (fn
-    (body i n)
-    (cond
-      ((>= i n) false)
-      ((let ((lit (nth body i)))
-         (or (and (dict? lit) (has-key? lit :neg))
-             (dl-aggregate? lit)))
-        true)
-      (else (dl-rule-has-nonprop-lit? body (+ i 1) n)))))
-
-(define
-  dl-rules-need-presaturation?
-  (fn
-    (rules)
-    (cond
-      ((= (len rules) 0) false)
-      ((let ((body (get (first rules) :body)))
-         (dl-rule-has-nonprop-lit? body 0 (len body)))
-        true)
-      (else (dl-rules-need-presaturation? (rest rules))))))
-
-(define
-  dl-magic-query
-  (fn
-    (db query-goal)
-    ;; Magic-sets only applies to positive non-builtin / non-aggregate
-    ;; literals against rule-defined relations. For other goal shapes
-    ;; (built-ins, aggregates, EDB-only relations) the seed is either
-    ;; non-ground or unused; fall back to dl-query.
-    (cond
-      ((not (and (list? query-goal)
-                 (> (len query-goal) 0)
-                 (symbol? (first query-goal))))
-        (error (str "dl-magic-query: goal must be a positive literal "
-                    "(non-empty list with a symbol head), got " query-goal)))
-      ((or (dl-builtin? query-goal)
-           (dl-aggregate? query-goal)
-           (and (dict? query-goal) (has-key? query-goal :neg)))
-        (dl-query db query-goal))
-      (else
-        (do
-          ;; If the rule set has aggregates or negation, pre-saturate
-          ;; the source db before copying facts. The magic rewriter
-          ;; passes aggregate body lits and negated lits through
-          ;; unchanged (no magic propagation generated for them) — so
-          ;; if their inner-goal relation is IDB, it would be empty in
-          ;; the magic db. Pre-saturating ensures equivalence with
-          ;; `dl-query` for every stratified program. Pure positive
-          ;; programs skip this and keep the full magic-sets perf win
-          ;; from goal-directed re-derivation.
-          (when
-            (dl-rules-need-presaturation? (dl-rules db))
-            (dl-saturate! db))
-          (let
-            ((query-rel (dl-rel-name query-goal))
-              (query-adn (dl-adorn-goal query-goal)))
-            (let
-              ((query-args (dl-bound-args query-goal query-adn))
-                (rules (dl-rules db)))
-              (let
-                ((rewritten (dl-magic-rewrite rules query-rel query-adn query-args))
-                  (mdb (dl-make-db))
-                  (rule-heads (dl-magic-rule-heads rules)))
-            (do
-              ;; Copy ALL existing facts. EDB-only relations bring their
-              ;; tuples; mixed EDB+IDB relations bring both their EDB
-              ;; portion and any pre-saturated IDB tuples (which the
-              ;; rewritten rules would re-derive anyway). Skipping facts
-              ;; for rule-headed relations would leave the magic run
-              ;; without the EDB portion of mixed relations.
-              (for-each
-                (fn
-                  (rel)
-                  (for-each
-                    (fn (t) (dl-add-fact! mdb t))
-                    (dl-rel-tuples db rel)))
-                (keys (get db :facts)))
-              ;; Seed + rewritten rules.
-              (dl-add-fact! mdb (get rewritten :seed))
-              (for-each (fn (r) (dl-add-rule! mdb r)) (get rewritten :rules))
-              (dl-query mdb query-goal))))))))))

lib/datalog/parser.sx

@@ -1,252 +0,0 @@
-;; lib/datalog/parser.sx — Datalog tokens → AST
-;;
-;; Output shapes:
-;;   Literal (positive)  := (relname arg ... arg)        — SX list
-;;   Literal (negative)  := {:neg (relname arg ... arg)} — dict
-;;   Argument            := var-symbol | atom-symbol | number | string
-;;                        | (op-name arg ... arg)        — arithmetic compound
-;;   Fact                := {:head literal :body ()}
-;;   Rule                := {:head literal :body (lit ... lit)}
-;;   Query               := {:query (lit ... lit)}
-;;   Program             := list of facts / rules / queries
-;;
-;; Variables and constants are both SX symbols; the evaluator dispatches
-;; on first-char case ('A'..'Z' or '_' = variable, otherwise constant).
-;;
-;; The parser permits nested compounds in arg position to support
-;; arithmetic (e.g. (is Z (+ X Y))). Safety analysis at rule-load time
-;; rejects compounds whose head is not an arithmetic operator.
-
-(define
-  dl-pp-peek
-  (fn
-    (st)
-    (let
-      ((i (get st :idx)) (tokens (get st :tokens)))
-      (if (< i (len tokens)) (nth tokens i) {:type "eof" :value nil :pos 0}))))
-
-(define
-  dl-pp-peek2
-  (fn
-    (st)
-    (let
-      ((i (+ (get st :idx) 1)) (tokens (get st :tokens)))
-      (if (< i (len tokens)) (nth tokens i) {:type "eof" :value nil :pos 0}))))
-
-(define
-  dl-pp-advance!
-  (fn (st) (dict-set! st :idx (+ (get st :idx) 1))))
-
-(define
-  dl-pp-at?
-  (fn
-    (st type value)
-    (let
-      ((t (dl-pp-peek st)))
-      (and
-        (= (get t :type) type)
-        (or (= value nil) (= (get t :value) value))))))
-
-(define
-  dl-pp-error
-  (fn
-    (st msg)
-    (let
-      ((t (dl-pp-peek st)))
-      (error
-        (str
-          "Parse error at pos "
-          (get t :pos)
-          ": "
-          msg
-          " (got "
-          (get t :type)
-          " '"
-          (if (= (get t :value) nil) "" (get t :value))
-          "')")))))
-
-(define
-  dl-pp-expect!
-  (fn
-    (st type value)
-    (let
-      ((t (dl-pp-peek st)))
-      (if
-        (dl-pp-at? st type value)
-        (do (dl-pp-advance! st) t)
-        (dl-pp-error
-          st
-          (str "expected " type (if (= value nil) "" (str " '" value "'"))))))))
-
-;; Argument: variable, atom, number, string, or compound (relname/op + parens).
-(define
-  dl-pp-parse-arg
-  (fn
-    (st)
-    (let
-      ((t (dl-pp-peek st)))
-      (let
-        ((ty (get t :type)) (vv (get t :value)))
-        (cond
-          ((= ty "number") (do (dl-pp-advance! st) vv))
-          ((= ty "string") (do (dl-pp-advance! st) vv))
-          ((= ty "var") (do (dl-pp-advance! st) (string->symbol vv)))
-          ;; Negative numeric literal: `-` op directly followed by a
-          ;; number (no `(`) is parsed as a single negative number.
-          ;; This keeps `(-X Y)` (compound) and `-N` (literal) distinct.
-          ((and (= ty "op") (= vv "-")
-                (= (get (dl-pp-peek2 st) :type) "number"))
-            (do
-              (dl-pp-advance! st)
-              (let
-                ((n (get (dl-pp-peek st) :value)))
-                (do (dl-pp-advance! st) (- 0 n)))))
-          ((or (= ty "atom") (= ty "op"))
-            (do
-              (dl-pp-advance! st)
-              (if
-                (dl-pp-at? st "punct" "(")
-                (do
-                  (dl-pp-advance! st)
-                  (let
-                    ((args (dl-pp-parse-arg-list st)))
-                    (do
-                      (dl-pp-expect! st "punct" ")")
-                      (cons (string->symbol vv) args))))
-                (string->symbol vv))))
-          (else (dl-pp-error st "expected term")))))))
-
-;; Comma-separated args inside parens.
-(define
-  dl-pp-parse-arg-list
-  (fn
-    (st)
-    (let
-      ((args (list)))
-      (do
-        (append! args (dl-pp-parse-arg st))
-        (define
-          dl-pp-arg-loop
-          (fn
-            ()
-            (when
-              (dl-pp-at? st "punct" ",")
-              (do
-                (dl-pp-advance! st)
-                (append! args (dl-pp-parse-arg st))
-                (dl-pp-arg-loop)))))
-        (dl-pp-arg-loop)
-        args))))
-
-;; A positive literal: relname (atom or op) followed by optional (args).
-(define
-  dl-pp-parse-positive
-  (fn
-    (st)
-    (let
-      ((t (dl-pp-peek st)))
-      (let
-        ((ty (get t :type)) (vv (get t :value)))
-        (if
-          (or (= ty "atom") (= ty "op"))
-          (do
-            (dl-pp-advance! st)
-            (if
-              (dl-pp-at? st "punct" "(")
-              (do
-                (dl-pp-advance! st)
-                (let
-                  ((args (dl-pp-parse-arg-list st)))
-                  (do
-                    (dl-pp-expect! st "punct" ")")
-                    (cons (string->symbol vv) args))))
-              (list (string->symbol vv))))
-          (dl-pp-error st "expected literal head"))))))
-
-;; A body literal: positive, or not(positive).
-(define
-  dl-pp-parse-body-lit
-  (fn
-    (st)
-    (let
-      ((t1 (dl-pp-peek st)) (t2 (dl-pp-peek2 st)))
-      (if
-        (and
-          (= (get t1 :type) "atom")
-          (= (get t1 :value) "not")
-          (= (get t2 :type) "punct")
-          (= (get t2 :value) "("))
-        (do
-          (dl-pp-advance! st)
-          (dl-pp-advance! st)
-          (let
-            ((inner (dl-pp-parse-positive st)))
-            (do (dl-pp-expect! st "punct" ")") {:neg inner})))
-        (dl-pp-parse-positive st)))))
-
-;; Comma-separated body literals.
-(define
-  dl-pp-parse-body
-  (fn
-    (st)
-    (let
-      ((lits (list)))
-      (do
-        (append! lits (dl-pp-parse-body-lit st))
-        (define
-          dl-pp-body-loop
-          (fn
-            ()
-            (when
-              (dl-pp-at? st "punct" ",")
-              (do
-                (dl-pp-advance! st)
-                (append! lits (dl-pp-parse-body-lit st))
-                (dl-pp-body-loop)))))
-        (dl-pp-body-loop)
-        lits))))
-
-;; Single clause: fact, rule, or query. Consumes trailing dot.
-(define
-  dl-pp-parse-clause
-  (fn
-    (st)
-    (cond
-      ((dl-pp-at? st "op" "?-")
-        (do
-          (dl-pp-advance! st)
-          (let
-            ((body (dl-pp-parse-body st)))
-            (do (dl-pp-expect! st "punct" ".") {:query body}))))
-      (else
-        (let
-          ((head (dl-pp-parse-positive st)))
-          (cond
-            ((dl-pp-at? st "op" ":-")
-              (do
-                (dl-pp-advance! st)
-                (let
-                  ((body (dl-pp-parse-body st)))
-                  (do (dl-pp-expect! st "punct" ".") {:body body :head head}))))
-            (else (do (dl-pp-expect! st "punct" ".") {:body (list) :head head}))))))))
-
-(define
-  dl-parse-program
-  (fn
-    (tokens)
-    (let
-      ((st {:tokens tokens :idx 0}) (clauses (list)))
-      (do
-        (define
-          dl-pp-prog-loop
-          (fn
-            ()
-            (when
-              (not (dl-pp-at? st "eof" nil))
-              (do
-                (append! clauses (dl-pp-parse-clause st))
-                (dl-pp-prog-loop)))))
-        (dl-pp-prog-loop)
-        clauses))))
-
-(define dl-parse (fn (src) (dl-parse-program (dl-tokenize src))))

lib/datalog/scoreboard.json

@@ -1,20 +0,0 @@
-{
-  "lang": "datalog",
-  "total_passed": 276,
-  "total_failed": 0,
-  "total": 276,
-  "suites": [
-    {"name":"tokenize","passed":31,"failed":0,"total":31},
-    {"name":"parse","passed":23,"failed":0,"total":23},
-    {"name":"unify","passed":29,"failed":0,"total":29},
-    {"name":"eval","passed":44,"failed":0,"total":44},
-    {"name":"builtins","passed":26,"failed":0,"total":26},
-    {"name":"semi_naive","passed":8,"failed":0,"total":8},
-    {"name":"negation","passed":12,"failed":0,"total":12},
-    {"name":"aggregates","passed":23,"failed":0,"total":23},
-    {"name":"api","passed":22,"failed":0,"total":22},
-    {"name":"magic","passed":37,"failed":0,"total":37},
-    {"name":"demo","passed":21,"failed":0,"total":21}
-  ],
-  "generated": "2026-05-11T09:40:12+00:00"
-}

lib/datalog/scoreboard.md

@@ -1,17 +0,0 @@
-# datalog scoreboard
-
-**276 / 276 passing** (0 failure(s)).
-
-| Suite | Passed | Total | Status |
-|-------|--------|-------|--------|
-| tokenize | 31 | 31 | ok |
-| parse | 23 | 23 | ok |
-| unify | 29 | 29 | ok |
-| eval | 44 | 44 | ok |
-| builtins | 26 | 26 | ok |
-| semi_naive | 8 | 8 | ok |
-| negation | 12 | 12 | ok |
-| aggregates | 23 | 23 | ok |
-| api | 22 | 22 | ok |
-| magic | 37 | 37 | ok |
-| demo | 21 | 21 | ok |

lib/datalog/strata.sx

@@ -1,323 +0,0 @@
-;; lib/datalog/strata.sx — dependency graph, SCC analysis, stratum assignment.
-;;
-;; A program is stratifiable iff no cycle in its dependency graph passes
-;; through a negative edge. The stratum of relation R is the depth at which
-;; R can first be evaluated:
-;;
-;;   stratum(R) = max over edges (R → S) of:
-;;       stratum(S)         if the edge is positive
-;;       stratum(S) + 1     if the edge is negative
-;;
-;; All relations in the same SCC share a stratum (and the SCC must have only
-;; positive internal edges, else the program is non-stratifiable).
-
-;; Build dep graph: dict {head-rel-name -> ({:rel str :neg bool} ...)}.
-(define
-  dl-build-dep-graph
-  (fn
-    (db)
-    (let ((g {}))
-      (do
-        (for-each
-          (fn
-            (rule)
-            (let
-              ((head-rel (dl-rel-name (get rule :head))))
-              (when
-                (not (nil? head-rel))
-                (do
-                  (when
-                    (not (has-key? g head-rel))
-                    (dict-set! g head-rel (list)))
-                  (let ((existing (get g head-rel)))
-                    (for-each
-                      (fn
-                        (lit)
-                        (cond
-                          ((dl-aggregate? lit)
-                            (let
-                              ((edge (dl-aggregate-dep-edge lit)))
-                              (when
-                                (not (nil? edge))
-                                (append! existing edge))))
-                          (else
-                            (let
-                              ((target
-                                 (cond
-                                   ((and (dict? lit) (has-key? lit :neg))
-                                     (dl-rel-name (get lit :neg)))
-                                   ((dl-builtin? lit) nil)
-                                   ((and (list? lit) (> (len lit) 0))
-                                     (dl-rel-name lit))
-                                   (else nil)))
-                                (neg?
-                                  (and (dict? lit) (has-key? lit :neg))))
-                              (when
-                                (not (nil? target))
-                                (append!
-                                  existing
-                                  {:rel target :neg neg?}))))))
-                      (get rule :body)))))))
-          (dl-rules db))
-        g))))
-
-;; All relations referenced — heads of rules + EDB names + body relations.
-(define
-  dl-all-relations
-  (fn
-    (db)
-    (let ((seen (list)))
-      (do
-        (for-each
-          (fn
-            (k)
-            (when (not (dl-member-string? k seen)) (append! seen k)))
-          (keys (get db :facts)))
-        (for-each
-          (fn
-            (rule)
-            (do
-              (let ((h (dl-rel-name (get rule :head))))
-                (when
-                  (and (not (nil? h)) (not (dl-member-string? h seen)))
-                  (append! seen h)))
-              (for-each
-                (fn
-                  (lit)
-                  (let
-                    ((t
-                       (cond
-                         ((dl-aggregate? lit)
-                           (let ((edge (dl-aggregate-dep-edge lit)))
-                             (if (nil? edge) nil (get edge :rel))))
-                         ((and (dict? lit) (has-key? lit :neg))
-                           (dl-rel-name (get lit :neg)))
-                         ((dl-builtin? lit) nil)
-                         ((and (list? lit) (> (len lit) 0))
-                           (dl-rel-name lit))
-                         (else nil))))
-                    (when
-                      (and (not (nil? t)) (not (dl-member-string? t seen)))
-                      (append! seen t))))
-                (get rule :body))))
-          (dl-rules db))
-        seen))))
-
-;; reach: dict {from: dict {to: edge-info}} where edge-info is
-;;   {:any bool :neg bool}
-;; meaning "any path from `from` to `to`" and "exists a negative-passing
-;; path from `from` to `to`".
-;;
-;; Floyd-Warshall over the dep graph. The 'neg' flag propagates through
-;; concatenation: if any edge along the path is negative, the path's
-;; flag is true.
-(define
-  dl-build-reach
-  (fn
-    (graph nodes)
-    (let ((reach {}))
-      (do
-        (for-each
-          (fn (n) (dict-set! reach n {}))
-          nodes)
-        (for-each
-          (fn
-            (head)
-            (when
-              (has-key? graph head)
-              (for-each
-                (fn
-                  (edge)
-                  (let
-                    ((target (get edge :rel)) (n (get edge :neg)))
-                    (let ((row (get reach head)))
-                      (cond
-                        ((has-key? row target)
-                          (let ((cur (get row target)))
-                            (dict-set!
-                              row
-                              target
-                              {:any true :neg (or n (get cur :neg))})))
-                        (else
-                          (dict-set! row target {:any true :neg n}))))))
-                (get graph head))))
-          nodes)
-        (for-each
-          (fn
-            (k)
-            (for-each
-              (fn
-                (i)
-                (let ((row-i (get reach i)))
-                  (when
-                    (has-key? row-i k)
-                    (let ((ik (get row-i k)) (row-k (get reach k)))
-                      (for-each
-                        (fn
-                          (j)
-                          (when
-                            (has-key? row-k j)
-                            (let ((kj (get row-k j)))
-                              (let
-                                ((combined-neg (or (get ik :neg) (get kj :neg))))
-                                (cond
-                                  ((has-key? row-i j)
-                                    (let ((cur (get row-i j)))
-                                      (dict-set!
-                                        row-i
-                                        j
-                                        {:any true
-                                         :neg (or combined-neg (get cur :neg))})))
-                                  (else
-                                    (dict-set!
-                                      row-i
-                                      j
-                                      {:any true :neg combined-neg})))))))
-                        nodes)))))
-              nodes))
-          nodes)
-        reach))))
-
-;; Returns nil on success, or error message string on failure.
-(define
-  dl-check-stratifiable
-  (fn
-    (db)
-    (let
-      ((graph (dl-build-dep-graph db))
-        (nodes (dl-all-relations db)))
-      (let ((reach (dl-build-reach graph nodes)) (err nil))
-        (do
-          (for-each
-            (fn
-              (rule)
-              (when
-                (nil? err)
-                (let ((head-rel (dl-rel-name (get rule :head))))
-                  (for-each
-                    (fn
-                      (lit)
-                      (cond
-                        ((and (dict? lit) (has-key? lit :neg))
-                          (let ((tgt (dl-rel-name (get lit :neg))))
-                            (when
-                              (and (not (nil? tgt))
-                                   (dl-reach-cycle? reach head-rel tgt))
-                              (set!
-                                err
-                                (str "non-stratifiable: relation " head-rel
-                                     " transitively depends through negation on "
-                                     tgt
-                                     " which depends back on " head-rel)))))
-                        ((dl-aggregate? lit)
-                          (let ((edge (dl-aggregate-dep-edge lit)))
-                            (when
-                              (not (nil? edge))
-                              (let ((tgt (get edge :rel)))
-                                (when
-                                  (and (not (nil? tgt))
-                                       (dl-reach-cycle? reach head-rel tgt))
-                                  (set!
-                                    err
-                                    (str "non-stratifiable: relation "
-                                         head-rel
-                                         " aggregates over " tgt
-                                         " which depends back on "
-                                         head-rel))))))))) 
-                    (get rule :body)))))
-            (dl-rules db))
-          err)))))
-
-(define
-  dl-reach-cycle?
-  (fn
-    (reach a b)
-    (and
-      (dl-reach-row-has? reach b a)
-      (dl-reach-row-has? reach a b))))
-
-(define
-  dl-reach-row-has?
-  (fn
-    (reach from to)
-    (let ((row (get reach from)))
-      (and (not (nil? row)) (has-key? row to)))))
-
-;; Compute stratum per relation. Iteratively propagate from EDB roots.
-;; Uses the per-relation max-stratum-of-deps formula. Stops when stable.
-(define
-  dl-compute-strata
-  (fn
-    (db)
-    (let
-      ((graph (dl-build-dep-graph db))
-        (nodes (dl-all-relations db))
-        (strata {}))
-      (do
-        (for-each (fn (n) (dict-set! strata n 0)) nodes)
-        (let ((changed true))
-          (do
-            (define
-              dl-cs-loop
-              (fn
-                ()
-                (when
-                  changed
-                  (do
-                    (set! changed false)
-                    (for-each
-                      (fn
-                        (head)
-                        (when
-                          (has-key? graph head)
-                          (for-each
-                            (fn
-                              (edge)
-                              (let
-                                ((tgt (get edge :rel))
-                                  (n (get edge :neg)))
-                                (let
-                                  ((tgt-strat
-                                     (if (has-key? strata tgt)
-                                       (get strata tgt) 0))
-                                    (cur (get strata head)))
-                                  (let
-                                    ((needed
-                                       (if n (+ tgt-strat 1) tgt-strat)))
-                                    (when
-                                      (> needed cur)
-                                      (do
-                                        (dict-set! strata head needed)
-                                        (set! changed true)))))))
-                            (get graph head))))
-                      nodes)
-                    (dl-cs-loop)))))
-            (dl-cs-loop)))
-        strata))))
-
-;; Group rules by their head's stratum. Returns dict {stratum-int -> rules}.
-(define
-  dl-group-rules-by-stratum
-  (fn
-    (db strata)
-    (let ((groups {}) (max-s 0))
-      (do
-        (for-each
-          (fn
-            (rule)
-            (let
-              ((head-rel (dl-rel-name (get rule :head))))
-              (let
-                ((s (if (has-key? strata head-rel)
-                       (get strata head-rel) 0)))
-                (do
-                  (when (> s max-s) (set! max-s s))
-                  (let
-                    ((sk (str s)))
-                    (do
-                      (when
-                        (not (has-key? groups sk))
-                        (dict-set! groups sk (list)))
-                      (append! (get groups sk) rule)))))))
-          (dl-rules db))
-        {:groups groups :max max-s}))))

lib/datalog/tests/aggregates.sx

@@ -1,357 +0,0 @@
-;; lib/datalog/tests/aggregates.sx — count / sum / min / max.
-
-(define dl-at-pass 0)
-(define dl-at-fail 0)
-(define dl-at-failures (list))
-
-(define
-  dl-at-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-at-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-at-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-at-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-at-deep=? (nth a i) (nth b i))) false)
-      (else (dl-at-deq-l? a b (+ i 1))))))
-
-(define
-  dl-at-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i)))
-         (not (dl-at-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-at-deq-d? a b ka (+ i 1))))))
-
-(define
-  dl-at-set=?
-  (fn
-    (a b)
-    (and
-      (= (len a) (len b))
-      (dl-at-subset? a b)
-      (dl-at-subset? b a))))
-
-(define
-  dl-at-subset?
-  (fn
-    (xs ys)
-    (cond
-      ((= (len xs) 0) true)
-      ((not (dl-at-contains? ys (first xs))) false)
-      (else (dl-at-subset? (rest xs) ys)))))
-
-(define
-  dl-at-contains?
-  (fn
-    (xs target)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-at-deep=? (first xs) target) true)
-      (else (dl-at-contains? (rest xs) target)))))
-
-(define
-  dl-at-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-at-deep=? got expected)
-      (set! dl-at-pass (+ dl-at-pass 1))
-      (do
-        (set! dl-at-fail (+ dl-at-fail 1))
-        (append!
-          dl-at-failures
-          (str
-            name
-            "\n    expected: " expected
-            "\n    got:      " got))))))
-
-(define
-  dl-at-test-set!
-  (fn
-    (name got expected)
-    (if
-      (dl-at-set=? got expected)
-      (set! dl-at-pass (+ dl-at-pass 1))
-      (do
-        (set! dl-at-fail (+ dl-at-fail 1))
-        (append!
-          dl-at-failures
-          (str
-            name
-            "\n    expected (set): " expected
-            "\n    got:            " got))))))
-
-(define
-  dl-at-throws?
-  (fn
-    (thunk)
-    (let
-      ((threw false))
-      (do
-        (guard
-          (e (#t (set! threw true)))
-          (thunk))
-        threw))))
-
-(define
-  dl-at-run-all!
-  (fn
-    ()
-    (do
-      ;; count
-      (dl-at-test-set! "count siblings"
-        (dl-query
-          (dl-program
-            "parent(p, bob). parent(p, alice). parent(p, charlie).
-             sibling(X, Y) :- parent(P, X), parent(P, Y), !=(X, Y).
-             sib_count(N) :- count(N, S, sibling(bob, S)).")
-          (list (quote sib_count) (quote N)))
-        (list {:N 2}))
-
-      ;; sum
-      (dl-at-test-set! "sum prices"
-        (dl-query
-          (dl-program
-            "price(apple, 5). price(pear, 7). price(plum, 3).
-             total(T) :- sum(T, X, price(F, X)).")
-          (list (quote total) (quote T)))
-        (list {:T 15}))
-
-      ;; min
-      (dl-at-test-set! "min score"
-        (dl-query
-          (dl-program
-            "score(alice, 80). score(bob, 65). score(carol, 92).
-             lo(M) :- min(M, S, score(P, S)).")
-          (list (quote lo) (quote M)))
-        (list {:M 65}))
-
-      ;; max
-      (dl-at-test-set! "max score"
-        (dl-query
-          (dl-program
-            "score(alice, 80). score(bob, 65). score(carol, 92).
-             hi(M) :- max(M, S, score(P, S)).")
-          (list (quote hi) (quote M)))
-        (list {:M 92}))
-
-      ;; count over derived relation (stratification needed).
-      (dl-at-test-set! "count over derived"
-        (dl-query
-          (dl-program
-            "parent(a, b). parent(a, c). parent(b, d). parent(c, e).
-             ancestor(X, Y) :- parent(X, Y).
-             ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).
-             num_ancestors(N) :- count(N, X, ancestor(a, X)).")
-          (list (quote num_ancestors) (quote N)))
-        (list {:N 4}))
-
-      ;; count with no matches → 0.
-      (dl-at-test-set! "count empty"
-        (dl-query
-          (dl-program
-            "p(1). p(2).
-             zero(N) :- count(N, X, q(X)).")
-          (list (quote zero) (quote N)))
-        (list {:N 0}))
-
-      ;; sum with no matches → 0.
-      (dl-at-test-set! "sum empty"
-        (dl-query
-          (dl-program
-            "p(1). p(2).
-             total(T) :- sum(T, X, q(X)).")
-          (list (quote total) (quote T)))
-        (list {:T 0}))
-
-      ;; min with no matches → rule does not fire.
-      (dl-at-test-set! "min empty"
-        (dl-query
-          (dl-program
-            "p(1). p(2).
-             lo(M) :- min(M, X, q(X)).")
-          (list (quote lo) (quote M)))
-        (list))
-
-      ;; Aggregate with comparison filter on result.
-      (dl-at-test-set! "popularity threshold"
-        (dl-query
-          (dl-program
-            "post(p1). post(p2).
-             liked(u1, p1). liked(u2, p1). liked(u3, p1).
-             liked(u1, p2). liked(u2, p2).
-             popular(P) :- post(P), count(N, U, liked(U, P)), >=(N, 3).")
-          (list (quote popular) (quote P)))
-        (list {:P (quote p1)}))
-
-      ;; findall: collect distinct values into a list.
-      (dl-at-test-set! "findall over EDB"
-        (dl-query
-          (dl-program
-            "p(a). p(b). p(c).
-             all_p(L) :- findall(L, X, p(X)).")
-          (list (quote all_p) (quote L)))
-        (list {:L (list (quote a) (quote b) (quote c))}))
-
-      (dl-at-test-set! "findall over derived"
-        (dl-query
-          (dl-program
-            "parent(a, b). parent(b, c). parent(c, d).
-             ancestor(X, Y) :- parent(X, Y).
-             ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).
-             desc(L) :- findall(L, X, ancestor(a, X)).")
-          (list (quote desc) (quote L)))
-        (list {:L (list (quote b) (quote c) (quote d))}))
-
-      (dl-at-test-set! "findall empty"
-        (dl-query
-          (dl-program
-            "p(1).
-             all_q(L) :- findall(L, X, q(X)).")
-          (list (quote all_q) (quote L)))
-        (list {:L (list)}))
-
-      ;; Aggregate vs single distinct.
-      ;; Group-by via aggregate-in-rule-body. Per-user friend count
-      ;; over a friends relation. The U var is bound by the prior
-      ;; positive lit u(U) so the aggregate counts only U-rooted
-      ;; friends per group.
-      (dl-at-test-set! "group-by per-user friend count"
-        (dl-query
-          (dl-program
-            "u(alice). u(bob). u(carol).
-             f(alice, x). f(alice, y). f(bob, x).
-             counts(U, N) :- u(U), count(N, X, f(U, X)).")
-          (list (quote counts) (quote U) (quote N)))
-        (list
-          {:U (quote alice) :N 2}
-          {:U (quote bob) :N 1}
-          {:U (quote carol) :N 0}))
-
-      ;; Stratification: recursion through aggregation is rejected.
-      ;; Aggregate validates that second arg is a variable.
-      (dl-at-test! "agg second arg must be var"
-        (dl-at-throws?
-          (fn () (dl-eval "p(1). q(N) :- count(N, 5, p(X))." "?- q(N).")))
-        true)
-
-      ;; Aggregate validates that third arg is a positive literal.
-      (dl-at-test! "agg third arg must be a literal"
-        (dl-at-throws?
-          (fn () (dl-eval "p(1). q(N) :- count(N, X, 42)." "?- q(N).")))
-        true)
-
-      ;; Aggregate validates that the agg-var (2nd arg) appears in the
-      ;; goal. Without it every match contributes the same unbound
-      ;; symbol — count silently returns 1, sum raises a confusing
-      ;; "expected number" error, etc. Catch the mistake at safety
-      ;; check time instead.
-      (dl-at-test! "agg-var must appear in goal"
-        (dl-at-throws?
-          (fn ()
-            (dl-eval
-              "p(1). p(2). c(N) :- count(N, Y, p(X))."
-              "?- c(N).")))
-        true)
-
-      ;; Indirect recursion through aggregation also rejected.
-      ;; q -> r (via positive lit), r -> q (via aggregate body).
-      ;; The aggregate edge counts as negation for stratification.
-      (dl-at-test! "indirect agg cycle rejected"
-        (dl-at-throws?
-          (fn ()
-            (let ((db (dl-make-db)))
-              (do
-                (dl-add-rule! db
-                  {:head (list (quote q) (quote N))
-                   :body (list (list (quote r) (quote N)))})
-                (dl-add-rule! db
-                  {:head (list (quote r) (quote N))
-                   :body (list (list (quote count) (quote N) (quote X)
-                                     (list (quote q) (quote X))))})
-                (dl-saturate! db)))))
-        true)
-
-      (dl-at-test! "agg recursion rejected"
-        (dl-at-throws?
-          (fn ()
-            (let ((db (dl-make-db)))
-              (do
-                (dl-add-rule! db
-                  {:head (list (quote q) (quote N))
-                   :body (list (list (quote count) (quote N) (quote X)
-                                     (list (quote q) (quote X))))})
-                (dl-saturate! db)))))
-        true)
-
-      ;; Negation + aggregation in the same body — different strata.
-      (dl-at-test-set! "neg + agg coexist"
-        (dl-query
-          (dl-program
-            "u(a). u(b). u(c). banned(b).
-             active(X) :- u(X), not(banned(X)).
-             cnt(N) :- count(N, X, active(X)).")
-          (list (quote cnt) (quote N)))
-        (list {:N 2}))
-
-      ;; Min over a derived empty relation: no result.
-      (dl-at-test-set! "min over empty derived"
-        (dl-query
-          (dl-program
-            "s(50). s(60).
-             score(N) :- s(N), >(N, 100).
-             low(M) :- min(M, X, score(X)).")
-          (list (quote low) (quote M)))
-        (list))
-
-      ;; Aggregates as the top-level query goal (regression for
-      ;; dl-match-lit aggregate dispatch and projection cleanup).
-      (dl-at-test-set! "count as query goal"
-        (dl-query
-          (dl-program "p(1). p(2). p(3). p(4).")
-          (list (quote count) (quote N) (quote X) (list (quote p) (quote X))))
-        (list {:N 4}))
-
-      (dl-at-test-set! "findall as query goal"
-        (dl-query
-          (dl-program "p(1). p(2). p(3).")
-          (list (quote findall) (quote L) (quote X)
-                (list (quote p) (quote X))))
-        (list {:L (list 1 2 3)}))
-
-      (dl-at-test-set! "distinct counted once"
-        (dl-query
-          (dl-program
-            "rated(alice, x). rated(alice, y). rated(bob, x).
-             rater_count(N) :- count(N, U, rated(U, F)).")
-          (list (quote rater_count) (quote N)))
-        (list {:N 2})))))
-
-(define
-  dl-aggregates-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-at-pass 0)
-      (set! dl-at-fail 0)
-      (set! dl-at-failures (list))
-      (dl-at-run-all!)
-      {:passed dl-at-pass
-       :failed dl-at-fail
-       :total (+ dl-at-pass dl-at-fail)
-       :failures dl-at-failures})))

lib/datalog/tests/api.sx

@@ -1,350 +0,0 @@
-;; lib/datalog/tests/api.sx — SX-data embedding API.
-
-(define dl-api-pass 0)
-(define dl-api-fail 0)
-(define dl-api-failures (list))
-
-(define
-  dl-api-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-api-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-api-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-api-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-api-deep=? (nth a i) (nth b i))) false)
-      (else (dl-api-deq-l? a b (+ i 1))))))
-
-(define
-  dl-api-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i)))
-         (not (dl-api-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-api-deq-d? a b ka (+ i 1))))))
-
-(define
-  dl-api-set=?
-  (fn
-    (a b)
-    (and
-      (= (len a) (len b))
-      (dl-api-subset? a b)
-      (dl-api-subset? b a))))
-
-(define
-  dl-api-subset?
-  (fn
-    (xs ys)
-    (cond
-      ((= (len xs) 0) true)
-      ((not (dl-api-contains? ys (first xs))) false)
-      (else (dl-api-subset? (rest xs) ys)))))
-
-(define
-  dl-api-contains?
-  (fn
-    (xs target)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-api-deep=? (first xs) target) true)
-      (else (dl-api-contains? (rest xs) target)))))
-
-(define
-  dl-api-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-api-deep=? got expected)
-      (set! dl-api-pass (+ dl-api-pass 1))
-      (do
-        (set! dl-api-fail (+ dl-api-fail 1))
-        (append!
-          dl-api-failures
-          (str
-            name
-            "\n    expected: " expected
-            "\n    got:      " got))))))
-
-(define
-  dl-api-test-set!
-  (fn
-    (name got expected)
-    (if
-      (dl-api-set=? got expected)
-      (set! dl-api-pass (+ dl-api-pass 1))
-      (do
-        (set! dl-api-fail (+ dl-api-fail 1))
-        (append!
-          dl-api-failures
-          (str
-            name
-            "\n    expected (set): " expected
-            "\n    got:            " got))))))
-
-(define
-  dl-api-run-all!
-  (fn
-    ()
-    (do
-      ;; dl-program-data with arrow form.
-      (dl-api-test-set! "data API ancestor closure"
-        (dl-query
-          (dl-program-data
-            (quote ((parent tom bob) (parent bob ann) (parent ann pat)))
-            (quote
-              ((ancestor X Y <- (parent X Y))
-               (ancestor X Z <- (parent X Y) (ancestor Y Z)))))
-          (quote (ancestor tom X)))
-        (list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
-
-      ;; dl-program-data with dict rules.
-      (dl-api-test-set! "data API with dict rules"
-        (dl-query
-          (dl-program-data
-            (quote ((p a) (p b) (p c)))
-            (list
-              {:head (quote (q X)) :body (quote ((p X)))}))
-          (quote (q X)))
-        (list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
-
-      ;; dl-rule helper.
-      (dl-api-test-set! "dl-rule constructor"
-        (dl-query
-          (dl-program-data
-            (quote ((p 1) (p 2)))
-            (list (dl-rule (quote (q X)) (quote ((p X))))))
-          (quote (q X)))
-        (list {:X 1} {:X 2}))
-
-      ;; dl-assert! adds and re-derives.
-      (dl-api-test-set! "dl-assert! incremental"
-        (let
-          ((db (dl-program-data
-                 (quote ((parent tom bob) (parent bob ann)))
-                 (quote
-                   ((ancestor X Y <- (parent X Y))
-                    (ancestor X Z <- (parent X Y) (ancestor Y Z)))))))
-          (do
-            (dl-saturate! db)
-            (dl-assert! db (quote (parent ann pat)))
-            (dl-query db (quote (ancestor tom X)))))
-        (list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
-
-      ;; dl-retract! removes a fact and recomputes IDB.
-      (dl-api-test-set! "dl-retract! removes derived"
-        (let
-          ((db (dl-program-data
-                 (quote ((parent tom bob) (parent bob ann) (parent ann pat)))
-                 (quote
-                   ((ancestor X Y <- (parent X Y))
-                    (ancestor X Z <- (parent X Y) (ancestor Y Z)))))))
-          (do
-            (dl-saturate! db)
-            (dl-retract! db (quote (parent bob ann)))
-            (dl-query db (quote (ancestor tom X)))))
-        (list {:X (quote bob)}))
-
-      ;; dl-retract! on a relation with BOTH explicit facts AND a rule
-      ;; (a "mixed" relation) used to wipe the EDB portion when the IDB
-      ;; was re-derived, even when the retract didn't match anything.
-      ;; :edb-keys provenance now preserves user-asserted facts.
-      (dl-api-test-set! "dl-retract! preserves EDB in mixed relation"
-        (let
-          ((db (dl-program-data
-                 (quote ((p a) (p b) (q c)))
-                 (quote ((p X <- (q X)))))))
-          (do
-            (dl-saturate! db)
-            ;; Retract a non-existent tuple — should be a no-op.
-            (dl-retract! db (quote (p z)))
-            (dl-query db (quote (p X)))))
-        (list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
-
-      ;; And retracting an actual EDB fact in a mixed relation drops
-      ;; only that fact; the derived portion stays.
-      (dl-api-test-set! "dl-retract! mixed: drop EDB, keep IDB"
-        (let
-          ((db (dl-program-data
-                 (quote ((p a) (p b) (q c)))
-                 (quote ((p X <- (q X)))))))
-          (do
-            (dl-saturate! db)
-            (dl-retract! db (quote (p a)))
-            (dl-query db (quote (p X)))))
-        (list {:X (quote b)} {:X (quote c)}))
-
-      ;; dl-program-data + dl-query with constants in head.
-      (dl-api-test-set! "constant-in-head data"
-        (dl-query
-          (dl-program-data
-            (quote ((edge a b) (edge b c) (edge c a)))
-            (quote
-              ((reach X Y <- (edge X Y))
-               (reach X Z <- (edge X Y) (reach Y Z)))))
-          (quote (reach a X)))
-        (list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
-
-      ;; Assert into empty db.
-      (dl-api-test-set! "assert into empty"
-        (let
-          ((db (dl-program-data (list) (list))))
-          (do
-            (dl-assert! db (quote (p 1)))
-            (dl-assert! db (quote (p 2)))
-            (dl-query db (quote (p X)))))
-        (list {:X 1} {:X 2}))
-
-      ;; Multi-goal query: pass list of literals.
-      (dl-api-test-set! "multi-goal query"
-        (dl-query
-          (dl-program-data
-            (quote ((p 1) (p 2) (p 3) (q 2) (q 3)))
-            (list))
-          (list (quote (p X)) (quote (q X))))
-        (list {:X 2} {:X 3}))
-
-      ;; Multi-goal with comparison.
-      (dl-api-test-set! "multi-goal with comparison"
-        (dl-query
-          (dl-program-data
-            (quote ((n 1) (n 2) (n 3) (n 4) (n 5)))
-            (list))
-          (list (quote (n X)) (list (string->symbol ">") (quote X) 2)))
-        (list {:X 3} {:X 4} {:X 5}))
-
-      ;; dl-eval: single-call source + query.
-      (dl-api-test-set! "dl-eval ancestor"
-        (dl-eval
-          "parent(a, b). parent(b, c).
-           ancestor(X, Y) :- parent(X, Y).
-           ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."
-          "?- ancestor(a, X).")
-        (list {:X (quote b)} {:X (quote c)}))
-
-      (dl-api-test-set! "dl-eval multi-goal"
-        (dl-eval
-          "p(1). p(2). p(3). q(2). q(3)."
-          "?- p(X), q(X).")
-        (list {:X 2} {:X 3}))
-
-      ;; dl-rules-of: rules with head matching a relation name.
-      (dl-api-test! "dl-rules-of count"
-        (let
-          ((db (dl-program
-                 "p(1). q(X) :- p(X). r(X) :- p(X). q(2).")))
-          (len (dl-rules-of db "q")))
-        1)
-
-      (dl-api-test! "dl-rules-of empty"
-        (let
-          ((db (dl-program "p(1). p(2).")))
-          (len (dl-rules-of db "q")))
-        0)
-
-      ;; dl-clear-idb!: wipe rule-headed relations.
-      (dl-api-test! "dl-clear-idb! wipes IDB"
-        (let
-          ((db (dl-program
-                 "parent(a, b). parent(b, c).
-                  ancestor(X, Y) :- parent(X, Y).
-                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (do
-            (dl-saturate! db)
-            (dl-clear-idb! db)
-            (len (dl-relation db "ancestor"))))
-        0)
-
-      (dl-api-test! "dl-clear-idb! preserves EDB"
-        (let
-          ((db (dl-program
-                 "parent(a, b). parent(b, c).
-                  ancestor(X, Y) :- parent(X, Y).")))
-          (do
-            (dl-saturate! db)
-            (dl-clear-idb! db)
-            (len (dl-relation db "parent"))))
-        2)
-
-      ;; dl-eval-magic — routes single-goal queries through
-      ;; magic-sets evaluation.
-      (dl-api-test-set! "dl-eval-magic ancestor"
-        (dl-eval-magic
-          "parent(a, b). parent(b, c).
-           ancestor(X, Y) :- parent(X, Y).
-           ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."
-          "?- ancestor(a, X).")
-        (list {:X (quote b)} {:X (quote c)}))
-
-      ;; Equivalence: dl-eval and dl-eval-magic produce the same
-      ;; answers for any well-formed query (magic-sets is a perf
-      ;; alternative, not a semantic change).
-      (dl-api-test! "dl-eval ≡ dl-eval-magic on ancestor"
-        (let
-          ((source "parent(a, b). parent(b, c). parent(c, d).
-                    ancestor(X, Y) :- parent(X, Y).
-                    ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
-          (let
-            ((semi (dl-eval source "?- ancestor(a, X)."))
-              (magic (dl-eval-magic source "?- ancestor(a, X).")))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; Comprehensive integration: recursion + stratified negation
-      ;; + aggregation + comparison composed in a single program.
-      ;; (Uses _Anything as a regular var instead of `_` so the
-      ;;  outer rule binds via the reach lit.)
-      (dl-api-test-set! "integration"
-        (dl-eval
-          (str
-            "edge(a, b). edge(b, c). edge(c, d). edge(a, d). "
-            "banned(c). "
-            "reach(X, Y) :- edge(X, Y). "
-            "reach(X, Z) :- edge(X, Y), reach(Y, Z). "
-            "safe(X, Y) :- reach(X, Y), not(banned(Y)). "
-            "reach_count(X, N) :- reach(X, Z), count(N, Y, safe(X, Y)). "
-            "popular(X) :- reach_count(X, N), >=(N, 2).")
-          "?- popular(X).")
-        (list {:X (quote a)}))
-
-      ;; dl-rule-from-list with no arrow → fact-style.
-      (dl-api-test-set! "no arrow → fact-like rule"
-        (let
-          ((rule (dl-rule-from-list (quote (foo X Y)))))
-          (list rule))
-        (list {:head (quote (foo X Y)) :body (list)}))
-
-      ;; dl-coerce-rule on dict passes through.
-      (dl-api-test-set! "coerce dict rule"
-        (let
-          ((d {:head (quote (h X)) :body (quote ((b X)))}))
-          (list (dl-coerce-rule d)))
-        (list {:head (quote (h X)) :body (quote ((b X)))})))))
-
-(define
-  dl-api-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-api-pass 0)
-      (set! dl-api-fail 0)
-      (set! dl-api-failures (list))
-      (dl-api-run-all!)
-      {:passed dl-api-pass
-       :failed dl-api-fail
-       :total (+ dl-api-pass dl-api-fail)
-       :failures dl-api-failures})))

lib/datalog/tests/builtins.sx

@@ -1,285 +0,0 @@
-;; lib/datalog/tests/builtins.sx — comparison + arithmetic body literals.
-
-(define dl-bt-pass 0)
-(define dl-bt-fail 0)
-(define dl-bt-failures (list))
-
-(define
-  dl-bt-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-bt-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let
-          ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-bt-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-bt-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-bt-deep=? (nth a i) (nth b i))) false)
-      (else (dl-bt-deq-l? a b (+ i 1))))))
-
-(define
-  dl-bt-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i))) (not (dl-bt-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-bt-deq-d? a b ka (+ i 1))))))
-
-(define
-  dl-bt-set=?
-  (fn
-    (a b)
-    (and (= (len a) (len b)) (dl-bt-subset? a b) (dl-bt-subset? b a))))
-
-(define
-  dl-bt-subset?
-  (fn
-    (xs ys)
-    (cond
-      ((= (len xs) 0) true)
-      ((not (dl-bt-contains? ys (first xs))) false)
-      (else (dl-bt-subset? (rest xs) ys)))))
-
-(define
-  dl-bt-contains?
-  (fn
-    (xs target)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-bt-deep=? (first xs) target) true)
-      (else (dl-bt-contains? (rest xs) target)))))
-
-(define
-  dl-bt-test-set!
-  (fn
-    (name got expected)
-    (if
-      (dl-bt-set=? got expected)
-      (set! dl-bt-pass (+ dl-bt-pass 1))
-      (do
-        (set! dl-bt-fail (+ dl-bt-fail 1))
-        (append!
-          dl-bt-failures
-          (str
-            name
-            "\n    expected (set): "
-            expected
-            "\n    got:            "
-            got))))))
-
-(define
-  dl-bt-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-bt-deep=? got expected)
-      (set! dl-bt-pass (+ dl-bt-pass 1))
-      (do
-        (set! dl-bt-fail (+ dl-bt-fail 1))
-        (append!
-          dl-bt-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define
-  dl-bt-throws?
-  (fn
-    (thunk)
-    (let
-      ((threw false))
-      (do (guard (e (#t (set! threw true))) (thunk)) threw))))
-
-(define
-  dl-bt-run-all!
-  (fn
-    ()
-    (do
-      (dl-bt-test-set!
-        "less than filter"
-        (dl-query
-          (dl-program
-            "age(alice, 30). age(bob, 17). age(carol, 22).\n             adult(X) :- age(X, A), >=(A, 18).")
-          (list (quote adult) (quote X)))
-        (list {:X (quote alice)} {:X (quote carol)}))
-      (dl-bt-test-set!
-        "less-equal filter"
-        (dl-query
-          (dl-program
-            "n(1). n(2). n(3). n(4). n(5).\n             small(X) :- n(X), <=(X, 3).")
-          (list (quote small) (quote X)))
-        (list {:X 1} {:X 2} {:X 3}))
-      (dl-bt-test-set!
-        "not-equal filter"
-        (dl-query
-          (dl-program
-            "p(1, 2). p(2, 2). p(3, 4).\n             diff(X, Y) :- p(X, Y), !=(X, Y).")
-          (list (quote diff) (quote X) (quote Y)))
-        (list {:X 1 :Y 2} {:X 3 :Y 4}))
-      (dl-bt-test-set!
-        "is plus"
-        (dl-query
-          (dl-program
-            "n(1). n(2). n(3).\n             succ(X, Y) :- n(X), is(Y, +(X, 1)).")
-          (list (quote succ) (quote X) (quote Y)))
-        (list {:X 1 :Y 2} {:X 2 :Y 3} {:X 3 :Y 4}))
-      (dl-bt-test-set!
-        "is multiply"
-        (dl-query
-          (dl-program
-            "n(2). n(3). n(4).\n             square(X, Y) :- n(X), is(Y, *(X, X)).")
-          (list (quote square) (quote X) (quote Y)))
-        (list {:X 2 :Y 4} {:X 3 :Y 9} {:X 4 :Y 16}))
-      (dl-bt-test-set!
-        "is nested expr"
-        (dl-query
-          (dl-program
-            "n(1). n(2). n(3).\n             f(X, Y) :- n(X), is(Y, *(+(X, 1), 2)).")
-          (list (quote f) (quote X) (quote Y)))
-        (list {:X 1 :Y 4} {:X 2 :Y 6} {:X 3 :Y 8}))
-      (dl-bt-test-set!
-        "is bound LHS — equality"
-        (dl-query
-          (dl-program
-            "n(1, 2). n(2, 5). n(3, 4).\n             succ(X, Y) :- n(X, Y), is(Y, +(X, 1)).")
-          (list (quote succ) (quote X) (quote Y)))
-        (list {:X 1 :Y 2} {:X 3 :Y 4}))
-      (dl-bt-test-set!
-        "triple via is"
-        (dl-query
-          (dl-program
-            "n(1). n(2). n(3).\n             triple(X, Y) :- n(X), is(Y, *(X, 3)).")
-          (list (quote triple) (quote X) (quote Y)))
-        (list {:X 1 :Y 3} {:X 2 :Y 6} {:X 3 :Y 9}))
-      (dl-bt-test-set!
-        "= unifies var with constant"
-        (dl-query
-          (dl-program "p(a). p(b).\n             qual(X) :- p(X), =(X, a).")
-          (list (quote qual) (quote X)))
-        (list {:X (quote a)}))
-      (dl-bt-test-set!
-        "= unifies two vars (one bound)"
-        (dl-query
-          (dl-program "p(a). p(b).\n             twin(X, Y) :- p(X), =(Y, X).")
-          (list (quote twin) (quote X) (quote Y)))
-        (list {:X (quote a) :Y (quote a)} {:X (quote b) :Y (quote b)}))
-      (dl-bt-test!
-        "big count"
-        (let
-          ((db (dl-program "n(0). n(1). n(2). n(3). n(4). n(5). n(6). n(7). n(8). n(9).\n                  big(X) :- n(X), >=(X, 5).")))
-          (do (dl-saturate! db) (len (dl-relation db "big"))))
-        5)
-      ;; Built-in / arithmetic literals work as standalone query goals
-      ;; (without needing a wrapper rule).
-      (dl-bt-test-set! "comparison-only goal true"
-        (dl-eval "" "?- <(1, 2).")
-        (list {}))
-
-      (dl-bt-test-set! "comparison-only goal false"
-        (dl-eval "" "?- <(2, 1).")
-        (list))
-
-      (dl-bt-test-set! "is goal binds"
-        (dl-eval "" "?- is(N, +(2, 3)).")
-        (list {:N 5}))
-
-      ;; Bounded successor: a recursive rule with a comparison
-      ;; guard terminates because the Herbrand base is effectively
-      ;; bounded.
-      (dl-bt-test-set! "bounded successor"
-        (dl-query
-          (dl-program
-            "nat(0).
-             nat(Y) :- nat(X), is(Y, +(X, 1)), <(Y, 5).")
-          (list (quote nat) (quote X)))
-        (list {:X 0} {:X 1} {:X 2} {:X 3} {:X 4}))
-
-      (dl-bt-test!
-        "unsafe — comparison without binder"
-        (dl-bt-throws? (fn () (dl-program "p(X) :- <(X, 5).")))
-        true)
-      (dl-bt-test!
-        "unsafe — comparison both unbound"
-        (dl-bt-throws? (fn () (dl-program "p(X, Y) :- <(X, Y), q(X).")))
-        true)
-      (dl-bt-test!
-        "unsafe — is uses unbound RHS var"
-        (dl-bt-throws?
-          (fn () (dl-program "p(X, Y) :- q(X), is(Y, +(X, Z)).")))
-        true)
-      (dl-bt-test!
-        "unsafe — is on its own"
-        (dl-bt-throws? (fn () (dl-program "p(Y) :- is(Y, +(X, 1)).")))
-        true)
-      (dl-bt-test!
-        "unsafe — = between two unbound"
-        (dl-bt-throws? (fn () (dl-program "p(X, Y) :- =(X, Y).")))
-        true)
-      (dl-bt-test!
-        "safe — is binds head var"
-        (dl-bt-throws?
-          (fn () (dl-program "n(1). p(Y) :- n(X), is(Y, +(X, 1)).")))
-        false)
-      (dl-bt-test!
-        "safe — comparison after binder"
-        (dl-bt-throws?
-          (fn () (dl-program "n(1). big(X) :- n(X), >=(X, 0).")))
-        false)
-      (dl-bt-test!
-        "safe — = binds head var"
-        (dl-bt-throws?
-          (fn () (dl-program "p(a). p(b). x(Y) :- p(X), =(Y, X).")))
-        false)
-
-      ;; Division by zero raises with a clear error. Without this guard
-      ;; SX's `/` returned IEEE infinity, which then silently flowed
-      ;; through comparisons and aggregations.
-      (dl-bt-test!
-        "is — division by zero raises"
-        (dl-bt-throws?
-          (fn ()
-            (dl-eval "p(10). q(R) :- p(X), is(R, /(X, 0))." "?- q(R).")))
-        true)
-
-      ;; Comparison ops `<`, `<=`, `>`, `>=` require both operands to
-      ;; have the same primitive type. Cross-type comparisons used to
-      ;; silently return false (for some pairs) or raise a confusing
-      ;; host-level error (for others) — now they all raise with a
-      ;; message that names the offending values.
-      (dl-bt-test!
-        "comparison — string vs number raises"
-        (dl-bt-throws?
-          (fn ()
-            (dl-eval "p(\"hello\"). q(X) :- p(X), <(X, 5)." "?- q(X).")))
-        true)
-
-      ;; `!=` is the exception — it's a polymorphic inequality test
-      ;; (uses dl-tuple-equal? underneath) so cross-type pairs are
-      ;; legitimate (and trivially unequal).
-      (dl-bt-test-set! "!= works across types"
-        (dl-query
-          (dl-program
-            "p(1). p(\"1\"). q(X) :- p(X), !=(X, 1).")
-          (quote (q X)))
-        (list {:X "1"})))))
-
-(define
-  dl-builtins-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-bt-pass 0)
-      (set! dl-bt-fail 0)
-      (set! dl-bt-failures (list))
-      (dl-bt-run-all!)
-      {:failures dl-bt-failures :total (+ dl-bt-pass dl-bt-fail) :passed dl-bt-pass :failed dl-bt-fail})))

lib/datalog/tests/demo.sx

@@ -1,321 +0,0 @@
-;; lib/datalog/tests/demo.sx — Phase 10 demo programs.
-
-(define dl-demo-pass 0)
-(define dl-demo-fail 0)
-(define dl-demo-failures (list))
-
-(define
-  dl-demo-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-demo-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-demo-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-demo-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-demo-deep=? (nth a i) (nth b i))) false)
-      (else (dl-demo-deq-l? a b (+ i 1))))))
-
-(define
-  dl-demo-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i)))
-         (not (dl-demo-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-demo-deq-d? a b ka (+ i 1))))))
-
-(define
-  dl-demo-set=?
-  (fn
-    (a b)
-    (and
-      (= (len a) (len b))
-      (dl-demo-subset? a b)
-      (dl-demo-subset? b a))))
-
-(define
-  dl-demo-subset?
-  (fn
-    (xs ys)
-    (cond
-      ((= (len xs) 0) true)
-      ((not (dl-demo-contains? ys (first xs))) false)
-      (else (dl-demo-subset? (rest xs) ys)))))
-
-(define
-  dl-demo-contains?
-  (fn
-    (xs target)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-demo-deep=? (first xs) target) true)
-      (else (dl-demo-contains? (rest xs) target)))))
-
-(define
-  dl-demo-test-set!
-  (fn
-    (name got expected)
-    (if
-      (dl-demo-set=? got expected)
-      (set! dl-demo-pass (+ dl-demo-pass 1))
-      (do
-        (set! dl-demo-fail (+ dl-demo-fail 1))
-        (append!
-          dl-demo-failures
-          (str
-            name
-            "\n    expected (set): " expected
-            "\n    got:            " got))))))
-
-(define
-  dl-demo-run-all!
-  (fn
-    ()
-    (do
-      ;; ── Federation ──────────────────────────────────────────
-      (dl-demo-test-set! "mutuals"
-        (dl-query
-          (dl-demo-make
-            (quote ((follows alice bob) (follows bob alice)
-                    (follows bob carol) (follows carol dave)))
-            dl-demo-federation-rules)
-          (quote (mutual alice X)))
-        (list {:X (quote bob)}))
-
-      (dl-demo-test-set! "reachable transitive"
-        (dl-query
-          (dl-demo-make
-            (quote ((follows alice bob) (follows bob carol) (follows carol dave)))
-            dl-demo-federation-rules)
-          (quote (reachable alice X)))
-        (list {:X (quote bob)} {:X (quote carol)} {:X (quote dave)}))
-
-      (dl-demo-test-set! "foaf"
-        (dl-query
-          (dl-demo-make
-            (quote ((follows alice bob) (follows bob carol) (follows alice dave)))
-            dl-demo-federation-rules)
-          (quote (foaf alice X)))
-        (list {:X (quote carol)}))
-
-      ;; ── Content ─────────────────────────────────────────────
-      (dl-demo-test-set! "popular posts"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((authored alice p1) (authored bob p2) (authored carol p3)
-               (liked u1 p1) (liked u2 p1) (liked u3 p1)
-               (liked u1 p2)))
-            dl-demo-content-rules)
-          (quote (popular P)))
-        (list {:P (quote p1)}))
-
-      (dl-demo-test-set! "interesting feed"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((follows me alice) (follows me bob)
-               (authored alice p1) (authored bob p2)
-               (liked u1 p1) (liked u2 p1) (liked u3 p1)
-               (liked u4 p2)))
-            dl-demo-content-rules)
-          (quote (interesting me P)))
-        (list {:P (quote p1)}))
-
-      (dl-demo-test-set! "post likes count"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((authored alice p1)
-               (liked u1 p1) (liked u2 p1) (liked u3 p1)))
-            dl-demo-content-rules)
-          (quote (post-likes p1 N)))
-        (list {:N 3}))
-
-      ;; ── Permissions ─────────────────────────────────────────
-      (dl-demo-test-set! "direct group access"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((member alice editors)
-               (allowed editors blog)))
-            dl-demo-perm-rules)
-          (quote (can-access X blog)))
-        (list {:X (quote alice)}))
-
-      (dl-demo-test-set! "subgroup access"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((member bob writers)
-               (subgroup writers editors)
-               (allowed editors blog)))
-            dl-demo-perm-rules)
-          (quote (can-access X blog)))
-        (list {:X (quote bob)}))
-
-      (dl-demo-test-set! "transitive subgroup"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((member carol drafters)
-               (subgroup drafters writers)
-               (subgroup writers editors)
-               (allowed editors blog)))
-            dl-demo-perm-rules)
-          (quote (can-access X blog)))
-        (list {:X (quote carol)}))
-
-      ;; ── Cooking posts (canonical Phase 10 example) ─────────
-      (dl-demo-test-set! "cooking posts by network"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((follows me alice) (follows alice bob) (follows alice carol)
-               (authored alice p1) (authored bob p2)
-               (authored carol p3) (authored carol p4)
-               (tagged p1 travel) (tagged p2 cooking)
-               (tagged p3 cooking) (tagged p4 books)))
-            dl-demo-cooking-rules)
-          (quote (cooking-post-by-network me P)))
-        (list {:P (quote p2)} {:P (quote p3)}))
-
-      (dl-demo-test-set! "cooking — direct follow only"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((follows me bob)
-               (authored bob p1) (authored bob p2)
-               (tagged p1 cooking) (tagged p2 books)))
-            dl-demo-cooking-rules)
-          (quote (cooking-post-by-network me P)))
-        (list {:P (quote p1)}))
-
-      (dl-demo-test-set! "cooking — none in network"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((follows me bob)
-               (authored bob p1) (tagged p1 books)))
-            dl-demo-cooking-rules)
-          (quote (cooking-post-by-network me P)))
-        (list))
-
-      ;; ── Tag co-occurrence ──────────────────────────────────
-      (dl-demo-test-set! "cotagged posts"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((tagged p1 cooking) (tagged p1 vegetarian)
-               (tagged p2 cooking) (tagged p2 quick)
-               (tagged p3 vegetarian)))
-            dl-demo-tag-cooccur-rules)
-          (quote (cotagged P cooking vegetarian)))
-        (list {:P (quote p1)}))
-
-      (dl-demo-test-set! "tag pair count"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((tagged p1 cooking) (tagged p1 vegetarian)
-               (tagged p2 cooking) (tagged p2 quick)
-               (tagged p3 cooking) (tagged p3 vegetarian)))
-            dl-demo-tag-cooccur-rules)
-          (quote (tag-pair-count cooking vegetarian N)))
-        (list {:N 2}))
-
-      ;; ── Shortest path on a weighted DAG ──────────────────
-      (dl-demo-test-set! "shortest a→d via DAG"
-        (dl-query
-          (dl-demo-make
-            (quote ((edge a b 5) (edge b c 3) (edge a c 10) (edge c d 2)))
-            dl-demo-shortest-path-rules)
-          (quote (shortest a d W)))
-        (list {:W 10}))
-
-      (dl-demo-test-set! "shortest a→c picks 2-hop"
-        (dl-query
-          (dl-demo-make
-            (quote ((edge a b 5) (edge b c 3) (edge a c 10)))
-            dl-demo-shortest-path-rules)
-          (quote (shortest a c W)))
-        (list {:W 8}))
-
-      (dl-demo-test-set! "shortest unreachable empty"
-        (dl-query
-          (dl-demo-make
-            (quote ((edge a b 5) (edge b c 3)))
-            dl-demo-shortest-path-rules)
-          (quote (shortest a d W)))
-        (list))
-
-      ;; ── Org chart + headcount ─────────────────────────────
-      (dl-demo-test-set! "ceo subordinate transitive"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((manager ic1 mgr1) (manager ic2 mgr1)
-               (manager mgr1 vp1) (manager ic3 vp1)
-               (manager vp1 ceo)))
-            dl-demo-org-rules)
-          (quote (subordinate ceo X)))
-        (list
-          {:X (quote vp1)} {:X (quote mgr1)} {:X (quote ic1)}
-          {:X (quote ic2)} {:X (quote ic3)}))
-
-      (dl-demo-test-set! "ceo headcount = 5"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((manager ic1 mgr1) (manager ic2 mgr1)
-               (manager mgr1 vp1) (manager ic3 vp1)
-               (manager vp1 ceo)))
-            dl-demo-org-rules)
-          (quote (headcount ceo N)))
-        (list {:N 5}))
-
-      (dl-demo-test-set! "mgr1 headcount = 2"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((manager ic1 mgr1) (manager ic2 mgr1)
-               (manager mgr1 vp1) (manager ic3 vp1)
-               (manager vp1 ceo)))
-            dl-demo-org-rules)
-          (quote (headcount mgr1 N)))
-        (list {:N 2}))
-
-      (dl-demo-test-set! "no access without grant"
-        (dl-query
-          (dl-demo-make
-            (quote ((member dave outsiders) (allowed editors blog)))
-            dl-demo-perm-rules)
-          (quote (can-access X blog)))
-        (list)))))
-
-(define
-  dl-demo-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-demo-pass 0)
-      (set! dl-demo-fail 0)
-      (set! dl-demo-failures (list))
-      (dl-demo-run-all!)
-      {:passed dl-demo-pass
-       :failed dl-demo-fail
-       :total (+ dl-demo-pass dl-demo-fail)
-       :failures dl-demo-failures})))

lib/datalog/tests/eval.sx

@@ -1,463 +0,0 @@
-;; lib/datalog/tests/eval.sx — naive evaluation + safety analysis tests.
-
-(define dl-et-pass 0)
-(define dl-et-fail 0)
-(define dl-et-failures (list))
-
-;; Same deep-equal helper used in other suites.
-(define
-  dl-et-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-et-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let
-          ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-et-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-et-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-et-deep=? (nth a i) (nth b i))) false)
-      (else (dl-et-deq-l? a b (+ i 1))))))
-
-(define
-  dl-et-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i))) (not (dl-et-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-et-deq-d? a b ka (+ i 1))))))
-
-;; Set-equality on lists (order-independent, uses dl-et-deep=?).
-(define
-  dl-et-set=?
-  (fn
-    (a b)
-    (and (= (len a) (len b)) (dl-et-subset? a b) (dl-et-subset? b a))))
-
-(define
-  dl-et-subset?
-  (fn
-    (xs ys)
-    (cond
-      ((= (len xs) 0) true)
-      ((not (dl-et-contains? ys (first xs))) false)
-      (else (dl-et-subset? (rest xs) ys)))))
-
-(define
-  dl-et-contains?
-  (fn
-    (xs target)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-et-deep=? (first xs) target) true)
-      (else (dl-et-contains? (rest xs) target)))))
-
-(define
-  dl-et-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-et-deep=? got expected)
-      (set! dl-et-pass (+ dl-et-pass 1))
-      (do
-        (set! dl-et-fail (+ dl-et-fail 1))
-        (append!
-          dl-et-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define
-  dl-et-test-set!
-  (fn
-    (name got expected)
-    (if
-      (dl-et-set=? got expected)
-      (set! dl-et-pass (+ dl-et-pass 1))
-      (do
-        (set! dl-et-fail (+ dl-et-fail 1))
-        (append!
-          dl-et-failures
-          (str
-            name
-            "\n    expected (set): "
-            expected
-            "\n    got:            "
-            got))))))
-
-(define
-  dl-et-throws?
-  (fn
-    (thunk)
-    (let
-      ((threw false))
-      (do (guard (e (#t (set! threw true))) (thunk)) threw))))
-
-(define
-  dl-et-run-all!
-  (fn
-    ()
-    (do
-      (dl-et-test-set!
-        "fact lookup any"
-        (dl-query
-          (dl-program "parent(tom, bob). parent(bob, ann).")
-          (list (quote parent) (quote X) (quote Y)))
-        (list {:X (quote tom) :Y (quote bob)} {:X (quote bob) :Y (quote ann)}))
-      (dl-et-test-set!
-        "fact lookup constant arg"
-        (dl-query
-          (dl-program "parent(tom, bob). parent(tom, liz). parent(bob, ann).")
-          (list (quote parent) (quote tom) (quote Y)))
-        (list {:Y (quote bob)} {:Y (quote liz)}))
-      (dl-et-test-set!
-        "no match"
-        (dl-query
-          (dl-program "parent(tom, bob).")
-          (list (quote parent) (quote nobody) (quote X)))
-        (list))
-      (dl-et-test-set!
-        "ancestor closure"
-        (dl-query
-          (dl-program
-            "parent(tom, bob). parent(bob, ann). parent(ann, pat).\n             ancestor(X, Y) :- parent(X, Y).\n             ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
-          (list (quote ancestor) (quote tom) (quote X)))
-        (list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
-      (dl-et-test-set!
-        "sibling"
-        (dl-query
-          (dl-program
-            "parent(tom, bob). parent(tom, liz). parent(jane, bob). parent(jane, liz).\n             sibling(X, Y) :- parent(P, X), parent(P, Y).")
-          (list (quote sibling) (quote bob) (quote Y)))
-        (list {:Y (quote bob)} {:Y (quote liz)}))
-      (dl-et-test-set!
-        "same-generation"
-        (dl-query
-          (dl-program
-            "parent(tom, bob). parent(tom, liz). parent(bob, ann). parent(liz, joe).\n             person(tom). person(bob). person(liz). person(ann). person(joe).\n             sg(X, X) :- person(X).\n             sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y).")
-          (list (quote sg) (quote ann) (quote X)))
-        (list {:X (quote ann)} {:X (quote joe)}))
-      (dl-et-test!
-        "ancestor count"
-        (let
-          ((db (dl-program "parent(a, b). parent(b, c). parent(c, d).\n                  ancestor(X, Y) :- parent(X, Y).\n                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (do (dl-saturate! db) (len (dl-relation db "ancestor"))))
-        6)
-      (dl-et-test-set!
-        "grandparent"
-        (dl-query
-          (dl-program
-            "parent(a, b). parent(b, c). parent(c, d).\n             grandparent(X, Z) :- parent(X, Y), parent(Y, Z).")
-          (list (quote grandparent) (quote X) (quote Y)))
-        (list {:X (quote a) :Y (quote c)} {:X (quote b) :Y (quote d)}))
-      (dl-et-test!
-        "no recursion infinite loop"
-        (let
-          ((db (dl-program "edge(1, 2). edge(2, 3). edge(3, 1).\n                  reach(X, Y) :- edge(X, Y).\n                  reach(X, Z) :- edge(X, Y), reach(Y, Z).")))
-          (do (dl-saturate! db) (len (dl-relation db "reach"))))
-        9)
-      ;; Rule-shape sanity: empty-list head and non-list body raise
-      ;; clear errors rather than crashing inside the saturator.
-      (dl-et-test! "empty head rejected"
-        (dl-et-throws?
-          (fn ()
-            (dl-add-rule! (dl-make-db)
-              {:head (list) :body (list)})))
-        true)
-
-      (dl-et-test! "non-list body rejected"
-        (dl-et-throws?
-          (fn ()
-            (dl-add-rule! (dl-make-db)
-              {:head (list (quote p) (quote X)) :body 42})))
-        true)
-
-      ;; Reserved relation names rejected as rule/fact heads.
-      (dl-et-test!
-        "reserved name `not` as head rejected"
-        (dl-et-throws? (fn () (dl-program "not(X) :- p(X).")))
-        true)
-
-      (dl-et-test!
-        "reserved name `count` as head rejected"
-        (dl-et-throws?
-          (fn () (dl-program "count(N, X, p(X)) :- p(X).")))
-        true)
-
-      (dl-et-test!
-        "reserved name `<` as head rejected"
-        (dl-et-throws? (fn () (dl-program "<(X, 5) :- p(X).")))
-        true)
-
-      (dl-et-test!
-        "reserved name `is` as head rejected"
-        (dl-et-throws? (fn () (dl-program "is(N, +(1, 2)) :- p(N).")))
-        true)
-
-      ;; Body literal with a reserved-name positive head is rejected.
-      ;; The parser only treats outer-level `not(P)` as negation; nested
-      ;; `not(not(P))` would otherwise silently parse as a positive call
-      ;; to a relation named `not` and succeed vacuously. The safety
-      ;; checker now flags this so the user gets a clear error.
-      ;; Body literal with a reserved-name positive head is rejected.
-      ;; The parser only treats outer-level `not(P)` as negation; nested
-      ;; `not(not(P))` would otherwise silently parse as a positive call
-      ;; to a relation named `not` and succeed vacuously — so the safety
-      ;; checker now flags this to give the user a clear error.
-      (dl-et-test!
-        "nested not(not(...)) rejected"
-        (dl-et-throws?
-          (fn ()
-            (dl-program
-              "banned(a). u(a). vip(X) :- u(X), not(not(banned(X))).")))
-        true)
-
-      ;; A dict body literal that isn't `{:neg ...}` is almost always a
-      ;; typo — it would otherwise silently fall through to a confusing
-      ;; head-var-unbound safety error. Now caught with a clear message.
-      (dl-et-test!
-        "dict body lit without :neg rejected"
-        (dl-et-throws?
-          (fn ()
-            (let ((db (dl-make-db)))
-              (dl-add-rule! db
-                {:head (list (quote p) (quote X))
-                 :body (list {:weird "stuff"})}))))
-        true)
-
-      ;; Facts may only have simple-term args (number / string / symbol).
-      ;; A compound arg like `+(1, 2)` would otherwise be silently
-      ;; stored as the unreduced expression `(+ 1 2)` because dl-ground?
-      ;; sees no free variables.
-      (dl-et-test!
-        "compound arg in fact rejected"
-        (dl-et-throws? (fn () (dl-program "p(+(1, 2)).")))
-        true)
-
-      ;; Rule heads may only have variable or constant args — no
-      ;; compounds. Compound heads would be saturated as unreduced
-      ;; tuples rather than the arithmetic result the user expected.
-      (dl-et-test!
-        "compound arg in rule head rejected"
-        (dl-et-throws?
-          (fn () (dl-program "n(3). double(*(X, 2)) :- n(X).")))
-        true)
-
-      ;; The anonymous-variable renamer used to start at `_anon1`
-      ;; unconditionally; a rule that wrote `q(_anon1) :- p(_anon1, _)`
-      ;; (the user picking the same name the renamer would generate)
-      ;; would see the `_` renamed to `_anon1` too, collapsing the
-      ;; two positions in `p(_anon1, _)` to a single var. Now the
-      ;; renamer scans the rule for the max `_anon<N>` and starts past
-      ;; it, so user-written names of that form are preserved.
-      (dl-et-test-set! "anonymous-rename avoids user `_anon` collision"
-        (dl-query
-          (dl-program
-            "p(a, b). p(c, d). q(_anon1) :- p(_anon1, _).")
-          (quote (q X)))
-        (list {:X (quote a)} {:X (quote c)}))
-
-      (dl-et-test!
-        "unsafe head var"
-        (dl-et-throws? (fn () (dl-program "p(X, Y) :- q(X).")))
-        true)
-      (dl-et-test!
-        "unsafe — empty body"
-        (dl-et-throws? (fn () (dl-program "p(X) :- .")))
-        true)
-      ;; Underscore in head is unsafe — it's a fresh existential per
-      ;; occurrence after Phase 5d's anonymous-var renaming, and there's
-      ;; nothing in the body to bind it. (Old behavior accepted this by
-      ;; treating '_' as a literal name to skip; the renaming made it an
-      ;; ordinary unbound variable.)
-      (dl-et-test!
-        "underscore in head — unsafe"
-        (dl-et-throws? (fn () (dl-program "p(X, _) :- q(X).")))
-        true)
-      (dl-et-test!
-        "underscore in body only — safe"
-        (dl-et-throws? (fn () (dl-program "p(X) :- q(X, _).")))
-        false)
-      (dl-et-test!
-        "var only in head — unsafe"
-        (dl-et-throws? (fn () (dl-program "p(X, Y) :- q(Z).")))
-        true)
-      (dl-et-test!
-        "head var bound by body"
-        (dl-et-throws? (fn () (dl-program "p(X) :- q(X).")))
-        false)
-      (dl-et-test!
-        "head subset of body"
-        (dl-et-throws?
-          (fn
-            ()
-            (dl-program
-              "edge(a,b). edge(b,c). reach(X, Z) :- edge(X, Y), edge(Y, Z).")))
-        false)
-
-      ;; Anonymous variables: each occurrence must be independent.
-      (dl-et-test-set! "anon vars in rule are independent"
-        (dl-query
-          (dl-program
-            "p(a, b). p(c, d). q(X) :- p(X, _), p(_, Y).")
-          (list (quote q) (quote X)))
-        (list {:X (quote a)} {:X (quote c)}))
-
-      (dl-et-test-set! "anon vars in goal are independent"
-        (dl-query
-          (dl-program "p(1, 2, 3). p(4, 5, 6).")
-          (list (quote p) (quote _) (quote X) (quote _)))
-        (list {:X 2} {:X 5}))
-
-      ;; dl-summary: relation -> tuple-count for inspection.
-      (dl-et-test! "dl-summary basic"
-        (dl-summary
-          (let
-            ((db (dl-program "p(1). p(2). q(3).")))
-            (do (dl-saturate! db) db)))
-        {:p 2 :q 1})
-
-      (dl-et-test! "dl-summary empty IDB shown"
-        (dl-summary
-          (let
-            ((db (dl-program "r(X) :- s(X).")))
-            (do (dl-saturate! db) db)))
-        {:r 0})
-
-      (dl-et-test! "dl-summary mixed EDB and IDB"
-        (dl-summary
-          (let
-            ((db (dl-program
-                   "parent(a, b).
-                    ancestor(X, Y) :- parent(X, Y).
-                    ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-            (do (dl-saturate! db) db)))
-        {:parent 1 :ancestor 1})
-
-      (dl-et-test! "dl-summary empty db"
-        (dl-summary (dl-make-db))
-        {})
-
-      ;; Strategy hook: default semi-naive; :magic accepted but
-      ;; falls back to semi-naive (the transformation itself is
-      ;; deferred — Phase 6 in plan).
-      (dl-et-test! "default strategy"
-        (dl-get-strategy (dl-make-db))
-        :semi-naive)
-
-      (dl-et-test! "set strategy"
-        (let ((db (dl-make-db)))
-          (do (dl-set-strategy! db :magic) (dl-get-strategy db)))
-        :magic)
-
-      ;; Unknown strategy values are rejected so typos don't silently
-      ;; fall back to the default.
-      (dl-et-test!
-        "unknown strategy rejected"
-        (dl-et-throws?
-          (fn ()
-            (let ((db (dl-make-db)))
-              (dl-set-strategy! db :semi_naive))))
-        true)
-
-      ;; dl-saturated?: no-work-left predicate.
-      (dl-et-test! "saturated? after saturation"
-        (let ((db (dl-program
-                    "parent(a, b).
-                     ancestor(X, Y) :- parent(X, Y).")))
-          (do (dl-saturate! db) (dl-saturated? db)))
-        true)
-
-      (dl-et-test! "saturated? before saturation"
-        (let ((db (dl-program
-                    "parent(a, b).
-                     ancestor(X, Y) :- parent(X, Y).")))
-          (dl-saturated? db))
-        false)
-
-      ;; Disjunction via multiple rules — Datalog has no `;` in
-      ;; body, so disjunction is expressed as separate rules with
-      ;; the same head. Here plant_based(X) is satisfied by either
-      ;; vegan(X) or vegetarian(X).
-      (dl-et-test-set! "disjunction via multiple rules"
-        (dl-query
-          (dl-program
-            "vegan(alice). vegetarian(bob). meat_eater(carol).
-             plant_based(X) :- vegan(X).
-             plant_based(X) :- vegetarian(X).")
-          (list (quote plant_based) (quote X)))
-        (list {:X (quote alice)} {:X (quote bob)}))
-
-      ;; Bipartite-style join: pair-of-friends who share a hobby.
-      ;; Three-relation join exercising the planner's join order.
-      (dl-et-test-set! "bipartite friends-with-hobby"
-        (dl-query
-          (dl-program
-            "hobby(alice, climb). hobby(bob, paint).
-             hobby(carol, climb).
-             friend(alice, carol). friend(bob, alice).
-             match(A, B, H) :- friend(A, B), hobby(A, H), hobby(B, H).")
-          (list (quote match) (quote A) (quote B) (quote H)))
-        (list {:A (quote alice) :B (quote carol) :H (quote climb)}))
-
-      ;; Repeated variable (diagonal): p(X, X) only matches tuples
-      ;; whose two args are equal. The unifier handles this via the
-      ;; subst chain — first occurrence binds X, second occurrence
-      ;; checks against the binding.
-      (dl-et-test-set! "diagonal query"
-        (dl-query
-          (dl-program "p(1, 1). p(2, 3). p(4, 4). p(5, 5).")
-          (list (quote p) (quote X) (quote X)))
-        (list {:X 1} {:X 4} {:X 5}))
-
-      ;; A relation can be both EDB-seeded and rule-derived;
-      ;; saturate combines facts + derivations.
-      (dl-et-test-set! "mixed EDB + IDB same relation"
-        (dl-query
-          (dl-program
-            "link(a, b). link(c, d). link(e, c).
-             via(a, e).
-             link(X, Y) :- via(X, M), link(M, Y).")
-          (list (quote link) (quote a) (quote X)))
-        (list {:X (quote b)} {:X (quote c)}))
-
-      (dl-et-test! "saturated? after assert"
-        (let ((db (dl-program
-                    "parent(a, b).
-                     ancestor(X, Y) :- parent(X, Y).")))
-          (do
-            (dl-saturate! db)
-            (dl-add-fact! db (list (quote parent) (quote b) (quote c)))
-            (dl-saturated? db)))
-        false)
-
-      (dl-et-test-set! "magic-set still derives correctly"
-        (let
-          ((db (dl-program
-                 "parent(a, b). parent(b, c).
-                  ancestor(X, Y) :- parent(X, Y).
-                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (do
-            (dl-set-strategy! db :magic)
-            (dl-query db (list (quote ancestor) (quote a) (quote X)))))
-        (list {:X (quote b)} {:X (quote c)})))))
-
-(define
-  dl-eval-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-et-pass 0)
-      (set! dl-et-fail 0)
-      (set! dl-et-failures (list))
-      (dl-et-run-all!)
-      {:failures dl-et-failures :total (+ dl-et-pass dl-et-fail) :passed dl-et-pass :failed dl-et-fail})))

lib/datalog/tests/magic.sx

@@ -1,528 +0,0 @@
-;; lib/datalog/tests/magic.sx — adornment + SIPS analysis tests.
-
-(define dl-mt-pass 0)
-(define dl-mt-fail 0)
-(define dl-mt-failures (list))
-
-(define
-  dl-mt-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-mt-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-mt-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-mt-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-mt-deep=? (nth a i) (nth b i))) false)
-      (else (dl-mt-deq-l? a b (+ i 1))))))
-
-(define
-  dl-mt-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i)))
-         (not (dl-mt-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-mt-deq-d? a b ka (+ i 1))))))
-
-(define
-  dl-mt-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-mt-deep=? got expected)
-      (set! dl-mt-pass (+ dl-mt-pass 1))
-      (do
-        (set! dl-mt-fail (+ dl-mt-fail 1))
-        (append!
-          dl-mt-failures
-          (str
-            name
-            "\n    expected: " expected
-            "\n    got:      " got))))))
-
-(define
-  dl-mt-run-all!
-  (fn
-    ()
-    (do
-      ;; Goal adornment.
-      (dl-mt-test! "adorn 0-ary"
-        (dl-adorn-goal (list (quote ready)))
-        "")
-      (dl-mt-test! "adorn all bound"
-        (dl-adorn-goal (list (quote p) 1 2 3))
-        "bbb")
-      (dl-mt-test! "adorn all free"
-        (dl-adorn-goal (list (quote p) (quote X) (quote Y)))
-        "ff")
-      (dl-mt-test! "adorn mixed"
-        (dl-adorn-goal (list (quote ancestor) (quote tom) (quote X)))
-        "bf")
-      (dl-mt-test! "adorn const var const"
-        (dl-adorn-goal (list (quote p) (quote a) (quote X) (quote b)))
-        "bfb")
-
-      ;; dl-adorn-lit with explicit bound set.
-      (dl-mt-test! "adorn lit with bound"
-        (dl-adorn-lit (list (quote p) (quote X) (quote Y)) (list "X"))
-        "bf")
-
-      ;; Rule SIPS — chain ancestor.
-      (dl-mt-test! "sips chain ancestor bf"
-        (dl-rule-sips
-          {:head (list (quote ancestor) (quote X) (quote Z))
-           :body (list (list (quote parent) (quote X) (quote Y))
-                       (list (quote ancestor) (quote Y) (quote Z)))}
-          "bf")
-        (list
-          {:lit (list (quote parent) (quote X) (quote Y)) :adornment "bf"}
-          {:lit (list (quote ancestor) (quote Y) (quote Z)) :adornment "bf"}))
-
-      ;; SIPS — head fully bound.
-      (dl-mt-test! "sips head bb"
-        (dl-rule-sips
-          {:head (list (quote q) (quote X) (quote Y))
-           :body (list (list (quote p) (quote X) (quote Z))
-                       (list (quote r) (quote Z) (quote Y)))}
-          "bb")
-        (list
-          {:lit (list (quote p) (quote X) (quote Z)) :adornment "bf"}
-          {:lit (list (quote r) (quote Z) (quote Y)) :adornment "bb"}))
-
-      ;; SIPS — comparison; vars must be bound by prior body lit.
-      (dl-mt-test! "sips with comparison"
-        (dl-rule-sips
-          {:head (list (quote q) (quote X))
-           :body (list (list (quote p) (quote X))
-                       (list (string->symbol "<") (quote X) 5))}
-          "f")
-        (list
-          {:lit (list (quote p) (quote X)) :adornment "f"}
-          {:lit (list (string->symbol "<") (quote X) 5) :adornment "bb"}))
-
-      ;; SIPS — `is` binds its left arg.
-      (dl-mt-test! "sips with is"
-        (dl-rule-sips
-          {:head (list (quote q) (quote X) (quote Y))
-           :body (list (list (quote p) (quote X))
-                       (list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1)))}
-          "ff")
-        (list
-          {:lit (list (quote p) (quote X)) :adornment "f"}
-          {:lit (list (quote is) (quote Y)
-                      (list (string->symbol "+") (quote X) 1))
-           :adornment "fb"}))
-
-      ;; Magic predicate naming.
-      (dl-mt-test! "magic-rel-name"
-        (dl-magic-rel-name "ancestor" "bf")
-        "magic_ancestor^bf")
-
-      ;; Bound-args extraction.
-      (dl-mt-test! "bound-args bf"
-        (dl-bound-args (list (quote ancestor) (quote tom) (quote X)) "bf")
-        (list (quote tom)))
-
-      (dl-mt-test! "bound-args mixed"
-        (dl-bound-args (list (quote p) 1 (quote Y) 3) "bfb")
-        (list 1 3))
-
-      (dl-mt-test! "bound-args all-free"
-        (dl-bound-args (list (quote p) (quote X) (quote Y)) "ff")
-        (list))
-
-      ;; Magic literal construction.
-      (dl-mt-test! "magic-lit"
-        (dl-magic-lit "ancestor" "bf" (list (quote tom)))
-        (list (string->symbol "magic_ancestor^bf") (quote tom)))
-
-      ;; Magic-sets rewriter: structural sanity.
-      (dl-mt-test! "rewrite ancestor produces seed"
-        (let
-          ((rules
-             (list
-               {:head (list (quote ancestor) (quote X) (quote Y))
-                :body (list (list (quote parent) (quote X) (quote Y)))}
-               {:head (list (quote ancestor) (quote X) (quote Z))
-                :body
-                (list (list (quote parent) (quote X) (quote Y))
-                      (list (quote ancestor) (quote Y) (quote Z)))})))
-          (get
-            (dl-magic-rewrite rules "ancestor" "bf" (list (quote a)))
-            :seed))
-        (list (string->symbol "magic_ancestor^bf") (quote a)))
-
-      ;; Equivalence: rewritten program derives same ancestor tuples.
-      ;; In a chain a→b→c→d, magic-rewritten run still derives all
-      ;; ancestor pairs reachable from any node a/b/c/d propagated via
-      ;; magic_ancestor^bf — i.e. the full closure (6 tuples). Magic
-      ;; saves work only when the EDB has irrelevant nodes outside
-      ;; the seed's transitive cone.
-      (dl-mt-test! "magic-rewritten ancestor count"
-        (let
-          ((rules
-             (list
-               {:head (list (quote ancestor) (quote X) (quote Y))
-                :body (list (list (quote parent) (quote X) (quote Y)))}
-               {:head (list (quote ancestor) (quote X) (quote Z))
-                :body
-                (list (list (quote parent) (quote X) (quote Y))
-                      (list (quote ancestor) (quote Y) (quote Z)))}))
-            (edb (list
-                   (list (quote parent) (quote a) (quote b))
-                   (list (quote parent) (quote b) (quote c))
-                   (list (quote parent) (quote c) (quote d)))))
-          (let
-            ((rewritten (dl-magic-rewrite rules "ancestor" "bf" (list (quote a))))
-              (db (dl-make-db)))
-            (do
-              (for-each (fn (f) (dl-add-fact! db f)) edb)
-              (dl-add-fact! db (get rewritten :seed))
-              (for-each (fn (r) (dl-add-rule! db r)) (get rewritten :rules))
-              (dl-saturate! db)
-              (len (dl-relation db "ancestor")))))
-        6)
-
-      ;; dl-magic-query: end-to-end driver, doesn't mutate caller's db.
-      ;; Magic over a rule with negated body literal — propagation
-      ;; rules generated only for positive lits; negated lits pass
-      ;; through unchanged.
-      (dl-mt-test! "magic over rule with negation"
-        (let
-          ((db (dl-program
-                 "u(a). u(b). u(c). banned(b).
-                  active(X) :- u(X), not(banned(X)).")))
-          (let
-            ((semi (dl-query db (list (quote active) (quote X))))
-              (magic (dl-magic-query db (list (quote active) (quote X)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; All-bound query (existence check) generates an "bb"
-      ;; adornment chain. Verifies the rewriter walks multiple
-      ;; (rel, adn) pairs through the worklist.
-      (dl-mt-test! "magic existence check via bb"
-        (let
-          ((db (dl-program
-                 "parent(a, b). parent(b, c). parent(c, d).
-                  ancestor(X, Y) :- parent(X, Y).
-                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (let
-            ((found (dl-magic-query
-                      db (list (quote ancestor) (quote a) (quote c))))
-              (missing (dl-magic-query
-                         db (list (quote ancestor) (quote a) (quote z)))))
-            (and (= (len found) 1) (= (len missing) 0))))
-        true)
-
-      ;; Magic equivalence on the federation demo.
-      (dl-mt-test! "magic ≡ semi on foaf demo"
-        (let
-          ((db (dl-program-data
-                 (quote ((follows alice bob)
-                         (follows bob carol)
-                         (follows alice dave)))
-                 dl-demo-federation-rules)))
-          (let
-            ((semi (dl-query db (quote (foaf alice X))))
-              (magic (dl-magic-query db (quote (foaf alice X)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; Shape validation: dl-magic-query rejects non-list / non-
-      ;; dict goal shapes cleanly rather than crashing in `rest`.
-      (dl-mt-test! "magic rejects string goal"
-        (let ((threw false))
-          (do
-            (guard (e (#t (set! threw true)))
-              (dl-magic-query (dl-make-db) "foo"))
-            threw))
-        true)
-
-      (dl-mt-test! "magic rejects bare dict goal"
-        (let ((threw false))
-          (do
-            (guard (e (#t (set! threw true)))
-              (dl-magic-query (dl-make-db) {:foo "bar"}))
-            threw))
-        true)
-
-      ;; 3-stratum program under magic — distinct rule heads at
-      ;; strata 0/1/2 must all rewrite via the worklist.
-      (dl-mt-test! "magic 3-stratum program"
-        (let
-          ((db (dl-program
-                 "a(1). a(2). a(3). b(2).
-                  c(X) :- a(X), not(b(X)).
-                  d(X) :- c(X), not(banned(X)).
-                  banned(3).")))
-          (let
-            ((semi (dl-query db (list (quote d) (quote X))))
-              (magic (dl-magic-query db (list (quote d) (quote X)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; Aggregate -> derived -> threshold chain via magic.
-      (dl-mt-test! "magic aggregate-derived chain"
-        (let
-          ((db (dl-program
-                 "src(1). src(2). src(3).
-                  cnt(N) :- count(N, X, src(X)).
-                  active(N) :- cnt(N), >=(N, 2).")))
-          (let
-            ((semi (dl-query db (list (quote active) (quote N))))
-              (magic (dl-magic-query db (list (quote active) (quote N)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; Multi-relation rewrite chain: query r4 → propagate to r3,
-      ;; r2, r1, a. The worklist must process all of them; an
-      ;; earlier bug stopped after only the head pair.
-      (dl-mt-test! "magic chain through 4 rule levels"
-        (let
-          ((db (dl-program
-                 "a(1). a(2). r1(X) :- a(X). r2(X) :- r1(X).
-                  r3(X) :- r2(X). r4(X) :- r3(X).")))
-          (= 2 (len (dl-magic-query db (list (quote r4) (quote X))))))
-        true)
-
-      ;; Shortest-path demo via magic — exercises the rewriter
-      ;; against rules that mix recursive positive lits with an
-      ;; aggregate body literal.
-      (dl-mt-test! "magic on shortest-path demo"
-        (let
-          ((db (dl-program-data
-                 (quote ((edge a b 5) (edge b c 3) (edge a c 10)))
-                 dl-demo-shortest-path-rules)))
-          (let
-            ((semi (dl-query db (quote (shortest a c W))))
-              (magic (dl-magic-query db (quote (shortest a c W)))))
-            (and (= (len semi) (len magic))
-                 (= (len semi) 1))))
-        true)
-
-      ;; Same relation called with different adornment patterns
-      ;; in different rules. The worklist must enqueue and process
-      ;; each (rel, adornment) pair.
-      (dl-mt-test! "magic with multi-adornment same relation"
-        (let
-          ((db (dl-program
-                 "parent(p1, alice). parent(p2, bob).
-                  parent(g, p1). parent(g, p2).
-                  sibling(P1, P2) :- parent(G, P1), parent(G, P2),
-                                     !=(P1, P2).
-                  cousin(X, Y) :- parent(P1, X), parent(P2, Y),
-                                  sibling(P1, P2).")))
-          (let
-            ((semi (dl-query db (list (quote cousin) (quote alice) (quote Y))))
-              (magic (dl-magic-query db (list (quote cousin) (quote alice) (quote Y)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; Magic over a rule whose body contains an aggregate.
-      ;; The rewriter passes aggregate body lits through unchanged
-      ;; (no propagation generated for them), so semi-naive's count
-      ;; logic still fires correctly under the rewritten program.
-      (dl-mt-test! "magic over rule with aggregate body"
-        (let
-          ((db (dl-program
-                 "post(p1). post(p2). post(p3).
-                  liked(u1, p1). liked(u2, p1). liked(u3, p1).
-                  liked(u1, p2).
-                  rich(P) :- post(P), count(N, U, liked(U, P)),
-                             >=(N, 2).")))
-          (let
-            ((semi (dl-query db (list (quote rich) (quote P))))
-              (magic (dl-magic-query db (list (quote rich) (quote P)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; Mixed EDB + IDB: a relation can be both EDB-seeded and
-      ;; rule-derived. dl-magic-query must include the EDB portion
-      ;; even though the relation has rules.
-      (dl-mt-test! "magic mixed EDB+IDB"
-        (len
-          (dl-magic-query
-            (dl-program
-              "link(a, b). link(c, d). link(e, c).
-               via(a, e).
-               link(X, Y) :- via(X, M), link(M, Y).")
-            (list (quote link) (quote a) (quote X))))
-        2)
-
-      ;; dl-magic-query falls back to dl-query for built-in,
-      ;; aggregate, and negation goals (the magic seed would
-      ;; otherwise be non-ground).
-      (dl-mt-test! "magic-query falls back on aggregate"
-        (let
-          ((r (dl-magic-query
-                (dl-program "p(1). p(2). p(3).")
-                (list (quote count) (quote N) (quote X)
-                      (list (quote p) (quote X))))))
-          (and (= (len r) 1) (= (get (first r) "N") 3)))
-        true)
-
-      (dl-mt-test! "magic-query equivalent to dl-query"
-        (let
-          ((db (dl-program
-                 "parent(a, b). parent(b, c). parent(c, d).
-                  ancestor(X, Y) :- parent(X, Y).
-                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (let
-            ((semi (dl-query db (list (quote ancestor) (quote a) (quote X))))
-              (magic (dl-magic-query
-                       db (list (quote ancestor) (quote a) (quote X)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; The magic rewriter passes aggregate body lits through
-      ;; unchanged, so an aggregate over an IDB relation would see an
-      ;; empty inner-goal in the magic db unless the IDB is already
-      ;; materialised. dl-magic-query now pre-saturates the source db
-      ;; to guarantee equivalence with dl-query for every stratified
-      ;; program. Previously this returned `({:N 0})` because `active`
-      ;; (IDB, derived through negation) was never derived in the
-      ;; magic db.
-      (dl-mt-test! "magic over aggregate-of-IDB matches vanilla"
-        (let
-          ((src
-             "u(a). u(b). u(c). u(d). banned(b). banned(d).
-              active(X) :- u(X), not(banned(X)).
-              n(N) :- count(N, X, active(X))."))
-          (let
-            ((vanilla (dl-eval src "?- n(N)."))
-              (magic (dl-eval-magic src "?- n(N).")))
-            (and (= (len vanilla) 1)
-                 (= (len magic) 1)
-                 (= (get (first vanilla) "N")
-                    (get (first magic) "N")))))
-        true)
-
-      ;; magic-query doesn't mutate caller db.
-      (dl-mt-test! "magic-query preserves caller db"
-        (let
-          ((db (dl-program
-                 "parent(a, b). parent(b, c).
-                  ancestor(X, Y) :- parent(X, Y).
-                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (let
-            ((rules-before (len (dl-rules db))))
-            (do
-              (dl-magic-query db (list (quote ancestor) (quote a) (quote X)))
-              (= rules-before (len (dl-rules db))))))
-        true)
-
-      ;; Magic-sets benefit: query touches only one cluster of a
-      ;; multi-component graph. Semi-naive derives the full closure
-      ;; over both clusters; magic only the seeded one.
-      ;; Magic-vs-semi work shape: chain of 12. Semi-naive
-      ;; derives the full closure (78 = 12·13/2). A magic query
-      ;; rooted at node 0 returns the 12 descendants only —
-      ;; demonstrating that magic limits derivation to the
-      ;; query's transitive cone.
-      (dl-mt-test! "magic vs semi work-shape on chain-12"
-        (let
-          ((source (str
-                     "parent(0, 1). parent(1, 2). parent(2, 3). "
-                     "parent(3, 4). parent(4, 5). parent(5, 6). "
-                     "parent(6, 7). parent(7, 8). parent(8, 9). "
-                     "parent(9, 10). parent(10, 11). parent(11, 12). "
-                     "ancestor(X, Y) :- parent(X, Y). "
-                     "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (let
-            ((db1 (dl-make-db)) (db2 (dl-make-db)))
-            (do
-              (dl-load-program! db1 source)
-              (dl-saturate! db1)
-              (dl-load-program! db2 source)
-              (let
-                ((semi-count (len (dl-relation db1 "ancestor")))
-                  (magic-count
-                    (len (dl-magic-query
-                           db2 (list (quote ancestor) 0 (quote X))))))
-                ;; Magic returns only descendants of 0 (12 of them).
-                (and (= semi-count 78) (= magic-count 12))))))
-        true)
-
-      ;; Magic + arithmetic: rules with `is` clauses pass through
-      ;; the rewriter unchanged (built-ins aren't propagated).
-      (dl-mt-test! "magic preserves arithmetic"
-        (let
-          ((source "n(1). n(2). n(3).
-                    doubled(X, Y) :- n(X), is(Y, *(X, 2))."))
-          (let
-            ((semi (dl-eval source "?- doubled(2, Y)."))
-              (magic (dl-eval-magic source "?- doubled(2, Y).")))
-            (= (len semi) (len magic))))
-        true)
-
-      (dl-mt-test! "magic skips irrelevant clusters"
-        (let
-          ;; Two disjoint chains. Query is rooted in cluster 1.
-          ((db (dl-program
-                 "parent(a, b). parent(b, c).
-                  parent(x, y). parent(y, z).
-                  ancestor(X, Y) :- parent(X, Y).
-                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (do
-            (dl-saturate! db)
-            (let
-              ((semi-count (len (dl-relation db "ancestor")))
-                (magic-results
-                  (dl-magic-query
-                    db (list (quote ancestor) (quote a) (quote X)))))
-              ;; Semi-naive derives 6 (3 in each cluster). Magic
-              ;; gives 3 query results (a's reachable: b, c).
-              (and (= semi-count 6) (= (len magic-results) 2)))))
-        true)
-
-      (dl-mt-test! "magic-rewritten finds same answers"
-        (let
-          ((rules
-             (list
-               {:head (list (quote ancestor) (quote X) (quote Y))
-                :body (list (list (quote parent) (quote X) (quote Y)))}
-               {:head (list (quote ancestor) (quote X) (quote Z))
-                :body
-                (list (list (quote parent) (quote X) (quote Y))
-                      (list (quote ancestor) (quote Y) (quote Z)))}))
-            (edb (list
-                   (list (quote parent) (quote a) (quote b))
-                   (list (quote parent) (quote b) (quote c)))))
-          (let
-            ((rewritten (dl-magic-rewrite rules "ancestor" "bf" (list (quote a))))
-              (db (dl-make-db)))
-            (do
-              (for-each (fn (f) (dl-add-fact! db f)) edb)
-              (dl-add-fact! db (get rewritten :seed))
-              (for-each (fn (r) (dl-add-rule! db r)) (get rewritten :rules))
-              (dl-saturate! db)
-              (len (dl-query db (list (quote ancestor) (quote a) (quote X)))))))
-        2))))
-
-(define
-  dl-magic-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-mt-pass 0)
-      (set! dl-mt-fail 0)
-      (set! dl-mt-failures (list))
-      (dl-mt-run-all!)
-      {:passed dl-mt-pass
-       :failed dl-mt-fail
-       :total (+ dl-mt-pass dl-mt-fail)
-       :failures dl-mt-failures})))

lib/datalog/tests/negation.sx

@@ -1,252 +0,0 @@
-;; lib/datalog/tests/negation.sx — stratified negation tests.
-
-(define dl-nt-pass 0)
-(define dl-nt-fail 0)
-(define dl-nt-failures (list))
-
-(define
-  dl-nt-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-nt-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-nt-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-nt-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-nt-deep=? (nth a i) (nth b i))) false)
-      (else (dl-nt-deq-l? a b (+ i 1))))))
-
-(define
-  dl-nt-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i)))
-         (not (dl-nt-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-nt-deq-d? a b ka (+ i 1))))))
-
-(define
-  dl-nt-set=?
-  (fn
-    (a b)
-    (and
-      (= (len a) (len b))
-      (dl-nt-subset? a b)
-      (dl-nt-subset? b a))))
-
-(define
-  dl-nt-subset?
-  (fn
-    (xs ys)
-    (cond
-      ((= (len xs) 0) true)
-      ((not (dl-nt-contains? ys (first xs))) false)
-      (else (dl-nt-subset? (rest xs) ys)))))
-
-(define
-  dl-nt-contains?
-  (fn
-    (xs target)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-nt-deep=? (first xs) target) true)
-      (else (dl-nt-contains? (rest xs) target)))))
-
-(define
-  dl-nt-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-nt-deep=? got expected)
-      (set! dl-nt-pass (+ dl-nt-pass 1))
-      (do
-        (set! dl-nt-fail (+ dl-nt-fail 1))
-        (append!
-          dl-nt-failures
-          (str
-            name
-            "\n    expected: " expected
-            "\n    got:      " got))))))
-
-(define
-  dl-nt-test-set!
-  (fn
-    (name got expected)
-    (if
-      (dl-nt-set=? got expected)
-      (set! dl-nt-pass (+ dl-nt-pass 1))
-      (do
-        (set! dl-nt-fail (+ dl-nt-fail 1))
-        (append!
-          dl-nt-failures
-          (str
-            name
-            "\n    expected (set): " expected
-            "\n    got:            " got))))))
-
-(define
-  dl-nt-throws?
-  (fn
-    (thunk)
-    (let
-      ((threw false))
-      (do
-        (guard
-          (e (#t (set! threw true)))
-          (thunk))
-        threw))))
-
-(define
-  dl-nt-run-all!
-  (fn
-    ()
-    (do
-      ;; Negation against EDB-only relation.
-      (dl-nt-test-set! "not against EDB"
-        (dl-query
-          (dl-program
-            "p(1). p(2). p(3). r(2).
-             q(X) :- p(X), not(r(X)).")
-          (list (quote q) (quote X)))
-        (list {:X 1} {:X 3}))
-
-      ;; Negation against derived relation — needs stratification.
-      (dl-nt-test-set! "not against derived rel"
-        (dl-query
-          (dl-program
-            "p(1). p(2). p(3). s(2).
-             r(X) :- s(X).
-             q(X) :- p(X), not(r(X)).")
-          (list (quote q) (quote X)))
-        (list {:X 1} {:X 3}))
-
-      ;; Two-step strata: r derives via s; q derives via not r.
-      (dl-nt-test-set! "two-step strata"
-        (dl-query
-          (dl-program
-            "node(a). node(b). node(c). node(d).
-             edge(a, b). edge(b, c). edge(c, a).
-             reach(X, Y) :- edge(X, Y).
-             reach(X, Z) :- edge(X, Y), reach(Y, Z).
-             unreachable(X) :- node(X), not(reach(a, X)).")
-          (list (quote unreachable) (quote X)))
-        (list {:X (quote d)}))
-
-      ;; Combine negation with arithmetic and comparison.
-      (dl-nt-test-set! "negation with arithmetic"
-        (dl-query
-          (dl-program
-            "n(1). n(2). n(3). n(4). n(5). odd(1). odd(3). odd(5).
-             even(X) :- n(X), not(odd(X)).")
-          (list (quote even) (quote X)))
-        (list {:X 2} {:X 4}))
-
-      ;; Empty negation result.
-      (dl-nt-test-set! "negation always succeeds"
-        (dl-query
-          (dl-program
-            "p(1). p(2). q(X) :- p(X), not(r(X)).")
-          (list (quote q) (quote X)))
-        (list {:X 1} {:X 2}))
-
-      ;; Negation always fails.
-      (dl-nt-test-set! "negation always fails"
-        (dl-query
-          (dl-program
-            "p(1). p(2). r(1). r(2). q(X) :- p(X), not(r(X)).")
-          (list (quote q) (quote X)))
-        (list))
-
-      ;; Anonymous `_` in a negated literal is existentially quantified
-      ;; — it doesn't need to be bound by an earlier body lit. Without
-      ;; this exemption the safety check would reject the common idiom
-      ;; `orphan(X) :- person(X), not(parent(X, _))`.
-      (dl-nt-test-set! "negation with anonymous var — orphan idiom"
-        (dl-query
-          (dl-program
-            "person(a). person(b). person(c). parent(a, b).
-             orphan(X) :- person(X), not(parent(X, _)).")
-          (list (quote orphan) (quote X)))
-        (list {:X (quote b)} {:X (quote c)}))
-
-      ;; Multiple anonymous vars are each independently existential.
-      (dl-nt-test-set! "negation with multiple anonymous vars"
-        (dl-query
-          (dl-program
-            "u(a). u(b). u(c). edge(a, x). edge(b, y).
-             solo(X) :- u(X), not(edge(X, _)).")
-          (list (quote solo) (quote X)))
-        (list {:X (quote c)}))
-
-      ;; Stratifiability checks.
-      (dl-nt-test! "non-stratifiable rejected"
-        (dl-nt-throws?
-          (fn ()
-            (let ((db (dl-make-db)))
-              (do
-                (dl-add-rule!
-                  db
-                  {:head (list (quote p) (quote X))
-                   :body (list (list (quote q) (quote X))
-                               {:neg (list (quote r) (quote X))})})
-                (dl-add-rule!
-                  db
-                  {:head (list (quote r) (quote X))
-                   :body (list (list (quote p) (quote X)))})
-                (dl-add-fact! db (list (quote q) 1))
-                (dl-saturate! db)))))
-        true)
-
-      (dl-nt-test! "stratifiable accepted"
-        (dl-nt-throws?
-          (fn ()
-            (dl-program
-              "p(1). p(2). r(2).
-               q(X) :- p(X), not(r(X)).")))
-        false)
-
-      ;; Multi-stratum chain.
-      (dl-nt-test-set! "three-level strata"
-        (dl-query
-          (dl-program
-            "a(1). a(2). a(3). a(4).
-             b(X) :- a(X), not(c(X)).
-             c(X) :- d(X).
-             d(2).
-             d(4).")
-          (list (quote b) (quote X)))
-        (list {:X 1} {:X 3}))
-
-      ;; Safety violation: negation refers to unbound var.
-      (dl-nt-test! "negation safety violation"
-        (dl-nt-throws?
-          (fn ()
-            (dl-program
-              "p(1). q(X) :- p(X), not(r(Y)).")))
-        true))))
-
-(define
-  dl-negation-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-nt-pass 0)
-      (set! dl-nt-fail 0)
-      (set! dl-nt-failures (list))
-      (dl-nt-run-all!)
-      {:passed dl-nt-pass
-       :failed dl-nt-fail
-       :total (+ dl-nt-pass dl-nt-fail)
-       :failures dl-nt-failures})))

lib/datalog/tests/parse.sx

@@ -1,179 +0,0 @@
-;; lib/datalog/tests/parse.sx — parser unit tests
-;;
-;; Run via: bash lib/datalog/conformance.sh
-;; Or:      (load "lib/datalog/tokenizer.sx") (load "lib/datalog/parser.sx")
-;;          (load "lib/datalog/tests/parse.sx") (dl-parse-tests-run!)
-
-(define dl-pt-pass 0)
-(define dl-pt-fail 0)
-(define dl-pt-failures (list))
-
-;; Order-independent structural equality. Lists compared positionally,
-;; dicts as sets of (key, value) pairs. Numbers via = (so 30.0 = 30).
-(define
-  dl-deep-equal?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-deep-equal-list? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let
-          ((ka (keys a)) (kb (keys b)))
-          (and
-            (= (len ka) (len kb))
-            (dl-deep-equal-dict? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-deep-equal-list?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-deep-equal? (nth a i) (nth b i))) false)
-      (else (dl-deep-equal-list? a b (+ i 1))))))
-
-(define
-  dl-deep-equal-dict?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i))) (not (dl-deep-equal? (get a k) (get b k))))
-        false)
-      (else (dl-deep-equal-dict? a b ka (+ i 1))))))
-
-(define
-  dl-pt-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-deep-equal? got expected)
-      (set! dl-pt-pass (+ dl-pt-pass 1))
-      (do
-        (set! dl-pt-fail (+ dl-pt-fail 1))
-        (append!
-          dl-pt-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define
-  dl-pt-throws?
-  (fn
-    (thunk)
-    (let
-      ((threw false))
-      (do (guard (e (#t (set! threw true))) (thunk)) threw))))
-
-(define
-  dl-pt-run-all!
-  (fn
-    ()
-    (do
-      (dl-pt-test! "empty program" (dl-parse "") (list))
-      (dl-pt-test! "fact" (dl-parse "parent(tom, bob).") (list {:body (list) :head (list (quote parent) (quote tom) (quote bob))}))
-      (dl-pt-test!
-        "two facts"
-        (dl-parse "parent(tom, bob). parent(bob, ann).")
-        (list {:body (list) :head (list (quote parent) (quote tom) (quote bob))} {:body (list) :head (list (quote parent) (quote bob) (quote ann))}))
-      (dl-pt-test! "zero-ary fact" (dl-parse "ready.") (list {:body (list) :head (list (quote ready))}))
-      (dl-pt-test!
-        "rule one body lit"
-        (dl-parse "ancestor(X, Y) :- parent(X, Y).")
-        (list {:body (list (list (quote parent) (quote X) (quote Y))) :head (list (quote ancestor) (quote X) (quote Y))}))
-      (dl-pt-test!
-        "recursive rule"
-        (dl-parse "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
-        (list {:body (list (list (quote parent) (quote X) (quote Y)) (list (quote ancestor) (quote Y) (quote Z))) :head (list (quote ancestor) (quote X) (quote Z))}))
-      (dl-pt-test!
-        "query single"
-        (dl-parse "?- ancestor(tom, X).")
-        (list {:query (list (list (quote ancestor) (quote tom) (quote X)))}))
-      (dl-pt-test!
-        "query multi"
-        (dl-parse "?- p(X), q(X).")
-        (list {:query (list (list (quote p) (quote X)) (list (quote q) (quote X)))}))
-      (dl-pt-test!
-        "negation"
-        (dl-parse "safe(X) :- person(X), not(parent(X, _)).")
-        (list {:body (list (list (quote person) (quote X)) {:neg (list (quote parent) (quote X) (quote _))}) :head (list (quote safe) (quote X))}))
-      (dl-pt-test!
-        "number arg"
-        (dl-parse "age(alice, 30).")
-        (list {:body (list) :head (list (quote age) (quote alice) 30)}))
-      (dl-pt-test!
-        "string arg"
-        (dl-parse "label(x, \"hi\").")
-        (list {:body (list) :head (list (quote label) (quote x) "hi")}))
-      ;; Quoted 'atoms' parse as strings — a uppercase-starting name
-      ;; in quotes used to misclassify as a variable and reject the
-      ;; fact as non-ground.
-      (dl-pt-test!
-        "quoted atom arg parses as string"
-        (dl-parse "p('Hello World').")
-        (list {:body (list) :head (list (quote p) "Hello World")}))
-      (dl-pt-test!
-        "comparison literal"
-        (dl-parse "p(X) :- <(X, 5).")
-        (list {:body (list (list (string->symbol "<") (quote X) 5)) :head (list (quote p) (quote X))}))
-      (dl-pt-test!
-        "is with arith"
-        (dl-parse "succ(X, Y) :- nat(X), is(Y, +(X, 1)).")
-        (list {:body (list (list (quote nat) (quote X)) (list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1))) :head (list (quote succ) (quote X) (quote Y))}))
-      (dl-pt-test!
-        "mixed program"
-        (dl-parse "p(a). p(b). q(X) :- p(X). ?- q(Y).")
-        (list {:body (list) :head (list (quote p) (quote a))} {:body (list) :head (list (quote p) (quote b))} {:body (list (list (quote p) (quote X))) :head (list (quote q) (quote X))} {:query (list (list (quote q) (quote Y)))}))
-      (dl-pt-test!
-        "comments skipped"
-        (dl-parse "% comment\nfoo(a).\n/* block */ bar(b).")
-        (list {:body (list) :head (list (quote foo) (quote a))} {:body (list) :head (list (quote bar) (quote b))}))
-      (dl-pt-test!
-        "underscore var"
-        (dl-parse "p(X) :- q(X, _).")
-        (list {:body (list (list (quote q) (quote X) (quote _))) :head (list (quote p) (quote X))}))
-      ;; Negative number literals parse as one negative number,
-      ;; while subtraction (`-(X, Y)`) compound is preserved.
-      (dl-pt-test!
-        "negative integer literal"
-        (dl-parse "n(-3).")
-        (list {:head (list (quote n) -3) :body (list)}))
-
-      (dl-pt-test!
-        "subtraction compound preserved"
-        (dl-parse "r(X) :- is(X, -(10, 3)).")
-        (list
-          {:head (list (quote r) (quote X))
-           :body (list (list (quote is) (quote X)
-                             (list (string->symbol "-") 10 3)))}))
-
-      (dl-pt-test!
-        "number as relation name raises"
-        (dl-pt-throws? (fn () (dl-parse "1(X) :- p(X).")))
-        true)
-
-      (dl-pt-test!
-        "var as relation name raises"
-        (dl-pt-throws? (fn () (dl-parse "P(X).")))
-        true)
-
-      (dl-pt-test!
-        "missing dot raises"
-        (dl-pt-throws? (fn () (dl-parse "p(a)")))
-        true)
-      (dl-pt-test!
-        "trailing comma raises"
-        (dl-pt-throws? (fn () (dl-parse "p(a,).")))
-        true))))
-
-(define
-  dl-parse-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-pt-pass 0)
-      (set! dl-pt-fail 0)
-      (set! dl-pt-failures (list))
-      (dl-pt-run-all!)
-      {:failures dl-pt-failures :total (+ dl-pt-pass dl-pt-fail) :passed dl-pt-pass :failed dl-pt-fail})))

lib/datalog/tests/semi_naive.sx

@@ -1,153 +0,0 @@
-;; lib/datalog/tests/semi_naive.sx — semi-naive correctness vs naive.
-;;
-;; Strategy: differential — run both saturators on each program and
-;; compare the resulting per-relation tuple counts. Counting (not
-;; element-wise set equality) keeps the suite fast under the bundled
-;; conformance session; correctness on the inhabitants is covered by
-;; eval.sx and builtins.sx (which use dl-saturate! by default — the
-;; semi-naive saturator).
-
-(define dl-sn-pass 0)
-(define dl-sn-fail 0)
-(define dl-sn-failures (list))
-
-(define
-  dl-sn-test!
-  (fn
-    (name got expected)
-    (if
-      (equal? got expected)
-      (set! dl-sn-pass (+ dl-sn-pass 1))
-      (do
-        (set! dl-sn-fail (+ dl-sn-fail 1))
-        (append!
-          dl-sn-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-;; Load `source` into both a semi-naive and a naive db and return a
-;; list of (rel-name semi-count naive-count) triples. Both sets must
-;; have the same union of relation names.
-(define
-  dl-sn-counts
-  (fn
-    (source)
-    (let
-      ((db-s (dl-program source)) (db-n (dl-program source)))
-      (do
-        (dl-saturate! db-s)
-        (dl-saturate-naive! db-n)
-        (let
-          ((out (list)))
-          (do
-            (for-each
-              (fn
-                (k)
-                (append!
-                  out
-                  (list
-                    k
-                    (len (dl-relation db-s k))
-                    (len (dl-relation db-n k)))))
-              (keys (get db-s :facts)))
-            out))))))
-
-(define
-  dl-sn-counts-agree?
-  (fn
-    (counts)
-    (cond
-      ((= (len counts) 0) true)
-      (else
-        (let
-          ((row (first counts)))
-          (and
-            (= (nth row 1) (nth row 2))
-            (dl-sn-counts-agree? (rest counts))))))))
-
-(define
-  dl-sn-chain-source
-  (fn
-    (n)
-    (let
-      ((parts (list "")))
-      (do
-        (define
-          dl-sn-loop
-          (fn
-            (i)
-            (when
-              (< i n)
-              (do
-                (append! parts (str "parent(" i ", " (+ i 1) "). "))
-                (dl-sn-loop (+ i 1))))))
-        (dl-sn-loop 0)
-        (str
-          (join "" parts)
-          "ancestor(X, Y) :- parent(X, Y). "
-          "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))))
-
-(define
-  dl-sn-run-all!
-  (fn
-    ()
-    (do
-      (dl-sn-test!
-        "ancestor closure counts match"
-        (dl-sn-counts-agree?
-          (dl-sn-counts
-            "parent(a, b). parent(b, c). parent(c, d).\n             ancestor(X, Y) :- parent(X, Y).\n             ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
-        true)
-      (dl-sn-test!
-        "cyclic reach counts match"
-        (dl-sn-counts-agree?
-          (dl-sn-counts
-            "edge(1, 2). edge(2, 3). edge(3, 1). edge(3, 4).\n             reach(X, Y) :- edge(X, Y).\n             reach(X, Z) :- edge(X, Y), reach(Y, Z)."))
-        true)
-      (dl-sn-test!
-        "same-gen counts match"
-        (dl-sn-counts-agree?
-          (dl-sn-counts
-            "parent(a, b). parent(a, c). parent(b, d). parent(c, e).\n             person(a). person(b). person(c). person(d). person(e).\n             sg(X, X) :- person(X).\n             sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y)."))
-        true)
-      (dl-sn-test!
-        "rules with builtins counts match"
-        (dl-sn-counts-agree?
-          (dl-sn-counts
-            "n(1). n(2). n(3). n(4). n(5).\n             small(X) :- n(X), <(X, 5).\n             succ(X, Y) :- n(X), <(X, 5), is(Y, +(X, 1))."))
-        true)
-      (dl-sn-test!
-        "static rule fires under semi-naive"
-        (dl-sn-counts-agree?
-          (dl-sn-counts "p(a). p(b). q(X) :- p(X), =(X, a)."))
-        true)
-      ;; Chain length 12 — multiple semi-naive iterations against
-      ;; the recursive ancestor rule (differential vs naive).
-      (dl-sn-test!
-        "chain-12 ancestor counts match"
-        (dl-sn-counts-agree? (dl-sn-counts (dl-sn-chain-source 12)))
-        true)
-      ;; Chain length 25 — semi-naive only — first-arg index makes
-      ;; this tractable in conformance budget.
-      (dl-sn-test!
-        "chain-25 ancestor count value (semi only)"
-        (let
-          ((db (dl-program (dl-sn-chain-source 25))))
-          (do (dl-saturate! db) (len (dl-relation db "ancestor"))))
-        325)
-      (dl-sn-test!
-        "query through semi saturate"
-        (let
-          ((db (dl-program "parent(a, b). parent(b, c).\n                  ancestor(X, Y) :- parent(X, Y).\n                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (len (dl-query db (list (quote ancestor) (quote a) (quote X)))))
-        2))))
-
-(define
-  dl-semi-naive-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-sn-pass 0)
-      (set! dl-sn-fail 0)
-      (set! dl-sn-failures (list))
-      (dl-sn-run-all!)
-      {:failures dl-sn-failures :total (+ dl-sn-pass dl-sn-fail) :passed dl-sn-pass :failed dl-sn-fail})))

lib/datalog/tests/tokenize.sx

@@ -1,189 +0,0 @@
-;; lib/datalog/tests/tokenize.sx — tokenizer unit tests
-;;
-;; Run via: bash lib/datalog/conformance.sh
-;; Or:      (load "lib/datalog/tokenizer.sx") (load "lib/datalog/tests/tokenize.sx")
-;;          (dl-tokenize-tests-run!)
-
-(define dl-tk-pass 0)
-(define dl-tk-fail 0)
-(define dl-tk-failures (list))
-
-(define
-  dl-tk-test!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! dl-tk-pass (+ dl-tk-pass 1))
-      (do
-        (set! dl-tk-fail (+ dl-tk-fail 1))
-        (append!
-          dl-tk-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define dl-tk-types (fn (toks) (map (fn (t) (get t :type)) toks)))
-(define dl-tk-values (fn (toks) (map (fn (t) (get t :value)) toks)))
-
-(define
-  dl-tk-run-all!
-  (fn
-    ()
-    (do
-      (dl-tk-test! "empty" (dl-tk-types (dl-tokenize "")) (list "eof"))
-      (dl-tk-test!
-        "atom dot"
-        (dl-tk-types (dl-tokenize "foo."))
-        (list "atom" "punct" "eof"))
-      (dl-tk-test!
-        "atom dot value"
-        (dl-tk-values (dl-tokenize "foo."))
-        (list "foo" "." nil))
-      (dl-tk-test!
-        "var"
-        (dl-tk-types (dl-tokenize "X."))
-        (list "var" "punct" "eof"))
-      (dl-tk-test!
-        "underscore var"
-        (dl-tk-types (dl-tokenize "_x."))
-        (list "var" "punct" "eof"))
-      (dl-tk-test!
-        "integer"
-        (dl-tk-values (dl-tokenize "42"))
-        (list 42 nil))
-      (dl-tk-test!
-        "decimal"
-        (dl-tk-values (dl-tokenize "3.14"))
-        (list 3.14 nil))
-      (dl-tk-test!
-        "string"
-        (dl-tk-values (dl-tokenize "\"hello\""))
-        (list "hello" nil))
-      ;; Quoted 'atoms' tokenize as strings — see the type-table
-      ;; comment in lib/datalog/tokenizer.sx for the rationale.
-      (dl-tk-test!
-        "quoted atom as string"
-        (dl-tk-types (dl-tokenize "'two words'"))
-        (list "string" "eof"))
-      (dl-tk-test!
-        "quoted atom value"
-        (dl-tk-values (dl-tokenize "'two words'"))
-        (list "two words" nil))
-      ;; A quoted atom whose name would otherwise be a variable
-      ;; (uppercase / leading underscore) is now safely a string —
-      ;; this was the bug that motivated the type change.
-      (dl-tk-test!
-        "quoted Uppercase as string"
-        (dl-tk-types (dl-tokenize "'Hello'"))
-        (list "string" "eof"))
-      (dl-tk-test! ":-" (dl-tk-values (dl-tokenize ":-")) (list ":-" nil))
-      (dl-tk-test! "?-" (dl-tk-values (dl-tokenize "?-")) (list "?-" nil))
-      (dl-tk-test! "<=" (dl-tk-values (dl-tokenize "<=")) (list "<=" nil))
-      (dl-tk-test! ">=" (dl-tk-values (dl-tokenize ">=")) (list ">=" nil))
-      (dl-tk-test! "!=" (dl-tk-values (dl-tokenize "!=")) (list "!=" nil))
-      (dl-tk-test!
-        "single op values"
-        (dl-tk-values (dl-tokenize "< > = + - * /"))
-        (list "<" ">" "=" "+" "-" "*" "/" nil))
-      (dl-tk-test!
-        "single op types"
-        (dl-tk-types (dl-tokenize "< > = + - * /"))
-        (list "op" "op" "op" "op" "op" "op" "op" "eof"))
-      (dl-tk-test!
-        "punct"
-        (dl-tk-values (dl-tokenize "( ) , ."))
-        (list "(" ")" "," "." nil))
-      (dl-tk-test!
-        "fact tokens"
-        (dl-tk-types (dl-tokenize "parent(tom, bob)."))
-        (list "atom" "punct" "atom" "punct" "atom" "punct" "punct" "eof"))
-      (dl-tk-test!
-        "rule shape"
-        (dl-tk-types (dl-tokenize "p(X) :- q(X)."))
-        (list
-          "atom"
-          "punct"
-          "var"
-          "punct"
-          "op"
-          "atom"
-          "punct"
-          "var"
-          "punct"
-          "punct"
-          "eof"))
-      (dl-tk-test!
-        "comparison literal"
-        (dl-tk-values (dl-tokenize "<(X, 5)"))
-        (list "<" "(" "X" "," 5 ")" nil))
-      (dl-tk-test!
-        "is form"
-        (dl-tk-values (dl-tokenize "is(Y, +(X, 1))"))
-        (list "is" "(" "Y" "," "+" "(" "X" "," 1 ")" ")" nil))
-      (dl-tk-test!
-        "line comment"
-        (dl-tk-types (dl-tokenize "% comment line\nfoo."))
-        (list "atom" "punct" "eof"))
-      (dl-tk-test!
-        "block comment"
-        (dl-tk-types (dl-tokenize "/* a\nb */ x."))
-        (list "atom" "punct" "eof"))
-      ;; Unexpected characters surface at tokenize time rather
-      ;; than being silently consumed (previously `?(X)` parsed as
-      ;; if the leading `?` weren't there).
-      (dl-tk-test!
-        "unexpected char raises"
-        (let ((threw false))
-          (do
-            (guard (e (#t (set! threw true)))
-              (dl-tokenize "?(X)"))
-            threw))
-        true)
-
-      ;; Unterminated string / quoted-atom must raise.
-      (dl-tk-test!
-        "unterminated string raises"
-        (let ((threw false))
-          (do
-            (guard (e (#t (set! threw true)))
-              (dl-tokenize "\"unclosed"))
-            threw))
-        true)
-
-      (dl-tk-test!
-        "unterminated quoted atom raises"
-        (let ((threw false))
-          (do
-            (guard (e (#t (set! threw true)))
-              (dl-tokenize "'unclosed"))
-            threw))
-        true)
-
-      ;; Unterminated block comment must raise — previously it was
-      ;; silently consumed to EOF.
-      (dl-tk-test!
-        "unterminated block comment raises"
-        (let ((threw false))
-          (do
-            (guard (e (#t (set! threw true)))
-              (dl-tokenize "/* unclosed comment"))
-            threw))
-        true)
-      (dl-tk-test!
-        "whitespace"
-        (dl-tk-types (dl-tokenize "  foo  ,\t bar  ."))
-        (list "atom" "punct" "atom" "punct" "eof"))
-      (dl-tk-test!
-        "positions"
-        (map (fn (t) (get t :pos)) (dl-tokenize "foo bar"))
-        (list 0 4 7)))))
-
-(define
-  dl-tokenize-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-tk-pass 0)
-      (set! dl-tk-fail 0)
-      (set! dl-tk-failures (list))
-      (dl-tk-run-all!)
-      {:failures dl-tk-failures :total (+ dl-tk-pass dl-tk-fail) :passed dl-tk-pass :failed dl-tk-fail})))

lib/datalog/tests/unify.sx

@@ -1,194 +0,0 @@
-;; lib/datalog/tests/unify.sx — unification + substitution tests.
-
-(define dl-ut-pass 0)
-(define dl-ut-fail 0)
-(define dl-ut-failures (list))
-
-(define
-  dl-ut-deep-equal?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-ut-deq-list? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let
-          ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-ut-deq-dict? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-ut-deq-list?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-ut-deep-equal? (nth a i) (nth b i))) false)
-      (else (dl-ut-deq-list? a b (+ i 1))))))
-
-(define
-  dl-ut-deq-dict?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i))) (not (dl-ut-deep-equal? (get a k) (get b k))))
-        false)
-      (else (dl-ut-deq-dict? a b ka (+ i 1))))))
-
-(define
-  dl-ut-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-ut-deep-equal? got expected)
-      (set! dl-ut-pass (+ dl-ut-pass 1))
-      (do
-        (set! dl-ut-fail (+ dl-ut-fail 1))
-        (append!
-          dl-ut-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define
-  dl-ut-run-all!
-  (fn
-    ()
-    (do
-      (dl-ut-test! "var? uppercase" (dl-var? (quote X)) true)
-      (dl-ut-test! "var? underscore" (dl-var? (quote _foo)) true)
-      (dl-ut-test! "var? lowercase" (dl-var? (quote tom)) false)
-      (dl-ut-test! "var? number" (dl-var? 5) false)
-      (dl-ut-test! "var? string" (dl-var? "hi") false)
-      (dl-ut-test! "var? list" (dl-var? (list 1)) false)
-      (dl-ut-test!
-        "atom-atom match"
-        (dl-unify (quote tom) (quote tom) (dl-empty-subst))
-        {})
-      (dl-ut-test!
-        "atom-atom fail"
-        (dl-unify (quote tom) (quote bob) (dl-empty-subst))
-        nil)
-      (dl-ut-test!
-        "num-num match"
-        (dl-unify 5 5 (dl-empty-subst))
-        {})
-      (dl-ut-test!
-        "num-num fail"
-        (dl-unify 5 6 (dl-empty-subst))
-        nil)
-      (dl-ut-test!
-        "string match"
-        (dl-unify "hi" "hi" (dl-empty-subst))
-        {})
-      (dl-ut-test! "string fail" (dl-unify "hi" "bye" (dl-empty-subst)) nil)
-      (dl-ut-test!
-        "var-atom binds"
-        (dl-unify (quote X) (quote tom) (dl-empty-subst))
-        {:X (quote tom)})
-      (dl-ut-test!
-        "atom-var binds"
-        (dl-unify (quote tom) (quote X) (dl-empty-subst))
-        {:X (quote tom)})
-      (dl-ut-test!
-        "var-var same"
-        (dl-unify (quote X) (quote X) (dl-empty-subst))
-        {})
-      (dl-ut-test!
-        "var-var bind"
-        (let
-          ((s (dl-unify (quote X) (quote Y) (dl-empty-subst))))
-          (dl-walk (quote X) s))
-        (quote Y))
-      (dl-ut-test!
-        "tuple match"
-        (dl-unify
-          (list (quote parent) (quote X) (quote bob))
-          (list (quote parent) (quote tom) (quote Y))
-          (dl-empty-subst))
-        {:X (quote tom) :Y (quote bob)})
-      (dl-ut-test!
-        "tuple arity mismatch"
-        (dl-unify
-          (list (quote p) (quote X))
-          (list (quote p) (quote a) (quote b))
-          (dl-empty-subst))
-        nil)
-      (dl-ut-test!
-        "tuple head mismatch"
-        (dl-unify
-          (list (quote p) (quote X))
-          (list (quote q) (quote X))
-          (dl-empty-subst))
-        nil)
-      (dl-ut-test!
-        "walk chain"
-        (let
-          ((s1 (dl-unify (quote X) (quote Y) (dl-empty-subst))))
-          (let
-            ((s2 (dl-unify (quote Y) (quote tom) s1)))
-            (dl-walk (quote X) s2)))
-        (quote tom))
-
-      ;; Walk with circular substitution must not infinite-loop.
-      ;; Cycles return the current term unchanged.
-      (dl-ut-test!
-        "walk circular subst no hang"
-        (let ((s (dl-bind (quote B) (quote A)
-                   (dl-bind (quote A) (quote B) (dl-empty-subst)))))
-          (dl-walk (quote A) s))
-        (quote A))
-      (dl-ut-test!
-        "apply subst on tuple"
-        (let
-          ((s (dl-bind (quote X) (quote tom) (dl-empty-subst))))
-          (dl-apply-subst (list (quote parent) (quote X) (quote Y)) s))
-        (list (quote parent) (quote tom) (quote Y)))
-      (dl-ut-test!
-        "ground? all const"
-        (dl-ground?
-          (list (quote p) (quote tom) 5)
-          (dl-empty-subst))
-        true)
-      (dl-ut-test!
-        "ground? unbound var"
-        (dl-ground? (list (quote p) (quote X)) (dl-empty-subst))
-        false)
-      (dl-ut-test!
-        "ground? bound var"
-        (let
-          ((s (dl-bind (quote X) (quote tom) (dl-empty-subst))))
-          (dl-ground? (list (quote p) (quote X)) s))
-        true)
-      (dl-ut-test!
-        "ground? bare var"
-        (dl-ground? (quote X) (dl-empty-subst))
-        false)
-      (dl-ut-test!
-        "vars-of basic"
-        (dl-vars-of
-          (list (quote p) (quote X) (quote tom) (quote Y) (quote X)))
-        (list "X" "Y"))
-      (dl-ut-test!
-        "vars-of ground"
-        (dl-vars-of (list (quote p) (quote tom) (quote bob)))
-        (list))
-      (dl-ut-test!
-        "vars-of nested compound"
-        (dl-vars-of
-          (list
-            (quote is)
-            (quote Z)
-            (list (string->symbol "+") (quote X) 1)))
-        (list "Z" "X")))))
-
-(define
-  dl-unify-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-ut-pass 0)
-      (set! dl-ut-fail 0)
-      (set! dl-ut-failures (list))
-      (dl-ut-run-all!)
-      {:failures dl-ut-failures :total (+ dl-ut-pass dl-ut-fail) :passed dl-ut-pass :failed dl-ut-fail})))

lib/datalog/tokenizer.sx

@@ -1,269 +0,0 @@
-;; lib/datalog/tokenizer.sx — Datalog source → token stream
-;;
-;; Tokens: {:type T :value V :pos P}
-;; Types:
-;;   "atom"    — lowercase-start bare identifier
-;;   "var"     — uppercase-start or _-start ident (value is the name)
-;;   "number"  — numeric literal (decoded to number)
-;;   "string"  — "..." string literal OR quoted 'atom' (treated as a
-;;               string value to avoid the var-vs-atom ambiguity that
-;;               would arise from a quoted atom whose name starts with
-;;               an uppercase letter or underscore)
-;;   "punct"   — ( ) , .
-;;   "op"      — :- ?- <= >= != < > = + - * /
-;;   "eof"
-;;
-;; Datalog has no function symbols in arg position; the parser still
-;; accepts nested compounds for arithmetic ((is X (+ A B))) but safety
-;; analysis rejects non-arithmetic nesting at rule-load time.
-
-(define dl-make-token (fn (type value pos) {:type type :value value :pos pos}))
-
-(define dl-digit? (fn (c) (and (>= c "0") (<= c "9"))))
-(define dl-lower? (fn (c) (and (>= c "a") (<= c "z"))))
-(define dl-upper? (fn (c) (and (>= c "A") (<= c "Z"))))
-
-(define
-  dl-ident-char?
-  (fn (c) (or (dl-lower? c) (dl-upper? c) (dl-digit? c) (= c "_"))))
-
-(define dl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
-
-(define
-  dl-tokenize
-  (fn
-    (src)
-    (let
-      ((tokens (list)) (pos 0) (src-len (len src)))
-      (define
-        dl-peek
-        (fn
-          (offset)
-          (if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
-      (define cur (fn () (dl-peek 0)))
-      (define advance! (fn (n) (set! pos (+ pos n))))
-      (define
-        at?
-        (fn
-          (s)
-          (let
-            ((sl (len s)))
-            (and (<= (+ pos sl) src-len) (= (slice src pos (+ pos sl)) s)))))
-      (define
-        dl-emit!
-        (fn
-          (type value start)
-          (append! tokens (dl-make-token type value start))))
-      (define
-        skip-line-comment!
-        (fn
-          ()
-          (when
-            (and (< pos src-len) (not (= (cur) "\n")))
-            (do (advance! 1) (skip-line-comment!)))))
-      (define
-        skip-block-comment!
-        (fn
-          ()
-          (cond
-            ((>= pos src-len)
-              (error (str "Tokenizer: unterminated block comment "
-                          "(started at position " pos ")")))
-            ((and (= (cur) "*") (< (+ pos 1) src-len) (= (dl-peek 1) "/"))
-              (advance! 2))
-            (else (do (advance! 1) (skip-block-comment!))))))
-      (define
-        skip-ws!
-        (fn
-          ()
-          (cond
-            ((>= pos src-len) nil)
-            ((dl-ws? (cur)) (do (advance! 1) (skip-ws!)))
-            ((= (cur) "%")
-              (do (advance! 1) (skip-line-comment!) (skip-ws!)))
-            ((and (= (cur) "/") (< (+ pos 1) src-len) (= (dl-peek 1) "*"))
-              (do (advance! 2) (skip-block-comment!) (skip-ws!)))
-            (else nil))))
-      (define
-        read-ident
-        (fn
-          (start)
-          (do
-            (when
-              (and (< pos src-len) (dl-ident-char? (cur)))
-              (do (advance! 1) (read-ident start)))
-            (slice src start pos))))
-      (define
-        read-decimal-digits!
-        (fn
-          ()
-          (when
-            (and (< pos src-len) (dl-digit? (cur)))
-            (do (advance! 1) (read-decimal-digits!)))))
-      (define
-        read-number
-        (fn
-          (start)
-          (do
-            (read-decimal-digits!)
-            (when
-              (and
-                (< pos src-len)
-                (= (cur) ".")
-                (< (+ pos 1) src-len)
-                (dl-digit? (dl-peek 1)))
-              (do (advance! 1) (read-decimal-digits!)))
-            (parse-number (slice src start pos)))))
-      (define
-        read-quoted
-        (fn
-          (quote-char)
-          (let
-            ((chars (list)))
-            (advance! 1)
-            (define
-              loop
-              (fn
-                ()
-                (cond
-                  ((>= pos src-len)
-                    (error
-                      (str "Tokenizer: unterminated "
-                           (if (= quote-char "'") "quoted atom" "string")
-                           " (started near position " pos ")")))
-                  ((= (cur) "\\")
-                    (do
-                      (advance! 1)
-                      (when
-                        (< pos src-len)
-                        (let
-                          ((ch (cur)))
-                          (do
-                            (cond
-                              ((= ch "n") (append! chars "\n"))
-                              ((= ch "t") (append! chars "\t"))
-                              ((= ch "r") (append! chars "\r"))
-                              ((= ch "\\") (append! chars "\\"))
-                              ((= ch "'") (append! chars "'"))
-                              ((= ch "\"") (append! chars "\""))
-                              (else (append! chars ch)))
-                            (advance! 1))))
-                      (loop)))
-                  ((= (cur) quote-char) (advance! 1))
-                  (else
-                    (do (append! chars (cur)) (advance! 1) (loop))))))
-            (loop)
-            (join "" chars))))
-      (define
-        scan!
-        (fn
-          ()
-          (do
-            (skip-ws!)
-            (when
-              (< pos src-len)
-              (let
-                ((ch (cur)) (start pos))
-                (cond
-                  ((at? ":-")
-                    (do
-                      (dl-emit! "op" ":-" start)
-                      (advance! 2)
-                      (scan!)))
-                  ((at? "?-")
-                    (do
-                      (dl-emit! "op" "?-" start)
-                      (advance! 2)
-                      (scan!)))
-                  ((at? "<=")
-                    (do
-                      (dl-emit! "op" "<=" start)
-                      (advance! 2)
-                      (scan!)))
-                  ((at? ">=")
-                    (do
-                      (dl-emit! "op" ">=" start)
-                      (advance! 2)
-                      (scan!)))
-                  ((at? "!=")
-                    (do
-                      (dl-emit! "op" "!=" start)
-                      (advance! 2)
-                      (scan!)))
-                  ((dl-digit? ch)
-                    (do
-                      (dl-emit! "number" (read-number start) start)
-                      (scan!)))
-                  ((= ch "'")
-                    ;; Quoted 'atoms' tokenize as strings so a name
-                    ;; like 'Hello World' doesn't get misclassified
-                    ;; as a variable by dl-var? (which inspects the
-                    ;; symbol's first character).
-                    (do (dl-emit! "string" (read-quoted "'") start) (scan!)))
-                  ((= ch "\"")
-                    (do (dl-emit! "string" (read-quoted "\"") start) (scan!)))
-                  ((dl-lower? ch)
-                    (do (dl-emit! "atom" (read-ident start) start) (scan!)))
-                  ((or (dl-upper? ch) (= ch "_"))
-                    (do (dl-emit! "var" (read-ident start) start) (scan!)))
-                  ((= ch "(")
-                    (do
-                      (dl-emit! "punct" "(" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch ")")
-                    (do
-                      (dl-emit! "punct" ")" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch ",")
-                    (do
-                      (dl-emit! "punct" "," start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch ".")
-                    (do
-                      (dl-emit! "punct" "." start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch "<")
-                    (do
-                      (dl-emit! "op" "<" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch ">")
-                    (do
-                      (dl-emit! "op" ">" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch "=")
-                    (do
-                      (dl-emit! "op" "=" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch "+")
-                    (do
-                      (dl-emit! "op" "+" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch "-")
-                    (do
-                      (dl-emit! "op" "-" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch "*")
-                    (do
-                      (dl-emit! "op" "*" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch "/")
-                    (do
-                      (dl-emit! "op" "/" start)
-                      (advance! 1)
-                      (scan!)))
-                  (else (error
-                          (str "Tokenizer: unexpected character '" ch
-                               "' at position " start)))))))))
-      (scan!)
-      (dl-emit! "eof" nil pos)
-      tokens)))

lib/datalog/unify.sx

@@ -1,171 +0,0 @@
-;; lib/datalog/unify.sx — unification + substitution for Datalog terms.
-;;
-;; Term taxonomy (after parsing):
-;;   variable  — SX symbol whose first char is uppercase A–Z or '_'.
-;;   constant  — SX symbol whose first char is lowercase a–z (atom name).
-;;   number    — numeric literal.
-;;   string    — string literal.
-;;   compound  — SX list (functor arg ... arg). In core Datalog these
-;;               only appear as arithmetic expressions (see Phase 4
-;;               safety analysis); compound-against-compound unification
-;;               is supported anyway for completeness.
-;;
-;; Substitutions are immutable dicts keyed by variable name (string).
-;; A failed unification returns nil; success returns the extended subst.
-
-(define dl-empty-subst (fn () {}))
-
-(define
-  dl-var?
-  (fn
-    (term)
-    (and
-      (symbol? term)
-      (let
-        ((name (symbol->string term)))
-        (and
-          (> (len name) 0)
-          (let
-            ((c (slice name 0 1)))
-            (or (and (>= c "A") (<= c "Z")) (= c "_"))))))))
-
-;; Walk: chase variable bindings until we hit a non-variable or an unbound
-;; variable. The result is either a non-variable term or an unbound var.
-(define
-  dl-walk
-  (fn (term subst) (dl-walk-aux term subst (list))))
-
-;; Internal: walk with a visited-var set so circular substitutions
-;; (from raw dl-bind misuse) don't infinite-loop. Cycles return the
-;; current term unchanged.
-(define
-  dl-walk-aux
-  (fn
-    (term subst visited)
-    (if
-      (dl-var? term)
-      (let
-        ((name (symbol->string term)))
-        (cond
-          ((dl-member? name visited) term)
-          ((and (dict? subst) (has-key? subst name))
-            (let ((seen (list)))
-              (do
-                (for-each (fn (v) (append! seen v)) visited)
-                (append! seen name)
-                (dl-walk-aux (get subst name) subst seen))))
-          (else term)))
-      term)))
-
-;; Bind a variable symbol to a value in subst, returning a new subst.
-(define
-  dl-bind
-  (fn (var-sym value subst) (assoc subst (symbol->string var-sym) value)))
-
-(define
-  dl-unify
-  (fn
-    (t1 t2 subst)
-    (if
-      (nil? subst)
-      nil
-      (let
-        ((u1 (dl-walk t1 subst)) (u2 (dl-walk t2 subst)))
-        (cond
-          ((dl-var? u1)
-            (cond
-              ((and (dl-var? u2) (= (symbol->string u1) (symbol->string u2)))
-                subst)
-              (else (dl-bind u1 u2 subst))))
-          ((dl-var? u2) (dl-bind u2 u1 subst))
-          ((and (list? u1) (list? u2))
-            (if
-              (= (len u1) (len u2))
-              (dl-unify-list u1 u2 subst 0)
-              nil))
-          ((and (number? u1) (number? u2)) (if (= u1 u2) subst nil))
-          ((and (string? u1) (string? u2)) (if (= u1 u2) subst nil))
-          ((and (symbol? u1) (symbol? u2))
-            (if (= (symbol->string u1) (symbol->string u2)) subst nil))
-          (else nil))))))
-
-(define
-  dl-unify-list
-  (fn
-    (a b subst i)
-    (cond
-      ((nil? subst) nil)
-      ((>= i (len a)) subst)
-      (else
-        (dl-unify-list
-          a
-          b
-          (dl-unify (nth a i) (nth b i) subst)
-          (+ i 1))))))
-
-;; Apply substitution: walk the term and recurse into lists.
-(define
-  dl-apply-subst
-  (fn
-    (term subst)
-    (let
-      ((w (dl-walk term subst)))
-      (if (list? w) (map (fn (x) (dl-apply-subst x subst)) w) w))))
-
-;; Ground? — true iff no free variables remain after walking.
-(define
-  dl-ground?
-  (fn
-    (term subst)
-    (let
-      ((w (dl-walk term subst)))
-      (cond
-        ((dl-var? w) false)
-        ((list? w) (dl-ground-list? w subst 0))
-        (else true)))))
-
-(define
-  dl-ground-list?
-  (fn
-    (xs subst i)
-    (cond
-      ((>= i (len xs)) true)
-      ((not (dl-ground? (nth xs i) subst)) false)
-      (else (dl-ground-list? xs subst (+ i 1))))))
-
-;; Return the list of variable names appearing in a term (deduped, in
-;; left-to-right order). Useful for safety analysis later.
-(define
-  dl-vars-of
-  (fn (term) (let ((seen (list))) (do (dl-vars-of-aux term seen) seen))))
-
-(define
-  dl-vars-of-aux
-  (fn
-    (term acc)
-    (cond
-      ((dl-var? term)
-        (let
-          ((name (symbol->string term)))
-          (when (not (dl-member? name acc)) (append! acc name))))
-      ((list? term) (dl-vars-of-list term acc 0))
-      (else nil))))
-
-(define
-  dl-vars-of-list
-  (fn
-    (xs acc i)
-    (when
-      (< i (len xs))
-      (do
-        (dl-vars-of-aux (nth xs i) acc)
-        (dl-vars-of-list xs acc (+ i 1))))))
-
-(define
-  dl-member?
-  (fn
-    (x xs)
-    (cond
-      ((= (len xs) 0) false)
-      ((= (first xs) x) true)
-      (else (dl-member? x (rest xs))))))

lib/erlang/conformance.sh

@@ -76,7 +76,7 @@ cat > "$TMPFILE" << 'EPOCHS'
 (eval "(list er-fib-test-pass er-fib-test-count)")
 EPOCHS
 
-timeout 120 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
+timeout 600 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
 
 # Parse "(N M)" from the line after each "(ok-len <epoch> ...)" marker.
 parse_pair() {

lib/erlang/scoreboard.json

@@ -1,16 +1,16 @@
 {
   "language": "erlang",
-  "total_pass": 0,
-  "total": 0,
+  "total_pass": 530,
+  "total": 530,
   "suites": [
-    {"name":"tokenize","pass":0,"total":0,"status":"ok"},
-    {"name":"parse","pass":0,"total":0,"status":"ok"},
-    {"name":"eval","pass":0,"total":0,"status":"ok"},
-    {"name":"runtime","pass":0,"total":0,"status":"ok"},
-    {"name":"ring","pass":0,"total":0,"status":"ok"},
-    {"name":"ping-pong","pass":0,"total":0,"status":"ok"},
-    {"name":"bank","pass":0,"total":0,"status":"ok"},
-    {"name":"echo","pass":0,"total":0,"status":"ok"},
-    {"name":"fib","pass":0,"total":0,"status":"ok"}
+    {"name":"tokenize","pass":62,"total":62,"status":"ok"},
+    {"name":"parse","pass":52,"total":52,"status":"ok"},
+    {"name":"eval","pass":346,"total":346,"status":"ok"},
+    {"name":"runtime","pass":39,"total":39,"status":"ok"},
+    {"name":"ring","pass":4,"total":4,"status":"ok"},
+    {"name":"ping-pong","pass":4,"total":4,"status":"ok"},
+    {"name":"bank","pass":8,"total":8,"status":"ok"},
+    {"name":"echo","pass":7,"total":7,"status":"ok"},
+    {"name":"fib","pass":8,"total":8,"status":"ok"}
   ]
 }

lib/erlang/scoreboard.md

@@ -1,18 +1,18 @@
 # Erlang-on-SX Scoreboard
 
-**Total: 0 / 0 tests passing**
+**Total: 530 / 530 tests passing**
 
 |  | Suite | Pass | Total |
 |---|---|---|---|
-| ✅ | tokenize | 0 | 0 |
-| ✅ | parse | 0 | 0 |
-| ✅ | eval | 0 | 0 |
-| ✅ | runtime | 0 | 0 |
-| ✅ | ring | 0 | 0 |
-| ✅ | ping-pong | 0 | 0 |
-| ✅ | bank | 0 | 0 |
-| ✅ | echo | 0 | 0 |
-| ✅ | fib | 0 | 0 |
+| ✅ | tokenize | 62 | 62 |
+| ✅ | parse | 52 | 52 |
+| ✅ | eval | 346 | 346 |
+| ✅ | runtime | 39 | 39 |
+| ✅ | ring | 4 | 4 |
+| ✅ | ping-pong | 4 | 4 |
+| ✅ | bank | 8 | 8 |
+| ✅ | echo | 7 | 7 |
+| ✅ | fib | 8 | 8 |
 
 
 Generated by `lib/erlang/conformance.sh`.

lib/guest/reflective/env.sx

@@ -0,0 +1,159 @@
+;; lib/guest/reflective/env.sx — first-class environment kit.
+;;
+;; Extracted from Kernel-on-SX (lib/kernel/eval.sx) when Tcl's
+;; uplevel/upvar machinery (lib/tcl/runtime.sx) materialised as a
+;; second consumer needing the same scope-chain semantics.
+;;
+;; Canonical wire shape
+;; --------------------
+;;   {:refl-tag :env :bindings DICT :parent ENV-OR-NIL}
+;;
+;;   - :bindings is a mutable SX dict keyed by symbol name.
+;;   - :parent is either another env or nil (root).
+;;   - Lookup walks the parent chain until a hit or nil.
+;;   - Default cfg uses dict-set! to mutate bindings in place.
+;;
+;; Consumers with their own shape (e.g., Tcl's {:level :locals :parent})
+;; pass an adapter cfg dict — same trick as lib/guest/match.sx's cfg
+;; for unification over guest-specific term shapes.
+;;
+;; Adapter cfg keys
+;; ----------------
+;;   :bindings-of  — fn (scope) → DICT
+;;   :parent-of    — fn (scope) → SCOPE-OR-NIL
+;;   :extend       — fn (scope) → SCOPE         (push a fresh child)
+;;   :bind!        — fn (scope name val) → scope (functional or mutable)
+;;   :env?         — fn (v) → bool              (predicate; cheap shape check)
+;;
+;; Public API — canonical shape, mutable, raises on miss
+;;
+;;   (refl-make-env)
+;;   (refl-extend-env PARENT)
+;;   (refl-env? V)
+;;   (refl-env-bind! ENV NAME VAL)
+;;   (refl-env-has? ENV NAME)
+;;   (refl-env-lookup ENV NAME)
+;;   (refl-env-lookup-or-nil ENV NAME)
+;;
+;; Public API — adapter-cfg, any shape
+;;
+;;   (refl-env-extend-with CFG SCOPE)
+;;   (refl-env-bind!-with  CFG SCOPE NAME VAL)
+;;   (refl-env-has?-with   CFG SCOPE NAME)
+;;   (refl-env-lookup-with CFG SCOPE NAME)
+;;   (refl-env-lookup-or-nil-with CFG SCOPE NAME)
+;;   (refl-env-find-frame-with CFG SCOPE NAME)
+;;     — returns the scope in the chain that contains NAME (or nil).
+;;       Consumers needing source-frame mutation use this.
+;;
+;;   (refl-canonical-cfg) — the default cfg, exposed so consumers
+;;                          can compare or extend it.
+
+;; ── Canonical-shape predicates and constructors ─────────────────
+
+(define refl-env? (fn (v) (and (dict? v) (= (get v :refl-tag) :env))))
+
+(define refl-make-env (fn () {:parent nil :refl-tag :env :bindings {}}))
+
+(define refl-extend-env (fn (parent) {:parent parent :refl-tag :env :bindings {}}))
+
+(define
+  refl-env-bind!
+  (fn (env name val) (dict-set! (get env :bindings) name val) env))
+
+(define
+  refl-env-has?
+  (fn
+    (env name)
+    (cond
+      ((nil? env) false)
+      ((not (refl-env? env)) false)
+      ((dict-has? (get env :bindings) name) true)
+      (:else (refl-env-has? (get env :parent) name)))))
+
+(define
+  refl-env-lookup
+  (fn
+    (env name)
+    (cond
+      ((nil? env) (error (str "refl-env-lookup: unbound symbol: " name)))
+      ((not (refl-env? env))
+        (error (str "refl-env-lookup: corrupt env: " env)))
+      ((dict-has? (get env :bindings) name) (get (get env :bindings) name))
+      (:else (refl-env-lookup (get env :parent) name)))))
+
+(define
+  refl-env-lookup-or-nil
+  (fn
+    (env name)
+    (cond
+      ((nil? env) nil)
+      ((not (refl-env? env)) nil)
+      ((dict-has? (get env :bindings) name) (get (get env :bindings) name))
+      (:else (refl-env-lookup-or-nil (get env :parent) name)))))
+
+;; ── Adapter-cfg variants — any wire shape ───────────────────────
+
+(define refl-env-extend-with (fn (cfg scope) ((get cfg :extend) scope)))
+
+(define
+  refl-env-bind!-with
+  (fn (cfg scope name val) ((get cfg :bind!) scope name val)))
+
+(define
+  refl-env-has?-with
+  (fn
+    (cfg scope name)
+    (cond
+      ((nil? scope) false)
+      ((not ((get cfg :env?) scope)) false)
+      ((dict-has? ((get cfg :bindings-of) scope) name) true)
+      (:else (refl-env-has?-with cfg ((get cfg :parent-of) scope) name)))))
+
+(define
+  refl-env-lookup-with
+  (fn
+    (cfg scope name)
+    (cond
+      ((nil? scope) (error (str "refl-env-lookup: unbound symbol: " name)))
+      ((not ((get cfg :env?) scope))
+        (error (str "refl-env-lookup: corrupt scope: " scope)))
+      ((dict-has? ((get cfg :bindings-of) scope) name)
+        (get ((get cfg :bindings-of) scope) name))
+      (:else (refl-env-lookup-with cfg ((get cfg :parent-of) scope) name)))))
+
+(define
+  refl-env-lookup-or-nil-with
+  (fn
+    (cfg scope name)
+    (cond
+      ((nil? scope) nil)
+      ((not ((get cfg :env?) scope)) nil)
+      ((dict-has? ((get cfg :bindings-of) scope) name)
+        (get ((get cfg :bindings-of) scope) name))
+      (:else
+        (refl-env-lookup-or-nil-with cfg ((get cfg :parent-of) scope) name)))))
+
+;; Returns the SCOPE in the chain that contains NAME, or nil if no
+;; scope binds it. Consumers (e.g. Smalltalk) use this to mutate the
+;; binding at its source frame rather than introducing a new shadow
+;; binding at the current frame. Pairs with `refl-env-lookup-with`
+;; for callers that need both the value and the defining scope.
+
+(define refl-env-find-frame-with
+  (fn (cfg scope name)
+    (cond
+      ((nil? scope) nil)
+      ((not ((get cfg :env?) scope)) nil)
+      ((dict-has? ((get cfg :bindings-of) scope) name) scope)
+      (:else
+        (refl-env-find-frame-with cfg ((get cfg :parent-of) scope) name)))))
+
+(define refl-env-find-frame
+  (fn (env name) (refl-env-find-frame-with refl-canonical-cfg env name)))
+
+;; ── Default canonical cfg ───────────────────────────────────────
+;; Exposed so consumers can use it explicitly, compose with it, or
+;; check adapter-correctness against the canonical implementation.
+
+(define refl-canonical-cfg {:bind! (fn (e n v) (refl-env-bind! e n v)) :parent-of (fn (e) (get e :parent)) :env? (fn (v) (refl-env? v)) :bindings-of (fn (e) (get e :bindings)) :extend (fn (e) (refl-extend-env e))})

lib/guest/reflective/quoting.sx

@@ -0,0 +1,77 @@
+;; lib/guest/reflective/quoting.sx — quasiquote walker.
+;;
+;; Extracted from Kernel's `knl-quasi-walk` and Scheme's `scm-quasi-walk`,
+;; which differ only in:
+;;   - the unquote keyword name (Kernel: "$unquote" / "$unquote-splicing";
+;;     Scheme: "unquote" / "unquote-splicing")
+;;   - the host evaluator function (`kernel-eval` vs `scheme-eval`)
+;;
+;; Algorithm is identical. Adapter cfg parameterises the two
+;; language-specific knobs.
+;;
+;; Adapter cfg keys
+;; ----------------
+;;   :unquote-name           — string, name of the unquote keyword
+;;   :unquote-splicing-name  — string, name of the splice keyword
+;;   :eval                   — fn (form env) → value
+;;
+;; Public API
+;;   (refl-quasi-walk-with CFG FORM ENV)
+;;     Top-level walker. Returns FORM with unquotes evaluated in ENV.
+;;
+;;   (refl-quasi-walk-list-with CFG FORMS ENV)
+;;     Walks a list of forms, splicing unquote-splicing results inline.
+;;
+;;   (refl-quasi-list-concat XS YS)
+;;     Pure-SX list append (no host append/append! needed).
+
+(define
+  refl-quasi-list-concat
+  (fn
+    (xs ys)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) ys)
+      (:else (cons (first xs) (refl-quasi-list-concat (rest xs) ys))))))
+
+(define
+  refl-quasi-walk-with
+  (fn
+    (cfg form env)
+    (cond
+      ((not (list? form)) form)
+      ((= (length form) 0) form)
+      ((and (string? (first form)) (= (first form) (get cfg :unquote-name)))
+        (cond
+          ((not (= (length form) 2))
+            (error
+              (str (get cfg :unquote-name) ": expects exactly 1 argument")))
+          (:else ((get cfg :eval) (nth form 1) env))))
+      (:else (refl-quasi-walk-list-with cfg form env)))))
+
+(define
+  refl-quasi-walk-list-with
+  (fn
+    (cfg forms env)
+    (cond
+      ((or (nil? forms) (= (length forms) 0)) (list))
+      (:else
+        (let
+          ((head (first forms)))
+          (cond
+            ((and (list? head) (= (length head) 2) (string? (first head)) (= (first head) (get cfg :unquote-splicing-name)))
+              (let
+                ((spliced ((get cfg :eval) (nth head 1) env)))
+                (cond
+                  ((not (list? spliced))
+                    (error
+                      (str
+                        (get cfg :unquote-splicing-name)
+                        ": value must be a list")))
+                  (:else
+                    (refl-quasi-list-concat
+                      spliced
+                      (refl-quasi-walk-list-with cfg (rest forms) env))))))
+            (:else
+              (cons
+                (refl-quasi-walk-with cfg head env)
+                (refl-quasi-walk-list-with cfg (rest forms) env)))))))))

lib/haskell/conformance.conf

@@ -14,6 +14,8 @@ PRELOADS=(
   lib/haskell/runtime.sx
   lib/haskell/match.sx
   lib/haskell/eval.sx
+  lib/haskell/map.sx
+  lib/haskell/set.sx
   lib/haskell/testlib.sx
 )
 
@@ -36,6 +38,24 @@ SUITES=(
   "matrix:lib/haskell/tests/program-matrix.sx"
   "wordcount:lib/haskell/tests/program-wordcount.sx"
   "powers:lib/haskell/tests/program-powers.sx"
+  "caesar:lib/haskell/tests/program-caesar.sx"
+  "runlength-str:lib/haskell/tests/program-runlength-str.sx"
+  "showadt:lib/haskell/tests/program-showadt.sx"
+  "showio:lib/haskell/tests/program-showio.sx"
+  "partial:lib/haskell/tests/program-partial.sx"
+  "statistics:lib/haskell/tests/program-statistics.sx"
+  "newton:lib/haskell/tests/program-newton.sx"
+  "wordfreq:lib/haskell/tests/program-wordfreq.sx"
+  "mapgraph:lib/haskell/tests/program-mapgraph.sx"
+  "uniquewords:lib/haskell/tests/program-uniquewords.sx"
+  "setops:lib/haskell/tests/program-setops.sx"
+  "shapes:lib/haskell/tests/program-shapes.sx"
+  "person:lib/haskell/tests/program-person.sx"
+  "config:lib/haskell/tests/program-config.sx"
+  "counter:lib/haskell/tests/program-counter.sx"
+  "accumulate:lib/haskell/tests/program-accumulate.sx"
+  "safediv:lib/haskell/tests/program-safediv.sx"
+  "trycatch:lib/haskell/tests/program-trycatch.sx"
 )
 
 emit_scoreboard_json() {

lib/haskell/desugar.sx

@@ -131,119 +131,280 @@
         (let
           ((tag (first node)))
           (cond
-            ;; Transformations
             ((= tag "where")
               (list
-                :let
-                (map hk-desugar (nth node 2))
+                :let (map hk-desugar (nth node 2))
                 (hk-desugar (nth node 1))))
             ((= tag "guarded") (hk-guards-to-if (nth node 1)))
             ((= tag "list-comp")
-              (hk-lc-desugar
-                (hk-desugar (nth node 1))
-                (nth node 2)))
-
-            ;; Expression nodes
+              (hk-lc-desugar (hk-desugar (nth node 1)) (nth node 2)))
             ((= tag "app")
               (list
-                :app
-                (hk-desugar (nth node 1))
+                :app (hk-desugar (nth node 1))
                 (hk-desugar (nth node 2))))
+            ((= tag "p-rec")
+              (let
+                ((cname (nth node 1))
+                  (field-pats (nth node 2))
+                  (field-order (hk-record-field-names cname)))
+                (cond
+                  ((nil? field-order)
+                    (raise (str "p-rec: no record info for " cname)))
+                  (:else
+                    (list
+                      :p-con
+                      cname
+                      (map
+                        (fn
+                          (fname)
+                          (let
+                            ((p (hk-find-rec-pair field-pats fname)))
+                            (cond
+                              ((nil? p) (list :p-wild))
+                              (:else (hk-desugar (nth p 1))))))
+                        field-order))))))
+            ((= tag "rec-update")
+              (list
+                :rec-update
+                (hk-desugar (nth node 1))
+                (map
+                  (fn (p) (list (first p) (hk-desugar (nth p 1))))
+                  (nth node 2))))
+            ((= tag "rec-create")
+              (let
+                ((cname (nth node 1))
+                  (field-pairs (nth node 2))
+                  (field-order (hk-record-field-names cname)))
+                (cond
+                  ((nil? field-order)
+                    (raise (str "rec-create: no record info for " cname)))
+                  (:else
+                    (let
+                      ((acc (list :con cname)))
+                      (begin
+                        (for-each
+                          (fn
+                            (fname)
+                            (let
+                              ((pair
+                                  (hk-find-rec-pair field-pairs fname)))
+                              (cond
+                                ((nil? pair)
+                                  (raise
+                                    (str
+                                      "rec-create: missing field "
+                                      fname
+                                      " for "
+                                      cname)))
+                                (:else
+                                  (set!
+                                    acc
+                                    (list
+                                      :app
+                                      acc
+                                      (hk-desugar (nth pair 1))))))))
+                          field-order)
+                        acc))))))
             ((= tag "op")
               (list
-                :op
-                (nth node 1)
+                :op (nth node 1)
                 (hk-desugar (nth node 2))
                 (hk-desugar (nth node 3))))
             ((= tag "neg") (list :neg (hk-desugar (nth node 1))))
             ((= tag "if")
               (list
-                :if
-                (hk-desugar (nth node 1))
+                :if (hk-desugar (nth node 1))
                 (hk-desugar (nth node 2))
                 (hk-desugar (nth node 3))))
-            ((= tag "tuple")
-              (list :tuple (map hk-desugar (nth node 1))))
-            ((= tag "list")
-              (list :list (map hk-desugar (nth node 1))))
+            ((= tag "tuple") (list :tuple (map hk-desugar (nth node 1))))
+            ((= tag "list") (list :list (map hk-desugar (nth node 1))))
             ((= tag "range")
               (list
-                :range
-                (hk-desugar (nth node 1))
+                :range (hk-desugar (nth node 1))
                 (hk-desugar (nth node 2))))
             ((= tag "range-step")
               (list
-                :range-step
-                (hk-desugar (nth node 1))
+                :range-step (hk-desugar (nth node 1))
                 (hk-desugar (nth node 2))
                 (hk-desugar (nth node 3))))
             ((= tag "lambda")
-              (list
-                :lambda
-                (nth node 1)
-                (hk-desugar (nth node 2))))
+              (list :lambda (nth node 1) (hk-desugar (nth node 2))))
             ((= tag "let")
               (list
-                :let
-                (map hk-desugar (nth node 1))
+                :let (map hk-desugar (nth node 1))
                 (hk-desugar (nth node 2))))
             ((= tag "case")
               (list
-                :case
-                (hk-desugar (nth node 1))
+                :case (hk-desugar (nth node 1))
                 (map hk-desugar (nth node 2))))
             ((= tag "alt")
-              (list :alt (nth node 1) (hk-desugar (nth node 2))))
+              (list :alt (hk-desugar (nth node 1)) (hk-desugar (nth node 2))))
             ((= tag "do") (hk-desugar-do (nth node 1)))
             ((= tag "sect-left")
-              (list
-                :sect-left
-                (nth node 1)
-                (hk-desugar (nth node 2))))
+              (list :sect-left (nth node 1) (hk-desugar (nth node 2))))
             ((= tag "sect-right")
-              (list
-                :sect-right
-                (nth node 1)
-                (hk-desugar (nth node 2))))
-
-            ;; Top-level
+              (list :sect-right (nth node 1) (hk-desugar (nth node 2))))
             ((= tag "program")
-              (list :program (map hk-desugar (nth node 1))))
+              (list :program (map hk-desugar (hk-expand-records (nth node 1)))))
             ((= tag "module")
               (list
-                :module
-                (nth node 1)
+                :module (nth node 1)
                 (nth node 2)
                 (nth node 3)
-                (map hk-desugar (nth node 4))))
-
-            ;; Decls carrying a body
+                (map hk-desugar (hk-expand-records (nth node 4)))))
             ((= tag "fun-clause")
               (list
-                :fun-clause
-                (nth node 1)
-                (nth node 2)
+                :fun-clause (nth node 1)
+                (map hk-desugar (nth node 2))
                 (hk-desugar (nth node 3))))
+            ((= tag "instance-decl")
+              (list
+                :instance-decl (nth node 1)
+                (nth node 2)
+                (map hk-desugar (nth node 3))))
             ((= tag "pat-bind")
-              (list
-                :pat-bind
-                (nth node 1)
-                (hk-desugar (nth node 2))))
+              (list :pat-bind (nth node 1) (hk-desugar (nth node 2))))
             ((= tag "bind")
-              (list
-                :bind
-                (nth node 1)
-                (hk-desugar (nth node 2))))
-
-            ;; Everything else: leaf literals, vars, cons, patterns,
-            ;; types, imports, type-sigs, data / newtype / fixity, …
+              (list :bind (nth node 1) (hk-desugar (nth node 2))))
             (:else node)))))))
 
 ;; Convenience — tokenize + layout + parse + desugar.
-(define
-  hk-core
-  (fn (src) (hk-desugar (hk-parse-top src))))
+(define hk-record-fields (dict))
 
 (define
-  hk-core-expr
-  (fn (src) (hk-desugar (hk-parse src))))
+  hk-register-record-fields!
+  (fn (cname fields) (dict-set! hk-record-fields cname fields)))
+
+(define
+  hk-record-field-names
+  (fn
+    (cname)
+    (if (has-key? hk-record-fields cname) (get hk-record-fields cname) nil)))
+
+(define
+  hk-record-field-index
+  (fn
+    (cname fname)
+    (let
+      ((fields (hk-record-field-names cname)))
+      (cond
+        ((nil? fields) -1)
+        (:else
+          (let
+            ((i 0) (idx -1))
+            (begin
+              (for-each
+                (fn
+                  (f)
+                  (begin (when (= f fname) (set! idx i)) (set! i (+ i 1))))
+                fields)
+              idx)))))))
+
+(define
+  hk-find-rec-pair
+  (fn
+    (pairs name)
+    (cond
+      ((empty? pairs) nil)
+      ((= (first (first pairs)) name) (first pairs))
+      (:else (hk-find-rec-pair (rest pairs) name)))))
+
+(define
+  hk-record-accessors
+  (fn
+    (cname rec-fields)
+    (let
+      ((n (len rec-fields)) (i 0) (out (list)))
+      (define
+        hk-ra-loop
+        (fn
+          ()
+          (when
+            (< i n)
+            (let
+              ((field (nth rec-fields i)))
+              (let
+                ((fname (first field)) (j 0) (pats (list)))
+                (define
+                  hk-pat-loop
+                  (fn
+                    ()
+                    (when
+                      (< j n)
+                      (begin
+                        (append!
+                          pats
+                          (if
+                            (= j i)
+                            (list "p-var" "__rec_field")
+                            (list "p-wild")))
+                        (set! j (+ j 1))
+                        (hk-pat-loop)))))
+                (hk-pat-loop)
+                (append!
+                  out
+                  (list
+                    "fun-clause"
+                    fname
+                    (list (list "p-con" cname pats))
+                    (list "var" "__rec_field")))
+                (set! i (+ i 1))
+                (hk-ra-loop))))))
+      (hk-ra-loop)
+      out)))
+
+(define
+  hk-expand-records
+  (fn
+    (decls)
+    (let
+      ((out (list)))
+      (for-each
+        (fn
+          (d)
+          (cond
+            ((and (list? d) (= (first d) "data"))
+              (let
+                ((dname (nth d 1))
+                  (tvars (nth d 2))
+                  (cons-list (nth d 3))
+                  (deriving (if (> (len d) 4) (nth d 4) (list)))
+                  (new-cons (list))
+                  (accessors (list)))
+                (begin
+                  (for-each
+                    (fn
+                      (c)
+                      (cond
+                        ((= (first c) "con-rec")
+                          (let
+                            ((cname (nth c 1)) (rec-fields (nth c 2)))
+                            (begin
+                              (hk-register-record-fields!
+                                cname
+                                (map (fn (f) (first f)) rec-fields))
+                              (append!
+                                new-cons
+                                (list
+                                  "con-def"
+                                  cname
+                                  (map (fn (f) (nth f 1)) rec-fields)))
+                              (for-each
+                                (fn (a) (append! accessors a))
+                                (hk-record-accessors cname rec-fields)))))
+                        (:else (append! new-cons c))))
+                    cons-list)
+                  (append!
+                    out
+                    (if
+                      (empty? deriving)
+                      (list "data" dname tvars new-cons)
+                      (list "data" dname tvars new-cons deriving)))
+                  (for-each (fn (a) (append! out a)) accessors))))
+            (:else (append! out d))))
+        decls)
+      out)))
+
+(define hk-core (fn (src) (hk-desugar (hk-parse-top src))))
+
+(define hk-core-expr (fn (src) (hk-desugar (hk-parse src))))

lib/haskell/map.sx

@@ -0,0 +1,520 @@
+;; map.sx — Phase 11 Data.Map: weight-balanced BST in pure SX.
+;;
+;; Algorithm: Adams's weight-balanced tree (the same family as Haskell's
+;; Data.Map). Each node tracks its size; rotations maintain the invariant
+;;
+;;     size(small-side) * delta >= size(large-side)        (delta = 3)
+;;
+;; with single or double rotations chosen by the gamma ratio (gamma = 2).
+;; The size field is an Int and is included so `size`, `lookup`, etc. are
+;; O(log n) on both extremes of the tree.
+;;
+;; Representation:
+;;   Empty → ("Map-Empty")
+;;   Node  → ("Map-Node" key val left right size)
+;;
+;; All operations are pure SX — no mutation of nodes once constructed.
+;; The user-facing Haskell layer (Phase 11 next iteration) wraps these
+;; for `import Data.Map as Map`.
+
+;; ── Constructors ────────────────────────────────────────────
+(define hk-map-empty (list "Map-Empty"))
+
+(define
+  hk-map-node
+  (fn
+    (k v l r)
+    (list "Map-Node" k v l r (+ 1 (+ (hk-map-size l) (hk-map-size r))))))
+
+;; ── Predicates and accessors ────────────────────────────────
+(define hk-map-empty? (fn (m) (and (list? m) (= (first m) "Map-Empty"))))
+
+(define hk-map-node? (fn (m) (and (list? m) (= (first m) "Map-Node"))))
+
+(define
+  hk-map-size
+  (fn (m) (cond ((hk-map-empty? m) 0) (:else (nth m 5)))))
+
+(define hk-map-key (fn (m) (nth m 1)))
+(define hk-map-val (fn (m) (nth m 2)))
+(define hk-map-left (fn (m) (nth m 3)))
+(define hk-map-right (fn (m) (nth m 4)))
+
+;; ── Weight-balanced rotations ───────────────────────────────
+;; delta and gamma per Adams 1992 / Haskell Data.Map.
+
+(define hk-map-delta 3)
+(define hk-map-gamma 2)
+
+(define
+  hk-map-single-l
+  (fn
+    (k v l r)
+    (let
+      ((rk (hk-map-key r))
+        (rv (hk-map-val r))
+        (rl (hk-map-left r))
+        (rr (hk-map-right r)))
+      (hk-map-node rk rv (hk-map-node k v l rl) rr))))
+
+(define
+  hk-map-single-r
+  (fn
+    (k v l r)
+    (let
+      ((lk (hk-map-key l))
+        (lv (hk-map-val l))
+        (ll (hk-map-left l))
+        (lr (hk-map-right l)))
+      (hk-map-node lk lv ll (hk-map-node k v lr r)))))
+
+(define
+  hk-map-double-l
+  (fn
+    (k v l r)
+    (let
+      ((rk (hk-map-key r))
+        (rv (hk-map-val r))
+        (rl (hk-map-left r))
+        (rr (hk-map-right r))
+        (rlk (hk-map-key (hk-map-left r)))
+        (rlv (hk-map-val (hk-map-left r)))
+        (rll (hk-map-left (hk-map-left r)))
+        (rlr (hk-map-right (hk-map-left r))))
+      (hk-map-node
+        rlk
+        rlv
+        (hk-map-node k v l rll)
+        (hk-map-node rk rv rlr rr)))))
+
+(define
+  hk-map-double-r
+  (fn
+    (k v l r)
+    (let
+      ((lk (hk-map-key l))
+        (lv (hk-map-val l))
+        (ll (hk-map-left l))
+        (lr (hk-map-right l))
+        (lrk (hk-map-key (hk-map-right l)))
+        (lrv (hk-map-val (hk-map-right l)))
+        (lrl (hk-map-left (hk-map-right l)))
+        (lrr (hk-map-right (hk-map-right l))))
+      (hk-map-node
+        lrk
+        lrv
+        (hk-map-node lk lv ll lrl)
+        (hk-map-node k v lrr r)))))
+
+;; ── Balanced node constructor ──────────────────────────────
+;; Use this in place of hk-map-node when one side may have grown
+;; or shrunk by one and we need to restore the weight invariant.
+(define
+  hk-map-balance
+  (fn
+    (k v l r)
+    (let
+      ((sl (hk-map-size l)) (sr (hk-map-size r)))
+      (cond
+        ((<= (+ sl sr) 1) (hk-map-node k v l r))
+        ((> sr (* hk-map-delta sl))
+          (let
+            ((rl (hk-map-left r)) (rr (hk-map-right r)))
+            (cond
+              ((< (hk-map-size rl) (* hk-map-gamma (hk-map-size rr)))
+                (hk-map-single-l k v l r))
+              (:else (hk-map-double-l k v l r)))))
+        ((> sl (* hk-map-delta sr))
+          (let
+            ((ll (hk-map-left l)) (lr (hk-map-right l)))
+            (cond
+              ((< (hk-map-size lr) (* hk-map-gamma (hk-map-size ll)))
+                (hk-map-single-r k v l r))
+              (:else (hk-map-double-r k v l r)))))
+        (:else (hk-map-node k v l r))))))
+
+(define
+  hk-map-singleton
+  (fn (k v) (hk-map-node k v hk-map-empty hk-map-empty)))
+
+(define
+  hk-map-insert
+  (fn
+    (k v m)
+    (cond
+      ((hk-map-empty? m) (hk-map-singleton k v))
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-insert k v (hk-map-left m))
+                (hk-map-right m)))
+            ((> k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-left m)
+                (hk-map-insert k v (hk-map-right m))))
+            (:else (hk-map-node k v (hk-map-left m) (hk-map-right m)))))))))
+
+(define
+  hk-map-lookup
+  (fn
+    (k m)
+    (cond
+      ((hk-map-empty? m) (list "Nothing"))
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk) (hk-map-lookup k (hk-map-left m)))
+            ((> k mk) (hk-map-lookup k (hk-map-right m)))
+            (:else (list "Just" (hk-map-val m)))))))))
+
+(define
+  hk-map-member
+  (fn
+    (k m)
+    (cond
+      ((hk-map-empty? m) false)
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk) (hk-map-member k (hk-map-left m)))
+            ((> k mk) (hk-map-member k (hk-map-right m)))
+            (:else true)))))))
+
+(define hk-map-null hk-map-empty?)
+
+(define
+  hk-map-find-min
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? (hk-map-left m))
+        (list (hk-map-key m) (hk-map-val m)))
+      (:else (hk-map-find-min (hk-map-left m))))))
+
+(define
+  hk-map-delete-min
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? (hk-map-left m)) (hk-map-right m))
+      (:else
+        (hk-map-balance
+          (hk-map-key m)
+          (hk-map-val m)
+          (hk-map-delete-min (hk-map-left m))
+          (hk-map-right m))))))
+
+(define
+  hk-map-find-max
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? (hk-map-right m))
+        (list (hk-map-key m) (hk-map-val m)))
+      (:else (hk-map-find-max (hk-map-right m))))))
+
+(define
+  hk-map-delete-max
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? (hk-map-right m)) (hk-map-left m))
+      (:else
+        (hk-map-balance
+          (hk-map-key m)
+          (hk-map-val m)
+          (hk-map-left m)
+          (hk-map-delete-max (hk-map-right m)))))))
+
+(define
+  hk-map-glue
+  (fn
+    (l r)
+    (cond
+      ((hk-map-empty? l) r)
+      ((hk-map-empty? r) l)
+      ((> (hk-map-size l) (hk-map-size r))
+        (let
+          ((mp (hk-map-find-max l)))
+          (hk-map-balance (first mp) (nth mp 1) (hk-map-delete-max l) r)))
+      (:else
+        (let
+          ((mp (hk-map-find-min r)))
+          (hk-map-balance (first mp) (nth mp 1) l (hk-map-delete-min r)))))))
+
+(define
+  hk-map-delete
+  (fn
+    (k m)
+    (cond
+      ((hk-map-empty? m) m)
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-delete k (hk-map-left m))
+                (hk-map-right m)))
+            ((> k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-left m)
+                (hk-map-delete k (hk-map-right m))))
+            (:else (hk-map-glue (hk-map-left m) (hk-map-right m)))))))))
+
+(define
+  hk-map-from-list
+  (fn
+    (pairs)
+    (reduce
+      (fn (acc p) (hk-map-insert (first p) (nth p 1) acc))
+      hk-map-empty
+      pairs)))
+
+(define
+  hk-map-to-asc-list
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? m) (list))
+      (:else
+        (append
+          (hk-map-to-asc-list (hk-map-left m))
+          (cons
+            (list (hk-map-key m) (hk-map-val m))
+            (hk-map-to-asc-list (hk-map-right m))))))))
+
+(define hk-map-to-list hk-map-to-asc-list)
+
+(define
+  hk-map-keys
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? m) (list))
+      (:else
+        (append
+          (hk-map-keys (hk-map-left m))
+          (cons (hk-map-key m) (hk-map-keys (hk-map-right m))))))))
+
+(define
+  hk-map-elems
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? m) (list))
+      (:else
+        (append
+          (hk-map-elems (hk-map-left m))
+          (cons (hk-map-val m) (hk-map-elems (hk-map-right m))))))))
+
+(define
+  hk-map-union-with
+  (fn
+    (f m1 m2)
+    (reduce
+      (fn
+        (acc p)
+        (let
+          ((k (first p)) (v (nth p 1)))
+          (let
+            ((look (hk-map-lookup k acc)))
+            (cond
+              ((= (first look) "Just")
+                (hk-map-insert k (f (nth look 1) v) acc))
+              (:else (hk-map-insert k v acc))))))
+      m1
+      (hk-map-to-asc-list m2))))
+
+(define
+  hk-map-intersection-with
+  (fn
+    (f m1 m2)
+    (reduce
+      (fn
+        (acc p)
+        (let
+          ((k (first p)) (v1 (nth p 1)))
+          (let
+            ((look (hk-map-lookup k m2)))
+            (cond
+              ((= (first look) "Just")
+                (hk-map-insert k (f v1 (nth look 1)) acc))
+              (:else acc)))))
+      hk-map-empty
+      (hk-map-to-asc-list m1))))
+
+(define
+  hk-map-difference
+  (fn
+    (m1 m2)
+    (reduce
+      (fn
+        (acc p)
+        (let
+          ((k (first p)) (v (nth p 1)))
+          (cond ((hk-map-member k m2) acc) (:else (hk-map-insert k v acc)))))
+      hk-map-empty
+      (hk-map-to-asc-list m1))))
+
+(define
+  hk-map-foldl-with-key
+  (fn
+    (f acc m)
+    (cond
+      ((hk-map-empty? m) acc)
+      (:else
+        (let
+          ((acc1 (hk-map-foldl-with-key f acc (hk-map-left m))))
+          (let
+            ((acc2 (f acc1 (hk-map-key m) (hk-map-val m))))
+            (hk-map-foldl-with-key f acc2 (hk-map-right m))))))))
+
+(define
+  hk-map-foldr-with-key
+  (fn
+    (f acc m)
+    (cond
+      ((hk-map-empty? m) acc)
+      (:else
+        (let
+          ((acc1 (hk-map-foldr-with-key f acc (hk-map-right m))))
+          (let
+            ((acc2 (f (hk-map-key m) (hk-map-val m) acc1)))
+            (hk-map-foldr-with-key f acc2 (hk-map-left m))))))))
+
+(define
+  hk-map-map-with-key
+  (fn
+    (f m)
+    (cond
+      ((hk-map-empty? m) m)
+      (:else
+        (list
+          "Map-Node"
+          (hk-map-key m)
+          (f (hk-map-key m) (hk-map-val m))
+          (hk-map-map-with-key f (hk-map-left m))
+          (hk-map-map-with-key f (hk-map-right m))
+          (hk-map-size m))))))
+
+(define
+  hk-map-filter-with-key
+  (fn
+    (p m)
+    (hk-map-foldr-with-key
+      (fn (k v acc) (cond ((p k v) (hk-map-insert k v acc)) (:else acc)))
+      hk-map-empty
+      m)))
+
+(define
+  hk-map-adjust
+  (fn
+    (f k m)
+    (cond
+      ((hk-map-empty? m) m)
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk)
+              (hk-map-node
+                mk
+                (hk-map-val m)
+                (hk-map-adjust f k (hk-map-left m))
+                (hk-map-right m)))
+            ((> k mk)
+              (hk-map-node
+                mk
+                (hk-map-val m)
+                (hk-map-left m)
+                (hk-map-adjust f k (hk-map-right m))))
+            (:else
+              (hk-map-node
+                mk
+                (f (hk-map-val m))
+                (hk-map-left m)
+                (hk-map-right m)))))))))
+
+(define
+  hk-map-insert-with
+  (fn
+    (f k v m)
+    (cond
+      ((hk-map-empty? m) (hk-map-singleton k v))
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-insert-with f k v (hk-map-left m))
+                (hk-map-right m)))
+            ((> k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-left m)
+                (hk-map-insert-with f k v (hk-map-right m))))
+            (:else
+              (hk-map-node
+                mk
+                (f v (hk-map-val m))
+                (hk-map-left m)
+                (hk-map-right m)))))))))
+
+(define
+  hk-map-insert-with-key
+  (fn
+    (f k v m)
+    (cond
+      ((hk-map-empty? m) (hk-map-singleton k v))
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-insert-with-key f k v (hk-map-left m))
+                (hk-map-right m)))
+            ((> k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-left m)
+                (hk-map-insert-with-key f k v (hk-map-right m))))
+            (:else
+              (hk-map-node
+                mk
+                (f k v (hk-map-val m))
+                (hk-map-left m)
+                (hk-map-right m)))))))))
+
+(define
+  hk-map-alter
+  (fn
+    (f k m)
+    (let
+      ((look (hk-map-lookup k m)))
+      (let
+        ((res (f look)))
+        (cond
+          ((= (first res) "Nothing") (hk-map-delete k m))
+          (:else (hk-map-insert k (nth res 1) m)))))))

lib/haskell/match.sx

@@ -87,45 +87,41 @@
                   ((nil? res) nil)
                   (:else (assoc res (nth pat 1) val)))))
             (:else
-              (let ((fv (hk-force val)))
+              (let
+                ((fv (hk-force val)))
                 (cond
                   ((= tag "p-int")
-                    (if
-                      (and (number? fv) (= fv (nth pat 1)))
-                      env
-                      nil))
+                    (if (and (number? fv) (= fv (nth pat 1))) env nil))
                   ((= tag "p-float")
-                    (if
-                      (and (number? fv) (= fv (nth pat 1)))
-                      env
-                      nil))
+                    (if (and (number? fv) (= fv (nth pat 1))) env nil))
                   ((= tag "p-string")
-                    (if
-                      (and (string? fv) (= fv (nth pat 1)))
-                      env
-                      nil))
+                    (if (and (string? fv) (= fv (nth pat 1))) env nil))
                   ((= tag "p-char")
-                    (if
-                      (and (string? fv) (= fv (nth pat 1)))
-                      env
-                      nil))
+                    (if (and (string? fv) (= fv (nth pat 1))) env nil))
                   ((= tag "p-con")
                     (let
                       ((pat-name (nth pat 1)) (pat-args (nth pat 2)))
                       (cond
+                        ((and (= pat-name ":") (hk-str? fv) (not (hk-str-null? fv)))
+                          (let
+                            ((str-head (hk-str-head fv))
+                              (str-tail (hk-str-tail fv)))
+                            (let
+                              ((head-pat (nth pat-args 0))
+                                (tail-pat (nth pat-args 1)))
+                              (let
+                                ((res (hk-match head-pat str-head env)))
+                                (cond
+                                  ((nil? res) nil)
+                                  (:else (hk-match tail-pat str-tail res)))))))
                         ((not (hk-is-con-val? fv)) nil)
                         ((not (= (hk-val-con-name fv) pat-name)) nil)
                         (:else
                           (let
                             ((val-args (hk-val-con-args fv)))
                             (cond
-                              ((not (= (len pat-args) (len val-args)))
-                                nil)
-                              (:else
-                                (hk-match-all
-                                  pat-args
-                                  val-args
-                                  env))))))))
+                              ((not (= (len val-args) (len pat-args))) nil)
+                              (:else (hk-match-all pat-args val-args env))))))))
                   ((= tag "p-tuple")
                     (let
                       ((items (nth pat 1)))
@@ -134,13 +130,8 @@
                         ((not (= (hk-val-con-name fv) "Tuple")) nil)
                         ((not (= (len (hk-val-con-args fv)) (len items)))
                           nil)
-                        (:else
-                          (hk-match-all
-                            items
-                            (hk-val-con-args fv)
-                            env)))))
-                  ((= tag "p-list")
-                    (hk-match-list-pat (nth pat 1) fv env))
+                        (:else (hk-match-all items (hk-val-con-args fv) env)))))
+                  ((= tag "p-list") (hk-match-list-pat (nth pat 1) fv env))
                   (:else nil))))))))))
 
 (define
@@ -161,17 +152,26 @@
   hk-match-list-pat
   (fn
     (items val env)
-    (let ((fv (hk-force val)))
+    (let
+      ((fv (hk-force val)))
       (cond
         ((empty? items)
           (if
-            (and
-              (hk-is-con-val? fv)
-              (= (hk-val-con-name fv) "[]"))
+            (or
+              (and (hk-is-con-val? fv) (= (hk-val-con-name fv) "[]"))
+              (and (hk-str? fv) (hk-str-null? fv)))
             env
             nil))
         (:else
           (cond
+            ((and (hk-str? fv) (not (hk-str-null? fv)))
+              (let
+                ((h (hk-str-head fv)) (t (hk-str-tail fv)))
+                (let
+                  ((res (hk-match (first items) h env)))
+                  (cond
+                    ((nil? res) nil)
+                    (:else (hk-match-list-pat (rest items) t res))))))
             ((not (hk-is-con-val? fv)) nil)
             ((not (= (hk-val-con-name fv) ":")) nil)
             (:else
@@ -183,11 +183,7 @@
                     ((res (hk-match (first items) h env)))
                     (cond
                       ((nil? res) nil)
-                      (:else
-                        (hk-match-list-pat
-                          (rest items)
-                          t
-                          res)))))))))))))
+                      (:else (hk-match-list-pat (rest items) t res)))))))))))))
 
 ;; ── Convenience: parse a pattern from source for tests ─────
 ;; (Uses the parser's case-alt entry — `case _ of pat -> 0` —

lib/haskell/parser.sx

@@ -208,9 +208,19 @@
               ((= (get t "type") "char")
                 (do (hk-advance!) (list :char (get t "value"))))
               ((= (get t "type") "varid")
-                (do (hk-advance!) (list :var (get t "value"))))
+                (do
+                  (hk-advance!)
+                  (cond
+                    ((hk-match? "lbrace" nil)
+                      (hk-parse-rec-update (list :var (get t "value"))))
+                    (:else (list :var (get t "value"))))))
               ((= (get t "type") "conid")
-                (do (hk-advance!) (list :con (get t "value"))))
+                (do
+                  (hk-advance!)
+                  (cond
+                    ((hk-match? "lbrace" nil)
+                      (hk-parse-rec-create (get t "value")))
+                    (:else (list :con (get t "value"))))))
               ((= (get t "type") "qvarid")
                 (do (hk-advance!) (list :var (get t "value"))))
               ((= (get t "type") "qconid")
@@ -456,6 +466,90 @@
                     (do
                       (hk-expect! "rbracket" nil)
                       (list :list (list first-e))))))))))
+      (define
+        hk-parse-rec-create
+        (fn
+          (cname)
+          (begin
+            (hk-expect! "lbrace" nil)
+            (let
+              ((fields (list)))
+              (define
+                hk-rc-loop
+                (fn
+                  ()
+                  (when
+                    (hk-match? "varid" nil)
+                    (let
+                      ((fname (get (hk-advance!) "value")))
+                      (begin
+                        (hk-expect! "reservedop" "=")
+                        (let
+                          ((fexpr (hk-parse-expr-inner)))
+                          (begin
+                            (append! fields (list fname fexpr))
+                            (when
+                              (hk-match? "comma" nil)
+                              (begin (hk-advance!) (hk-rc-loop))))))))))
+              (hk-rc-loop)
+              (hk-expect! "rbrace" nil)
+              (list :rec-create cname fields)))))
+      (define
+        hk-parse-rec-update
+        (fn
+          (rec-expr)
+          (begin
+            (hk-expect! "lbrace" nil)
+            (let
+              ((fields (list)))
+              (define
+                hk-ru-loop
+                (fn
+                  ()
+                  (when
+                    (hk-match? "varid" nil)
+                    (let
+                      ((fname (get (hk-advance!) "value")))
+                      (begin
+                        (hk-expect! "reservedop" "=")
+                        (let
+                          ((fexpr (hk-parse-expr-inner)))
+                          (begin
+                            (append! fields (list fname fexpr))
+                            (when
+                              (hk-match? "comma" nil)
+                              (begin (hk-advance!) (hk-ru-loop))))))))))
+              (hk-ru-loop)
+              (hk-expect! "rbrace" nil)
+              (list :rec-update rec-expr fields)))))
+      (define
+        hk-parse-rec-pat
+        (fn
+          (cname)
+          (begin
+            (hk-expect! "lbrace" nil)
+            (let
+              ((field-pats (list)))
+              (define
+                hk-rp-loop
+                (fn
+                  ()
+                  (when
+                    (hk-match? "varid" nil)
+                    (let
+                      ((fname (get (hk-advance!) "value")))
+                      (begin
+                        (hk-expect! "reservedop" "=")
+                        (let
+                          ((fpat (hk-parse-pat)))
+                          (begin
+                            (append! field-pats (list fname fpat))
+                            (when
+                              (hk-match? "comma" nil)
+                              (begin (hk-advance!) (hk-rp-loop))))))))))
+              (hk-rp-loop)
+              (hk-expect! "rbrace" nil)
+              (list :p-rec cname field-pats)))))
       (define
         hk-parse-fexp
         (fn
@@ -696,7 +790,12 @@
                     (:else
                       (do (hk-advance!) (list :p-var (get t "value")))))))
               ((= (get t "type") "conid")
-                (do (hk-advance!) (list :p-con (get t "value") (list))))
+                (do
+                  (hk-advance!)
+                  (cond
+                    ((hk-match? "lbrace" nil)
+                      (hk-parse-rec-pat (get t "value")))
+                    (:else (list :p-con (get t "value") (list))))))
               ((= (get t "type") "qconid")
                 (do (hk-advance!) (list :p-con (get t "value") (list))))
               ((= (get t "type") "lparen") (hk-parse-paren-pat))
@@ -762,16 +861,24 @@
             (cond
               ((and (not (nil? t)) (or (= (get t "type") "conid") (= (get t "type") "qconid")))
                 (let
-                  ((name (get (hk-advance!) "value")) (args (list)))
-                  (define
-                    hk-pca-loop
-                    (fn
-                      ()
-                      (when
-                        (hk-apat-start? (hk-peek))
-                        (do (append! args (hk-parse-apat)) (hk-pca-loop)))))
-                  (hk-pca-loop)
-                  (list :p-con name args)))
+                  ((name (get (hk-advance!) "value")))
+                  (cond
+                    ((hk-match? "lbrace" nil)
+                      (hk-parse-rec-pat name))
+                    (:else
+                      (let
+                        ((args (list)))
+                        (define
+                          hk-pca-loop
+                          (fn
+                            ()
+                            (when
+                              (hk-apat-start? (hk-peek))
+                              (do
+                                (append! args (hk-parse-apat))
+                                (hk-pca-loop)))))
+                        (hk-pca-loop)
+                        (list :p-con name args))))))
               (:else (hk-parse-apat))))))
       (define
         hk-parse-pat
@@ -1212,16 +1319,47 @@
             (not (hk-match? "conid" nil))
             (hk-err "expected constructor name"))
           (let
-            ((name (get (hk-advance!) "value")) (fields (list)))
-            (define
-              hk-cd-loop
-              (fn
-                ()
-                (when
-                  (hk-atype-start? (hk-peek))
-                  (do (append! fields (hk-parse-atype)) (hk-cd-loop)))))
-            (hk-cd-loop)
-            (list :con-def name fields))))
+            ((name (get (hk-advance!) "value")))
+            (cond
+              ((hk-match? "lbrace" nil)
+                (begin
+                  (hk-advance!)
+                  (let
+                    ((rec-fields (list)))
+                    (define
+                      hk-rec-loop
+                      (fn
+                        ()
+                        (when
+                          (hk-match? "varid" nil)
+                          (let
+                            ((fname (get (hk-advance!) "value")))
+                            (begin
+                              (hk-expect! "reservedop" "::")
+                              (let
+                                ((ftype (hk-parse-type)))
+                                (begin
+                                  (append! rec-fields (list fname ftype))
+                                  (when
+                                    (hk-match? "comma" nil)
+                                    (begin (hk-advance!) (hk-rec-loop))))))))))
+                    (hk-rec-loop)
+                    (hk-expect! "rbrace" nil)
+                    (list :con-rec name rec-fields))))
+              (:else
+                (let
+                  ((fields (list)))
+                  (define
+                    hk-cd-loop
+                    (fn
+                      ()
+                      (when
+                        (hk-atype-start? (hk-peek))
+                        (begin
+                          (append! fields (hk-parse-atype))
+                          (hk-cd-loop)))))
+                  (hk-cd-loop)
+                  (list :con-def name fields)))))))
       (define
         hk-parse-tvars
         (fn

lib/haskell/runtime.sx

@@ -12,12 +12,7 @@
 
 (define
   hk-register-con!
-  (fn
-    (cname arity type-name)
-    (dict-set!
-      hk-constructors
-      cname
-      {:arity arity :type type-name})))
+  (fn (cname arity type-name) (dict-set! hk-constructors cname {:arity arity :type type-name})))
 
 (define hk-is-con? (fn (name) (has-key? hk-constructors name)))
 
@@ -48,26 +43,15 @@
   (fn
     (data-node)
     (let
-      ((type-name (nth data-node 1))
-        (cons-list (nth data-node 3)))
+      ((type-name (nth data-node 1)) (cons-list (nth data-node 3)))
       (for-each
-        (fn
-          (cd)
-          (hk-register-con!
-            (nth cd 1)
-            (len (nth cd 2))
-            type-name))
+        (fn (cd) (hk-register-con! (nth cd 1) (len (nth cd 2)) type-name))
         cons-list))))
 
 ;; (:newtype NAME TVARS CNAME FIELD)
 (define
   hk-register-newtype!
-  (fn
-    (nt-node)
-    (hk-register-con!
-      (nth nt-node 3)
-      1
-      (nth nt-node 1))))
+  (fn (nt-node) (hk-register-con! (nth nt-node 3) 1 (nth nt-node 1))))
 
 ;; Walk a decls list, registering every `data` / `newtype` decl.
 (define
@@ -78,15 +62,9 @@
       (fn
         (d)
         (cond
-          ((and
-              (list? d)
-              (not (empty? d))
-              (= (first d) "data"))
+          ((and (list? d) (not (empty? d)) (= (first d) "data"))
             (hk-register-data! d))
-          ((and
-              (list? d)
-              (not (empty? d))
-              (= (first d) "newtype"))
+          ((and (list? d) (not (empty? d)) (= (first d) "newtype"))
             (hk-register-newtype! d))
           (:else nil)))
       decls)))
@@ -99,16 +77,12 @@
       ((nil? ast) nil)
       ((not (list? ast)) nil)
       ((empty? ast) nil)
-      ((= (first ast) "program")
-        (hk-register-decls! (nth ast 1)))
-      ((= (first ast) "module")
-        (hk-register-decls! (nth ast 4)))
+      ((= (first ast) "program") (hk-register-decls! (nth ast 1)))
+      ((= (first ast) "module") (hk-register-decls! (nth ast 4)))
       (:else nil))))
 
 ;; Convenience: source → AST → desugar → register.
-(define
-  hk-load-source!
-  (fn (src) (hk-register-program! (hk-core src))))
+(define hk-load-source! (fn (src) (hk-register-program! (hk-core src))))
 
 ;; ── Built-in constructors pre-registered ─────────────────────
 ;; Bool — used implicitly by `if`, comparison operators.
@@ -122,9 +96,55 @@
 ;; Standard Prelude types — pre-registered so expression-level
 ;; programs can use them without a `data` decl.
 (hk-register-con! "Nothing" 0 "Maybe")
-(hk-register-con! "Just"    1 "Maybe")
-(hk-register-con! "Left"    1 "Either")
-(hk-register-con! "Right"   1 "Either")
+(hk-register-con! "Just" 1 "Maybe")
+(hk-register-con! "Left" 1 "Either")
+(hk-register-con! "Right" 1 "Either")
 (hk-register-con! "LT" 0 "Ordering")
 (hk-register-con! "EQ" 0 "Ordering")
 (hk-register-con! "GT" 0 "Ordering")
+(hk-register-con! "SomeException" 1 "SomeException")
+
+(define
+  hk-str?
+  (fn (v) (or (string? v) (and (dict? v) (has-key? v "hk-str")))))
+
+(define
+  hk-str-head
+  (fn
+    (v)
+    (if
+      (string? v)
+      (char-code (char-at v 0))
+      (char-code (char-at (get v "hk-str") (get v "hk-off"))))))
+
+(define
+  hk-str-tail
+  (fn
+    (v)
+    (let
+      ((buf (if (string? v) v (get v "hk-str")))
+        (off (if (string? v) 1 (+ (get v "hk-off") 1))))
+      (if (>= off (string-length buf)) (list "[]") {:hk-off off :hk-str buf}))))
+
+(define
+  hk-str-null?
+  (fn
+    (v)
+    (if
+      (string? v)
+      (= (string-length v) 0)
+      (>= (get v "hk-off") (string-length (get v "hk-str"))))))
+
+(define
+  hk-str-to-native
+  (fn
+    (v)
+    (if
+      (string? v)
+      v
+      (let
+        ((buf (get v "hk-str")) (off (get v "hk-off")))
+        (reduce
+          (fn (acc i) (str acc (char-at buf i)))
+          ""
+          (range off (string-length buf)))))))

lib/haskell/scoreboard.json

@@ -1,6 +1,6 @@
 {
-  "date": "2026-05-06",
-  "total_pass": 156,
+  "date": "2026-05-08",
+  "total_pass": 285,
   "total_fail": 0,
   "programs": {
     "fib": {"pass": 2, "fail": 0},
@@ -9,7 +9,7 @@
     "nqueens": {"pass": 2, "fail": 0},
     "calculator": {"pass": 5, "fail": 0},
     "collatz": {"pass": 11, "fail": 0},
-    "palindrome": {"pass": 8, "fail": 0},
+    "palindrome": {"pass": 12, "fail": 0},
     "maybe": {"pass": 12, "fail": 0},
     "fizzbuzz": {"pass": 12, "fail": 0},
     "anagram": {"pass": 9, "fail": 0},
@@ -19,7 +19,25 @@
     "primes": {"pass": 12, "fail": 0},
     "zipwith": {"pass": 9, "fail": 0},
     "matrix": {"pass": 8, "fail": 0},
-    "wordcount": {"pass": 7, "fail": 0},
-    "powers": {"pass": 14, "fail": 0}
+    "wordcount": {"pass": 10, "fail": 0},
+    "powers": {"pass": 14, "fail": 0},
+    "caesar": {"pass": 8, "fail": 0},
+    "runlength-str": {"pass": 9, "fail": 0},
+    "showadt": {"pass": 5, "fail": 0},
+    "showio": {"pass": 5, "fail": 0},
+    "partial": {"pass": 7, "fail": 0},
+    "statistics": {"pass": 5, "fail": 0},
+    "newton": {"pass": 5, "fail": 0},
+    "wordfreq": {"pass": 7, "fail": 0},
+    "mapgraph": {"pass": 6, "fail": 0},
+    "uniquewords": {"pass": 4, "fail": 0},
+    "setops": {"pass": 8, "fail": 0},
+    "shapes": {"pass": 5, "fail": 0},
+    "person": {"pass": 7, "fail": 0},
+    "config": {"pass": 10, "fail": 0},
+    "counter": {"pass": 7, "fail": 0},
+    "accumulate": {"pass": 8, "fail": 0},
+    "safediv": {"pass": 8, "fail": 0},
+    "trycatch": {"pass": 8, "fail": 0}
   }
 }

lib/haskell/scoreboard.md

@@ -1,6 +1,6 @@
 # Haskell-on-SX Scoreboard
 
-Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
+Updated 2026-05-08 · Phase 6 (prelude extras + 18 programs)
 
 | Program | Tests | Status |
 |---------|-------|--------|
@@ -10,7 +10,7 @@ Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
 | nqueens.hs | 2/2 | ✓ |
 | calculator.hs | 5/5 | ✓ |
 | collatz.hs | 11/11 | ✓ |
-| palindrome.hs | 8/8 | ✓ |
+| palindrome.hs | 12/12 | ✓ |
 | maybe.hs | 12/12 | ✓ |
 | fizzbuzz.hs | 12/12 | ✓ |
 | anagram.hs | 9/9 | ✓ |
@@ -20,6 +20,24 @@ Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
 | primes.hs | 12/12 | ✓ |
 | zipwith.hs | 9/9 | ✓ |
 | matrix.hs | 8/8 | ✓ |
-| wordcount.hs | 7/7 | ✓ |
+| wordcount.hs | 10/10 | ✓ |
 | powers.hs | 14/14 | ✓ |
-| **Total** | **156/156** | **18/18 programs** |
+| caesar.hs | 8/8 | ✓ |
+| runlength-str.hs | 9/9 | ✓ |
+| showadt.hs | 5/5 | ✓ |
+| showio.hs | 5/5 | ✓ |
+| partial.hs | 7/7 | ✓ |
+| statistics.hs | 5/5 | ✓ |
+| newton.hs | 5/5 | ✓ |
+| wordfreq.hs | 7/7 | ✓ |
+| mapgraph.hs | 6/6 | ✓ |
+| uniquewords.hs | 4/4 | ✓ |
+| setops.hs | 8/8 | ✓ |
+| shapes.hs | 5/5 | ✓ |
+| person.hs | 7/7 | ✓ |
+| config.hs | 10/10 | ✓ |
+| counter.hs | 7/7 | ✓ |
+| accumulate.hs | 8/8 | ✓ |
+| safediv.hs | 8/8 | ✓ |
+| trycatch.hs | 8/8 | ✓ |
+| **Total** | **285/285** | **36/36 programs** |

lib/haskell/set.sx

@@ -0,0 +1,62 @@
+;; set.sx — Phase 12 Data.Set: wraps Data.Map with unit values.
+;;
+;; A Set is a Map from key to (). All set operations delegate to the map
+;; ops, ignoring the value side. Storage representation matches Data.Map:
+;;
+;;   Empty → ("Map-Empty")
+;;   Node  → ("Map-Node" key () left right size)
+;;
+;; Tradeoff: trivial maintenance burden, slight overhead per node from
+;; the unused value slot. Faster path forward than re-implementing the
+;; weight-balanced BST.
+;;
+;; Functions live in this file; the Haskell-level `import Data.Set` /
+;; `import qualified Data.Set as Set` wiring (next Phase 12 box) binds
+;; them under the chosen alias.
+
+(define hk-set-unit (list "Tuple"))
+
+(define hk-set-empty hk-map-empty)
+
+(define hk-set-singleton (fn (k) (hk-map-singleton k hk-set-unit)))
+
+(define hk-set-insert (fn (k s) (hk-map-insert k hk-set-unit s)))
+
+(define hk-set-delete hk-map-delete)
+(define hk-set-member hk-map-member)
+(define hk-set-size hk-map-size)
+(define hk-set-null hk-map-null)
+(define hk-set-to-asc-list hk-map-keys)
+(define hk-set-to-list hk-map-keys)
+
+(define
+  hk-set-from-list
+  (fn (xs) (reduce (fn (acc k) (hk-set-insert k acc)) hk-set-empty xs)))
+
+(define
+  hk-set-union
+  (fn (a b) (hk-map-union-with (fn (x y) hk-set-unit) a b)))
+
+(define
+  hk-set-intersection
+  (fn (a b) (hk-map-intersection-with (fn (x y) hk-set-unit) a b)))
+
+(define hk-set-difference hk-map-difference)
+
+(define
+  hk-set-is-subset-of
+  (fn (a b) (= (hk-map-size (hk-map-difference a b)) 0)))
+
+(define
+  hk-set-filter
+  (fn (p s) (hk-map-filter-with-key (fn (k v) (p k)) s)))
+
+(define hk-set-map (fn (f s) (hk-set-from-list (map f (hk-map-keys s)))))
+
+(define
+  hk-set-foldr
+  (fn (f z s) (hk-map-foldr-with-key (fn (k v acc) (f k acc)) z s)))
+
+(define
+  hk-set-foldl
+  (fn (f z s) (hk-map-foldl-with-key (fn (acc k v) (f acc k)) z s)))

lib/haskell/test.sh

@@ -55,6 +55,8 @@ for FILE in "${FILES[@]}"; do
 (load "lib/haskell/runtime.sx")
 (load "lib/haskell/match.sx")
 (load "lib/haskell/eval.sx")
+(load "lib/haskell/map.sx")
+(load "lib/haskell/set.sx")
 $INFER_LOAD
 (load "lib/haskell/testlib.sx")
 (epoch 2)
@@ -98,6 +100,8 @@ EPOCHS
 (load "lib/haskell/runtime.sx")
 (load "lib/haskell/match.sx")
 (load "lib/haskell/eval.sx")
+(load "lib/haskell/map.sx")
+(load "lib/haskell/set.sx")
 $INFER_LOAD
 (load "lib/haskell/testlib.sx")
 (epoch 2)

lib/haskell/testlib.sx

@@ -56,3 +56,21 @@
         (append!
           hk-test-fails
           {:actual actual :expected expected :name name})))))
+
+(define
+  hk-test-error
+  (fn
+    (name thunk expected-substring)
+    (let
+      ((caught (guard (e (true (if (string? e) e (str e)))) (begin (thunk) nil))))
+      (cond
+        ((nil? caught)
+          (do
+            (set! hk-test-fail (+ hk-test-fail 1))
+            (append! hk-test-fails {:actual "no error raised" :expected (str "error containing: " expected-substring) :name name})))
+        ((>= (index-of caught expected-substring) 0)
+          (set! hk-test-pass (+ hk-test-pass 1)))
+        (:else
+          (do
+            (set! hk-test-fail (+ hk-test-fail 1))
+            (append! hk-test-fails {:actual caught :expected (str "error containing: " expected-substring) :name name})))))))

lib/haskell/tests/class-defaults.sx

@@ -0,0 +1,86 @@
+;; class-defaults.sx — Phase 13: class default method implementations.
+
+;; ── Eq default: myNeq derived from myEq via `not (myEq x y)` ──
+(define
+  hk-myeq-source
+  "class MyEq a where\n  myEq :: a -> a -> Bool\n  myNeq :: a -> a -> Bool\n  myNeq x y = not (myEq x y)\ninstance MyEq Int where\n  myEq x y = x == y\n")
+
+(hk-test
+  "Eq default: myNeq 3 5 = True (no explicit myNeq in instance)"
+  (hk-deep-force (hk-run (str hk-myeq-source "main = myNeq 3 5\n")))
+  (list "True"))
+
+(hk-test
+  "Eq default: myNeq 3 3 = False"
+  (hk-deep-force (hk-run (str hk-myeq-source "main = myNeq 3 3\n")))
+  (list "False"))
+
+(hk-test
+  "Eq default: myEq still works in same instance"
+  (hk-deep-force (hk-run (str hk-myeq-source "main = myEq 7 7\n")))
+  (list "True"))
+
+;; ── Override path: instance can still provide the method explicitly. ──
+(hk-test
+  "Default override: instance-provided beats class default"
+  (hk-deep-force
+    (hk-run
+      "class Hi a where\n  greet :: a -> String\n  greet x = \"default\"\ninstance Hi Bool where\n  greet x = \"override\"\nmain = greet True"))
+  "override")
+
+(hk-test
+  "Default fallback: empty instance picks default"
+  (hk-deep-force
+    (hk-run
+      "class Hi a where\n  greet :: a -> String\n  greet x = \"default\"\ninstance Hi Bool where\nmain = greet True"))
+  "default")
+
+(define
+  hk-myord-source
+  "class MyOrd a where\n  myCmp :: a -> a -> Bool\n  myMax :: a -> a -> a\n  myMin :: a -> a -> a\n  myMax a b = if myCmp a b then a else b\n  myMin a b = if myCmp a b then b else a\ninstance MyOrd Int where\n  myCmp x y = x >= y\n")
+
+(hk-test
+  "Ord default: myMax 3 5 = 5"
+  (hk-deep-force (hk-run (str hk-myord-source "main = myMax 3 5\n")))
+  5)
+
+(hk-test
+  "Ord default: myMax 8 2 = 8"
+  (hk-deep-force (hk-run (str hk-myord-source "main = myMax 8 2\n")))
+  8)
+
+(hk-test
+  "Ord default: myMin 3 5 = 3"
+  (hk-deep-force (hk-run (str hk-myord-source "main = myMin 3 5\n")))
+  3)
+
+(hk-test
+  "Ord default: myMin 8 2 = 2"
+  (hk-deep-force (hk-run (str hk-myord-source "main = myMin 8 2\n")))
+  2)
+
+(hk-test
+  "Ord default: myMax of equals returns first"
+  (hk-deep-force (hk-run (str hk-myord-source "main = myMax 4 4\n")))
+  4)
+
+(define
+  hk-mynum-source
+  "class MyNum a where\n  mySub :: a -> a -> a\n  myLt :: a -> a -> Bool\n  myNegate :: a -> a\n  myAbs :: a -> a\n  myNegate x = mySub (mySub x x) x\n  myAbs x = if myLt x (mySub x x) then myNegate x else x\ninstance MyNum Int where\n  mySub x y = x - y\n  myLt x y = x < y\n")
+
+(hk-test
+  "Num default: myNegate 5 = -5"
+  (hk-deep-force (hk-run (str hk-mynum-source "main = myNegate 5\n")))
+  -5)
+
+(hk-test
+  "Num default: myAbs (myNegate 7) = 7"
+  (hk-deep-force (hk-run (str hk-mynum-source "main = myAbs (myNegate 7)\n")))
+  7)
+
+(hk-test
+  "Num default: myAbs 9 = 9"
+  (hk-deep-force (hk-run (str hk-mynum-source "main = myAbs 9\n")))
+  9)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/deriving.sx

@@ -12,14 +12,14 @@
   "deriving Show: constructor with arg"
   (hk-deep-force
     (hk-run "data Wrapper = Wrap Int deriving (Show)\nmain = show (Wrap 42)"))
-  "(Wrap 42)")
+  "Wrap 42")
 
 (hk-test
   "deriving Show: nested constructors"
   (hk-deep-force
     (hk-run
       "data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf Leaf)"))
-  "(Node 1 Leaf Leaf)")
+  "Node 1 Leaf Leaf")
 
 (hk-test
   "deriving Show: second constructor"
@@ -30,6 +30,31 @@
 
 ;; ─── Eq ──────────────────────────────────────────────────────────────────────
 
+(hk-test
+  "deriving Show: nested ADT wraps inner constructor in parens"
+  (hk-deep-force
+    (hk-run
+      "data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf (Node 2 Leaf Leaf))"))
+  "Node 1 Leaf (Node 2 Leaf Leaf)")
+
+(hk-test
+  "deriving Show: Maybe Maybe wraps inner Just"
+  (hk-deep-force (hk-run "main = show (Just (Just 3))"))
+  "Just (Just 3)")
+
+(hk-test
+  "deriving Show: negative argument wrapped in parens"
+  (hk-deep-force (hk-run "main = show (Just (negate 3))"))
+  "Just (-3)")
+
+(hk-test
+  "deriving Show: list element does not need parens"
+  (hk-deep-force
+    (hk-run "data Box = Box [Int] deriving (Show)\nmain = show (Box [1,2,3])"))
+  "Box [1,2,3]")
+
+;; ─── combined Eq + Show ───────────────────────────────────────────────────────
+
 (hk-test
   "deriving Eq: same constructor"
   (hk-deep-force
@@ -58,14 +83,12 @@
       "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Blue)"))
   "True")
 
-;; ─── combined Eq + Show ───────────────────────────────────────────────────────
-
 (hk-test
-  "deriving Eq Show: combined in parens"
+  "deriving Eq Show: combined"
   (hk-deep-force
     (hk-run
       "data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 5)"))
-  "(Circle 5)")
+  "Circle 5")
 
 (hk-test
   "deriving Eq Show: eq on constructor with arg"

lib/haskell/tests/errors.sx

@@ -0,0 +1,99 @@
+;; errors.sx — Phase 9 error / undefined / partial-fn coverage via hk-test-error.
+
+;; ── error builtin ────────────────────────────────────────────
+(define
+  hk-as-list
+  (fn
+    (xs)
+    (cond
+      ((and (list? xs) (= (first xs) "[]")) (list))
+      ((and (list? xs) (= (first xs) ":"))
+        (cons (nth xs 1) (hk-as-list (nth xs 2))))
+      (:else xs))))
+
+(hk-test-error
+  "error: raises with literal message"
+  (fn () (hk-deep-force (hk-run "main = error \"boom\"")))
+  "hk-error: boom")
+
+(hk-test-error
+  "error: raises with computed message"
+  (fn () (hk-deep-force (hk-run "main = error (\"oops: \" ++ show 42)")))
+  "hk-error: oops: 42")
+
+;; ── undefined ────────────────────────────────────────────────
+(hk-test-error
+  "error: nested in if branch (only fires when forced)"
+  (fn
+    ()
+    (hk-deep-force (hk-run "main = if 1 == 1 then error \"taken\" else 0")))
+  "taken")
+
+(hk-test-error
+  "undefined: raises Prelude.undefined"
+  (fn () (hk-deep-force (hk-run "main = undefined")))
+  "Prelude.undefined")
+
+;; The non-strict path: undefined doesn't fire when not forced.
+(hk-test-error
+  "undefined: forced via arithmetic"
+  (fn () (hk-deep-force (hk-run "main = undefined + 1")))
+  "Prelude.undefined")
+
+;; ── partial functions ───────────────────────────────────────
+(hk-test
+  "undefined: lazy, not forced when discarded"
+  (hk-deep-force (hk-run "main = let _ = undefined in 5"))
+  5)
+
+(hk-test-error
+  "head []: raises Prelude.head: empty list"
+  (fn () (hk-deep-force (hk-run "main = head []")))
+  "Prelude.head: empty list")
+
+(hk-test-error
+  "tail []: raises Prelude.tail: empty list"
+  (fn () (hk-deep-force (hk-run "main = tail []")))
+  "Prelude.tail: empty list")
+
+;; head and tail still work on non-empty lists.
+(hk-test-error
+  "fromJust Nothing: raises Maybe.fromJust: Nothing"
+  (fn () (hk-deep-force (hk-run "main = fromJust Nothing")))
+  "Maybe.fromJust: Nothing")
+
+(hk-test
+  "head [42]: still works"
+  (hk-deep-force (hk-run "main = head [42]"))
+  42)
+
+;; ── error in IO context ─────────────────────────────────────
+(hk-test
+  "tail [1,2,3]: still works"
+  (hk-as-list (hk-deep-force (hk-run "main = tail [1,2,3]")))
+  (list 2 3))
+
+(hk-test
+  "hk-run-io: error in main lands in io-lines"
+  (let
+    ((lines (hk-run-io "main = error \"caught here\"")))
+    (>= (index-of (str lines) "caught here") 0))
+  true)
+
+;; ── hk-test-error helper itself ─────────────────────────────
+(hk-test
+  "hk-run-io: putStrLn before error preserves earlier output"
+  (let
+    ((lines (hk-run-io "main = do { putStrLn \"first\"; error \"died\"; putStrLn \"never\" }")))
+    (and
+      (>= (index-of (str lines) "first") 0)
+      (>= (index-of (str lines) "died") 0)))
+  true)
+
+;; hk-as-list helper for converting a forced Haskell cons into an SX list.
+(hk-test-error
+  "hk-test-error: matches partial substring inside wrapped exception"
+  (fn () (hk-deep-force (hk-run "main = error \"unique-marker-xyz\"")))
+  "unique-marker-xyz")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/eval.sx

@@ -231,16 +231,82 @@
   1)
 
 ;; ── Laziness: app args evaluate only when forced ──
+(hk-test
+  "error builtin: raises with hk-error prefix"
+  (guard
+    (e (true (>= (index-of e "hk-error: boom") 0)))
+    (begin (hk-deep-force (hk-run "main = error \"boom\"")) false))
+  true)
+
+(hk-test
+  "error builtin: raises with computed message"
+  (guard
+    (e (true (>= (index-of e "hk-error: oops: 42") 0)))
+    (begin
+      (hk-deep-force (hk-run "main = error (\"oops: \" ++ show 42)"))
+      false))
+  true)
+
+(hk-test
+  "undefined: raises hk-error with Prelude.undefined message"
+  (guard
+    (e (true (>= (index-of e "hk-error: Prelude.undefined") 0)))
+    (begin (hk-deep-force (hk-run "main = undefined")) false))
+  true)
+
+(hk-test
+  "undefined: lazy — only fires when forced"
+  (hk-deep-force (hk-run "main = if True then 42 else undefined"))
+  42)
+
+(hk-test
+  "head []: raises Prelude.head: empty list"
+  (guard
+    (e (true (>= (index-of e "Prelude.head: empty list") 0)))
+    (begin (hk-deep-force (hk-run "main = head []")) false))
+  true)
+
+(hk-test
+  "tail []: raises Prelude.tail: empty list"
+  (guard
+    (e (true (>= (index-of e "Prelude.tail: empty list") 0)))
+    (begin (hk-deep-force (hk-run "main = tail []")) false))
+  true)
+
+;; ── not / id built-ins ──
+(hk-test
+  "fromJust Nothing: raises Maybe.fromJust: Nothing"
+  (guard
+    (e (true (>= (index-of e "Maybe.fromJust: Nothing") 0)))
+    (begin (hk-deep-force (hk-run "main = fromJust Nothing")) false))
+  true)
+(hk-test
+  "fromJust (Just 5) = 5"
+  (hk-deep-force (hk-run "main = fromJust (Just 5)"))
+  5)
+(hk-test
+  "head [42] = 42 (still works for non-empty)"
+  (hk-deep-force (hk-run "main = head [42]"))
+  42)
+
+(hk-test-error
+  "hk-test-error helper: catches matching error"
+  (fn () (hk-deep-force (hk-run "main = error \"boom\"")))
+  "hk-error: boom")
+
+(hk-test-error
+  "hk-test-error helper: catches head [] error"
+  (fn () (hk-deep-force (hk-run "main = head []")))
+  "Prelude.head: empty list")
+
 (hk-test
   "second arg never forced"
-  (hk-eval-expr-source
-    "(\\x y -> x) 1 (error \"never\")")
+  (hk-eval-expr-source "(\\x y -> x) 1 (error \"never\")")
   1)
 
 (hk-test
   "first arg never forced"
-  (hk-eval-expr-source
-    "(\\x y -> y) (error \"never\") 99")
+  (hk-eval-expr-source "(\\x y -> y) (error \"never\") 99")
   99)
 
 (hk-test
@@ -251,9 +317,7 @@
 
 (hk-test
   "lazy: const drops its second argument"
-  (hk-prog-val
-    "const x y = x\nresult = const 5 (error \"boom\")"
-    "result")
+  (hk-prog-val "const x y = x\nresult = const 5 (error \"boom\")" "result")
   5)
 
 (hk-test
@@ -270,9 +334,10 @@
     "result")
   (list "True"))
 
-;; ── not / id built-ins ──
 (hk-test "not True" (hk-eval-expr-source "not True") (list "False"))
+
 (hk-test "not False" (hk-eval-expr-source "not False") (list "True"))
+
 (hk-test "id" (hk-eval-expr-source "id 42") 42)
 
 {:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/exceptions.sx

@@ -0,0 +1,105 @@
+;; Phase 16 — Exception handling unit tests.
+
+(hk-test
+  "catch — success path returns the action result"
+  (hk-deep-force
+    (hk-run
+      "main = catch (return 42) (\\(SomeException m) -> return 0)"))
+  (list "IO" 42))
+
+(hk-test
+  "catch — error caught, handler receives message"
+  (hk-deep-force
+    (hk-run
+      "main = catch (error \"boom\") (\\(SomeException m) -> return m)"))
+  (list "IO" "boom"))
+
+(hk-test
+  "try — success returns Right v"
+  (hk-deep-force
+    (hk-run "main = try (return 42)"))
+  (list "IO" (list "Right" 42)))
+
+(hk-test
+  "try — error returns Left (SomeException msg)"
+  (hk-deep-force
+    (hk-run "main = try (error \"oops\")"))
+  (list "IO" (list "Left" (list "SomeException" "oops"))))
+
+(hk-test
+  "handle — flip catch — caught error message"
+  (hk-deep-force
+    (hk-run
+      "main = handle (\\(SomeException m) -> return m) (error \"hot\")"))
+  (list "IO" "hot"))
+
+(hk-test
+  "throwIO + catch — handler sees the SomeException"
+  (hk-deep-force
+    (hk-run
+      "main = catch (throwIO (SomeException \"bang\")) (\\(SomeException m) -> return m)"))
+  (list "IO" "bang"))
+
+(hk-test
+  "throwIO + try — Left side"
+  (hk-deep-force
+    (hk-run
+      "main = try (throwIO (SomeException \"x\"))"))
+  (list "IO" (list "Left" (list "SomeException" "x"))))
+
+(hk-test
+  "evaluate — pure value returns IO v"
+  (hk-deep-force
+    (hk-run "main = evaluate (1 + 2 + 3)"))
+  (list "IO" 6))
+
+(hk-test
+  "evaluate — error surfaces as catchable exception"
+  (hk-deep-force
+    (hk-run
+      "main = catch (evaluate (error \"deep\")) (\\(SomeException m) -> return m)"))
+  (list "IO" "deep"))
+
+(hk-test
+  "nested catch — inner handler runs first"
+  (hk-deep-force
+    (hk-run
+      "main = catch (catch (error \"inner\") (\\(SomeException m) -> error (m ++ \"-rethrown\"))) (\\(SomeException m) -> return m)"))
+  (list "IO" "inner-rethrown"))
+
+(hk-test
+  "catch chain — handler can succeed inside IO"
+  (hk-deep-force
+    (hk-run
+      "main = do { x <- catch (error \"e1\") (\\(SomeException m) -> return 100); return (x + 1) }"))
+  (list "IO" 101))
+
+(hk-test
+  "try then bind on Right"
+  (hk-deep-force
+    (hk-run
+      "branch (Right v) = return (v * 2)
+branch (Left _) = return 0
+main = do { r <- try (return 21); branch r }"))
+  (list "IO" 42))
+
+(hk-test
+  "try then bind on Left"
+  (hk-deep-force
+    (hk-run
+      "branch (Right _) = return \"ok\"
+branch (Left (SomeException m)) = return m
+main = do { r <- try (error \"failed\"); branch r }"))
+  (list "IO" "failed"))
+
+(hk-test
+  "catch — handler can use closed-over IORef"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef
+main = do
+  r <- IORef.newIORef 0
+  catch (error \"x\") (\\(SomeException m) -> IORef.writeIORef r 7)
+  v <- IORef.readIORef r
+  return v"))
+  (list "IO" 7))

lib/haskell/tests/instance-where.sx

@@ -0,0 +1,31 @@
+;; instance-where.sx — Phase 13: where-clauses inside instance bodies.
+
+(hk-test
+  "instance method body with where-helper (Bool)"
+  (hk-deep-force
+    (hk-run
+      "class Greet a where\n  greet :: a -> String\ninstance Greet Bool where\n  greet x = mkMsg x\n    where mkMsg True = \"yes\"\n          mkMsg False = \"no\"\nmain = greet True"))
+  "yes")
+
+(hk-test
+  "instance method body with where-helper (False branch)"
+  (hk-deep-force
+    (hk-run
+      "class Greet a where\n  greet :: a -> String\ninstance Greet Bool where\n  greet x = mkMsg x\n    where mkMsg True = \"yes\"\n          mkMsg False = \"no\"\nmain = greet False"))
+  "no")
+
+(hk-test
+  "instance method body with where-binding referenced multiple times"
+  (hk-deep-force
+    (hk-run
+      "class Twice a where\n  twice :: a -> Int\ninstance Twice Int where\n  twice x = h + h\n    where h = x + 1\nmain = twice 5"))
+  12)
+
+(hk-test
+  "instance method body with multi-binding where"
+  (hk-deep-force
+    (hk-run
+      "class Calc a where\n  calc :: a -> Int\ninstance Calc Int where\n  calc x = a + b\n    where a = x * 2\n          b = x + 1\nmain = calc 3"))
+  10)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/io-input.sx

@@ -64,12 +64,11 @@
 
 (hk-test
   "readFile error on missing file"
-  (guard
-    (e (true (>= (index-of e "file not found") 0)))
-    (begin
-      (set! hk-vfs (dict))
-      (hk-run-io "main = readFile \"no.txt\" >>= putStrLn")
-      false))
+  (begin
+    (set! hk-vfs (dict))
+    (let
+      ((lines (hk-run-io "main = readFile \"no.txt\" >>= putStrLn")))
+      (>= (index-of (str lines) "file not found") 0)))
   true)
 
 (hk-test

lib/haskell/tests/ioref.sx

@@ -0,0 +1,94 @@
+;; Phase 15 — IORef unit tests.
+
+(hk-test
+  "newIORef + readIORef returns initial value"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 42; v <- IORef.readIORef r; return v }"))
+  (list "IO" 42))
+
+(hk-test
+  "writeIORef updates the cell"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 0; IORef.writeIORef r 99; v <- IORef.readIORef r; return v }"))
+  (list "IO" 99))
+
+(hk-test
+  "writeIORef returns IO ()"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 0; IORef.writeIORef r 1 }"))
+  (list "IO" (list "Tuple")))
+
+(hk-test
+  "modifyIORef applies a function"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 5; IORef.modifyIORef r (\\x -> x * 2); v <- IORef.readIORef r; return v }"))
+  (list "IO" 10))
+
+(hk-test
+  "modifyIORef' (strict) applies a function"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 7; IORef.modifyIORef' r (\\x -> x + 3); v <- IORef.readIORef r; return v }"))
+  (list "IO" 10))
+
+(hk-test
+  "two reads return the same value"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 11; a <- IORef.readIORef r; b <- IORef.readIORef r; return (a + b) }"))
+  (list "IO" 22))
+
+(hk-test
+  "shared ref across do-steps: write then read"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 1; IORef.writeIORef r 2; IORef.writeIORef r 3; v <- IORef.readIORef r; return v }"))
+  (list "IO" 3))
+
+(hk-test
+  "two refs are independent"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r1 <- IORef.newIORef 1; r2 <- IORef.newIORef 2; IORef.writeIORef r1 10; a <- IORef.readIORef r1; b <- IORef.readIORef r2; return (a + b) }"))
+  (list "IO" 12))
+
+(hk-test
+  "string-valued IORef"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef \"hi\"; IORef.writeIORef r \"bye\"; v <- IORef.readIORef r; return v }"))
+  (list "IO" "bye"))
+
+(hk-test
+  "list-valued IORef + cons"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef [1,2,3]; IORef.modifyIORef r (\\xs -> 0 : xs); v <- IORef.readIORef r; return v }"))
+  (list
+    "IO"
+    (list ":" 0 (list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))))
+
+(hk-test
+  "counter loop: increment N times"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nloop r 0 = return ()\nloop r n = do { IORef.modifyIORef r (\\x -> x + 1); loop r (n - 1) }\nmain = do { r <- IORef.newIORef 0; loop r 10; v <- IORef.readIORef r; return v }"))
+  (list "IO" 10))
+
+(hk-test
+  "modifyIORef' inside a loop"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\ngo r 0 = return ()\ngo r n = do { IORef.modifyIORef' r (\\x -> x + n); go r (n - 1) }\nmain = do { r <- IORef.newIORef 0; go r 5; v <- IORef.readIORef r; return v }"))
+  (list "IO" 15))
+
+(hk-test
+  "newIORef inside a function passed via parameter"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nbump r = IORef.modifyIORef r (\\x -> x + 100)\nmain = do { r <- IORef.newIORef 1; bump r; v <- IORef.readIORef r; return v }"))
+  (list "IO" 101))

lib/haskell/tests/map.sx

@@ -0,0 +1,196 @@
+;; map.sx — Phase 11 Data.Map unit tests.
+;;
+;; Tests both the SX-level `hk-map-*` helpers and the Haskell-level
+;; `Map.*` aliases bound by the import handler.
+
+(define
+  hk-as-list
+  (fn
+    (xs)
+    (cond
+      ((and (list? xs) (= (first xs) "[]")) (list))
+      ((and (list? xs) (= (first xs) ":"))
+        (cons (nth xs 1) (hk-as-list (nth xs 2))))
+      (:else xs))))
+
+;; ── SX-level (direct hk-map-*) ───────────────────────────────
+(hk-test
+  "hk-map-empty: size 0, null true"
+  (list (hk-map-size hk-map-empty) (hk-map-null hk-map-empty))
+  (list 0 true))
+
+(hk-test
+  "hk-map-singleton: lookup hit"
+  (let
+    ((m (hk-map-singleton 5 "five")))
+    (list (hk-map-size m) (hk-map-lookup 5 m)))
+  (list 1 (list "Just" "five")))
+
+(hk-test
+  "hk-map-insert: lookup hit on inserted"
+  (let ((m (hk-map-insert 1 "a" hk-map-empty))) (hk-map-lookup 1 m))
+  (list "Just" "a"))
+
+(hk-test
+  "hk-map-lookup: miss returns Nothing"
+  (hk-map-lookup 99 (hk-map-singleton 1 "a"))
+  (list "Nothing"))
+
+(hk-test
+  "hk-map-insert: overwrites existing key"
+  (let
+    ((m (hk-map-insert 1 "second" (hk-map-insert 1 "first" hk-map-empty))))
+    (hk-map-lookup 1 m))
+  (list "Just" "second"))
+
+(hk-test
+  "hk-map-delete: removes key"
+  (let
+    ((m (hk-map-insert 2 "b" (hk-map-insert 1 "a" hk-map-empty))))
+    (let
+      ((m2 (hk-map-delete 1 m)))
+      (list (hk-map-size m2) (hk-map-lookup 1 m2) (hk-map-lookup 2 m2))))
+  (list 1 (list "Nothing") (list "Just" "b")))
+
+(hk-test
+  "hk-map-delete: missing key is no-op"
+  (let ((m (hk-map-singleton 1 "a"))) (hk-map-size (hk-map-delete 99 m)))
+  1)
+
+(hk-test
+  "hk-map-member: true on existing"
+  (hk-map-member 1 (hk-map-singleton 1 "a"))
+  true)
+
+(hk-test
+  "hk-map-member: false on missing"
+  (hk-map-member 99 (hk-map-singleton 1 "a"))
+  false)
+
+(hk-test
+  "hk-map-from-list: builds map; keys sorted"
+  (hk-map-keys
+    (hk-map-from-list
+      (list (list 3 "c") (list 1 "a") (list 5 "e") (list 2 "b"))))
+  (list 1 2 3 5))
+
+(hk-test
+  "hk-map-from-list: duplicates — last wins"
+  (hk-map-lookup
+    1
+    (hk-map-from-list (list (list 1 "first") (list 1 "second"))))
+  (list "Just" "second"))
+
+(hk-test
+  "hk-map-to-asc-list: ordered traversal"
+  (hk-map-to-asc-list
+    (hk-map-from-list (list (list 3 "c") (list 1 "a") (list 2 "b"))))
+  (list (list 1 "a") (list 2 "b") (list 3 "c")))
+
+(hk-test
+  "hk-map-elems: in key order"
+  (hk-map-elems
+    (hk-map-from-list (list (list 3 30) (list 1 10) (list 2 20))))
+  (list 10 20 30))
+
+(hk-test
+  "hk-map-union-with: combines duplicates"
+  (hk-map-to-asc-list
+    (hk-map-union-with
+      (fn (a b) (str a "+" b))
+      (hk-map-from-list (list (list 1 "a") (list 2 "b")))
+      (hk-map-from-list (list (list 2 "B") (list 3 "c")))))
+  (list (list 1 "a") (list 2 "b+B") (list 3 "c")))
+
+(hk-test
+  "hk-map-intersection-with: keeps shared keys"
+  (hk-map-to-asc-list
+    (hk-map-intersection-with
+      +
+      (hk-map-from-list (list (list 1 10) (list 2 20)))
+      (hk-map-from-list (list (list 2 200) (list 3 30)))))
+  (list (list 2 220)))
+
+(hk-test
+  "hk-map-difference: drops m2 keys"
+  (hk-map-keys
+    (hk-map-difference
+      (hk-map-from-list (list (list 1 "a") (list 2 "b") (list 3 "c")))
+      (hk-map-from-list (list (list 2 "x")))))
+  (list 1 3))
+
+(hk-test
+  "hk-map-foldl-with-key: in-order accumulate"
+  (hk-map-foldl-with-key
+    (fn (acc k v) (str acc k v))
+    ""
+    (hk-map-from-list (list (list 3 "c") (list 1 "a") (list 2 "b"))))
+  "1a2b3c")
+
+(hk-test
+  "hk-map-map-with-key: transforms values"
+  (hk-map-to-asc-list
+    (hk-map-map-with-key
+      (fn (k v) (* k v))
+      (hk-map-from-list (list (list 2 10) (list 3 100)))))
+  (list (list 2 20) (list 3 300)))
+
+(hk-test
+  "hk-map-filter-with-key: keeps matches"
+  (hk-map-keys
+    (hk-map-filter-with-key
+      (fn (k v) (> k 1))
+      (hk-map-from-list (list (list 1 "a") (list 2 "b") (list 3 "c")))))
+  (list 2 3))
+
+(hk-test
+  "hk-map-adjust: applies f to existing"
+  (hk-map-lookup
+    1
+    (hk-map-adjust (fn (v) (* v 10)) 1 (hk-map-singleton 1 5)))
+  (list "Just" 50))
+
+(hk-test
+  "hk-map-insert-with: combines on existing"
+  (hk-map-lookup 1 (hk-map-insert-with + 1 5 (hk-map-singleton 1 10)))
+  (list "Just" 15))
+
+(hk-test
+  "hk-map-alter: Nothing → delete"
+  (hk-map-size
+    (hk-map-alter
+      (fn (mv) (list "Nothing"))
+      1
+      (hk-map-from-list (list (list 1 "a") (list 2 "b")))))
+  1)
+
+;; ── Haskell-level (Map.*) via import wiring ─────────────────
+(hk-test
+  "Map.size after Map.insert chain"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Map as Map\nmain = Map.size (Map.insert 2 \"b\" (Map.insert 1 \"a\" Map.empty))"))
+  2)
+
+(hk-test
+  "Map.lookup hit"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Map as Map\nmain = Map.lookup 1 (Map.insert 1 \"a\" Map.empty)"))
+  (list "Just" "a"))
+
+(hk-test
+  "Map.lookup miss"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Map as Map\nmain = Map.lookup 99 (Map.insert 1 \"a\" Map.empty)"))
+  (list "Nothing"))
+
+(hk-test
+  "Map.member true"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Map as Map\nmain = Map.member 5 (Map.insert 5 \"x\" Map.empty)"))
+  (list "True"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/numerics.sx

@@ -0,0 +1,180 @@
+;; numerics.sx — Phase 10 numeric tower verification.
+;;
+;; Practical integer-precision limit in Haskell-on-SX:
+;;   • Raw SX `(* a b)` stays exact up to ±2^62 (≈ 4.6e18, OCaml int63).
+;;   • BUT the Haskell tokenizer/parser parses an integer literal as a float
+;;     once it exceeds 2^53 (≈ 9.007e15). Once any operand is a float, the
+;;     binop result is a float (and decimal-precision is lost past 2^53).
+;;   • Therefore: programs that stay below ~9e15 are exact; larger literals
+;;     or accumulated products silently become floats. `factorial 18` is the
+;;     last factorial that stays exact (6.4e15); `factorial 19` already floats.
+;;
+;; In Haskell terms, `Int` and `Integer` both currently map to SX number, so
+;; we don't yet support arbitrary-precision Integer. Documented; unbounded
+;; Integer is out of scope for Phase 10 — see Phase 11+ if it becomes needed.
+
+(define
+  hk-as-list
+  (fn
+    (xs)
+    (cond
+      ((and (list? xs) (= (first xs) "[]")) (list))
+      ((and (list? xs) (= (first xs) ":"))
+        (cons (nth xs 1) (hk-as-list (nth xs 2))))
+      (:else xs))))
+
+(hk-test
+  "factorial 10 = 3628800 (small, exact)"
+  (hk-deep-force
+    (hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 10"))
+  3628800)
+
+(hk-test
+  "factorial 15 = 1307674368000 (mid-range, exact)"
+  (hk-deep-force
+    (hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 15"))
+  1307674368000)
+
+(hk-test
+  "factorial 18 = 6402373705728000 (last exact factorial)"
+  (hk-deep-force
+    (hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 18"))
+  6402373705728000)
+
+(hk-test
+  "1000000 * 1000000 = 10^12 (exact)"
+  (hk-deep-force (hk-run "main = 1000000 * 1000000"))
+  1000000000000)
+
+(hk-test
+  "1000000000 * 1000000000 = 10^18 (exact, at boundary)"
+  (hk-deep-force (hk-run "main = 1000000000 * 1000000000"))
+  1e+18)
+
+(hk-test
+  "2^62 boundary: pow accumulates exactly"
+  (hk-deep-force
+    (hk-run "pow b 0 = 1\npow b n = b * pow b (n - 1)\nmain = pow 2 62"))
+  4.6116860184273879e+18)
+
+(hk-test
+  "show factorial 12 = 479001600 (whole, fits in 32-bit)"
+  (hk-deep-force
+    (hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = show (fact 12)"))
+  "479001600")
+
+(hk-test
+  "negate large positive — preserves magnitude"
+  (hk-deep-force (hk-run "main = negate 1000000000000000000"))
+  -1e+18)
+
+(hk-test
+  "abs negative large — preserves magnitude"
+  (hk-deep-force (hk-run "main = abs (negate 1000000000000000000)"))
+  1e+18)
+
+(hk-test
+  "div on large ints"
+  (hk-deep-force (hk-run "main = div 1000000000000000000 1000000000"))
+  1000000000)
+
+(hk-test
+  "fromIntegral 42 = 42 (identity in our runtime)"
+  (hk-deep-force (hk-run "main = fromIntegral 42"))
+  42)
+
+(hk-test
+  "fromIntegral preserves negative"
+  (hk-deep-force (hk-run "main = fromIntegral (negate 7)"))
+  -7)
+
+(hk-test
+  "fromIntegral round-trips through arithmetic"
+  (hk-deep-force (hk-run "main = fromIntegral 5 + fromIntegral 3"))
+  8)
+
+(hk-test
+  "fromIntegral in a program (mixing with map)"
+  (hk-as-list (hk-deep-force (hk-run "main = map fromIntegral [1,2,3]")))
+  (list 1 2 3))
+
+(hk-test
+  "toInteger 100 = 100 (identity)"
+  (hk-deep-force (hk-run "main = toInteger 100"))
+  100)
+
+(hk-test
+  "fromInteger 7 = 7 (identity)"
+  (hk-deep-force (hk-run "main = fromInteger 7"))
+  7)
+
+(hk-test
+  "toInteger / fromInteger round-trip"
+  (hk-deep-force (hk-run "main = fromInteger (toInteger 42)"))
+  42)
+
+(hk-test
+  "toInteger preserves negative"
+  (hk-deep-force (hk-run "main = toInteger (negate 13)"))
+  -13)
+
+(hk-test
+  "show 3.14 = 3.14"
+  (hk-deep-force (hk-run "main = show 3.14"))
+  "3.14")
+
+(hk-test
+  "show 1.0e10 — whole-valued float renders as decimal (int/float ambiguity)"
+  (hk-deep-force (hk-run "main = show 1.0e10"))
+  "10000000000")
+
+(hk-test
+  "show 0.001 uses scientific form (sub-0.1)"
+  (hk-deep-force (hk-run "main = show 0.001"))
+  "1.0e-3")
+
+(hk-test
+  "show negative float"
+  (hk-deep-force (hk-run "main = show (negate 3.14)"))
+  "-3.14")
+
+(hk-test "sqrt 16 = 4" (hk-deep-force (hk-run "main = sqrt 16")) 4)
+
+(hk-test "floor 3.7 = 3" (hk-deep-force (hk-run "main = floor 3.7")) 3)
+
+(hk-test "ceiling 3.2 = 4" (hk-deep-force (hk-run "main = ceiling 3.2")) 4)
+
+(hk-test
+  "ceiling on whole = self"
+  (hk-deep-force (hk-run "main = ceiling 4"))
+  4)
+
+(hk-test "round 2.6 = 3" (hk-deep-force (hk-run "main = round 2.6")) 3)
+
+(hk-test
+  "truncate -3.7 = -3"
+  (hk-deep-force (hk-run "main = truncate (negate 3.7)"))
+  -3)
+
+(hk-test "recip 4.0 = 0.25" (hk-deep-force (hk-run "main = recip 4.0")) 0.25)
+
+(hk-test "1.0 / 4.0 = 0.25" (hk-deep-force (hk-run "main = 1.0 / 4.0")) 0.25)
+
+(hk-test
+  "fromRational 0.5 = 0.5 (identity)"
+  (hk-deep-force (hk-run "main = fromRational 0.5"))
+  0.5)
+
+(hk-test "pi ≈ 3.14159" (hk-deep-force (hk-run "main = pi")) 3.14159)
+
+(hk-test "exp 0 = 1" (hk-deep-force (hk-run "main = exp 0")) 1)
+
+(hk-test "sin 0 = 0" (hk-deep-force (hk-run "main = sin 0")) 0)
+
+(hk-test "cos 0 = 1" (hk-deep-force (hk-run "main = cos 0")) 1)
+
+(hk-test "2 ** 10 = 1024" (hk-deep-force (hk-run "main = 2 ** 10")) 1024)
+
+(hk-test "log (exp 5) ≈ 5" (hk-deep-force (hk-run "main = log (exp 5)")) 5)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-accumulate.sx

@@ -0,0 +1,81 @@
+;; accumulate.hs — accumulate results into an IORef [Int] (Phase 15 conformance).
+
+(define
+  hk-accumulate-source
+  "import qualified Data.IORef as IORef\n\npush :: IORef [Int] -> Int -> IO ()\npush r x = IORef.modifyIORef r (\\xs -> x : xs)\n\npushAll :: IORef [Int] -> [Int] -> IO ()\npushAll r [] = return ()\npushAll r (x:xs) = do\n  push r x\n  pushAll r xs\n\nreadReversed :: IORef [Int] -> IO [Int]\nreadReversed r = do\n  xs <- IORef.readIORef r\n  return (reverse xs)\n\ndoubleEach :: IORef [Int] -> [Int] -> IO ()\ndoubleEach r [] = return ()\ndoubleEach r (x:xs) = do\n  push r (x * 2)\n  doubleEach r xs\n\nsumIntoRef :: IORef Int -> [Int] -> IO ()\nsumIntoRef r [] = return ()\nsumIntoRef r (x:xs) = do\n  IORef.modifyIORef r (\\acc -> acc + x)\n  sumIntoRef r xs\n\n")
+
+(hk-test
+  "accumulate.hs — push three then read length"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef []; push r 1; push r 2; push r 3; xs <- IORef.readIORef r; return (length xs) }")))
+  (list "IO" 3))
+
+(hk-test
+  "accumulate.hs — pushAll preserves reverse order"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef []; pushAll r [1,2,3,4]; xs <- IORef.readIORef r; return xs }")))
+  (list
+    "IO"
+    (list ":" 4 (list ":" 3 (list ":" 2 (list ":" 1 (list "[]")))))))
+
+(hk-test
+  "accumulate.hs — readReversed gives original order"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef []; pushAll r [10,20,30]; readReversed r }")))
+  (list "IO" (list ":" 10 (list ":" 20 (list ":" 30 (list "[]"))))))
+
+(hk-test
+  "accumulate.hs — doubleEach maps then accumulates"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef []; doubleEach r [1,2,3]; readReversed r }")))
+  (list "IO" (list ":" 2 (list ":" 4 (list ":" 6 (list "[]"))))))
+
+(hk-test
+  "accumulate.hs — sum into Int IORef"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef 0; sumIntoRef r [1,2,3,4,5]; v <- IORef.readIORef r; return v }")))
+  (list "IO" 15))
+
+(hk-test
+  "accumulate.hs — empty list leaves ref untouched"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef [99]; pushAll r []; xs <- IORef.readIORef r; return xs }")))
+  (list "IO" (list ":" 99 (list "[]"))))
+
+(hk-test
+  "accumulate.hs — pushAll then sumIntoRef on the same input"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef 0; sumIntoRef r [10,20,30,40]; v <- IORef.readIORef r; return v }")))
+  (list "IO" 100))
+
+(hk-test
+  "accumulate.hs — accumulate results from a recursive helper"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "squaresUpTo r 0 = return ()\nsquaresUpTo r n = do { push r (n * n); squaresUpTo r (n - 1) }\nmain = do { r <- IORef.newIORef []; squaresUpTo r 4; readReversed r }")))
+  (list
+    "IO"
+    (list ":" 16 (list ":" 9 (list ":" 4 (list ":" 1 (list "[]")))))))

lib/haskell/tests/program-caesar.sx

@@ -0,0 +1,80 @@
+;; caesar.hs — Caesar cipher.
+;; Source: https://rosettacode.org/wiki/Caesar_cipher#Haskell (adapted).
+;;
+;; Exercises chr, ord, isUpper, isLower, mod, string pattern matching
+;; (x:xs) over a String (which is now a [Char] string view), and map
+;; from the Phase 7 string=[Char] foundation.
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+(define
+  hk-as-list
+  (fn
+    (xs)
+    (cond
+      ((and (list? xs) (= (first xs) "[]")) (list))
+      ((and (list? xs) (= (first xs) ":"))
+        (cons (nth xs 1) (hk-as-list (nth xs 2))))
+      (:else xs))))
+
+(define
+  hk-caesar-source
+  "shift n c = if isUpper c\n              then chr (mod ((ord c) - 65 + n) 26 + 65)\n              else if isLower c\n                     then chr (mod ((ord c) - 97 + n) 26 + 97)\n                     else chr c\n\ncaesarRec n []     = []\ncaesarRec n (x:xs) = shift n x : caesarRec n xs\n\ncaesarMap n s = map (shift n) s\n")
+
+(hk-test
+  "caesar.hs — caesarRec 3 \"ABC\" = DEF"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarRec 3 \"ABC\"\n") "r"))
+  (list "D" "E" "F"))
+
+(hk-test
+  "caesar.hs — caesarRec 13 \"Hello\" = Uryyb"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarRec 13 \"Hello\"\n") "r"))
+  (list "U" "r" "y" "y" "b"))
+
+(hk-test
+  "caesar.hs — caesarRec 1 \"AZ\" wraps to BA"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarRec 1 \"AZ\"\n") "r"))
+  (list "B" "A"))
+
+(hk-test
+  "caesar.hs — caesarRec 0 \"World\" identity"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarRec 0 \"World\"\n") "r"))
+  (list "W" "o" "r" "l" "d"))
+
+(hk-test
+  "caesar.hs — caesarRec preserves punctuation"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarRec 3 \"Hi!\"\n") "r"))
+  (list "K" "l" "!"))
+
+(hk-test
+  "caesar.hs — caesarMap 3 \"abc\" via map"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarMap 3 \"abc\"\n") "r"))
+  (list "d" "e" "f"))
+
+(hk-test
+  "caesar.hs — caesarMap 13 round-trips with caesarMap 13"
+  (hk-as-list
+    (hk-prog-val
+      (str
+        hk-caesar-source
+        "r = caesarMap 13 (foldr (\\c acc -> c : acc) [] (caesarMap 13 \"Hello\"))\n")
+      "r"))
+  (list "H" "e" "l" "l" "o"))
+
+(hk-test
+  "caesar.hs — caesarRec 25 \"AB\" = ZA"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarRec 25 \"AB\"\n") "r"))
+  (list "Z" "A"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-config.sx

@@ -0,0 +1,63 @@
+;; config.hs — multi-field config record; partial update; defaultConfig
+;;            constant.
+;;
+;; Exercises Phase 14: 4-field record, defaultConfig as a CAF, partial
+;; updates that change one or two fields, accessors over derived configs.
+
+(define
+  hk-config-source
+  "data Config = Config { host :: String, port :: Int, retries :: Int, debug :: Bool } deriving (Show)\n\ndefaultConfig = Config { host = \"localhost\", port = 8080, retries = 3, debug = False }\n\ndevConfig = defaultConfig { debug = True }\nremoteConfig = defaultConfig { host = \"api.example.com\", port = 443 }\n")
+
+(hk-test
+  "config.hs — defaultConfig host"
+  (hk-deep-force (hk-run (str hk-config-source "main = host defaultConfig")))
+  "localhost")
+
+(hk-test
+  "config.hs — defaultConfig port"
+  (hk-deep-force (hk-run (str hk-config-source "main = port defaultConfig")))
+  8080)
+
+(hk-test
+  "config.hs — defaultConfig retries"
+  (hk-deep-force
+    (hk-run (str hk-config-source "main = retries defaultConfig")))
+  3)
+
+(hk-test
+  "config.hs — devConfig flips debug"
+  (hk-deep-force (hk-run (str hk-config-source "main = debug devConfig")))
+  (list "True"))
+
+(hk-test
+  "config.hs — devConfig preserves host"
+  (hk-deep-force (hk-run (str hk-config-source "main = host devConfig")))
+  "localhost")
+
+(hk-test
+  "config.hs — devConfig preserves port"
+  (hk-deep-force (hk-run (str hk-config-source "main = port devConfig")))
+  8080)
+
+(hk-test
+  "config.hs — remoteConfig new host"
+  (hk-deep-force (hk-run (str hk-config-source "main = host remoteConfig")))
+  "api.example.com")
+
+(hk-test
+  "config.hs — remoteConfig new port"
+  (hk-deep-force (hk-run (str hk-config-source "main = port remoteConfig")))
+  443)
+
+(hk-test
+  "config.hs — remoteConfig preserves retries"
+  (hk-deep-force
+    (hk-run (str hk-config-source "main = retries remoteConfig")))
+  3)
+
+(hk-test
+  "config.hs — remoteConfig preserves debug"
+  (hk-deep-force (hk-run (str hk-config-source "main = debug remoteConfig")))
+  (list "False"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-counter.sx

@@ -0,0 +1,66 @@
+;; counter.hs — IORef-backed mutable counter (Phase 15 conformance).
+
+(define
+  hk-counter-source
+  "import qualified Data.IORef as IORef\n\ncount :: IORef Int -> Int -> IO ()\ncount r 0 = return ()\ncount r n = do\n  IORef.modifyIORef r (\\x -> x + 1)\n  count r (n - 1)\n\ncountBy :: IORef Int -> Int -> Int -> IO ()\ncountBy r step 0 = return ()\ncountBy r step n = do\n  IORef.modifyIORef r (\\x -> x + step)\n  countBy r step (n - 1)\n\nnewCounter :: Int -> IO (IORef Int)\nnewCounter v = IORef.newIORef v\n\nbumpAndRead :: IORef Int -> IO Int\nbumpAndRead r = do\n  IORef.modifyIORef r (\\x -> x + 1)\n  IORef.readIORef r\n\n")
+
+(hk-test
+  "counter.hs — start at 0, count 5 ⇒ 5"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-counter-source
+        "main = do { r <- newCounter 0; count r 5; v <- IORef.readIORef r; return v }")))
+  (list "IO" 5))
+
+(hk-test
+  "counter.hs — start at 100, count 10 ⇒ 110"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-counter-source
+        "main = do { r <- newCounter 100; count r 10; v <- IORef.readIORef r; return v }")))
+  (list "IO" 110))
+
+(hk-test
+  "counter.hs — countBy step 5, n 4 ⇒ 20"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-counter-source
+        "main = do { r <- newCounter 0; countBy r 5 4; v <- IORef.readIORef r; return v }")))
+  (list "IO" 20))
+
+(hk-test
+  "counter.hs — bumpAndRead returns updated value"
+  (hk-deep-force
+    (hk-run
+      (str hk-counter-source "main = do { r <- newCounter 41; bumpAndRead r }")))
+  (list "IO" 42))
+
+(hk-test
+  "counter.hs — count then countBy compose"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-counter-source
+        "main = do { r <- newCounter 0; count r 3; countBy r 10 2; v <- IORef.readIORef r; return v }")))
+  (list "IO" 23))
+
+(hk-test
+  "counter.hs — two independent counters"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-counter-source
+        "main = do { a <- newCounter 0; b <- newCounter 0; count a 7; countBy b 100 2; va <- IORef.readIORef a; vb <- IORef.readIORef b; return (va + vb) }")))
+  (list "IO" 207))
+
+(hk-test
+  "counter.hs — modifyIORef' (strict) variant"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-counter-source
+        "tick r 0 = return ()\ntick r n = do { IORef.modifyIORef' r (\\x -> x + 1); tick r (n - 1) }\nmain = do { r <- newCounter 0; tick r 50; v <- IORef.readIORef r; return v }")))
+  (list "IO" 50))

lib/haskell/tests/program-mapgraph.sx

@@ -0,0 +1,46 @@
+;; mapgraph.hs — adjacency-list using Data.Map (BFS-style traversal).
+;;
+;; Exercises Phase 11: `import qualified Data.Map as Map`, `Map.empty`,
+;; `Map.insert`, `Map.lookup`, `Map.findWithDefault`. Adjacency lists are
+;; stored as `Map Int [Int]`; `neighbors` does a default-empty lookup.
+
+(define
+  hk-mapgraph-source
+  "import qualified Data.Map as Map\n\nemptyG = Map.empty\n\naddEdge u v g = Map.insertWith add u [v] g\n  where add new old = new ++ old\n\nbuild = addEdge 1 2 (addEdge 1 3 (addEdge 2 4 (addEdge 3 4 (addEdge 4 5 emptyG))))\n\nneighbors n g = Map.findWithDefault [] n g\n")
+
+(hk-test
+  "mapgraph.hs — neighbors of 1"
+  (hk-deep-force
+    (hk-run (str hk-mapgraph-source "main = neighbors 1 build\n")))
+  (list ":" 2 (list ":" 3 (list "[]"))))
+
+(hk-test
+  "mapgraph.hs — neighbors of 4"
+  (hk-deep-force
+    (hk-run (str hk-mapgraph-source "main = neighbors 4 build\n")))
+  (list ":" 5 (list "[]")))
+
+(hk-test
+  "mapgraph.hs — neighbors of 5 (leaf, no entry) defaults to []"
+  (hk-deep-force
+    (hk-run (str hk-mapgraph-source "main = neighbors 5 build\n")))
+  (list "[]"))
+
+(hk-test
+  "mapgraph.hs — neighbors of 99 (absent) defaults to []"
+  (hk-deep-force
+    (hk-run (str hk-mapgraph-source "main = neighbors 99 build\n")))
+  (list "[]"))
+
+(hk-test
+  "mapgraph.hs — Map.member 1"
+  (hk-deep-force
+    (hk-run (str hk-mapgraph-source "main = Map.member 1 build\n")))
+  (list "True"))
+
+(hk-test
+  "mapgraph.hs — Map.size = 4 source nodes"
+  (hk-deep-force (hk-run (str hk-mapgraph-source "main = Map.size build\n")))
+  4)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-newton.sx

@@ -0,0 +1,49 @@
+;; newton.hs — Newton's method for square root.
+;; Source: classic numerical analysis exercise.
+;;
+;; Exercises Phase 10: `Float`, `abs`, `/`, iteration via `until`.
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+(define
+  hk-newton-source
+  "improve x guess = (guess + x / guess) / 2\n\ngoodEnough x guess = abs (guess * guess - x) < 0.0001\n\nnewtonSqrt x = newtonHelp x 1.0\n\nnewtonHelp x guess = if goodEnough x guess\n                       then guess\n                       else newtonHelp x (improve x guess)\n")
+
+(hk-test
+  "newton.hs — newtonSqrt 4 ≈ 2"
+  (hk-prog-val
+    (str hk-newton-source "r = abs (newtonSqrt 4.0 - 2.0) < 0.001\n")
+    "r")
+  (list "True"))
+
+(hk-test
+  "newton.hs — newtonSqrt 9 ≈ 3"
+  (hk-prog-val
+    (str hk-newton-source "r = abs (newtonSqrt 9.0 - 3.0) < 0.001\n")
+    "r")
+  (list "True"))
+
+(hk-test
+  "newton.hs — newtonSqrt 2 ≈ 1.41421"
+  (hk-prog-val
+    (str hk-newton-source "r = abs (newtonSqrt 2.0 - 1.41421) < 0.001\n")
+    "r")
+  (list "True"))
+
+(hk-test
+  "newton.hs — improve converges (one step)"
+  (hk-prog-val (str hk-newton-source "r = improve 4.0 1.0\n") "r")
+  2.5)
+
+(hk-test
+  "newton.hs — newtonSqrt 100 ≈ 10"
+  (hk-prog-val
+    (str hk-newton-source "r = abs (newtonSqrt 100.0 - 10.0) < 0.001\n")
+    "r")
+  (list "True"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-partial.sx

@@ -0,0 +1,58 @@
+;; partial.hs — exercises Phase 9 partial functions caught at the top level.
+;;
+;; Each program calls a partial function on bad input; hk-run-io catches the
+;; raise and appends the error message to io-lines so tests can inspect.
+
+(hk-test
+  "partial.hs — main = print (head [])"
+  (let
+    ((lines (hk-run-io "main = print (head [])")))
+    (>= (index-of (str lines) "Prelude.head: empty list") 0))
+  true)
+
+(hk-test
+  "partial.hs — main = print (tail [])"
+  (let
+    ((lines (hk-run-io "main = print (tail [])")))
+    (>= (index-of (str lines) "Prelude.tail: empty list") 0))
+  true)
+
+(hk-test
+  "partial.hs — main = print (fromJust Nothing)"
+  (let
+    ((lines (hk-run-io "main = print (fromJust Nothing)")))
+    (>= (index-of (str lines) "Maybe.fromJust: Nothing") 0))
+  true)
+
+(hk-test
+  "partial.hs — putStrLn before error preserves prior output"
+  (let
+    ((lines (hk-run-io "main = do { putStrLn \"step 1\"; putStrLn (show (head [])); putStrLn \"never\" }")))
+    (and
+      (>= (index-of (str lines) "step 1") 0)
+      (>= (index-of (str lines) "Prelude.head: empty list") 0)
+      (= (index-of (str lines) "never") -1)))
+  true)
+
+(hk-test
+  "partial.hs — undefined as IO action"
+  (let
+    ((lines (hk-run-io "main = print undefined")))
+    (>= (index-of (str lines) "Prelude.undefined") 0))
+  true)
+
+(hk-test
+  "partial.hs — catches error from a user-thrown error"
+  (let
+    ((lines (hk-run-io "main = error \"boom from main\"")))
+    (>= (index-of (str lines) "boom from main") 0))
+  true)
+
+;; Negative case: when no error is raised, io-lines doesn't contain
+;; "Prelude" prefixes from our error path.
+(hk-test
+  "partial.hs — happy path: head [42] succeeds, no error in output"
+  (hk-run-io "main = print (head [42])")
+  (list "42"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-person.sx

@@ -0,0 +1,51 @@
+;; person.hs — record type with accessors, update, deriving Show.
+;;
+;; Exercises Phase 14: data with record syntax, accessor functions,
+;; record creation, record update, deriving Show on a record.
+
+(define
+  hk-person-source
+  "data Person = Person { name :: String, age :: Int } deriving (Show)\n\nalice = Person { name = \"alice\", age = 30 }\nbob = Person { name = \"bob\", age = 25 }\n\nbirthday p = p { age = age p + 1 }\n")
+
+(hk-test
+  "person.hs — alice's name"
+  (hk-deep-force (hk-run (str hk-person-source "main = name alice")))
+  "alice")
+
+(hk-test
+  "person.hs — alice's age"
+  (hk-deep-force (hk-run (str hk-person-source "main = age alice")))
+  30)
+
+(hk-test
+  "person.hs — birthday adds one year"
+  (hk-deep-force
+    (hk-run (str hk-person-source "main = age (birthday alice)")))
+  31)
+
+(hk-test
+  "person.hs — birthday preserves name"
+  (hk-deep-force
+    (hk-run (str hk-person-source "main = name (birthday alice)")))
+  "alice")
+
+(hk-test
+  "person.hs — show alice"
+  (hk-deep-force (hk-run (str hk-person-source "main = show alice")))
+  "Person \"alice\" 30")
+
+(hk-test
+  "person.hs — bob has different name"
+  (hk-deep-force (hk-run (str hk-person-source "main = name bob")))
+  "bob")
+
+(hk-test
+  "person.hs — pattern match in function"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "greet (Person { name = n }) = \"Hi, \" ++ n\nmain = greet alice")))
+  "Hi, alice")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-runlength-str.sx

@@ -0,0 +1,83 @@
+;; runlength-str.hs — run-length encoding on a String.
+;; Source: https://rosettacode.org/wiki/Run-length_encoding#Haskell (adapted).
+;;
+;; Exercises String pattern matching `(x:xs)`, `span` over a string view,
+;; tuple construction `(Int, Char)`, character equality, and tuple-in-cons
+;; patterns `((n, c) : rest)` — all enabled by Phase 7 string=[Char].
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+(define
+  hk-as-list
+  (fn
+    (xs)
+    (cond
+      ((and (list? xs) (= (first xs) "[]")) (list))
+      ((and (list? xs) (= (first xs) ":"))
+        (cons (nth xs 1) (hk-as-list (nth xs 2))))
+      (:else xs))))
+
+(define
+  hk-rle-source
+  "encodeRL []     = []\nencodeRL (x:xs) = let (same, rest) = span eqX xs\n                      eqX y         = y == x\n                  in (1 + length same, x) : encodeRL rest\n\nreplicateRL 0 _ = []\nreplicateRL n c = c : replicateRL (n - 1) c\n\ndecodeRL []                = []\ndecodeRL ((n, c) : rest)   = replicateRL n c ++ decodeRL rest\n")
+
+(hk-test
+  "rle.hs — encodeRL [] = []"
+  (hk-as-list (hk-prog-val (str hk-rle-source "r = encodeRL \"\"\n") "r"))
+  (list))
+
+(hk-test
+  "rle.hs — length (encodeRL \"aabbbcc\") = 3"
+  (hk-prog-val (str hk-rle-source "r = length (encodeRL \"aabbbcc\")\n") "r")
+  3)
+
+(hk-test
+  "rle.hs — map fst (encodeRL \"aabbbcc\") = [2,3,2]"
+  (hk-as-list
+    (hk-prog-val (str hk-rle-source "r = map fst (encodeRL \"aabbbcc\")\n") "r"))
+  (list 2 3 2))
+
+(hk-test
+  "rle.hs — map snd (encodeRL \"aabbbcc\") = [97,98,99]"
+  (hk-as-list
+    (hk-prog-val (str hk-rle-source "r = map snd (encodeRL \"aabbbcc\")\n") "r"))
+  (list 97 98 99))
+
+(hk-test
+  "rle.hs — counts of encodeRL \"aabbbccddddee\" = [2,3,2,4,2]"
+  (hk-as-list
+    (hk-prog-val
+      (str hk-rle-source "r = map fst (encodeRL \"aabbbccddddee\")\n")
+      "r"))
+  (list 2 3 2 4 2))
+
+(hk-test
+  "rle.hs — chars of encodeRL \"aabbbccddddee\" = [97,98,99,100,101]"
+  (hk-as-list
+    (hk-prog-val
+      (str hk-rle-source "r = map snd (encodeRL \"aabbbccddddee\")\n")
+      "r"))
+  (list 97 98 99 100 101))
+
+(hk-test
+  "rle.hs — singleton encodeRL \"x\""
+  (hk-as-list
+    (hk-prog-val (str hk-rle-source "r = map fst (encodeRL \"x\")\n") "r"))
+  (list 1))
+
+(hk-test
+  "rle.hs — decodeRL round-trip preserves \"aabbbcc\""
+  (hk-as-list
+    (hk-prog-val (str hk-rle-source "r = decodeRL (encodeRL \"aabbbcc\")\n") "r"))
+  (list 97 97 98 98 98 99 99))
+
+(hk-test
+  "rle.hs — replicateRL 4 65 = [65,65,65,65]"
+  (hk-as-list (hk-prog-val (str hk-rle-source "r = replicateRL 4 65\n") "r"))
+  (list 65 65 65 65))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-safediv.sx

@@ -0,0 +1,80 @@
+;; safediv.hs — safe division using catch (Phase 16 conformance).
+
+(define
+  hk-safediv-source
+  "safeDiv :: Int -> Int -> IO Int
+safeDiv _ 0 = throwIO (SomeException \"division by zero\")
+safeDiv x y = return (x `div` y)
+
+guarded :: Int -> Int -> IO Int
+guarded x y = catch (safeDiv x y) (\\(SomeException _) -> return 0)
+
+reason :: Int -> Int -> IO String
+reason x y = catch (safeDiv x y `seq` return \"ok\")
+  (\\(SomeException m) -> return m)
+
+bothBranches :: Int -> Int -> IO Int
+bothBranches x y = do
+  v <- catch (safeDiv x y) (\\(SomeException _) -> return (-1))
+  return (v + 100)
+
+")
+
+(hk-test
+  "safediv.hs — divide by non-zero"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source "main = guarded 10 2")))
+  (list "IO" 5))
+
+(hk-test
+  "safediv.hs — divide by zero returns 0"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source "main = guarded 10 0")))
+  (list "IO" 0))
+
+(hk-test
+  "safediv.hs — divide by zero — reason captured"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source "main = catch (safeDiv 1 0) (\\(SomeException m) -> return 0) >> reason 1 0")))
+  (list "IO" "division by zero"))
+
+(hk-test
+  "safediv.hs — bothBranches success path"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source "main = bothBranches 8 2")))
+  (list "IO" 104))
+
+(hk-test
+  "safediv.hs — bothBranches failure path"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source "main = bothBranches 8 0")))
+  (list "IO" 99))
+
+(hk-test
+  "safediv.hs — chained safeDiv with catch"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source
+        "main = do { a <- guarded 20 4; b <- guarded 7 0; return (a + b) }")))
+  (list "IO" 5))
+
+(hk-test
+  "safediv.hs — try then bind through Either"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source
+        "main = do { r <- try (safeDiv 1 0); case r of { Right v -> return v; Left (SomeException m) -> return 999 } }")))
+  (list "IO" 999))
+
+(hk-test
+  "safediv.hs — handle (flip catch)"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source
+        "main = handle (\\(SomeException _) -> return 0) (safeDiv 5 0)")))
+  (list "IO" 0))

lib/haskell/tests/program-setops.sx

@@ -0,0 +1,61 @@
+;; setops.hs — set union/intersection/difference on integer sets.
+;;
+;; Exercises Phase 12: `import qualified Data.Set as Set`, all three
+;; combining operations + isSubsetOf.
+
+(define
+  hk-setops-source
+  "import qualified Data.Set as Set\n\ns1 = Set.insert 1 (Set.insert 2 (Set.insert 3 Set.empty))\ns2 = Set.insert 3 (Set.insert 4 (Set.insert 5 Set.empty))\ns3 = Set.insert 1 (Set.insert 2 Set.empty)\n")
+
+(hk-test
+  "setops.hs — union size = 5"
+  (hk-deep-force
+    (hk-run (str hk-setops-source "main = Set.size (Set.union s1 s2)\n")))
+  5)
+
+(hk-test
+  "setops.hs — intersection size = 1"
+  (hk-deep-force
+    (hk-run
+      (str hk-setops-source "main = Set.size (Set.intersection s1 s2)\n")))
+  1)
+
+(hk-test
+  "setops.hs — intersection contains 3"
+  (hk-deep-force
+    (hk-run
+      (str hk-setops-source "main = Set.member 3 (Set.intersection s1 s2)\n")))
+  (list "True"))
+
+(hk-test
+  "setops.hs — difference s1 s2 size = 2"
+  (hk-deep-force
+    (hk-run (str hk-setops-source "main = Set.size (Set.difference s1 s2)\n")))
+  2)
+
+(hk-test
+  "setops.hs — difference doesn't contain shared key"
+  (hk-deep-force
+    (hk-run
+      (str hk-setops-source "main = Set.member 3 (Set.difference s1 s2)\n")))
+  (list "False"))
+
+(hk-test
+  "setops.hs — s3 is subset of s1"
+  (hk-deep-force
+    (hk-run (str hk-setops-source "main = Set.isSubsetOf s3 s1\n")))
+  (list "True"))
+
+(hk-test
+  "setops.hs — s1 not subset of s3"
+  (hk-deep-force
+    (hk-run (str hk-setops-source "main = Set.isSubsetOf s1 s3\n")))
+  (list "False"))
+
+(hk-test
+  "setops.hs — empty set is subset of anything"
+  (hk-deep-force
+    (hk-run (str hk-setops-source "main = Set.isSubsetOf Set.empty s1\n")))
+  (list "True"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-shapes.sx

@@ -0,0 +1,40 @@
+;; shapes.hs — class Area with a default perimeter, two instances
+;;             using where-local helpers.
+;;
+;; Exercises Phase 13: class default method (perimeter), instance
+;; methods that use `where`-bindings.
+
+(define
+  hk-shapes-source
+  "class Shape a where\n  area :: a -> Int\n  perimeter :: a -> Int\n  perimeter x = quadrilateral x\n    where quadrilateral y = 2 * (sideA y + sideB y)\n          sideA z = 1\n          sideB z = 1\n\ndata Square = Square Int\ndata Rect = Rect Int Int\n\ninstance Shape Square where\n  area (Square s) = s * s\n  perimeter (Square s) = 4 * s\n\ninstance Shape Rect where\n  area (Rect w h) = w * h\n  perimeter (Rect w h) = peri\n    where peri = 2 * (w + h)\n")
+
+(hk-test
+  "shapes.hs — area of Square 5 = 25"
+  (hk-deep-force (hk-run (str hk-shapes-source "main = area (Square 5)\n")))
+  25)
+
+(hk-test
+  "shapes.hs — perimeter of Square 5 = 20"
+  (hk-deep-force
+    (hk-run (str hk-shapes-source "main = perimeter (Square 5)\n")))
+  20)
+
+(hk-test
+  "shapes.hs — area of Rect 3 4 = 12"
+  (hk-deep-force (hk-run (str hk-shapes-source "main = area (Rect 3 4)\n")))
+  12)
+
+(hk-test
+  "shapes.hs — perimeter of Rect 3 4 = 14 (via where-bound)"
+  (hk-deep-force
+    (hk-run (str hk-shapes-source "main = perimeter (Rect 3 4)\n")))
+  14)
+
+(hk-test
+  "shapes.hs — Square sums area + perimeter"
+  (hk-deep-force
+    (hk-run
+      (str hk-shapes-source "main = area (Square 4) + perimeter (Square 4)\n")))
+  32)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-showadt.sx

@@ -0,0 +1,45 @@
+;; showadt.hs — `deriving (Show)` on a multi-constructor recursive ADT.
+;; Source: classic exposition example, e.g. Real World Haskell ch.6.
+;;
+;; Exercises Phase 8: `deriving (Show)` on an ADT whose constructors recurse
+;; into themselves; precedence-based paren wrapping for nested arguments;
+;; `print` from the prelude (which is `putStrLn (show x)`).
+
+(define
+  hk-showadt-source
+  "data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\n\nmain = do\n  print (Lit 3)\n  print (Add (Lit 1) (Lit 2))\n  print (Mul (Lit 3) (Add (Lit 4) (Lit 5)))\n")
+
+(hk-test
+  "showadt.hs — main prints three lines"
+  (hk-run-io hk-showadt-source)
+  (list "Lit 3" "Add (Lit 1) (Lit 2)" "Mul (Lit 3) (Add (Lit 4) (Lit 5))"))
+
+(hk-test
+  "showadt.hs — show Lit 3"
+  (hk-deep-force
+    (hk-run
+      "data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Lit 3)"))
+  "Lit 3")
+
+(hk-test
+  "showadt.hs — show Add wraps both args"
+  (hk-deep-force
+    (hk-run
+      "data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Add (Lit 1) (Lit 2))"))
+  "Add (Lit 1) (Lit 2)")
+
+(hk-test
+  "showadt.hs — fully nested Mul of Adds"
+  (hk-deep-force
+    (hk-run
+      "data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Mul (Add (Lit 1) (Lit 2)) (Add (Lit 3) (Lit 4)))"))
+  "Mul (Add (Lit 1) (Lit 2)) (Add (Lit 3) (Lit 4))")
+
+(hk-test
+  "showadt.hs — Lit with negative literal wraps int in parens"
+  (hk-deep-force
+    (hk-run
+      "data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Lit (negate 7))"))
+  "Lit (-7)")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-showio.sx

@@ -0,0 +1,36 @@
+;; showio.hs — `print` on various types inside a `do` block.
+;;
+;; Exercises Phase 8 `print x = putStrLn (show x)` and the IO monad's
+;; statement sequencing. Each `print` produces one io-line.
+
+(define
+  hk-showio-source
+  "main = do\n  print 42\n  print True\n  print False\n  print [1,2,3]\n  print (1, 2)\n  print (Just 5)\n  print Nothing\n  print \"hello\"\n")
+
+(hk-test
+  "showio.hs — main produces 8 lines, all show-formatted"
+  (hk-run-io hk-showio-source)
+  (list "42" "True" "False" "[1,2,3]" "(1,2)" "Just 5" "Nothing" "\"hello\""))
+
+(hk-test
+  "showio.hs — print Int alone"
+  (hk-run-io "main = print 42")
+  (list "42"))
+
+(hk-test
+  "showio.hs — print list of Maybe"
+  (hk-run-io "main = print [Just 1, Nothing, Just 3]")
+  (list "[Just 1,Nothing,Just 3]"))
+
+(hk-test
+  "showio.hs — print nested tuple"
+  (hk-run-io "main = print ((1, 2), (3, 4))")
+  (list "((1,2),(3,4))"))
+
+(hk-test
+  "showio.hs — print derived ADT inside do"
+  (hk-run-io
+    "data Color = Red | Green | Blue deriving (Show)\nmain = do { print Red; print Green; print Blue }")
+  (list "Red" "Green" "Blue"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-statistics.sx

@@ -0,0 +1,45 @@
+;; statistics.hs — mean, variance, std-dev on a [Double].
+;; Source: classic textbook example.
+;;
+;; Exercises Phase 10: `fromIntegral`, `/`, `sqrt`, list ops on `[Double]`.
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+(define
+  hk-stats-source
+  "mean xs = sum xs / fromIntegral (length xs)\n\nvariance xs = let m = mean xs\n                  sqDiff x = (x - m) * (x - m)\n              in sum (map sqDiff xs) / fromIntegral (length xs)\n\nstdDev xs = sqrt (variance xs)\n")
+
+(hk-test
+  "statistics.hs — mean [1,2,3,4,5] = 3"
+  (hk-prog-val (str hk-stats-source "r = mean [1.0,2.0,3.0,4.0,5.0]\n") "r")
+  3)
+
+(hk-test
+  "statistics.hs — mean [10,20,30] = 20"
+  (hk-prog-val (str hk-stats-source "r = mean [10.0,20.0,30.0]\n") "r")
+  20)
+
+(hk-test
+  "statistics.hs — variance [2,4,4,4,5,5,7,9] = 4"
+  (hk-prog-val
+    (str hk-stats-source "r = variance [2.0,4.0,4.0,4.0,5.0,5.0,7.0,9.0]\n")
+    "r")
+  4)
+
+(hk-test
+  "statistics.hs — stdDev [2,4,4,4,5,5,7,9] = 2"
+  (hk-prog-val
+    (str hk-stats-source "r = stdDev [2.0,4.0,4.0,4.0,5.0,5.0,7.0,9.0]\n")
+    "r")
+  2)
+
+(hk-test
+  "statistics.hs — variance of constant list = 0"
+  (hk-prog-val (str hk-stats-source "r = variance [5.0,5.0,5.0,5.0]\n") "r")
+  0)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-trycatch.sx

@@ -0,0 +1,95 @@
+;; trycatch.hs — try pattern: branch on Left/Right (Phase 16 conformance).
+
+(define
+  hk-trycatch-source
+  "parseInt :: String -> IO Int
+parseInt \"zero\" = return 0
+parseInt \"one\"  = return 1
+parseInt \"two\"  = return 2
+parseInt s = throwIO (SomeException (\"unknown: \" ++ s))
+
+describe :: Either SomeException Int -> String
+describe (Right v) = \"got \" ++ show v
+describe (Left (SomeException m)) = \"err: \" ++ m
+
+trial :: String -> IO String
+trial s = do
+  r <- try (parseInt s)
+  return (describe r)
+
+run3 :: String -> String -> String -> IO [String]
+run3 a b c = do
+  ra <- trial a
+  rb <- trial b
+  rc <- trial c
+  return [ra, rb, rc]
+
+")
+
+(hk-test
+  "trycatch.hs — Right branch"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source "main = trial \"one\"")))
+  (list "IO" "got 1"))
+
+(hk-test
+  "trycatch.hs — Left branch with message"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source "main = trial \"banana\"")))
+  (list "IO" "err: unknown: banana"))
+
+(hk-test
+  "trycatch.hs — chain over three inputs, all good"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source "main = run3 \"zero\" \"one\" \"two\"")))
+  (list "IO"
+    (list ":" "got 0"
+      (list ":" "got 1"
+        (list ":" "got 2"
+          (list "[]"))))))
+
+(hk-test
+  "trycatch.hs — chain over three inputs, mixed"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source "main = run3 \"zero\" \"qux\" \"two\"")))
+  (list "IO"
+    (list ":" "got 0"
+      (list ":" "err: unknown: qux"
+        (list ":" "got 2"
+          (list "[]"))))))
+
+(hk-test
+  "trycatch.hs — Left from throwIO carries message"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source
+        "main = do { r <- try (throwIO (SomeException \"explicit\")); return (describe r) }")))
+  (list "IO" "err: explicit"))
+
+(hk-test
+  "trycatch.hs — Right preserves the int"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source
+        "main = do { r <- try (return 42); return (describe r) }")))
+  (list "IO" "got 42"))
+
+(hk-test
+  "trycatch.hs — pattern-bind on Right inside do"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source
+        "main = do { Right v <- try (parseInt \"two\"); return (v + 100) }")))
+  (list "IO" 102))
+
+(hk-test
+  "trycatch.hs — handle alias on parseInt failure"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source
+        "main = handle (\\(SomeException m) -> return (\"caught: \" ++ m)) (parseInt \"nope\" >>= (\\v -> return (show v)))")))
+  (list "IO" "caught: unknown: nope"))

lib/haskell/tests/program-uniquewords.sx

@@ -0,0 +1,35 @@
+;; uniquewords.hs — count unique words using Data.Set.
+;;
+;; Exercises Phase 12: `import qualified Data.Set as Set`, `Set.empty`,
+;; `Set.insert`, `Set.size`, `foldl`.
+
+(define
+  hk-uniquewords-source
+  "import qualified Data.Set as Set\n\naddWord s w = Set.insert w s\n\nuniqueWords ws = foldl addWord Set.empty ws\n\nresult = uniqueWords [\"the\", \"cat\", \"the\", \"dog\", \"the\", \"cat\"]\n")
+
+(hk-test
+  "uniquewords.hs — unique count = 3"
+  (hk-deep-force
+    (hk-run (str hk-uniquewords-source "main = Set.size result\n")))
+  3)
+
+(hk-test
+  "uniquewords.hs — \"the\" present"
+  (hk-deep-force
+    (hk-run (str hk-uniquewords-source "main = Set.member \"the\" result\n")))
+  (list "True"))
+
+(hk-test
+  "uniquewords.hs — \"missing\" absent"
+  (hk-deep-force
+    (hk-run (str hk-uniquewords-source "main = Set.member \"missing\" result\n")))
+  (list "False"))
+
+(hk-test
+  "uniquewords.hs — empty list yields empty set"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Set as Set\nmain = Set.size (foldl (\\s w -> Set.insert w s) Set.empty [])"))
+  0)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-wordfreq.sx

@@ -0,0 +1,54 @@
+;; wordfreq.hs — word-frequency histogram using Data.Map.
+;; Source: Rosetta Code "Word frequency" (Haskell entry, simplified).
+;;
+;; Exercises Phase 11: `import qualified Data.Map as Map`, `Map.empty`,
+;; `Map.insertWith`, `Map.lookup`, `Map.findWithDefault`, `foldl`.
+
+(define
+  hk-wordfreq-source
+  "import qualified Data.Map as Map\n\ncountWord m w = Map.insertWith (+) w 1 m\n\nwordFreq xs = foldl countWord Map.empty xs\n\nresult = wordFreq [\"the\", \"cat\", \"the\", \"dog\", \"the\", \"cat\"]\n")
+
+(hk-test
+  "wordfreq.hs — \"the\" counted 3 times"
+  (hk-deep-force
+    (hk-run (str hk-wordfreq-source "main = Map.lookup \"the\" result\n")))
+  (list "Just" 3))
+
+(hk-test
+  "wordfreq.hs — \"cat\" counted 2 times"
+  (hk-deep-force
+    (hk-run (str hk-wordfreq-source "main = Map.lookup \"cat\" result\n")))
+  (list "Just" 2))
+
+(hk-test
+  "wordfreq.hs — \"dog\" counted 1 time"
+  (hk-deep-force
+    (hk-run (str hk-wordfreq-source "main = Map.lookup \"dog\" result\n")))
+  (list "Just" 1))
+
+(hk-test
+  "wordfreq.hs — \"missing\" not present"
+  (hk-deep-force
+    (hk-run (str hk-wordfreq-source "main = Map.lookup \"missing\" result\n")))
+  (list "Nothing"))
+
+(hk-test
+  "wordfreq.hs — Map.size = 3 unique words"
+  (hk-deep-force (hk-run (str hk-wordfreq-source "main = Map.size result\n")))
+  3)
+
+(hk-test
+  "wordfreq.hs — findWithDefault for missing returns 0"
+  (hk-deep-force
+    (hk-run
+      (str hk-wordfreq-source "main = Map.findWithDefault 0 \"absent\" result\n")))
+  0)
+
+(hk-test
+  "wordfreq.hs — findWithDefault for present returns count"
+  (hk-deep-force
+    (hk-run
+      (str hk-wordfreq-source "main = Map.findWithDefault 0 \"the\" result\n")))
+  3)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/records.sx

@@ -0,0 +1,127 @@
+;; records.sx — Phase 14 record syntax tests.
+
+(define
+  hk-person-source
+  "data Person = Person { name :: String, age :: Int }\n")
+
+(define hk-pt-source "data Pt = Pt { x :: Int, y :: Int }\n")
+
+;; ── Creation ────────────────────────────────────────────────
+(hk-test
+  "creation: Person { name = \"a\", age = 1 } via accessor name"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "main = name (Person { name = \"alice\", age = 30 })")))
+  "alice")
+
+(hk-test
+  "creation: source order doesn't matter (age first)"
+  (hk-deep-force
+    (hk-run
+      (str hk-person-source "main = name (Person { age = 99, name = \"bob\" })")))
+  "bob")
+
+(hk-test
+  "creation: age accessor returns the right field"
+  (hk-deep-force
+    (hk-run
+      (str hk-person-source "main = age (Person { age = 99, name = \"bob\" })")))
+  99)
+
+;; ── Accessors ──────────────────────────────────────────────
+(hk-test
+  "accessor: x of Pt"
+  (hk-deep-force
+    (hk-run (str hk-pt-source "main = x (Pt { x = 7, y = 99 })")))
+  7)
+
+(hk-test
+  "accessor: y of Pt"
+  (hk-deep-force
+    (hk-run (str hk-pt-source "main = y (Pt { x = 7, y = 99 })")))
+  99)
+
+;; ── Update — single field ──────────────────────────────────
+(hk-test
+  "update one field: age changes"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "alice = Person { name = \"alice\", age = 30 }\nmain = age (alice { age = 31 })")))
+  31)
+
+(hk-test
+  "update one field: name preserved"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "alice = Person { name = \"alice\", age = 30 }\nmain = name (alice { age = 31 })")))
+  "alice")
+
+;; ── Update — two fields ────────────────────────────────────
+(hk-test
+  "update two fields: both changed"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "alice = Person { name = \"alice\", age = 30 }\nbob = alice { name = \"bob\", age = 50 }\nmain = age bob")))
+  50)
+
+(hk-test
+  "update two fields: name takes new value"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "alice = Person { name = \"alice\", age = 30 }\nbob = alice { name = \"bob\", age = 50 }\nmain = name bob")))
+  "bob")
+
+;; ── Record patterns ────────────────────────────────────────
+(hk-test
+  "case-alt record pattern: Pt { x = a }"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-pt-source
+        "getX p = case p of Pt { x = a } -> a\nmain = getX (Pt { x = 7, y = 99 })")))
+  7)
+
+(hk-test
+  "case-alt record pattern: multi-field bind"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-pt-source
+        "sumPt p = case p of Pt { x = a, y = b } -> a + b\nmain = sumPt (Pt { x = 3, y = 4 })")))
+  7)
+
+(hk-test
+  "fun-LHS record pattern"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "getName (Person { name = n }) = n\nmain = getName (Person { name = \"alice\", age = 30 })")))
+  "alice")
+
+;; ── deriving Show on a record ───────────────────────────────
+(hk-test
+  "deriving Show on a record produces positional output"
+  (hk-deep-force
+    (hk-run
+      "data Person = Person { name :: String, age :: Int } deriving (Show)\nmain = show (Person { name = \"alice\", age = 30 })"))
+  "Person \"alice\" 30")
+
+(hk-test
+  "deriving Show on Pt"
+  (hk-deep-force
+    (hk-run
+      "data Pt = Pt { x :: Int, y :: Int } deriving (Show)\nmain = show (Pt { x = 3, y = 4 })"))
+  "Pt 3 4")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/set.sx

@@ -0,0 +1,119 @@
+;; set.sx — Phase 12 Data.Set unit tests.
+
+;; ── SX-level (direct hk-set-*) ───────────────────────────────
+(hk-test
+  "hk-set-empty: size 0 + null"
+  (list (hk-set-size hk-set-empty) (hk-set-null hk-set-empty))
+  (list 0 true))
+
+(hk-test
+  "hk-set-singleton: member yes"
+  (let
+    ((s (hk-set-singleton 5)))
+    (list (hk-set-size s) (hk-set-member 5 s) (hk-set-member 99 s)))
+  (list 1 true false))
+
+(hk-test
+  "hk-set-insert: idempotent"
+  (let
+    ((s (hk-set-insert 1 (hk-set-insert 1 hk-set-empty))))
+    (hk-set-size s))
+  1)
+
+(hk-test
+  "hk-set-from-list: dedupes"
+  (hk-set-to-asc-list (hk-set-from-list (list 3 1 4 1 5 9 2 6)))
+  (list 1 2 3 4 5 6 9))
+
+(hk-test
+  "hk-set-delete: removes"
+  (let
+    ((s (hk-set-from-list (list 1 2 3))))
+    (hk-set-to-asc-list (hk-set-delete 2 s)))
+  (list 1 3))
+
+(hk-test
+  "hk-set-union"
+  (hk-set-to-asc-list
+    (hk-set-union
+      (hk-set-from-list (list 1 2 3))
+      (hk-set-from-list (list 3 4 5))))
+  (list 1 2 3 4 5))
+
+(hk-test
+  "hk-set-intersection"
+  (hk-set-to-asc-list
+    (hk-set-intersection
+      (hk-set-from-list (list 1 2 3 4))
+      (hk-set-from-list (list 3 4 5 6))))
+  (list 3 4))
+
+(hk-test
+  "hk-set-difference"
+  (hk-set-to-asc-list
+    (hk-set-difference
+      (hk-set-from-list (list 1 2 3 4))
+      (hk-set-from-list (list 3 4 5))))
+  (list 1 2))
+
+(hk-test
+  "hk-set-is-subset-of: yes"
+  (hk-set-is-subset-of
+    (hk-set-from-list (list 2 3))
+    (hk-set-from-list (list 1 2 3 4)))
+  true)
+
+(hk-test
+  "hk-set-is-subset-of: no"
+  (hk-set-is-subset-of
+    (hk-set-from-list (list 5 6))
+    (hk-set-from-list (list 1 2 3 4)))
+  false)
+
+(hk-test
+  "hk-set-filter"
+  (hk-set-to-asc-list
+    (hk-set-filter (fn (k) (> k 2)) (hk-set-from-list (list 1 2 3 4 5))))
+  (list 3 4 5))
+
+(hk-test
+  "hk-set-map"
+  (hk-set-to-asc-list
+    (hk-set-map (fn (k) (* k 10)) (hk-set-from-list (list 1 2 3))))
+  (list 10 20 30))
+
+(hk-test
+  "hk-set-foldr: sum"
+  (hk-set-foldr + 0 (hk-set-from-list (list 1 2 3 4 5)))
+  15)
+
+;; ── Haskell-level (Set.* via import wiring) ──────────────────
+(hk-test
+  "Set.size after Set.insert chain"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Set as Set\nmain = Set.size (Set.insert 3 (Set.insert 1 (Set.insert 2 Set.empty)))"))
+  3)
+
+(hk-test
+  "Set.member true"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Set as Set\nmain = Set.member 5 (Set.insert 5 Set.empty)"))
+  (list "True"))
+
+(hk-test
+  "Set.union via Haskell"
+  (hk-deep-force
+    (hk-run
+      "import Data.Set\nmain = Set.size (Set.union (Set.insert 1 Set.empty) (Set.insert 2 Set.empty))"))
+  2)
+
+(hk-test
+  "Set.isSubsetOf via Haskell"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Set as S\nmain = S.isSubsetOf (S.insert 1 S.empty) (S.insert 2 (S.insert 1 S.empty))"))
+  (list "True"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/show.sx

@@ -0,0 +1,140 @@
+;; show.sx — tests for the Show / Read class plumbing.
+;;
+;; Covers Phase 8:
+;;  - showsPrec / showParen / shows / showString stubs
+;;  - Read class stubs (reads / readsPrec / read)
+;;  - direct show coverage (Int, Bool, String, list, tuple, Maybe, ADT, ...)
+
+;; ── ShowS / showsPrec / showParen stubs ──────────────────────
+(hk-test
+  "shows: prepends show output"
+  (hk-deep-force (hk-run "main = shows 5 \"abc\""))
+  "5abc")
+
+(hk-test
+  "shows: works on True"
+  (hk-deep-force (hk-run "main = shows True \"x\""))
+  "Truex")
+
+(hk-test
+  "showString: prepends literal"
+  (hk-deep-force (hk-run "main = showString \"hello\" \" world\""))
+  "hello world")
+
+(hk-test
+  "showParen True: wraps inner output in parens"
+  (hk-deep-force (hk-run "main = showParen True (showString \"inside\") \"\""))
+  "(inside)")
+
+(hk-test
+  "showParen False: passes through unchanged"
+  (hk-deep-force (hk-run "main = showParen False (showString \"inside\") \"\""))
+  "inside")
+
+(hk-test
+  "showsPrec: prepends show output regardless of prec"
+  (hk-deep-force (hk-run "main = showsPrec 11 42 \"end\""))
+  "42end")
+
+(hk-test
+  "showParen + manual composition: build (Just 3)"
+  (hk-deep-force
+    (hk-run
+      "buildJust3 s = showString \"Just \" (shows 3 s)\nmain = showParen True buildJust3 \"\""))
+  "(Just 3)")
+
+;; ── Read stubs ───────────────────────────────────────────────
+(hk-test
+  "reads: stub returns empty list (null-check)"
+  (hk-deep-force (hk-run "main = show (null (reads \"42\"))"))
+  "True")
+
+(hk-test
+  "readsPrec: stub returns empty list"
+  (hk-deep-force (hk-run "main = show (null (readsPrec 0 \"True\"))"))
+  "True")
+
+(hk-test
+  "reads: type-checks in expression context (length)"
+  (hk-deep-force (hk-run "main = show (length (reads \"abc\"))"))
+  "0")
+
+;; ── Direct `show` audit coverage ─────────────────────────────
+(hk-test "show Int" (hk-deep-force (hk-run "main = show 42")) "42")
+
+(hk-test
+  "show negative Int"
+  (hk-deep-force (hk-run "main = show (negate 5)"))
+  "-5")
+
+(hk-test "show Bool True" (hk-deep-force (hk-run "main = show True")) "True")
+
+(hk-test
+  "show Bool False"
+  (hk-deep-force (hk-run "main = show False"))
+  "False")
+
+(hk-test
+  "show String quotes the value"
+  (hk-deep-force (hk-run "main = show \"hello\""))
+  "\"hello\"")
+
+(hk-test
+  "show list of Int"
+  (hk-deep-force (hk-run "main = show [1,2,3]"))
+  "[1,2,3]")
+
+(hk-test
+  "show empty list"
+  (hk-deep-force (hk-run "main = show (drop 5 [1,2,3])"))
+  "[]")
+
+(hk-test
+  "show pair tuple"
+  (hk-deep-force (hk-run "main = show (1, True)"))
+  "(1,True)")
+
+(hk-test
+  "show triple tuple"
+  (hk-deep-force (hk-run "main = show (1, 2, 3)"))
+  "(1,2,3)")
+
+(hk-test
+  "show Maybe Nothing"
+  (hk-deep-force (hk-run "main = show Nothing"))
+  "Nothing")
+
+(hk-test
+  "show Maybe Just"
+  (hk-deep-force (hk-run "main = show (Just 3)"))
+  "Just 3")
+
+(hk-test
+  "show nested Just wraps inner in parens"
+  (hk-deep-force (hk-run "main = show (Just (Just 3))"))
+  "Just (Just 3)")
+
+(hk-test
+  "show Just (negate 3) wraps negative in parens"
+  (hk-deep-force (hk-run "main = show (Just (negate 3))"))
+  "Just (-3)")
+
+(hk-test
+  "show custom nullary ADT"
+  (hk-deep-force
+    (hk-run "data Day = Mon | Tue | Wed deriving (Show)\nmain = show Tue"))
+  "Tue")
+
+(hk-test
+  "show custom multi-constructor ADT"
+  (hk-deep-force
+    (hk-run
+      "data Shape = Pt | Sq Int | Rect Int Int deriving (Show)\nmain = show (Rect 3 4)"))
+  "Rect 3 4")
+
+(hk-test
+  "show list of Maybe wraps each element"
+  (hk-deep-force (hk-run "main = show [Just 1, Nothing, Just 2]"))
+  "[Just 1,Nothing,Just 2]")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/stdlib.sx

@@ -37,11 +37,11 @@
 (hk-ts "show neg" "negate 7" "-7")
 (hk-ts "show bool T" "True" "True")
 (hk-ts "show bool F" "False" "False")
-(hk-ts "show list" "[1,2,3]" "[1, 2, 3]")
-(hk-ts "show Just" "Just 5" "(Just 5)")
+(hk-ts "show list" "[1,2,3]" "[1,2,3]")
+(hk-ts "show Just" "Just 5" "Just 5")
 (hk-ts "show Nothing" "Nothing" "Nothing")
 (hk-ts "show LT" "LT" "LT")
-(hk-ts "show tuple" "(1, True)" "(1, True)")
+(hk-ts "show tuple" "(1, True)" "(1,True)")
 
 ;; ── Num extras ───────────────────────────────────────────────
 (hk-test "signum pos" (hk-deep-force (hk-run "main = signum 5")) 1)
@@ -59,13 +59,13 @@
 (hk-test
   "foldr cons"
   (hk-deep-force (hk-run "main = show (foldr (:) [] [1,2,3])"))
-  "[1, 2, 3]")
+  "[1,2,3]")
 
 ;; ── List ops ─────────────────────────────────────────────────
 (hk-test
   "reverse"
   (hk-deep-force (hk-run "main = show (reverse [1,2,3])"))
-  "[3, 2, 1]")
+  "[3,2,1]")
 (hk-test "null []" (hk-deep-force (hk-run "main = null []")) (list "True"))
 (hk-test
   "null xs"
@@ -82,7 +82,7 @@
 (hk-test
   "zip"
   (hk-deep-force (hk-run "main = show (zip [1,2] [3,4])"))
-  "[(1, 3), (2, 4)]")
+  "[(1,3),(2,4)]")
 (hk-test "sum" (hk-deep-force (hk-run "main = sum [1,2,3,4,5]")) 15)
 (hk-test "product" (hk-deep-force (hk-run "main = product [1,2,3,4]")) 24)
 (hk-test "maximum" (hk-deep-force (hk-run "main = maximum [3,1,9,2]")) 9)
@@ -112,7 +112,7 @@
 (hk-test
   "fmap list"
   (hk-deep-force (hk-run "main = show (fmap (+1) [1,2,3])"))
-  "[2, 3, 4]")
+  "[2,3,4]")
 
 ;; ── Monad / Applicative ──────────────────────────────────────
 (hk-test "return" (hk-deep-force (hk-run "main = return 7")) (list "IO" 7))
@@ -134,7 +134,7 @@
 (hk-test
   "lookup hit"
   (hk-deep-force (hk-run "main = show (lookup 2 [(1,10),(2,20)])"))
-  "(Just 20)")
+  "Just 20")
 (hk-test
   "lookup miss"
   (hk-deep-force (hk-run "main = show (lookup 9 [(1,10)])"))

lib/haskell/tests/string-char.sx

@@ -0,0 +1,139 @@
+;; String / Char tests — Phase 7 items 1-4.
+;;
+;; Covers:
+;;   hk-str? / hk-str-head / hk-str-tail / hk-str-null?   (runtime helpers)
+;;   chr / ord / toUpper / toLower                          (builtins in eval)
+;;   cons-pattern on strings via match.sx                   (":"-intercept)
+;;   empty-list pattern on strings via match.sx             ("[]"-intercept)
+
+;; ── hk-str? predicate ────────────────────────────────────────────────────
+(hk-test "hk-str? native string" (hk-str? "hello") true)
+
+(hk-test "hk-str? empty string" (hk-str? "") true)
+
+(hk-test "hk-str? view dict" (hk-str? {:hk-off 1 :hk-str "hi"}) true)
+
+(hk-test "hk-str? rejects number" (hk-str? 42) false)
+
+;; ── hk-str-null? predicate ───────────────────────────────────────────────
+(hk-test "hk-str-null? empty string" (hk-str-null? "") true)
+
+(hk-test "hk-str-null? non-empty" (hk-str-null? "a") false)
+
+(hk-test "hk-str-null? exhausted view" (hk-str-null? {:hk-off 2 :hk-str "hi"}) true)
+
+(hk-test "hk-str-null? live view" (hk-str-null? {:hk-off 1 :hk-str "hi"}) false)
+
+;; ── hk-str-head ──────────────────────────────────────────────────────────
+(hk-test "hk-str-head native string" (hk-str-head "hello") 104)
+
+(hk-test "hk-str-head view at offset" (hk-str-head {:hk-off 1 :hk-str "hello"}) 101)
+
+;; ── hk-str-tail ──────────────────────────────────────────────────────────
+(hk-test "hk-str-tail of single char is nil" (hk-str-tail "h") (list "[]"))
+
+(hk-test
+  "hk-str-tail of two-char string is live view"
+  (hk-str-null? (hk-str-tail "hi"))
+  false)
+
+(hk-test
+  "hk-str-tail head of tail of hi is i"
+  (hk-str-head (hk-str-tail "hi"))
+  105)
+
+;; ── chr / ord ────────────────────────────────────────────────────────────
+(hk-test "chr 65 = A" (hk-eval-expr-source "chr 65") "A")
+
+(hk-test "chr 104 = h" (hk-eval-expr-source "chr 104") "h")
+
+(hk-test "ord char literal 'A' = 65" (hk-eval-expr-source "ord 'A'") 65)
+
+(hk-test "ord char literal 'a' = 97" (hk-eval-expr-source "ord 'a'") 97)
+
+(hk-test
+  "ord of head string = char code"
+  (hk-eval-expr-source "ord (head \"hello\")")
+  104)
+
+;; ── toUpper / toLower ────────────────────────────────────────────────────
+(hk-test "toUpper 97 = 65 (a->A)" (hk-eval-expr-source "toUpper 97") 65)
+
+(hk-test
+  "toUpper 65 = 65 (already upper)"
+  (hk-eval-expr-source "toUpper 65")
+  65)
+
+(hk-test
+  "toUpper 48 = 48 (digit unchanged)"
+  (hk-eval-expr-source "toUpper 48")
+  48)
+
+(hk-test "toLower 65 = 97 (A->a)" (hk-eval-expr-source "toLower 65") 97)
+
+(hk-test
+  "toLower 97 = 97 (already lower)"
+  (hk-eval-expr-source "toLower 97")
+  97)
+
+(hk-test
+  "toLower 48 = 48 (digit unchanged)"
+  (hk-eval-expr-source "toLower 48")
+  48)
+
+;; ── Pattern matching on strings ──────────────────────────────────────────
+(hk-test
+  "cons pattern: head of hello = 104"
+  (hk-eval-expr-source "case \"hello\" of { (x:_) -> x }")
+  104)
+
+(hk-test
+  "cons pattern: tail is traversable"
+  (hk-eval-expr-source "case \"hi\" of { (_:xs) -> case xs of { (y:_) -> y } }")
+  105)
+
+(hk-test
+  "empty list pattern matches empty string"
+  (hk-eval-expr-source "case \"\" of { [] -> True; _ -> False }")
+  (list "True"))
+
+(hk-test
+  "empty list pattern fails on non-empty"
+  (hk-eval-expr-source "case \"a\" of { [] -> True; _ -> False }")
+  (list "False"))
+
+(hk-test
+  "cons pattern fails on empty string"
+  (hk-eval-expr-source "case \"\" of { (_:_) -> True; _ -> False }")
+  (list "False"))
+
+;; ── Haskell programs using string traversal ──────────────────────────────
+(hk-test
+  "null prelude on empty string"
+  (hk-eval-expr-source "null \"\"")
+  (list "True"))
+
+(hk-test
+  "null prelude on non-empty string"
+  (hk-eval-expr-source "null \"abc\"")
+  (list "False"))
+
+(hk-test
+  "length of string via cons recursion"
+  (hk-eval-expr-source "let { f [] = 0; f (_:xs) = 1 + f xs } in f \"hello\"")
+  5)
+
+(hk-test
+  "map ord over string gives char codes"
+  (hk-deep-force (hk-eval-expr-source "map ord \"abc\""))
+  (list ":" 97 (list ":" 98 (list ":" 99 (list "[]")))))
+
+(hk-test
+  "map toUpper over char codes then chr"
+  (hk-eval-expr-source "chr (toUpper (ord (head \"abc\")))")
+  "A")
+
+(hk-test
+  "head then ord using prelude head"
+  (hk-eval-expr-source "ord (head \"hello\")")
+  104)

lib/hyperscript/compiler.sx

@@ -226,6 +226,28 @@
                             value)
                           (list (quote set!) (hs-to-sx target) value)))))))
               (true (list (quote set!) (hs-to-sx target) value)))))))
+    ;; Throttle/debounce extraction state — module-level so they don't get
+    ;; redefined on every emit-on call (which was causing JIT churn). Set
+    ;; via _strip-throttle-debounce at the start of each emit-on, used in
+    ;; the handler-build step inside scan-on.
+    (define _throttle-ms nil)
+    (define _debounce-ms nil)
+    (define
+      _strip-throttle-debounce
+      (fn
+        (lst)
+        (cond
+          ((<= (len lst) 1) lst)
+          ((= (first lst) :throttle)
+            (do
+              (set! _throttle-ms (nth lst 1))
+              (_strip-throttle-debounce (rest (rest lst)))))
+          ((= (first lst) :debounce)
+            (do
+              (set! _debounce-ms (nth lst 1))
+              (_strip-throttle-debounce (rest (rest lst)))))
+          (true
+            (cons (first lst) (_strip-throttle-debounce (rest lst)))))))
     (define
       emit-on
       (fn
@@ -234,6 +256,8 @@
           ((parts (rest ast)))
           (let
             ((event-name (first parts)))
+            (set! _throttle-ms nil)
+            (set! _debounce-ms nil)
             (define
               scan-on
               (fn
@@ -266,6 +290,13 @@
                                   ((wrapped-body (if catch-info (let ((var (make-symbol (nth catch-info 0))) (catch-body (hs-to-sx (nth catch-info 1)))) (if finally-info (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (hs-to-sx finally-info) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))) (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body))))
                                   (let
                                     ((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let ((base-handler (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))) (if count-filter-info (let ((mn (get count-filter-info "min")) (mx (get count-filter-info "max"))) (list (quote let) (list (list (quote __hs-count) 0)) (list (quote fn) (list (quote event)) (list (quote begin) (list (quote set!) (quote __hs-count) (list (quote +) (quote __hs-count) 1)) (list (quote when) (if (= mx -1) (list (quote >=) (quote __hs-count) mn) (list (quote and) (list (quote >=) (quote __hs-count) mn) (list (quote <=) (quote __hs-count) mx))) (nth base-handler 2)))))) base-handler)))))
+                                    (let
+                                      ((handler (cond
+                                                  (_throttle-ms
+                                                    (list (quote hs-throttle!) handler (hs-to-sx _throttle-ms)))
+                                                  (_debounce-ms
+                                                    (list (quote hs-debounce!) handler (hs-to-sx _debounce-ms)))
+                                                  (true handler))))
                                     (let
                                       ((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
                                       (cond
@@ -325,7 +356,7 @@
                                                       (first pair)
                                                       handler))
                                                   or-sources)))
-                                            on-call)))))))))))))
+                                            on-call))))))))))))))
                   ((= (first items) :from)
                     (scan-on
                       (rest (rest items))
@@ -469,7 +500,7 @@
                       count-filter-info
                       elsewhere?
                       or-sources)))))
-            (scan-on (rest parts) nil nil false nil nil nil nil nil false nil)))))
+            (scan-on (_strip-throttle-debounce (rest parts)) nil nil false nil nil nil nil nil false nil)))))
     (define
       emit-send
       (fn
@@ -2490,6 +2521,15 @@
                             (quote fn)
                             (list (quote it))
                             (hs-to-sx body))))
+                      ((and (list? expr) (= (first expr) (quote attr)))
+                        (list
+                          (quote hs-attr-watch!)
+                          (hs-to-sx (nth expr 2))
+                          (nth expr 1)
+                          (list
+                            (quote fn)
+                            (list (quote it))
+                            (hs-to-sx body))))
                       (true nil))))
                 ((= head (quote init))
                   (list

lib/hyperscript/parser.sx

@@ -1358,7 +1358,17 @@
                           cls
                           (first extra-classes)
                           tgt))
-                      ((match-kw "for")
+                      ((and
+                          (= (tp-type) "keyword") (= (tp-val) "for")
+                          ;; Only consume 'for' as a duration clause if the next
+                          ;; token is NOT '<ident> in ...' — that pattern is a
+                          ;; for-in loop, not a toggle duration.
+                          (not
+                            (and
+                              (> (len tokens) (+ p 2))
+                              (= (get (nth tokens (+ p 1)) "type") "ident")
+                              (= (get (nth tokens (+ p 2)) "value") "in")))
+                          (do (adv!) true))
                         (let
                           ((dur (parse-expr)))
                           (list (quote toggle-class-for) cls tgt dur)))
@@ -3090,7 +3100,17 @@
                               (= (tp-val) "queue"))
                             (do (adv!) (adv!)))
                           (let
-                            ((every? (match-kw "every")))
+                            ((every? (match-kw "every"))
+                             (throttle-ms nil)
+                             (debounce-ms nil))
+                            ;; 'throttled at <duration>' / 'debounced at <duration>'
+                            ;; — parsed as handler modifiers, captured as :throttle / :debounce parts.
+                            (when (and (= (tp-type) "ident") (= (tp-val) "throttled"))
+                              (adv!)
+                              (when (match-kw "at") (set! throttle-ms (parse-expr))))
+                            (when (and (= (tp-type) "ident") (= (tp-val) "debounced"))
+                              (adv!)
+                              (when (match-kw "at") (set! debounce-ms (parse-expr))))
                             (let
                               ((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
                               (let
@@ -3105,6 +3125,10 @@
                                   (match-kw "end")
                                   (let
                                     ((parts (list (quote on) event-name)))
+                                    (let
+                                      ((parts (if throttle-ms (append parts (list :throttle throttle-ms)) parts)))
+                                    (let
+                                      ((parts (if debounce-ms (append parts (list :debounce debounce-ms)) parts)))
                                     (let
                                       ((parts (if every? (append parts (list :every true)) parts)))
                                       (let
@@ -3127,7 +3151,7 @@
                                                         ((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
                                                         (let
                                                           ((parts (append parts (list (if (> (len event-vars) 0) (cons (quote do) (append (map (fn (nm) (list (quote ref) nm)) event-vars) (if (and (list? body) (= (first body) (quote do))) (rest body) (list body)))) body)))))
-                                                          parts))))))))))))))))))))))))))
+                                                          parts))))))))))))))))))))))))))))
       (define
         parse-init-feat
         (fn
@@ -3177,6 +3201,7 @@
             (or
               (= (tp-type) "hat")
               (= (tp-type) "local")
+              (= (tp-type) "attr")
               (and (= (tp-type) "keyword") (= (tp-val) "dom")))
             (let
               ((expr (parse-expr)))

lib/hyperscript/runtime.sx

@@ -12,6 +12,29 @@
 
 ;; Register an event listener. Returns unlisten function.
 ;; (hs-on target event-name handler) → unlisten-fn
+(begin
+  (define _hs-config-log-all false)
+  (define _hs-log-captured (list))
+  (define
+    hs-set-log-all!
+    (fn (flag) (set! _hs-config-log-all (if flag true false))))
+  (define hs-get-log-captured (fn () _hs-log-captured))
+  (define
+    hs-clear-log-captured!
+    (fn () (begin (set! _hs-log-captured (list)) nil)))
+  (define
+    hs-log-event!
+    (fn
+      (msg)
+      (when
+        _hs-config-log-all
+        (begin
+          (set! _hs-log-captured (append _hs-log-captured (list msg)))
+          (host-call (host-global "console") "log" msg)
+          nil)))))
+
+;; Run an initializer function immediately.
+;; (hs-init thunk) — called at element boot time
 (define
   hs-each
   (fn
@@ -22,17 +45,52 @@
 ;; (hs-init thunk) — called at element boot time
 (define meta (host-new "Object"))
 
-;; Run an initializer function immediately.
-;; (hs-init thunk) — called at element boot time
-(define
-  hs-on-every
-  (fn (target event-name handler) (dom-listen target event-name handler)))
-
 ;; ── Async / timing ──────────────────────────────────────────────
 
 ;; Wait for a duration in milliseconds.
 ;; In hyperscript, wait is async-transparent — execution pauses.
 ;; Here we use perform/IO suspension for true pause semantics.
+(define
+  hs-on-every
+  (fn (target event-name handler) (dom-listen target event-name handler)))
+
+;; Throttle: drops events that arrive within the window. First event fires
+;; immediately; subsequent events within `ms` of the previous fire are dropped.
+;; Returns a wrapped handler suitable for hs-on / hs-on-every.
+(define
+  hs-throttle!
+  (fn
+    (handler ms)
+    (let
+      ((__hs-last-fire 0))
+      (fn
+        (event)
+        (let
+          ((__hs-now (host-call (host-global "Date") "now")))
+          (when
+            (>= (- __hs-now __hs-last-fire) ms)
+            (set! __hs-last-fire __hs-now)
+            (handler event)))))))
+
+;; Debounce: waits until `ms` has elapsed since the last event before firing.
+;; In our synchronous test mock no time passes, so the timer fires immediately
+;; via setTimeout(_, 0); the wrapped handler still gets called once per burst.
+(define
+  hs-debounce!
+  (fn
+    (handler ms)
+    (let
+      ((__hs-timer nil))
+      (fn
+        (event)
+        (when __hs-timer (host-call (host-global "window") "clearTimeout" __hs-timer))
+        (set! __hs-timer
+          (host-call (host-global "window") "setTimeout"
+            (host-new-function (list "ev") "return arguments[0](arguments[1]);")
+            ms handler event))))))
+
+;; Wait for a DOM event on a target.
+;; (hs-wait-for target event-name) — suspends until event fires
 (define
   _hs-on-caller
   (let
@@ -45,8 +103,7 @@
       (host-set! _ctx "meta" _m)
       _ctx)))
 
-;; Wait for a DOM event on a target.
-;; (hs-wait-for target event-name) — suspends until event fires
+;; Wait for CSS transitions/animations to settle on an element.
 (define
   hs-on
   (fn
@@ -66,14 +123,14 @@
               (append prev (list unlisten)))
             unlisten))))))
 
-;; Wait for CSS transitions/animations to settle on an element.
+;; ── Class manipulation ──────────────────────────────────────────
+
+;; Toggle a single class on an element.
 (define
   hs-on-every
   (fn (target event-name handler) (dom-listen target event-name handler)))
 
-;; ── Class manipulation ──────────────────────────────────────────
-
-;; Toggle a single class on an element.
+;; Toggle between two classes — exactly one is active at a time.
 (define
   hs-on-intersection-attach!
   (fn
@@ -89,7 +146,8 @@
           (host-call observer "observe" target)
           observer)))))
 
-;; Toggle between two classes — exactly one is active at a time.
+;; Take a class from siblings — add to target, remove from others.
+;; (hs-take! target cls) — like radio button class behavior
 (define
   hs-on-mutation-attach!
   (fn
@@ -110,19 +168,18 @@
             (host-call observer "observe" target opts)
             observer))))))
 
-;; Take a class from siblings — add to target, remove from others.
-;; (hs-take! target cls) — like radio button class behavior
-(define hs-init (fn (thunk) (thunk)))
-
 ;; ── DOM insertion ───────────────────────────────────────────────
 
 ;; Put content at a position relative to a target.
 ;; pos: "into" | "before" | "after"
-(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
+(define hs-init (fn (thunk) (thunk)))
 
 ;; ── Navigation / traversal ──────────────────────────────────────
 
 ;; Navigate to a URL.
+(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
+
+;; Find next sibling matching a selector (or any sibling).
 (begin
   (define
     hs-wait-for
@@ -135,7 +192,7 @@
       (target event-name timeout-ms)
       (perform (list (quote io-wait-event) target event-name timeout-ms)))))
 
-;; Find next sibling matching a selector (or any sibling).
+;; Find previous sibling matching a selector.
 (define
   hs-settle
   (fn
@@ -143,7 +200,7 @@
     (hs-null-raise! target)
     (when (not (nil? target)) (perform (list (quote io-settle) target)))))
 
-;; Find previous sibling matching a selector.
+;; First element matching selector within a scope.
 (define
   hs-toggle-class!
   (fn
@@ -153,7 +210,7 @@
       (not (nil? target))
       (host-call (host-get target "classList") "toggle" cls))))
 
-;; First element matching selector within a scope.
+;; Last element matching selector.
 (define
   hs-toggle-var-cycle!
   (fn
@@ -175,7 +232,7 @@
           var-name
           (if (= idx -1) (first values) (nth values (mod (+ idx 1) n))))))))
 
-;; Last element matching selector.
+;; First/last within a specific scope.
 (define
   hs-toggle-between!
   (fn
@@ -188,7 +245,6 @@
         (do (dom-remove-class target cls1) (dom-add-class target cls2))
         (do (dom-remove-class target cls2) (dom-add-class target cls1))))))
 
-;; First/last within a specific scope.
 (define
   hs-toggle-style!
   (fn
@@ -212,6 +268,9 @@
             (dom-set-style target prop "hidden")
             (dom-set-style target prop "")))))))
 
+;; ── Iteration ───────────────────────────────────────────────────
+
+;; Repeat a thunk N times.
 (define
   hs-toggle-style-between!
   (fn
@@ -223,9 +282,7 @@
         (dom-set-style target prop val2)
         (dom-set-style target prop val1)))))
 
-;; ── Iteration ───────────────────────────────────────────────────
-
-;; Repeat a thunk N times.
+;; Repeat forever (until break — relies on exception/continuation).
 (define
   hs-toggle-style-cycle!
   (fn
@@ -246,7 +303,10 @@
             (true (find-next (rest remaining))))))
       (dom-set-style target prop (find-next vals)))))
 
-;; Repeat forever (until break — relies on exception/continuation).
+;; ── Fetch ───────────────────────────────────────────────────────
+
+;; Fetch a URL, parse response according to format.
+;; (hs-fetch url format) — format is "json" | "text" | "html"
 (define
   hs-take!
   (fn
@@ -269,8 +329,7 @@
             (when with-cls (dom-remove-class target with-cls))))
         (let
           ((attr-val (if (> (len extra) 0) (first extra) nil))
-            (with-val
-              (if (> (len extra) 1) (nth extra 1) nil)))
+            (with-val (if (> (len extra) 1) (nth extra 1) nil)))
           (do
             (for-each
               (fn
@@ -287,10 +346,10 @@
               (dom-set-attr target name attr-val)
               (dom-set-attr target name ""))))))))
 
-;; ── Fetch ───────────────────────────────────────────────────────
+;; ── Type coercion ───────────────────────────────────────────────
 
-;; Fetch a URL, parse response according to format.
-;; (hs-fetch url format) — format is "json" | "text" | "html"
+;; Coerce a value to a type by name.
+;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
 (begin
   (define
     hs-element?
@@ -447,10 +506,10 @@
                     (dom-insert-adjacent-html target "beforeend" value)
                     (hs-boot-subtree! target)))))))))))
 
-;; ── Type coercion ───────────────────────────────────────────────
+;; ── Object creation ─────────────────────────────────────────────
 
-;; Coerce a value to a type by name.
-;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
+;; Make a new object of a given type.
+;; (hs-make type-name) — creates empty object/collection
 (define
   hs-add-to!
   (fn
@@ -464,10 +523,11 @@
       ((hs-is-set? target) (do (host-call target "add" value) target))
       (true (do (host-call target "push" value) target)))))
 
-;; ── Object creation ─────────────────────────────────────────────
+;; ── Behavior installation ───────────────────────────────────────
 
-;; Make a new object of a given type.
-;; (hs-make type-name) — creates empty object/collection
+;; Install a behavior on an element.
+;; A behavior is a function that takes (me ...params) and sets up features.
+;; (hs-install behavior-fn me ...args)
 (define
   hs-remove-from!
   (fn
@@ -477,11 +537,10 @@
       ((hs-is-set? target) (do (host-call target "delete" value) target))
       (true (host-call target "splice" (host-call target "indexOf" value) 1)))))
 
-;; ── Behavior installation ───────────────────────────────────────
+;; ── Measurement ─────────────────────────────────────────────────
 
-;; Install a behavior on an element.
-;; A behavior is a function that takes (me ...params) and sets up features.
-;; (hs-install behavior-fn me ...args)
+;; Measure an element's bounding rect, store as local variables.
+;; Returns a dict with x, y, width, height, top, left, right, bottom.
 (define
   hs-splice-at!
   (fn
@@ -494,10 +553,7 @@
           ((i (if (< idx 0) (+ n idx) idx)))
           (cond
             ((or (< i 0) (>= i n)) target)
-            (true
-              (concat
-                (slice target 0 i)
-                (slice target (+ i 1) n))))))
+            (true (concat (slice target 0 i) (slice target (+ i 1) n))))))
       (do
         (when
           target
@@ -508,10 +564,10 @@
               (host-call target "splice" i 1))))
         target))))
 
-;; ── Measurement ─────────────────────────────────────────────────
-
-;; Measure an element's bounding rect, store as local variables.
-;; Returns a dict with x, y, width, height, top, left, right, bottom.
+;; Return the current text selection as a string.  In the browser this is
+;; `window.getSelection().toString()`.  In the mock test runner, a test
+;; setup stashes the desired selection text at `window.__test_selection`
+;; and the fallback path returns that so tests can assert on the result.
 (define
   hs-index
   (fn
@@ -523,10 +579,11 @@
       ((string? obj) (nth obj key))
       (true (host-get obj key)))))
 
-;; Return the current text selection as a string.  In the browser this is
-;; `window.getSelection().toString()`.  In the mock test runner, a test
-;; setup stashes the desired selection text at `window.__test_selection`
-;; and the fallback path returns that so tests can assert on the result.
+
+;; ── Transition ──────────────────────────────────────────────────
+
+;; Transition a CSS property to a value, optionally with duration.
+;; (hs-transition target prop value duration)
 (define
   hs-put-at!
   (fn
@@ -548,11 +605,6 @@
                 ((= pos "start") (host-call target "unshift" value)))
               target)))))))
 
-
-;; ── Transition ──────────────────────────────────────────────────
-
-;; Transition a CSS property to a value, optionally with duration.
-;; (hs-transition target prop value duration)
 (define
   hs-dict-without
   (fn
@@ -589,6 +641,11 @@
       ((w (host-global "window")))
       (if w (host-call w "prompt" msg) nil))))
 
+
+;; ── Transition ──────────────────────────────────────────────────
+
+;; Transition a CSS property to a value, optionally with duration.
+;; (hs-transition target prop value duration)
 (define
   hs-answer
   (fn
@@ -597,11 +654,6 @@
       ((w (host-global "window")))
       (if w (if (host-call w "confirm" msg) yes-val no-val) no-val))))
 
-
-;; ── Transition ──────────────────────────────────────────────────
-
-;; Transition a CSS property to a value, optionally with duration.
-;; (hs-transition target prop value duration)
 (define
   hs-answer-alert
   (fn
@@ -662,6 +714,10 @@
             (if (nil? sel) "" (host-call sel "toString" (list))))
           stash)))))
 
+
+
+
+
 (define
   hs-reset!
   (fn
@@ -708,10 +764,6 @@
                   (when default-val (dom-set-prop target "value" default-val)))))
             (true nil)))))))
 
-
-
-
-
 (define
   hs-next
   (fn
@@ -730,7 +782,8 @@
               ((dom-matches? el sel) el)
               (true (find-next (dom-next-sibling el))))))
         (find-next sibling)))))
-
+;; ── Sandbox/test runtime additions ──────────────────────────────
+;; Property access — dot notation and .length
 (define
   hs-previous
   (fn
@@ -749,10 +802,9 @@
               ((dom-matches? el sel) el)
               (true (find-prev (dom-get-prop el "previousElementSibling"))))))
         (find-prev sibling)))))
-;; ── Sandbox/test runtime additions ──────────────────────────────
-;; Property access — dot notation and .length
-(define _hs-last-query-sel nil)
 ;; DOM query stub — sandbox returns empty list
+(define _hs-last-query-sel nil)
+;; Method dispatch — obj.method(args)
 (define
   hs-null-raise!
   (fn
@@ -763,7 +815,9 @@
         ((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
         (host-set! (host-global "window") "_hs_null_error" msg)
         (guard (_null-e (true nil)) (raise msg))))))
-;; Method dispatch — obj.method(args)
+
+;; ── 0.9.90 features ─────────────────────────────────────────────
+;; beep! — debug logging, returns value unchanged
 (define
   hs-empty-raise!
   (fn
@@ -777,9 +831,7 @@
         ((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
         (host-set! (host-global "window") "_hs_null_error" msg)
         (guard (_null-e (true nil)) (raise msg))))))
-
-;; ── 0.9.90 features ─────────────────────────────────────────────
-;; beep! — debug logging, returns value unchanged
+;; Property-based is — check obj.key truthiness
 (define
   hs-query-all-checked
   (fn
@@ -787,14 +839,14 @@
     (let
       ((result (hs-query-all sel)))
       (do (hs-empty-raise! result) result))))
-;; Property-based is — check obj.key truthiness
+;; Array slicing (inclusive both ends)
 (define
   hs-dispatch!
   (fn
     (target event detail)
     (hs-null-raise! target)
     (when (not (nil? target)) (dom-dispatch target event detail))))
-;; Array slicing (inclusive both ends)
+;; Collection: sorted by
 (define
   hs-query-all
   (fn
@@ -802,7 +854,7 @@
     (do
       (host-set! (host-global "window") "_hs_last_query_sel" sel)
       (dom-query-all (dom-document) sel))))
-;; Collection: sorted by
+;; Collection: sorted by descending
 (define
   hs-query-all-in
   (fn
@@ -811,17 +863,17 @@
       (nil? target)
       (hs-query-all sel)
       (host-call target "querySelectorAll" sel))))
-;; Collection: sorted by descending
+;; Collection: split by
 (define
   hs-list-set
   (fn
     (lst idx val)
     (append (take lst idx) (cons val (drop lst (+ idx 1))))))
-;; Collection: split by
+;; Collection: joined by
 (define
   hs-to-number
   (fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
-;; Collection: joined by
+
 (define
   hs-query-first
   (fn
@@ -951,7 +1003,7 @@
                   ((= (str ex) "hs-continue") (do-loop (rest remaining)))
                   (true (raise ex))))))))
       (do-loop items))))
-
+;; Collection: joined by
 (begin
   (define
     hs-append
@@ -992,7 +1044,7 @@
               (host-get value "outerHTML")
               (str value))))
         (true nil)))))
-;; Collection: joined by
+
 (define
   hs-sender
   (fn
@@ -1084,6 +1136,7 @@
               (hs-host-to-sx (perform (list "io-parse-json" raw))))
             ((= fmt "number")
               (hs-to-number (perform (list "io-parse-text" raw))))
+            ((= fmt "html") (perform (list "io-parse-html" raw)))
             (true (perform (list "io-parse-text" raw)))))))))
 
 (define hs-fetch (fn (url format) (hs-fetch-impl url format false)))
@@ -1623,14 +1676,10 @@
                 ((ch (substring sel i (+ i 1))))
                 (cond
                   ((= ch ".")
-                    (do
-                      (flush!)
-                      (set! mode "class")
-                      (walk (+ i 1))))
+                    (do (flush!) (set! mode "class") (walk (+ i 1))))
                   ((= ch "#")
                     (do (flush!) (set! mode "id") (walk (+ i 1))))
-                  (true
-                    (do (set! cur (str cur ch)) (walk (+ i 1)))))))))
+                  (true (do (set! cur (str cur ch)) (walk (+ i 1)))))))))
         (walk 0)
         (flush!)
         {:tag tag :classes classes :id id}))))
@@ -1724,11 +1773,11 @@
     (value type-name)
     (if (nil? value) false (hs-type-check value type-name))))
 
+
 (define
   hs-strict-eq
   (fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
 
-
 (define
   hs-id=
   (fn
@@ -1760,6 +1809,20 @@
       ((nil? suffix) false)
       (true (ends-with? (str s) (str suffix))))))
 
+(define
+  hs-attr-watch!
+  (fn
+    (target attr-name handler)
+    (let
+      ((mo-class (host-get (host-global "window") "MutationObserver")))
+      (when
+        mo-class
+        (let
+          ((cb (fn (records observer) (for-each (fn (rec) (when (= (host-get rec "attributeName") attr-name) (handler (host-call target "getAttribute" attr-name)))) records))))
+          (let
+            ((mo (host-new "MutationObserver" cb)))
+            (host-call mo "observe" target {:attributeFilter (list attr-name) :attributes true})))))))
+
 (define
   hs-scoped-set!
   (fn
@@ -1805,10 +1868,7 @@
       ((and (dict? a) (dict? b))
         (let
           ((pos (host-call a "compareDocumentPosition" b)))
-          (if
-            (number? pos)
-            (not (= 0 (mod (/ pos 4) 2)))
-            false)))
+          (if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
       (true (< (str a) (str b))))))
 
 (define
@@ -1929,10 +1989,7 @@
       ((and (dict? a) (dict? b))
         (let
           ((pos (host-call a "compareDocumentPosition" b)))
-          (if
-            (number? pos)
-            (not (= 0 (mod (/ pos 4) 2)))
-            false)))
+          (if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
       (true (< (str a) (str b))))))
 
 (define
@@ -1985,9 +2042,7 @@
 
 (define
   hs-morph-char
-  (fn
-    (s p)
-    (if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
+  (fn (s p) (if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
 
 (define
   hs-morph-index-from
@@ -2015,10 +2070,7 @@
         (q)
         (let
           ((c (hs-morph-char s q)))
-          (if
-            (and c (< (index-of stop c) 0))
-            (loop (+ q 1))
-            q))))
+          (if (and c (< (index-of stop c) 0)) (loop (+ q 1)) q))))
     (let ((e (loop p))) (list (substring s p e) e))))
 
 (define
@@ -2060,9 +2112,7 @@
                                 (append
                                   acc
                                   (list
-                                    (list
-                                      name
-                                      (substring s (+ p4 1) close)))))))
+                                    (list name (substring s (+ p4 1) close)))))))
                           ((= c2 "'")
                             (let
                               ((close (hs-morph-index-from s "'" (+ p4 1))))
@@ -2072,9 +2122,7 @@
                                 (append
                                   acc
                                   (list
-                                    (list
-                                      name
-                                      (substring s (+ p4 1) close)))))))
+                                    (list name (substring s (+ p4 1) close)))))))
                           (true
                             (let
                               ((r2 (hs-morph-read-until s p4 " \t\n/>")))
@@ -2158,9 +2206,7 @@
               (for-each
                 (fn
                   (c)
-                  (when
-                    (> (string-length c) 0)
-                    (dom-add-class el c)))
+                  (when (> (string-length c) 0) (dom-add-class el c)))
                 (split v " ")))
             ((and keep-id (= n "id")) nil)
             (true (dom-set-attr el n v)))))
@@ -2261,8 +2307,7 @@
           ((parts (split resolved ":")))
           (let
             ((prop (first parts))
-              (val
-                (if (> (len parts) 1) (nth parts 1) nil)))
+              (val (if (> (len parts) 1) (nth parts 1) nil)))
             (cond
               ((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
                 (let
@@ -2302,8 +2347,7 @@
           ((parts (split resolved ":")))
           (let
             ((prop (first parts))
-              (val
-                (if (> (len parts) 1) (nth parts 1) nil)))
+              (val (if (> (len parts) 1) (nth parts 1) nil)))
             (cond
               ((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
                 (let
@@ -2408,14 +2452,10 @@
                             (if
                               (= depth 1)
                               j
-                              (find-close
-                                (+ j 1)
-                                (- depth 1)))
+                              (find-close (+ j 1) (- depth 1)))
                             (if
                               (= (nth raw j) "{")
-                              (find-close
-                                (+ j 1)
-                                (+ depth 1))
+                              (find-close (+ j 1) (+ depth 1))
                               (find-close (+ j 1) depth))))))
                     (let
                       ((close (find-close start 1)))
@@ -2526,10 +2566,7 @@
               (if
                 (= (len lst) 0)
                 -1
-                (if
-                  (= (first lst) item)
-                  i
-                  (idx-loop (rest lst) (+ i 1))))))
+                (if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
           (idx-loop obj 0)))
       (true
         (let
@@ -2621,8 +2658,7 @@
                 (cond
                   ((= end "hs-pick-end") n)
                   ((= end "hs-pick-start") 0)
-                  ((and (number? end) (< end 0))
-                    (max 0 (+ n end)))
+                  ((and (number? end) (< end 0)) (max 0 (+ n end)))
                   (true end))))
             (cond
               ((string? col) (slice col s e))
@@ -2802,6 +2838,8 @@
   hs-sorted-by-desc
   (fn (col key-fn) (reverse (hs-sorted-by col key-fn))))
 
+;; ── SourceInfo API ────────────────────────────────────────────────
+
 (define
   hs-dom-has-var?
   (fn
@@ -2821,8 +2859,6 @@
       ((store (host-get el "__hs_vars")))
       (if (nil? store) nil (host-get store name)))))
 
-;; ── SourceInfo API ────────────────────────────────────────────────
-
 (define
   hs-dom-set-var-raw!
   (fn
@@ -2913,7 +2949,12 @@
 
 (define
   hs-null-error!
-  (fn (selector) (raise (str "'" selector "' is null"))))
+  (fn
+    (selector)
+    (let
+      ((msg (str "'" selector "' is null")))
+      (host-set! (host-global "window") "_hs_null_error" msg)
+      (guard (_null-e (true nil)) (raise msg)))))
 
 (define
   hs-named-target
@@ -2933,9 +2974,7 @@
       ((results (hs-query-all selector)))
       (if
         (and
-          (or
-            (nil? results)
-            (and (list? results) (= (len results) 0)))
+          (or (nil? results) (and (list? results) (= (len results) 0)))
           (string? selector)
           (> (len selector) 0)
           (= (substring selector 0 1) "#"))

lib/hyperscript/tokenizer.sx

@@ -855,4 +855,230 @@
                 :else (do (t-advance! 1) (scan-template!)))))))
       (scan-template!)
       (t-emit! "eof" nil)
-      tokens)))
+      tokens)))
+
+;; ── Stream wrapper for upstream-style stateful tokenizer API ───────────────
+;;
+;; Upstream _hyperscript exposes a Tokens object with cursor + follow-set
+;; semantics on _hyperscript.internals.tokenizer. Our hs-tokenize returns a
+;; flat list; the stream wrapper adds the stateful operations.
+;;
+;; Type names map ours → upstream's (e.g. "ident" → "IDENTIFIER").
+
+(define
+  hs-stream-type-map
+  (fn
+    (t)
+    (cond
+      ((= t "ident") "IDENTIFIER")
+      ((= t "number") "NUMBER")
+      ((= t "string") "STRING")
+      ((= t "class") "CLASS_REF")
+      ((= t "id") "ID_REF")
+      ((= t "attr") "ATTRIBUTE_REF")
+      ((= t "style") "STYLE_REF")
+      ((= t "whitespace") "WHITESPACE")
+      ((= t "op") "OPERATOR")
+      ((= t "eof") "EOF")
+      (true (upcase t)))))
+
+;; Create a stream from a source string.
+;; Returns a dict — mutable via dict-set!.
+(define
+  hs-stream
+  (fn
+    (src)
+    {:tokens (hs-tokenize src) :pos 0 :follows (list) :last-match nil :last-ws nil}))
+
+;; Skip whitespace tokens, advancing pos to the next non-WS token.
+;; Captures the last skipped whitespace value into :last-ws.
+(define
+  hs-stream-skip-ws!
+  (fn
+    (s)
+    (let
+      ((tokens (get s :tokens)))
+      (define
+        loop
+        (fn
+          ()
+          (let
+            ((p (get s :pos)))
+            (when
+              (and (< p (len tokens))
+                   (= (get (nth tokens p) :type) "whitespace"))
+              (do
+                (dict-set! s :last-ws (get (nth tokens p) :value))
+                (dict-set! s :pos (+ p 1))
+                (loop))))))
+      (loop))))
+
+;; Current token (after skipping whitespace).
+(define
+  hs-stream-current
+  (fn
+    (s)
+    (do
+      (hs-stream-skip-ws! s)
+      (let
+        ((tokens (get s :tokens)) (p (get s :pos)))
+        (if (< p (len tokens)) (nth tokens p) nil)))))
+
+;; Returns the current token if its value matches; advances and updates
+;; :last-match. Returns nil otherwise (no advance).
+;; Honors the follow set: tokens whose value is in :follows do NOT match.
+(define
+  hs-stream-match
+  (fn
+    (s value)
+    (let
+      ((cur (hs-stream-current s)))
+      (cond
+        ((nil? cur) nil)
+        ((some (fn (f) (= f value)) (get s :follows)) nil)
+        ((= (get cur :value) value)
+          (do
+            (dict-set! s :pos (+ (get s :pos) 1))
+            (dict-set! s :last-match cur)
+            cur))
+        (true nil)))))
+
+;; Match by upstream-style type name. Accepts any number of allowed types.
+(define
+  hs-stream-match-type
+  (fn
+    (s &rest types)
+    (let
+      ((cur (hs-stream-current s)))
+      (cond
+        ((nil? cur) nil)
+        ((some (fn (t) (= (hs-stream-type-map (get cur :type)) t)) types)
+          (do
+            (dict-set! s :pos (+ (get s :pos) 1))
+            (dict-set! s :last-match cur)
+            cur))
+        (true nil)))))
+
+;; Match if value is one of the given names.
+(define
+  hs-stream-match-any
+  (fn
+    (s &rest names)
+    (let
+      ((cur (hs-stream-current s)))
+      (cond
+        ((nil? cur) nil)
+        ((some (fn (n) (= (get cur :value) n)) names)
+          (do
+            (dict-set! s :pos (+ (get s :pos) 1))
+            (dict-set! s :last-match cur)
+            cur))
+        (true nil)))))
+
+;; Match an op token whose value is in the list.
+(define
+  hs-stream-match-any-op
+  (fn
+    (s &rest ops)
+    (let
+      ((cur (hs-stream-current s)))
+      (cond
+        ((nil? cur) nil)
+        ((and (= (get cur :type) "op")
+              (some (fn (o) (= (get cur :value) o)) ops))
+          (do
+            (dict-set! s :pos (+ (get s :pos) 1))
+            (dict-set! s :last-match cur)
+            cur))
+        (true nil)))))
+
+;; Peek N non-WS tokens ahead. Returns the token if its value matches; nil otherwise.
+(define
+  hs-stream-peek
+  (fn
+    (s value offset)
+    (let
+      ((tokens (get s :tokens)))
+      (define
+        skip-n-non-ws
+        (fn
+          (p remaining)
+          (cond
+            ((>= p (len tokens)) -1)
+            ((= (get (nth tokens p) :type) "whitespace")
+              (skip-n-non-ws (+ p 1) remaining))
+            ((= remaining 0) p)
+            (true (skip-n-non-ws (+ p 1) (- remaining 1))))))
+      (let
+        ((p (skip-n-non-ws (get s :pos) offset)))
+        (if (and (>= p 0) (< p (len tokens))
+                 (= (get (nth tokens p) :value) value))
+          (nth tokens p)
+          nil)))))
+
+;; Consume tokens until one whose value matches the marker. Returns
+;; the consumed list (excluding the marker). Marker becomes current.
+(define
+  hs-stream-consume-until
+  (fn
+    (s marker)
+    (let
+      ((tokens (get s :tokens)) (out (list)))
+      (define
+        loop
+        (fn
+          (acc)
+          (let
+            ((p (get s :pos)))
+            (cond
+              ((>= p (len tokens)) acc)
+              ((= (get (nth tokens p) :value) marker) acc)
+              (true
+                (do
+                  (dict-set! s :pos (+ p 1))
+                  (loop (append acc (list (nth tokens p))))))))))
+      (loop out))))
+
+;; Consume until the next whitespace token; returns the consumed list.
+(define
+  hs-stream-consume-until-ws
+  (fn
+    (s)
+    (let
+      ((tokens (get s :tokens)))
+      (define
+        loop
+        (fn
+          (acc)
+          (let
+            ((p (get s :pos)))
+            (cond
+              ((>= p (len tokens)) acc)
+              ((= (get (nth tokens p) :type) "whitespace") acc)
+              (true
+                (do
+                  (dict-set! s :pos (+ p 1))
+                  (loop (append acc (list (nth tokens p))))))))))
+      (loop (list)))))
+
+;; Follow-set management.
+(define hs-stream-push-follow! (fn (s v) (dict-set! s :follows (cons v (get s :follows)))))
+(define
+  hs-stream-pop-follow!
+  (fn (s) (let ((f (get s :follows))) (when (> (len f) 0) (dict-set! s :follows (rest f))))))
+(define
+  hs-stream-push-follows!
+  (fn (s vs) (for-each (fn (v) (hs-stream-push-follow! s v)) vs)))
+(define
+  hs-stream-pop-follows!
+  (fn (s n) (when (> n 0) (do (hs-stream-pop-follow! s) (hs-stream-pop-follows! s (- n 1))))))
+(define
+  hs-stream-clear-follows!
+  (fn (s) (let ((saved (get s :follows))) (do (dict-set! s :follows (list)) saved))))
+(define
+  hs-stream-restore-follows!
+  (fn (s saved) (dict-set! s :follows saved)))
+
+;; Last-consumed token / whitespace.
+(define hs-stream-last-match (fn (s) (get s :last-match)))
+(define hs-stream-last-ws (fn (s) (get s :last-ws)))

lib/kernel/eval.sx

@@ -0,0 +1,214 @@
+;; lib/kernel/eval.sx — Kernel evaluator.
+;;
+;; The evaluator is `lookup-and-combine`: there are no hardcoded special
+;; forms. Even $if / $define! / $lambda are ordinary operatives bound in
+;; the standard environment (Phase 4). This file builds the dispatch
+;; machinery and the operative/applicative tagged-value protocol.
+;;
+;; Tagged values
+;; -------------
+;;   {:refl-tag :env :bindings DICT :parent PARENT-OR-NIL}
+;;     A first-class Kernel environment. Bindings is a mutable SX dict
+;;     keyed by symbol name; parent walks up the lookup chain. Shape
+;;     and operations are inherited from lib/guest/reflective/env.sx
+;;     (canonical wire shape) — Kernel-side names are thin wrappers.
+;;
+;;   {:knl-tag :operative :impl FN}
+;;     Primitive operative. FN receives (args dyn-env) — args are the
+;;     UN-evaluated argument expressions, dyn-env is the calling env.
+;;
+;;   {:knl-tag :operative :params P :env-param EP :body B :static-env SE}
+;;     User-defined operative (built by $vau). Same tag; dispatch in
+;;     kernel-call-operative forks on which keys are present.
+;;
+;;   {:knl-tag :applicative :underlying OP}
+;;     An applicative wraps an operative. Calls evaluate args first,
+;;     then forward to the underlying operative.
+;;
+;; The env-param of a user operative may be the sentinel :knl-ignore,
+;; in which case the dynamic env is not bound.
+;;
+;; Public API
+;;   (kernel-eval EXPR ENV)                     — primary entry
+;;   (kernel-combine COMBINER ARGS DYN-ENV)
+;;   (kernel-call-operative OP ARGS DYN-ENV)
+;;   (kernel-bind-params! ENV PARAMS ARGS)
+;;   (kernel-make-env) / (kernel-extend-env P)
+;;   (kernel-env-bind! E N V) / (kernel-env-lookup E N)
+;;   (kernel-env-has? E N) / (kernel-env? V)
+;;   (kernel-make-primitive-operative IMPL)
+;;   (kernel-make-primitive-applicative IMPL)
+;;   (kernel-make-user-operative PARAMS EPARAM BODY STATIC-ENV)
+;;   (kernel-wrap OP) / (kernel-unwrap APP)
+;;   (kernel-operative? V) / (kernel-applicative? V) / (kernel-combiner? V)
+;;
+;; Consumes: lib/kernel/parser.sx (kernel-string?, kernel-string-value)
+
+;; ── Environments — delegated to lib/guest/reflective/env.sx ──────
+;; The env values themselves now carry `:refl-tag :env` (shared with the
+;; reflective kit). Kernel's API names stay; bodies are thin wrappers.
+
+(define kernel-env?        refl-env?)
+(define kernel-make-env    refl-make-env)
+(define kernel-extend-env  refl-extend-env)
+(define kernel-env-bind!   refl-env-bind!)
+(define kernel-env-has?    refl-env-has?)
+(define kernel-env-lookup  refl-env-lookup)
+
+;; ── Tagged-value constructors and predicates ─────────────────────
+
+(define kernel-make-primitive-operative (fn (impl) {:impl impl :knl-tag :operative}))
+
+(define
+  kernel-make-user-operative
+  (fn (params eparam body static-env) {:knl-tag :operative :static-env static-env :params params :body body :env-param eparam}))
+
+(define
+  kernel-operative?
+  (fn (v) (and (dict? v) (= (get v :knl-tag) :operative))))
+
+(define
+  kernel-applicative?
+  (fn (v) (and (dict? v) (= (get v :knl-tag) :applicative))))
+
+(define
+  kernel-combiner?
+  (fn (v) (or (kernel-operative? v) (kernel-applicative? v))))
+
+(define
+  kernel-wrap
+  (fn
+    (op)
+    (cond
+      ((kernel-operative? op) {:knl-tag :applicative :underlying op})
+      (:else (error "kernel-wrap: argument must be an operative")))))
+
+(define
+  kernel-unwrap
+  (fn
+    (app)
+    (cond
+      ((kernel-applicative? app) (get app :underlying))
+      (:else (error "kernel-unwrap: argument must be an applicative")))))
+
+(define
+  kernel-make-primitive-applicative
+  (fn
+    (impl)
+    (kernel-wrap
+      (kernel-make-primitive-operative (fn (args dyn-env) (impl args))))))
+
+;; As above, but IMPL receives (args dyn-env). Used by combinators that
+;; re-enter the evaluator (map, filter, reduce, apply, eval, ...).
+(define kernel-make-primitive-applicative-with-env
+  (fn (impl)
+    (kernel-wrap
+      (kernel-make-primitive-operative
+        (fn (args dyn-env) (impl args dyn-env))))))
+
+;; ── The evaluator ────────────────────────────────────────────────
+
+(define
+  kernel-eval
+  (fn
+    (expr env)
+    (cond
+      ((number? expr) expr)
+      ((boolean? expr) expr)
+      ((nil? expr) expr)
+      ((kernel-string? expr) (kernel-string-value expr))
+      ((string? expr) (kernel-env-lookup env expr))
+      ((list? expr)
+        (cond
+          ((= (length expr) 0) expr)
+          (:else
+            (let
+              ((combiner (kernel-eval (first expr) env))
+                (args (rest expr)))
+              (kernel-combine combiner args env)))))
+      (:else (error (str "kernel-eval: unknown form: " expr))))))
+
+(define
+  kernel-combine
+  (fn
+    (combiner args dyn-env)
+    (cond
+      ((kernel-operative? combiner)
+        (kernel-call-operative combiner args dyn-env))
+      ((kernel-applicative? combiner)
+        (kernel-combine
+          (get combiner :underlying)
+          (kernel-eval-args args dyn-env)
+          dyn-env))
+      (:else (error (str "kernel-eval: not a combiner: " combiner))))))
+
+;; Operatives may be primitive (:impl is a host fn) or user-defined
+;; (carry :params / :env-param / :body / :static-env). The dispatch
+;; fork is here so kernel-combine stays small.
+(define
+  kernel-call-operative
+  (fn
+    (op args dyn-env)
+    (cond
+      ((dict-has? op :impl) ((get op :impl) args dyn-env))
+      ((dict-has? op :body)
+        (let
+          ((local (kernel-extend-env (get op :static-env))))
+          (kernel-bind-params! local (get op :params) args)
+          (let
+            ((eparam (get op :env-param)))
+            (when
+              (not (= eparam :knl-ignore))
+              (kernel-env-bind! local eparam dyn-env)))
+          ;; :body is a list of forms — evaluate in sequence, return last.
+          (knl-eval-body (get op :body) local)))
+      (:else (error "kernel-call-operative: malformed operative")))))
+
+(define knl-eval-body
+  (fn (forms env)
+    (cond
+      ((= (length forms) 1) (kernel-eval (first forms) env))
+      (:else
+        (begin
+          (kernel-eval (first forms) env)
+          (knl-eval-body (rest forms) env))))))
+
+;; Phase 3 supports a flat parameter list only — destructuring later.
+(define
+  kernel-bind-params!
+  (fn
+    (env params args)
+    (cond
+      ((or (nil? params) (= (length params) 0))
+        (cond
+          ((or (nil? args) (= (length args) 0)) nil)
+          (:else (error "kernel-call: too many arguments"))))
+      ((or (nil? args) (= (length args) 0))
+        (error "kernel-call: too few arguments"))
+      (:else
+        (begin
+          (kernel-env-bind! env (first params) (first args))
+          (kernel-bind-params! env (rest params) (rest args)))))))
+
+(define
+  kernel-eval-args
+  (fn
+    (args env)
+    (cond
+      ((or (nil? args) (= (length args) 0)) (list))
+      (:else
+        (cons
+          (kernel-eval (first args) env)
+          (kernel-eval-args (rest args) env))))))
+
+(define
+  kernel-eval-program
+  (fn
+    (forms env)
+    (cond
+      ((or (nil? forms) (= (length forms) 0)) nil)
+      ((= (length forms) 1) (kernel-eval (first forms) env))
+      (:else
+        (begin
+          (kernel-eval (first forms) env)
+          (kernel-eval-program (rest forms) env))))))

lib/kernel/parser.sx

@@ -0,0 +1,253 @@
+;; lib/kernel/parser.sx — Kernel s-expression reader.
+;;
+;; Reads R-1RK lexical syntax: numbers, strings, symbols, booleans (#t/#f),
+;; the empty list (), nested lists, and ; line comments. Reader macros
+;; (' ` , ,@) deferred to Phase 6 per the plan.
+;;
+;; Public AST shape:
+;;   number      → SX number
+;;   #t / #f     → SX true / false
+;;   ()          → SX empty list (Kernel's nil — the empty list)
+;;   "..."       → {:knl-string "..."}    wrapped to distinguish from symbols
+;;   foo         → "foo"                  bare SX string is a Kernel symbol
+;;   (a b c)     → SX list of forms
+;;
+;; Public API:
+;;   (kernel-parse SRC)      — first form; errors on extra trailing input
+;;   (kernel-parse-all SRC)  — all top-level forms, as SX list
+;;   (kernel-string? V)      — recognise wrapped string literal
+;;   (kernel-string-value V) — extract the underlying string
+;;
+;; Consumes: lib/guest/lex.sx (lex-digit?, lex-whitespace?)
+
+(define kernel-string-make (fn (s) {:knl-string s}))
+(define
+  kernel-string?
+  (fn (v) (and (dict? v) (string? (get v :knl-string)))))
+(define kernel-string-value (fn (v) (get v :knl-string)))
+
+;; Atom delimiters: characters that end a symbol or numeric token.
+(define
+  knl-delim?
+  (fn
+    (c)
+    (or
+      (nil? c)
+      (lex-whitespace? c)
+      (= c "(")
+      (= c ")")
+      (= c "\"")
+      (= c ";")
+      (= c "'")
+      (= c "`")
+      (= c ","))))
+
+;; Numeric grammar:  [+-]? (digit+ ('.' digit+)? | '.' digit+) ([eE][+-]?digit+)?
+(define
+  knl-numeric?
+  (fn
+    (s)
+    (let
+      ((n (string-length s)))
+      (cond
+        ((= n 0) false)
+        (:else
+          (let
+            ((c0 (substring s 0 1)))
+            (let
+              ((start (if (or (= c0 "+") (= c0 "-")) 1 0)))
+              (knl-num-body? s start n))))))))
+
+(define
+  knl-num-body?
+  (fn
+    (s start n)
+    (cond
+      ((>= start n) false)
+      ((= (substring s start (+ start 1)) ".")
+        (knl-num-need-digits? s (+ start 1) n false))
+      ((lex-digit? (substring s start (+ start 1)))
+        (knl-num-int-tail? s (+ start 1) n))
+      (:else false))))
+
+(define
+  knl-num-int-tail?
+  (fn
+    (s i n)
+    (cond
+      ((>= i n) true)
+      ((lex-digit? (substring s i (+ i 1)))
+        (knl-num-int-tail? s (+ i 1) n))
+      ((= (substring s i (+ i 1)) ".")
+        (knl-num-need-digits? s (+ i 1) n true))
+      ((or (= (substring s i (+ i 1)) "e") (= (substring s i (+ i 1)) "E"))
+        (knl-num-exp-sign? s (+ i 1) n))
+      (:else false))))
+
+(define
+  knl-num-need-digits?
+  (fn
+    (s i n had-int)
+    (cond
+      ((>= i n) had-int)
+      ((lex-digit? (substring s i (+ i 1)))
+        (knl-num-frac-tail? s (+ i 1) n))
+      (:else false))))
+
+(define
+  knl-num-frac-tail?
+  (fn
+    (s i n)
+    (cond
+      ((>= i n) true)
+      ((lex-digit? (substring s i (+ i 1)))
+        (knl-num-frac-tail? s (+ i 1) n))
+      ((or (= (substring s i (+ i 1)) "e") (= (substring s i (+ i 1)) "E"))
+        (knl-num-exp-sign? s (+ i 1) n))
+      (:else false))))
+
+(define
+  knl-num-exp-sign?
+  (fn
+    (s i n)
+    (cond
+      ((>= i n) false)
+      ((or (= (substring s i (+ i 1)) "+") (= (substring s i (+ i 1)) "-"))
+        (knl-num-exp-digits? s (+ i 1) n false))
+      (:else (knl-num-exp-digits? s i n false)))))
+
+(define
+  knl-num-exp-digits?
+  (fn
+    (s i n had)
+    (cond
+      ((>= i n) had)
+      ((lex-digit? (substring s i (+ i 1)))
+        (knl-num-exp-digits? s (+ i 1) n true))
+      (:else false))))
+
+;; Reader: a closure over (src, pos). Exposes :read-form and :read-all.
+(define
+  knl-make-reader
+  (fn
+    (src)
+    (let
+      ((pos 0) (n (string-length src)))
+      (define
+        at
+        (fn () (if (< pos n) (substring src pos (+ pos 1)) nil)))
+      (define adv (fn () (set! pos (+ pos 1))))
+      (define
+        skip-line
+        (fn () (when (and (at) (not (= (at) "\n"))) (adv) (skip-line))))
+      (define
+        skip-ws
+        (fn
+          ()
+          (cond
+            ((nil? (at)) nil)
+            ((lex-whitespace? (at)) (do (adv) (skip-ws)))
+            ((= (at) ";") (do (adv) (skip-line) (skip-ws)))
+            (:else nil))))
+      (define
+        read-string-body
+        (fn
+          (acc)
+          (cond
+            ((nil? (at)) (error "kernel-parse: unterminated string"))
+            ((= (at) "\"") (do (adv) acc))
+            ((= (at) "\\")
+              (do
+                (adv)
+                (let
+                  ((c (at)))
+                  (when (nil? c) (error "kernel-parse: trailing backslash"))
+                  (adv)
+                  (read-string-body
+                    (str
+                      acc
+                      (cond
+                        ((= c "n") "\n")
+                        ((= c "t") "\t")
+                        ((= c "r") "\r")
+                        ((= c "\"") "\"")
+                        ((= c "\\") "\\")
+                        (:else c)))))))
+            (:else
+              (let ((c (at))) (adv) (read-string-body (str acc c)))))))
+      (define
+        read-atom-body
+        (fn
+          (acc)
+          (cond
+            ((knl-delim? (at)) acc)
+            (:else (let ((c (at))) (adv) (read-atom-body (str acc c)))))))
+      (define
+        classify-atom
+        (fn
+          (s)
+          (cond
+            ((= s "#t") true)
+            ((= s "#f") false)
+            ((knl-numeric? s) (string->number s))
+            (:else s))))
+      (define
+        read-form
+        (fn
+          ()
+          (skip-ws)
+          (cond
+            ((nil? (at)) :knl-eof)
+            ((= (at) ")") (error "kernel-parse: unexpected ')'"))
+            ((= (at) "(") (do (adv) (read-list (list))))
+            ((= (at) "\"")
+              (do (adv) (kernel-string-make (read-string-body ""))))
+            ((= (at) "'")
+              (do (adv) (list "$quote" (read-form))))
+            ((= (at) "`")
+              (do (adv) (list "$quasiquote" (read-form))))
+            ((= (at) ",")
+              (do (adv)
+                  (cond
+                    ((= (at) "@")
+                      (do (adv) (list "$unquote-splicing" (read-form))))
+                    (:else (list "$unquote" (read-form))))))
+            (:else (classify-atom (read-atom-body ""))))))
+      (define
+        read-list
+        (fn
+          (acc)
+          (skip-ws)
+          (cond
+            ((nil? (at)) (error "kernel-parse: unterminated list"))
+            ((= (at) ")") (do (adv) acc))
+            (:else (read-list (append acc (list (read-form))))))))
+      (define
+        read-all
+        (fn
+          (acc)
+          (skip-ws)
+          (if (nil? (at)) acc (read-all (append acc (list (read-form)))))))
+      {:read-form read-form :read-all read-all})))
+
+(define
+  kernel-parse-all
+  (fn (src) ((get (knl-make-reader src) :read-all) (list))))
+
+(define
+  kernel-parse
+  (fn
+    (src)
+    (let
+      ((r (knl-make-reader src)))
+      (let
+        ((form ((get r :read-form))))
+        (cond
+          ((= form :knl-eof) (error "kernel-parse: empty input"))
+          (:else
+            (let
+              ((next ((get r :read-form))))
+              (if
+                (= next :knl-eof)
+                form
+                (error "kernel-parse: trailing input after first form")))))))))

lib/kernel/runtime.sx

@@ -0,0 +1,881 @@
+;; lib/kernel/runtime.sx — the operative–applicative substrate and the
+;; standard Kernel environment.
+;;
+;; Phase 3 supplied four user-visible combiners ($vau, $lambda, wrap,
+;; unwrap). Phase 4 fills out the rest of the R-1RK core: $if, $define!,
+;; $sequence, eval, make-environment, get-current-environment, plus
+;; arithmetic, equality, list/pair, and boolean primitives — enough to
+;; write factorial.
+;;
+;; The standard env is built by EXTENDING the base env, not replacing
+;; it. So `kernel-standard-env` includes everything from `kernel-base-env`.
+;;
+;; Public API
+;;   (kernel-base-env)       — Phase 3 combiners
+;;   (kernel-standard-env)   — Phase 4 standard environment
+
+(define
+  knl-eparam-sentinel
+  (fn
+    (sym)
+    (cond
+      ((= sym "_") :knl-ignore)
+      ((= sym "#ignore") :knl-ignore)
+      (:else sym))))
+
+(define
+  knl-formals-ok?
+  (fn
+    (formals)
+    (cond
+      ((not (list? formals)) false)
+      ((= (length formals) 0) true)
+      ((string? (first formals)) (knl-formals-ok? (rest formals)))
+      (:else false))))
+
+;; ── $vau ─────────────────────────────────────────────────────────
+
+(define
+  kernel-vau-impl
+  (fn
+    (args dyn-env)
+    (cond
+      ((< (length args) 3)
+        (error "$vau: expects (formals env-param body...)"))
+      (:else
+        (let
+          ((formals (first args))
+            (eparam-raw (nth args 1))
+            (body-forms (rest (rest args))))
+          (cond
+            ((not (knl-formals-ok? formals))
+              (error "$vau: formals must be a list of symbols"))
+            ((not (string? eparam-raw))
+              (error "$vau: env-param must be a symbol"))
+            (:else
+              (kernel-make-user-operative
+                formals
+                (knl-eparam-sentinel eparam-raw)
+                body-forms
+                dyn-env))))))))
+
+(define
+  kernel-vau-operative
+  (kernel-make-primitive-operative kernel-vau-impl))
+
+;; ── $lambda ──────────────────────────────────────────────────────
+
+(define
+  kernel-lambda-impl
+  (fn
+    (args dyn-env)
+    (cond
+      ((< (length args) 2)
+        (error "$lambda: expects (formals body...)"))
+      (:else
+        (let
+          ((formals (first args)) (body-forms (rest args)))
+          (cond
+            ((not (knl-formals-ok? formals))
+              (error "$lambda: formals must be a list of symbols"))
+            (:else
+              (kernel-wrap
+                (kernel-make-user-operative
+                  formals
+                  :knl-ignore
+                  body-forms
+                  dyn-env)))))))))
+
+(define
+  kernel-lambda-operative
+  (kernel-make-primitive-operative kernel-lambda-impl))
+
+;; ── wrap / unwrap / predicates ───────────────────────────────────
+
+(define
+  kernel-wrap-applicative
+  (kernel-make-primitive-applicative
+    (fn
+      (args)
+      (cond
+        ((not (= (length args) 1))
+          (error "wrap: expects exactly 1 argument"))
+        (:else (kernel-wrap (first args)))))))
+
+(define
+  kernel-unwrap-applicative
+  (kernel-make-primitive-applicative
+    (fn
+      (args)
+      (cond
+        ((not (= (length args) 1))
+          (error "unwrap: expects exactly 1 argument"))
+        (:else (kernel-unwrap (first args)))))))
+
+(define
+  kernel-operative?-applicative
+  (kernel-make-primitive-applicative
+    (fn (args) (kernel-operative? (first args)))))
+
+(define
+  kernel-applicative?-applicative
+  (kernel-make-primitive-applicative
+    (fn (args) (kernel-applicative? (first args)))))
+
+(define
+  kernel-base-env
+  (fn
+    ()
+    (let
+      ((env (kernel-make-env)))
+      (kernel-env-bind! env "$vau" kernel-vau-operative)
+      (kernel-env-bind! env "$lambda" kernel-lambda-operative)
+      (kernel-env-bind! env "wrap" kernel-wrap-applicative)
+      (kernel-env-bind! env "unwrap" kernel-unwrap-applicative)
+      (kernel-env-bind! env "operative?" kernel-operative?-applicative)
+      (kernel-env-bind! env "applicative?" kernel-applicative?-applicative)
+      env)))
+
+;; ── $if / $define! / $sequence ───────────────────────────────────
+
+(define
+  kernel-if-operative
+  (kernel-make-primitive-operative
+    (fn
+      (args dyn-env)
+      (cond
+        ((not (= (length args) 3))
+          (error "$if: expects (condition then-expr else-expr)"))
+        (:else
+          (let
+            ((c (kernel-eval (first args) dyn-env)))
+            (if
+              c
+              (kernel-eval (nth args 1) dyn-env)
+              (kernel-eval (nth args 2) dyn-env))))))))
+
+(define
+  kernel-define!-operative
+  (kernel-make-primitive-operative
+    (fn
+      (args dyn-env)
+      (cond
+        ((not (= (length args) 2))
+          (error "$define!: expects (name expr)"))
+        ((not (string? (first args)))
+          (error "$define!: name must be a symbol"))
+        (:else
+          (let
+            ((v (kernel-eval (nth args 1) dyn-env)))
+            (kernel-env-bind! dyn-env (first args) v)
+            v))))))
+
+(define
+  kernel-sequence-operative
+  (kernel-make-primitive-operative
+    (fn
+      (args dyn-env)
+      (cond
+        ((or (nil? args) (= (length args) 0)) nil)
+        ((= (length args) 1) (kernel-eval (first args) dyn-env))
+        (:else
+          (begin
+            (kernel-eval (first args) dyn-env)
+            ((get kernel-sequence-operative :impl) (rest args) dyn-env)))))))
+
+;; ── eval / make-environment / get-current-environment ───────────
+
+(define
+  kernel-quote-operative
+  (kernel-make-primitive-operative
+    (fn
+      (args dyn-env)
+      (cond
+        ((not (= (length args) 1)) (error "$quote: expects 1 argument"))
+        (:else (first args))))))
+
+;; Kernel-side adapter for lib/guest/reflective/quoting.sx.
+;; Kernel uses $unquote / $unquote-splicing (dollar-prefixed) and the
+;; host-level kernel-eval as the evaluator. The walker algorithm
+;; itself is shared with Scheme via the kit.
+(define knl-quasi-cfg
+  {:unquote-name "$unquote"
+   :unquote-splicing-name "$unquote-splicing"
+   :eval (fn (form env) (kernel-eval form env))})
+
+(define knl-quasi-walk
+  (fn (form dyn-env)
+    (refl-quasi-walk-with knl-quasi-cfg form dyn-env)))
+
+;; $cond — multi-clause branch.
+;;   ($cond (TEST1 EXPR1 ...) (TEST2 EXPR2 ...) ...)
+;; Evaluates each TEST in order; first truthy one runs its EXPRs (in
+;; sequence) and returns the last; if no TEST is truthy, returns nil.
+;; A clause with TEST = `else` always matches (sugar for $if's default).
+(define knl-cond-impl
+  (fn (clauses dyn-env)
+    (cond
+      ((or (nil? clauses) (= (length clauses) 0)) nil)
+      (:else
+        (let ((clause (first clauses)))
+          (cond
+            ((not (list? clause))
+              (error "$cond: each clause must be a list"))
+            ((= (length clause) 0)
+              (error "$cond: empty clause"))
+            ((and (string? (first clause)) (= (first clause) "else"))
+              (knl-cond-eval-body (rest clause) dyn-env))
+            (:else
+              (let ((test-val (kernel-eval (first clause) dyn-env)))
+                (cond
+                  (test-val (knl-cond-eval-body (rest clause) dyn-env))
+                  (:else (knl-cond-impl (rest clauses) dyn-env)))))))))))
+
+(define knl-cond-eval-body
+  (fn (body dyn-env)
+    (cond
+      ((or (nil? body) (= (length body) 0)) nil)
+      ((= (length body) 1) (kernel-eval (first body) dyn-env))
+      (:else
+        (begin
+          (kernel-eval (first body) dyn-env)
+          (knl-cond-eval-body (rest body) dyn-env))))))
+
+(define kernel-cond-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env) (knl-cond-impl args dyn-env))))
+
+;; $when COND BODY... — evaluate body iff COND is truthy; else nil.
+(define kernel-when-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env)
+      (cond
+        ((< (length args) 1)
+          (error "$when: expects (cond body...)"))
+        (:else
+          (let ((c (kernel-eval (first args) dyn-env)))
+            (cond
+              (c (knl-cond-eval-body (rest args) dyn-env))
+              (:else nil))))))))
+
+;; $and? — short-circuit AND. Operative (not applicative) so untaken
+;; clauses are NOT evaluated. Empty $and? returns true (the identity).
+(define knl-and?-impl
+  (fn (args dyn-env)
+    (cond
+      ((or (nil? args) (= (length args) 0)) true)
+      ((= (length args) 1) (kernel-eval (first args) dyn-env))
+      (:else
+        (let ((v (kernel-eval (first args) dyn-env)))
+          (cond
+            (v (knl-and?-impl (rest args) dyn-env))
+            (:else v)))))))
+
+(define kernel-and?-operative
+  (kernel-make-primitive-operative knl-and?-impl))
+
+;; $or? — short-circuit OR. Operative; untaken clauses NOT evaluated.
+;; Empty $or? returns false (the identity).
+(define knl-or?-impl
+  (fn (args dyn-env)
+    (cond
+      ((or (nil? args) (= (length args) 0)) false)
+      ((= (length args) 1) (kernel-eval (first args) dyn-env))
+      (:else
+        (let ((v (kernel-eval (first args) dyn-env)))
+          (cond
+            (v v)
+            (:else (knl-or?-impl (rest args) dyn-env))))))))
+
+(define kernel-or?-operative
+  (kernel-make-primitive-operative knl-or?-impl))
+
+;; $unless COND BODY... — evaluate body iff COND is falsy; else nil.
+(define kernel-unless-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env)
+      (cond
+        ((< (length args) 1)
+          (error "$unless: expects (cond body...)"))
+        (:else
+          (let ((c (kernel-eval (first args) dyn-env)))
+            (cond
+              (c nil)
+              (:else (knl-cond-eval-body (rest args) dyn-env)))))))))
+
+(define kernel-quasiquote-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env)
+      (cond
+        ((not (= (length args) 1))
+          (error "$quasiquote: expects exactly 1 argument"))
+        (:else (knl-quasi-walk (first args) dyn-env))))))
+
+(define
+  kernel-eval-applicative
+  (kernel-make-primitive-applicative
+    (fn
+      (args)
+      (cond
+        ((not (= (length args) 2))
+          (error "eval: expects (expr env)"))
+        ((not (kernel-env? (nth args 1)))
+          (error "eval: second arg must be a kernel env"))
+        (:else (kernel-eval (first args) (nth args 1)))))))
+
+(define
+  kernel-make-environment-applicative
+  (kernel-make-primitive-applicative
+    (fn
+      (args)
+      (cond
+        ((= (length args) 0) (kernel-make-env))
+        ((= (length args) 1)
+          (cond
+            ((not (kernel-env? (first args)))
+              (error "make-environment: parent must be a kernel env"))
+            (:else (kernel-extend-env (first args)))))
+        (:else (error "make-environment: 0 or 1 argument"))))))
+
+;; ── arithmetic and comparison (binary; trivial to extend later) ─
+
+(define
+  kernel-get-current-env-operative
+  (kernel-make-primitive-operative
+    (fn
+      (args dyn-env)
+      (cond
+        ((not (= (length args) 0))
+          (error "get-current-environment: expects 0 arguments"))
+        (:else dyn-env)))))
+
+(define
+  knl-bin-app
+  (fn
+    (name f)
+    (kernel-make-primitive-applicative
+      (fn
+        (args)
+        (cond
+          ((not (= (length args) 2))
+            (error (str name ": expects 2 arguments")))
+          (:else (f (first args) (nth args 1))))))))
+
+;; Variadic left-fold helper. ZERO-RES is the identity (`(+)` → 0);
+;; ONE-FN handles single-arg case (`(- x)` negates; `(+ x)` returns x).
+(define knl-fold-step
+  (fn (f acc rest-args)
+    (cond
+      ((or (nil? rest-args) (= (length rest-args) 0)) acc)
+      (:else
+        (knl-fold-step f (f acc (first rest-args)) (rest rest-args))))))
+
+(define knl-fold-app
+  (fn (name f zero-res one-fn)
+    (kernel-make-primitive-applicative
+      (fn (args)
+        (cond
+          ((= (length args) 0) zero-res)
+          ((= (length args) 1) (one-fn (first args)))
+          (:else (knl-fold-step f (first args) (rest args))))))))
+
+;; Variadic n-ary chained comparison: `(< 1 2 3)` ≡ `(< 1 2)` AND `(< 2 3)`.
+(define knl-chain-step
+  (fn (cmp prev rest-args)
+    (cond
+      ((or (nil? rest-args) (= (length rest-args) 0)) true)
+      (:else
+        (let ((next (first rest-args)))
+          (cond
+            ((cmp prev next)
+              (knl-chain-step cmp next (rest rest-args)))
+            (:else false)))))))
+
+(define knl-chain-cmp
+  (fn (name cmp)
+    (kernel-make-primitive-applicative
+      (fn (args)
+        (cond
+          ((< (length args) 2)
+            (error (str name ": expects at least 2 arguments")))
+          (:else (knl-chain-step cmp (first args) (rest args))))))))
+
+;; ── list / pair primitives ──────────────────────────────────────
+
+(define
+  knl-unary-app
+  (fn
+    (name f)
+    (kernel-make-primitive-applicative
+      (fn
+        (args)
+        (cond
+          ((not (= (length args) 1))
+            (error (str name ": expects 1 argument")))
+          (:else (f (first args))))))))
+
+(define kernel-cons-applicative (knl-bin-app "cons" (fn (a b) (cons a b))))
+
+(define
+  kernel-car-applicative
+  (knl-unary-app
+    "car"
+    (fn
+      (xs)
+      (cond
+        ((or (nil? xs) (and (list? xs) (= (length xs) 0)))
+          (error "car: empty list"))
+        (:else (first xs))))))
+
+(define
+  kernel-cdr-applicative
+  (knl-unary-app
+    "cdr"
+    (fn
+      (xs)
+      (cond
+        ((or (nil? xs) (and (list? xs) (= (length xs) 0)))
+          (error "cdr: empty list"))
+        (:else (rest xs))))))
+
+(define
+  kernel-list-applicative
+  (kernel-make-primitive-applicative (fn (args) args)))
+
+(define
+  kernel-length-applicative
+  (knl-unary-app "length" (fn (xs) (length xs))))
+
+(define
+  kernel-null?-applicative
+  (knl-unary-app
+    "null?"
+    (fn (v) (or (nil? v) (and (list? v) (= (length v) 0))))))
+
+;; ── boolean / equality ──────────────────────────────────────────
+
+(define
+  kernel-pair?-applicative
+  (knl-unary-app
+    "pair?"
+    (fn (v) (and (list? v) (> (length v) 0)))))
+
+(define knl-append-step
+  (fn (xs ys)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) ys)
+      (:else (cons (first xs) (knl-append-step (rest xs) ys))))))
+
+(define knl-all-lists?
+  (fn (xs)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) true)
+      ((list? (first xs)) (knl-all-lists? (rest xs)))
+      (:else false))))
+
+(define knl-append-all
+  (fn (lists)
+    (cond
+      ((or (nil? lists) (= (length lists) 0)) (list))
+      ((= (length lists) 1) (first lists))
+      (:else
+        (knl-append-step (first lists)
+                         (knl-append-all (rest lists)))))))
+
+(define kernel-append-applicative
+  (kernel-make-primitive-applicative
+    (fn (args)
+      (cond
+        ((knl-all-lists? args) (knl-append-all args))
+        (:else (error "append: all arguments must be lists"))))))
+
+(define knl-reverse-step
+  (fn (xs acc)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) acc)
+      (:else (knl-reverse-step (rest xs) (cons (first xs) acc))))))
+
+(define kernel-reverse-applicative
+  (knl-unary-app "reverse"
+    (fn (xs)
+      (cond
+        ((not (list? xs)) (error "reverse: argument must be a list"))
+        (:else (knl-reverse-step xs (list)))))))
+
+(define kernel-not-applicative (knl-unary-app "not" (fn (v) (not v))))
+
+;; Type predicates (Kernel-visible). Note `string?` covers BOTH symbols
+;; and string-literals in our representation (symbols are bare SX
+;; strings); a `kernel-string?` applicative distinguishes the two if
+;; needed.
+(define kernel-number?-applicative
+  (knl-unary-app "number?" (fn (v) (number? v))))
+(define kernel-string?-applicative
+  (knl-unary-app "string?" (fn (v) (string? v))))
+(define kernel-list?-applicative
+  (knl-unary-app "list?" (fn (v) (list? v))))
+(define kernel-boolean?-applicative
+  (knl-unary-app "boolean?" (fn (v) (boolean? v))))
+(define kernel-symbol?-applicative
+  (knl-unary-app "symbol?" (fn (v) (string? v))))
+
+(define kernel-eq?-applicative (knl-bin-app "eq?" (fn (a b) (= a b))))
+
+;; ── the standard environment ────────────────────────────────────
+
+(define
+  kernel-equal?-applicative
+  (knl-bin-app "equal?" (fn (a b) (= a b))))
+
+;; ── List combinators: map / filter / reduce ─────────────────────
+;; These re-enter the evaluator on each element, so they use the
+;; with-env applicative constructor.
+
+;; When the combiner is an applicative, we MUST unwrap before calling
+;; — otherwise kernel-combine will re-evaluate the already-evaluated
+;; element values (and crash if an element is itself a list).
+(define knl-apply-op
+  (fn (combiner)
+    (cond
+      ((kernel-applicative? combiner) (kernel-unwrap combiner))
+      (:else combiner))))
+
+(define knl-map-step
+  (fn (fn-val xs dyn-env)
+    (let ((op (knl-apply-op fn-val)))
+      (knl-map-walk op xs dyn-env))))
+
+(define knl-map-walk
+  (fn (op xs dyn-env)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) (list))
+      (:else
+        (cons (kernel-combine op (list (first xs)) dyn-env)
+              (knl-map-walk op (rest xs) dyn-env))))))
+
+(define kernel-map-applicative
+  (kernel-make-primitive-applicative-with-env
+    (fn (args dyn-env)
+      (cond
+        ((not (= (length args) 2))
+          (error "map: expects (fn list)"))
+        ((not (kernel-combiner? (first args)))
+          (error "map: first arg must be a combiner"))
+        ((not (list? (nth args 1)))
+          (error "map: second arg must be a list"))
+        (:else (knl-map-step (first args) (nth args 1) dyn-env))))))
+
+(define knl-filter-step
+  (fn (pred xs dyn-env)
+    (knl-filter-walk (knl-apply-op pred) xs dyn-env)))
+
+(define knl-filter-walk
+  (fn (op xs dyn-env)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) (list))
+      (:else
+        (let ((keep? (kernel-combine op (list (first xs)) dyn-env)))
+          (cond
+            (keep?
+              (cons (first xs) (knl-filter-walk op (rest xs) dyn-env)))
+            (:else (knl-filter-walk op (rest xs) dyn-env))))))))
+
+(define kernel-filter-applicative
+  (kernel-make-primitive-applicative-with-env
+    (fn (args dyn-env)
+      (cond
+        ((not (= (length args) 2))
+          (error "filter: expects (pred list)"))
+        ((not (kernel-combiner? (first args)))
+          (error "filter: first arg must be a combiner"))
+        ((not (list? (nth args 1)))
+          (error "filter: second arg must be a list"))
+        (:else (knl-filter-step (first args) (nth args 1) dyn-env))))))
+
+(define knl-reduce-step
+  (fn (fn-val xs acc dyn-env)
+    (knl-reduce-walk (knl-apply-op fn-val) xs acc dyn-env)))
+
+(define knl-reduce-walk
+  (fn (op xs acc dyn-env)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) acc)
+      (:else
+        (knl-reduce-walk
+          op
+          (rest xs)
+          (kernel-combine op (list acc (first xs)) dyn-env)
+          dyn-env)))))
+
+;; (apply COMBINER ARGS-LIST) — call COMBINER with the elements of
+;; ARGS-LIST as arguments. The Kernel canonical use: turn a constructed
+;; list of values into a function call. We skip the applicative's
+;; auto-eval step (via unwrap) because ARGS-LIST is already values, not
+;; expressions; for a bare operative, we pass through directly.
+(define kernel-apply-applicative
+  (kernel-make-primitive-applicative-with-env
+    (fn (args dyn-env)
+      (cond
+        ((not (= (length args) 2))
+          (error "apply: expects (combiner args-list)"))
+        ((not (kernel-combiner? (first args)))
+          (error "apply: first arg must be a combiner"))
+        ((not (list? (nth args 1)))
+          (error "apply: second arg must be a list"))
+        (:else
+          (let ((op (cond
+                      ((kernel-applicative? (first args))
+                        (kernel-unwrap (first args)))
+                      (:else (first args)))))
+            (kernel-combine op (nth args 1) dyn-env)))))))
+
+(define kernel-reduce-applicative
+  (kernel-make-primitive-applicative-with-env
+    (fn (args dyn-env)
+      (cond
+        ((not (= (length args) 3))
+          (error "reduce: expects (fn init list)"))
+        ((not (kernel-combiner? (first args)))
+          (error "reduce: first arg must be a combiner"))
+        ((not (list? (nth args 2)))
+          (error "reduce: third arg must be a list"))
+        (:else
+          (knl-reduce-step (first args) (nth args 2)
+                           (nth args 1) dyn-env))))))
+
+;; ── Encapsulations: Kernel's opaque-type idiom ──────────────────
+;;
+;; (make-encapsulation-type) → (encapsulator predicate decapsulator)
+;;
+;; Each call returns three applicatives over a fresh family identity.
+;; - (encapsulator V) → an opaque wrapper around V.
+;; - (predicate V)    → true iff V was wrapped by THIS family.
+;; - (decapsulator W) → the inner value; errors on wrong family.
+;;
+;; Family identity is a fresh empty dict; SX compares dicts by reference,
+;; so two `(make-encapsulation-type)` calls return distinct families.
+;;
+;; Pattern usage (Phase 5 lacks destructuring, so accessors are explicit):
+;;   ($define! triple (make-encapsulation-type))
+;;   ($define! wrap-promise   (car  triple))
+;;   ($define! promise?       (car  (cdr triple)))
+;;   ($define! unwrap-promise (car  (cdr (cdr triple))))
+
+(define kernel-make-encap-type-impl
+  (fn (args)
+    (cond
+      ((not (= (length args) 0))
+        (error "make-encapsulation-type: expects 0 arguments"))
+      (:else
+        (let ((family {}))
+          (let ((encap
+                  (kernel-make-primitive-applicative
+                    (fn (vargs)
+                      (cond
+                        ((not (= (length vargs) 1))
+                          (error "encapsulator: expects 1 argument"))
+                        (:else
+                          {:knl-tag :encap
+                           :family family
+                           :value (first vargs)})))))
+                (pred
+                  (kernel-make-primitive-applicative
+                    (fn (vargs)
+                      (cond
+                        ((not (= (length vargs) 1))
+                          (error "predicate: expects 1 argument"))
+                        (:else
+                          (let ((v (first vargs)))
+                            (and (dict? v)
+                                 (= (get v :knl-tag) :encap)
+                                 (= (get v :family) family))))))))
+                (decap
+                  (kernel-make-primitive-applicative
+                    (fn (vargs)
+                      (cond
+                        ((not (= (length vargs) 1))
+                          (error "decapsulator: expects 1 argument"))
+                        (:else
+                          (let ((v (first vargs)))
+                            (cond
+                              ((not (and (dict? v)
+                                         (= (get v :knl-tag) :encap)))
+                                (error "decapsulator: not an encapsulation"))
+                              ((not (= (get v :family) family))
+                                (error "decapsulator: wrong family"))
+                              (:else (get v :value))))))))))
+            (list encap pred decap)))))))
+
+(define kernel-make-encap-type-applicative
+  (kernel-make-primitive-applicative kernel-make-encap-type-impl))
+
+;; ── Hygiene: $let, $define-in!, make-environment ────────────────
+;;
+;; Kernel-on-SX is hygienic *by default* because user-defined operatives
+;; (Phase 3) bind their formals + any $define! in a CHILD env extending
+;; the operative's static-env, never the dyn-env. The caller's env is
+;; only mutated when code explicitly says so (e.g. `(eval expr env-arg)`).
+;;
+;; Phase 6 adds two helpers that make the property easy to lean on:
+;;
+;;   ($let ((NAME EXPR) ...) BODY)
+;;     Evaluates each EXPR in the calling env, binds NAME in a fresh
+;;     child env, evaluates BODY in that child env. NAMES don't leak.
+;;
+;;   ($define-in! ENV NAME EXPR)
+;;     Binds NAME=value-of-EXPR in the *specified* env, not the dyn-env.
+;;     Useful for operatives that need to mutate a sandbox env without
+;;     touching their caller's env.
+;;
+;; Shutt's full scope-set / frame-stamp hygiene (lifted symbols carrying
+;; provenance markers so introduced bindings can shadow without
+;; capturing) is research-grade and not implemented here. Notes for
+;; `lib/guest/reflective/hygiene.sx` candidate API below the std env.
+
+(define knl-bind-let-vals!
+  (fn (local bindings dyn-env)
+    (cond
+      ((or (nil? bindings) (= (length bindings) 0)) nil)
+      (:else
+        (let ((b (first bindings)))
+          (cond
+            ((not (and (list? b) (= (length b) 2)))
+              (error "$let: each binding must be (name expr)"))
+            ((not (string? (first b)))
+              (error "$let: binding name must be a symbol"))
+            (:else
+              (begin
+                (kernel-env-bind! local
+                                  (first b)
+                                  (kernel-eval (nth b 1) dyn-env))
+                (knl-bind-let-vals! local (rest bindings) dyn-env)))))))))
+
+(define kernel-let-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env)
+      (cond
+        ((< (length args) 2)
+          (error "$let: expects (bindings body...)"))
+        ((not (list? (first args)))
+          (error "$let: bindings must be a list"))
+        (:else
+          (let ((local (kernel-extend-env dyn-env)))
+            (knl-bind-let-vals! local (first args) dyn-env)
+            (knl-eval-body (rest args) local)))))))
+
+;; $let* — sequential let. Each binding sees prior names in scope.
+;; Implemented by nesting envs one per binding; the body runs in the
+;; innermost env, so later bindings shadow earlier ones if names repeat.
+(define knl-let*-step
+  (fn (bindings env body-forms)
+    (cond
+      ((or (nil? bindings) (= (length bindings) 0))
+        (knl-eval-body body-forms env))
+      (:else
+        (let ((b (first bindings)))
+          (cond
+            ((not (and (list? b) (= (length b) 2)))
+              (error "$let*: each binding must be (name expr)"))
+            ((not (string? (first b)))
+              (error "$let*: binding name must be a symbol"))
+            (:else
+              (let ((child (kernel-extend-env env)))
+                (kernel-env-bind! child
+                                  (first b)
+                                  (kernel-eval (nth b 1) env))
+                (knl-let*-step (rest bindings) child body-forms)))))))))
+
+(define kernel-let*-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env)
+      (cond
+        ((< (length args) 2)
+          (error "$let*: expects (bindings body...)"))
+        ((not (list? (first args)))
+          (error "$let*: bindings must be a list"))
+        (:else
+          (knl-let*-step (first args) dyn-env (rest args)))))))
+
+(define kernel-define-in!-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env)
+      (cond
+        ((not (= (length args) 3))
+          (error "$define-in!: expects (env-expr name expr)"))
+        ((not (string? (nth args 1)))
+          (error "$define-in!: name must be a symbol"))
+        (:else
+          (let ((target (kernel-eval (first args) dyn-env)))
+            (cond
+              ((not (kernel-env? target))
+                (error "$define-in!: first arg must evaluate to an env"))
+              (:else
+                (let ((v (kernel-eval (nth args 2) dyn-env)))
+                  (kernel-env-bind! target (nth args 1) v)
+                  v)))))))))
+
+(define
+  kernel-standard-env
+  (fn
+    ()
+    (let
+      ((env (kernel-base-env)))
+      (kernel-env-bind! env "$if" kernel-if-operative)
+      (kernel-env-bind! env "$define!" kernel-define!-operative)
+      (kernel-env-bind! env "$sequence" kernel-sequence-operative)
+      (kernel-env-bind! env "$quote"    kernel-quote-operative)
+      (kernel-env-bind! env "$quasiquote" kernel-quasiquote-operative)
+      (kernel-env-bind! env "$cond"   kernel-cond-operative)
+      (kernel-env-bind! env "$when"   kernel-when-operative)
+      (kernel-env-bind! env "$unless" kernel-unless-operative)
+      (kernel-env-bind! env "$and?"   kernel-and?-operative)
+      (kernel-env-bind! env "$or?"    kernel-or?-operative)
+      (kernel-env-bind! env "eval" kernel-eval-applicative)
+      (kernel-env-bind!
+        env
+        "make-environment"
+        kernel-make-environment-applicative)
+      (kernel-env-bind!
+        env
+        "get-current-environment"
+        kernel-get-current-env-operative)
+      (kernel-env-bind! env "+"
+        (knl-fold-app "+" (fn (a b) (+ a b)) 0 (fn (x) x)))
+      (kernel-env-bind! env "-"
+        (knl-fold-app "-" (fn (a b) (- a b)) 0 (fn (x) (- 0 x))))
+      (kernel-env-bind! env "*"
+        (knl-fold-app "*" (fn (a b) (* a b)) 1 (fn (x) x)))
+      (kernel-env-bind! env "/"
+        (knl-fold-app "/" (fn (a b) (/ a b)) 1 (fn (x) (/ 1 x))))
+      (kernel-env-bind! env "<"   (knl-chain-cmp "<"   (fn (a b) (< a b))))
+      (kernel-env-bind! env ">"   (knl-chain-cmp ">"   (fn (a b) (> a b))))
+      (kernel-env-bind! env "<=?" (knl-chain-cmp "<=?" (fn (a b) (<= a b))))
+      (kernel-env-bind! env ">=?" (knl-chain-cmp ">=?" (fn (a b) (>= a b))))
+      (kernel-env-bind! env "=?" kernel-eq?-applicative)
+      (kernel-env-bind! env "equal?" kernel-equal?-applicative)
+      (kernel-env-bind! env "eq?" kernel-eq?-applicative)
+      (kernel-env-bind! env "cons" kernel-cons-applicative)
+      (kernel-env-bind! env "car" kernel-car-applicative)
+      (kernel-env-bind! env "cdr" kernel-cdr-applicative)
+      (kernel-env-bind! env "list" kernel-list-applicative)
+      (kernel-env-bind! env "length" kernel-length-applicative)
+      (kernel-env-bind! env "null?" kernel-null?-applicative)
+      (kernel-env-bind! env "pair?" kernel-pair?-applicative)
+      (kernel-env-bind! env "map"    kernel-map-applicative)
+      (kernel-env-bind! env "filter" kernel-filter-applicative)
+      (kernel-env-bind! env "reduce" kernel-reduce-applicative)
+      (kernel-env-bind! env "apply"   kernel-apply-applicative)
+      (kernel-env-bind! env "append"  kernel-append-applicative)
+      (kernel-env-bind! env "reverse" kernel-reverse-applicative)
+      (kernel-env-bind! env "number?"  kernel-number?-applicative)
+      (kernel-env-bind! env "string?"  kernel-string?-applicative)
+      (kernel-env-bind! env "list?"    kernel-list?-applicative)
+      (kernel-env-bind! env "boolean?" kernel-boolean?-applicative)
+      (kernel-env-bind! env "symbol?"  kernel-symbol?-applicative)
+      (kernel-env-bind! env "not" kernel-not-applicative)
+      (kernel-env-bind! env "make-encapsulation-type"
+                            kernel-make-encap-type-applicative)
+      (kernel-env-bind! env "$let"         kernel-let-operative)
+      (kernel-env-bind! env "$let*"        kernel-let*-operative)
+      (kernel-env-bind! env "$define-in!"  kernel-define-in!-operative)
+      env)))

lib/kernel/tests/encap.sx

@@ -0,0 +1,183 @@
+;; lib/kernel/tests/encap.sx — exercises make-encapsulation-type.
+;;
+;; The Phase 5 Kernel idiom: build opaque types whose constructor,
+;; predicate, and accessor are all standard Kernel applicatives. The
+;; identity is per-call, so two `(make-encapsulation-type)` calls
+;; produce non-interchangeable families.
+
+(define ken-test-pass 0)
+(define ken-test-fail 0)
+(define ken-test-fails (list))
+
+(define
+  ken-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! ken-test-pass (+ ken-test-pass 1))
+      (begin
+        (set! ken-test-fail (+ ken-test-fail 1))
+        (append! ken-test-fails {:name name :actual actual :expected expected})))))
+
+(define ken-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
+
+;; A helper that builds a standard env with `encap`/`pred?`/`decap`
+;; bound from a single call to make-encapsulation-type.
+(define
+  ken-make-encap-env
+  (fn
+    ()
+    (let
+      ((env (kernel-standard-env)))
+      (ken-eval-in "($define! triple (make-encapsulation-type))" env)
+      (ken-eval-in "($define! encap (car triple))" env)
+      (ken-eval-in "($define! pred? (car (cdr triple)))" env)
+      (ken-eval-in "($define! decap (car (cdr (cdr triple))))" env)
+      env)))
+
+;; ── construction ────────────────────────────────────────────────
+(ken-test
+  "make: returns 3-element list"
+  (ken-eval-in "(length (make-encapsulation-type))" (kernel-standard-env))
+  3)
+
+(ken-test
+  "make: first is applicative"
+  (kernel-applicative?
+    (ken-eval-in "(car (make-encapsulation-type))" (kernel-standard-env)))
+  true)
+
+(ken-test
+  "make: second is applicative"
+  (kernel-applicative?
+    (ken-eval-in
+      "(car (cdr (make-encapsulation-type)))"
+      (kernel-standard-env)))
+  true)
+
+(ken-test
+  "make: third is applicative"
+  (kernel-applicative?
+    (ken-eval-in
+      "(car (cdr (cdr (make-encapsulation-type))))"
+      (kernel-standard-env)))
+  true)
+
+;; ── round-trip ──────────────────────────────────────────────────
+(ken-test
+  "round-trip: number"
+  (ken-eval-in "(decap (encap 42))" (ken-make-encap-env))
+  42)
+
+(ken-test
+  "round-trip: string"
+  (ken-eval-in "(decap (encap ($quote hello)))" (ken-make-encap-env))
+  "hello")
+
+(ken-test
+  "round-trip: list"
+  (ken-eval-in "(decap (encap (list 1 2 3)))" (ken-make-encap-env))
+  (list 1 2 3))
+
+;; ── predicate ───────────────────────────────────────────────────
+(ken-test
+  "pred?: wrapped value"
+  (ken-eval-in "(pred? (encap 1))" (ken-make-encap-env))
+  true)
+
+(ken-test
+  "pred?: raw value"
+  (ken-eval-in "(pred? 1)" (ken-make-encap-env))
+  false)
+
+(ken-test
+  "pred?: raw string"
+  (ken-eval-in "(pred? ($quote foo))" (ken-make-encap-env))
+  false)
+
+(ken-test
+  "pred?: raw list"
+  (ken-eval-in "(pred? (list))" (ken-make-encap-env))
+  false)
+
+;; ── opacity: different families are not interchangeable ─────────
+(ken-test
+  "opacity: foreign value rejected by predicate"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in "($define! tA (make-encapsulation-type))" env)
+    (ken-eval-in "($define! tB (make-encapsulation-type))" env)
+    (ken-eval-in "($define! encA (car tA))" env)
+    (ken-eval-in "($define! predB (car (cdr tB)))" env)
+    (ken-eval-in "(predB (encA 42))" env))
+  false)
+
+(ken-test
+  "opacity: decap rejects foreign value"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in "($define! tA (make-encapsulation-type))" env)
+    (ken-eval-in "($define! tB (make-encapsulation-type))" env)
+    (ken-eval-in "($define! encA (car tA))" env)
+    (ken-eval-in "($define! decapB (car (cdr (cdr tB))))" env)
+    (guard (e (true :raised)) (ken-eval-in "(decapB (encA 42))" env)))
+  :raised)
+
+(ken-test
+  "opacity: decap rejects raw value"
+  (guard
+    (e (true :raised))
+    (ken-eval-in "(decap 42)" (ken-make-encap-env)))
+  :raised)
+
+;; ── promise: classic Kernel encapsulation use case ──────────────
+;; A "promise" wraps a thunk to compute on demand and memoises the
+;; first result. Built entirely with the standard encap idiom.
+(ken-test
+  "promise: force returns thunk result"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in
+      "($sequence\n         ($define! ptriple (make-encapsulation-type))\n         ($define! make-promise (car ptriple))\n         ($define! promise? (car (cdr ptriple)))\n         ($define! decode-promise (car (cdr (cdr ptriple))))\n         ($define! force ($lambda (p) ((decode-promise p))))\n         ($define! delay ($lambda (thunk) (make-promise thunk)))\n         (force (delay ($lambda () (+ 19 23)))))"
+      env))
+  42)
+
+(ken-test
+  "promise: promise? recognises its own type"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in
+      "($sequence\n         ($define! ptriple (make-encapsulation-type))\n         ($define! make-promise (car ptriple))\n         ($define! promise? (car (cdr ptriple)))\n         (promise? (make-promise ($lambda () 42))))"
+      env))
+  true)
+
+(ken-test
+  "promise: promise? false on plain value"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in
+      "($sequence\n         ($define! ptriple (make-encapsulation-type))\n         ($define! promise? (car (cdr ptriple)))\n         (promise? 99))"
+      env))
+  false)
+
+;; ── independent families don't leak ─────────────────────────────
+(ken-test
+  "two families: distinct identity"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in
+      "($sequence\n         ($define! t1 (make-encapsulation-type))\n         ($define! t2 (make-encapsulation-type))\n         ($define! enc1 (car t1))\n         ($define! pred2 (car (cdr t2)))\n         (pred2 (enc1 ($quote stuff))))"
+      env))
+  false)
+
+(ken-test
+  "same family: re-bound shares identity"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in
+      "($sequence\n         ($define! t (make-encapsulation-type))\n         ($define! e (car t))\n         ($define! p (car (cdr t)))\n         ($define! d (car (cdr (cdr t))))\n         (list (p (e 7)) (d (e 7))))"
+      env))
+  (list true 7))
+
+(define ken-tests-run! (fn () {:total (+ ken-test-pass ken-test-fail) :passed ken-test-pass :failed ken-test-fail :fails ken-test-fails}))

lib/kernel/tests/eval.sx

@@ -0,0 +1,270 @@
+;; lib/kernel/tests/eval.sx — exercises lib/kernel/eval.sx.
+;;
+;; Phase 2 covers literal evaluation, symbol lookup, and combiner
+;; dispatch (operative vs applicative). Standard-environment operatives
+;; ($if, $define!, $lambda, …) arrive in Phase 4, so tests build a
+;; minimal env on the fly and verify the dispatch contract directly.
+
+(define ke-test-pass 0)
+(define ke-test-fail 0)
+(define ke-test-fails (list))
+
+(define
+  ke-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! ke-test-pass (+ ke-test-pass 1))
+      (begin
+        (set! ke-test-fail (+ ke-test-fail 1))
+        (append! ke-test-fails {:name name :actual actual :expected expected})))))
+
+;; ── helpers ──────────────────────────────────────────────────────
+
+(define ke-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
+
+(define
+  ke-make-test-env
+  (fn
+    ()
+    (let
+      ((env (kernel-make-env)))
+      (kernel-env-bind!
+        env
+        "+"
+        (kernel-make-primitive-applicative
+          (fn (args) (+ (first args) (nth args 1)))))
+      (kernel-env-bind!
+        env
+        "list"
+        (kernel-make-primitive-applicative (fn (args) args)))
+      (kernel-env-bind!
+        env
+        "$quote"
+        (kernel-make-primitive-operative (fn (args dyn-env) (first args))))
+      (kernel-env-bind!
+        env
+        "$if"
+        (kernel-make-primitive-operative
+          (fn
+            (args dyn-env)
+            (if
+              (kernel-eval (first args) dyn-env)
+              (kernel-eval (nth args 1) dyn-env)
+              (kernel-eval (nth args 2) dyn-env)))))
+      env)))
+
+;; ── literal evaluation ───────────────────────────────────────────
+(ke-test "lit: number" (ke-eval-src "42" (kernel-make-env)) 42)
+(ke-test "lit: zero" (ke-eval-src "0" (kernel-make-env)) 0)
+(ke-test "lit: float" (ke-eval-src "3.14" (kernel-make-env)) 3.14)
+(ke-test "lit: true" (ke-eval-src "#t" (kernel-make-env)) true)
+(ke-test "lit: false" (ke-eval-src "#f" (kernel-make-env)) false)
+(ke-test "lit: string" (ke-eval-src "\"hello\"" (kernel-make-env)) "hello")
+(ke-test "lit: empty list" (ke-eval-src "()" (kernel-make-env)) (list))
+
+;; ── symbol lookup ────────────────────────────────────────────────
+(ke-test
+  "sym: bound to number"
+  (let
+    ((env (kernel-make-env)))
+    (kernel-env-bind! env "x" 100)
+    (ke-eval-src "x" env))
+  100)
+
+(ke-test
+  "sym: bound to string"
+  (let
+    ((env (kernel-make-env)))
+    (kernel-env-bind! env "name" "kernel")
+    (ke-eval-src "name" env))
+  "kernel")
+
+(ke-test
+  "sym: parent-chain lookup"
+  (let
+    ((p (kernel-make-env)))
+    (kernel-env-bind! p "outer" 1)
+    (let
+      ((c (kernel-extend-env p)))
+      (kernel-env-bind! c "inner" 2)
+      (+ (ke-eval-src "outer" c) (ke-eval-src "inner" c))))
+  3)
+
+(ke-test
+  "sym: child shadows parent"
+  (let
+    ((p (kernel-make-env)))
+    (kernel-env-bind! p "x" 1)
+    (let
+      ((c (kernel-extend-env p)))
+      (kernel-env-bind! c "x" 2)
+      (ke-eval-src "x" c)))
+  2)
+
+(ke-test
+  "env-has?: present"
+  (let
+    ((env (kernel-make-env)))
+    (kernel-env-bind! env "x" 1)
+    (kernel-env-has? env "x"))
+  true)
+
+(ke-test
+  "env-has?: missing"
+  (kernel-env-has? (kernel-make-env) "nope")
+  false)
+
+;; ── tagged-value predicates ─────────────────────────────────────
+(ke-test
+  "tag: operative?"
+  (kernel-operative? (kernel-make-primitive-operative (fn (a e) nil)))
+  true)
+
+(ke-test
+  "tag: applicative?"
+  (kernel-applicative? (kernel-make-primitive-applicative (fn (a) nil)))
+  true)
+
+(ke-test
+  "tag: combiner? operative"
+  (kernel-combiner? (kernel-make-primitive-operative (fn (a e) nil)))
+  true)
+
+(ke-test
+  "tag: combiner? applicative"
+  (kernel-combiner? (kernel-make-primitive-applicative (fn (a) nil)))
+  true)
+
+(ke-test "tag: combiner? number" (kernel-combiner? 42) false)
+
+(ke-test "tag: number is not operative" (kernel-operative? 42) false)
+
+;; ── wrap / unwrap ────────────────────────────────────────────────
+(ke-test
+  "wrap+unwrap roundtrip"
+  (let
+    ((op (kernel-make-primitive-operative (fn (a e) :sentinel))))
+    (= (kernel-unwrap (kernel-wrap op)) op))
+  true)
+
+(ke-test
+  "wrap produces applicative"
+  (kernel-applicative?
+    (kernel-wrap (kernel-make-primitive-operative (fn (a e) nil))))
+  true)
+
+(ke-test
+  "unwrap of primitive-applicative is operative"
+  (kernel-operative?
+    (kernel-unwrap (kernel-make-primitive-applicative (fn (a) nil))))
+  true)
+
+;; ── combiner dispatch — applicatives evaluate their args ─────────
+(ke-test
+  "applicative: simple call"
+  (ke-eval-src "(+ 2 3)" (ke-make-test-env))
+  5)
+
+(ke-test
+  "applicative: nested"
+  (ke-eval-src "(+ (+ 1 2) (+ 3 4))" (ke-make-test-env))
+  10)
+
+(ke-test
+  "applicative: receives evaluated args"
+  (let
+    ((env (ke-make-test-env)))
+    (kernel-env-bind! env "x" 10)
+    (kernel-env-bind! env "y" 20)
+    (ke-eval-src "(+ x y)" env))
+  30)
+
+(ke-test
+  "applicative: list builds an SX list of values"
+  (let
+    ((env (ke-make-test-env)))
+    (kernel-env-bind! env "a" 1)
+    (kernel-env-bind! env "b" 2)
+    (ke-eval-src "(list a b 99)" env))
+  (list 1 2 99))
+
+;; ── combiner dispatch — operatives DO NOT evaluate their args ───
+(ke-test
+  "operative: $quote returns symbol unevaluated"
+  (ke-eval-src "($quote foo)" (ke-make-test-env))
+  "foo")
+
+(ke-test
+  "operative: $quote returns list unevaluated"
+  (ke-eval-src "($quote (+ 1 2))" (ke-make-test-env))
+  (list "+" 1 2))
+
+(ke-test
+  "operative: $if true branch"
+  (ke-eval-src "($if #t 1 2)" (ke-make-test-env))
+  1)
+
+(ke-test
+  "operative: $if false branch"
+  (ke-eval-src "($if #f 1 2)" (ke-make-test-env))
+  2)
+
+(ke-test
+  "operative: $if doesn't eval untaken branch"
+  (ke-eval-src "($if #t 99 unbound)" (ke-make-test-env))
+  99)
+
+(ke-test
+  "operative: $if takes dynamic env for branches"
+  (let
+    ((env (ke-make-test-env)))
+    (kernel-env-bind! env "x" 7)
+    (ke-eval-src "($if #t x 0)" env))
+  7)
+
+;; ── operative built ON-THE-FLY can inspect raw expressions ──────
+(ke-test
+  "operative: sees raw symbol head"
+  (let
+    ((env (kernel-make-env)))
+    (kernel-env-bind!
+      env
+      "head"
+      (kernel-make-primitive-operative (fn (args dyn-env) (first args))))
+    (ke-eval-src "(head (+ 1 2))" env))
+  (list "+" 1 2))
+
+(ke-test
+  "operative: sees dynamic env"
+  (let
+    ((env (kernel-make-env)))
+    (kernel-env-bind! env "x" 999)
+    (kernel-env-bind!
+      env
+      "$probe"
+      (kernel-make-primitive-operative
+        (fn (args dyn-env) (kernel-env-lookup dyn-env "x"))))
+    (ke-eval-src "($probe ignored)" env))
+  999)
+
+;; ── error cases ──────────────────────────────────────────────────
+(ke-test
+  "error: unbound symbol"
+  (guard
+    (e (true :raised))
+    (kernel-eval (kernel-parse "nope") (kernel-make-env)))
+  :raised)
+
+(ke-test
+  "error: combine non-combiner"
+  (guard
+    (e (true :raised))
+    (let
+      ((env (kernel-make-env)))
+      (kernel-env-bind! env "x" 42)
+      (kernel-eval (kernel-parse "(x 1)") env)))
+  :raised)
+
+(define ke-tests-run! (fn () {:total (+ ke-test-pass ke-test-fail) :passed ke-test-pass :failed ke-test-fail :fails ke-test-fails}))

lib/kernel/tests/hygiene.sx

@@ -0,0 +1,220 @@
+;; lib/kernel/tests/hygiene.sx — exercises Phase 6 hygiene helpers.
+;;
+;; Kernel-on-SX is hygienic by default: $vau/$lambda close over their
+;; static env, and bind their formals (plus any $define!s in the body)
+;; in a CHILD env. The caller's env is only mutated when user code
+;; explicitly threads the env-param through `eval` or `$define-in!`.
+;;
+;; These tests verify the property, plus the Phase 6 helpers ($let and
+;; $define-in!). Shutt's full scope-set hygiene (lifted symbols with
+;; provenance markers) is research-grade and is NOT implemented — see
+;; the plan's reflective-API notes for the proposed approach.
+
+(define kh-test-pass 0)
+(define kh-test-fail 0)
+(define kh-test-fails (list))
+
+(define
+  kh-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! kh-test-pass (+ kh-test-pass 1))
+      (begin
+        (set! kh-test-fail (+ kh-test-fail 1))
+        (append! kh-test-fails {:name name :actual actual :expected expected})))))
+
+(define kh-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
+
+;; ── Default hygiene: $define! inside operative body stays local ─
+
+(kh-test
+  "hygiene: vau body $define! doesn't escape"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in
+      "($define! my-op ($vau () _ ($sequence ($define! x 999) x)))"
+      env)
+    (kh-eval-in "(my-op)" env)
+    (kh-eval-in "x" env))
+  1)
+
+(kh-test
+  "hygiene: vau body $define! visible inside body"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in
+      "($define! my-op ($vau () _ ($sequence ($define! x 999) x)))"
+      env)
+    (kh-eval-in "(my-op)" env))
+  999)
+
+(kh-test
+  "hygiene: lambda body $define! doesn't escape"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! y 50)" env)
+    (kh-eval-in "($define! f ($lambda () ($sequence ($define! y 7) y)))" env)
+    (kh-eval-in "(f)" env)
+    (kh-eval-in "y" env))
+  50)
+
+(kh-test
+  "hygiene: caller's binding visible inside operative"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! caller-x 88)" env)
+    (kh-eval-in "($define! my-op ($vau () _ caller-x))" env)
+    (kh-eval-in "(my-op)" env))
+  88)
+
+;; ── $let — proper hygienic scoping ──────────────────────────────
+
+(kh-test
+  "let: returns body value"
+  (kh-eval-in "($let ((x 5)) (+ x 1))" (kernel-standard-env))
+  6)
+
+(kh-test
+  "let: multiple bindings"
+  (kh-eval-in "($let ((x 3) (y 4)) (+ x y))" (kernel-standard-env))
+  7)
+
+(kh-test
+  "let: bindings shadow outer"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in "($let ((x 99)) x)" env))
+  99)
+
+(kh-test
+  "let: bindings don't leak after"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in "($let ((x 99)) x)" env)
+    (kh-eval-in "x" env))
+  1)
+
+(kh-test
+  "let: parallel — RHS sees outer, not inner"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in "($let ((x 10) (y x)) y)" env))
+  1)
+
+(kh-test
+  "let: nested"
+  (kh-eval-in "($let ((x 1)) ($let ((y 2)) (+ x y)))" (kernel-standard-env))
+  3)
+
+(kh-test
+  "let: error on malformed binding"
+  (guard
+    (e (true :raised))
+    (kh-eval-in "($let ((x)) x)" (kernel-standard-env)))
+  :raised)
+
+(kh-test
+  "let: error on non-symbol name"
+  (guard
+    (e (true :raised))
+    (kh-eval-in "($let ((1 2)) 1)" (kernel-standard-env)))
+  :raised)
+
+;; ── $define-in! — explicit env targeting ────────────────────────
+
+(kh-test
+  "define-in!: binds in chosen env, not dyn-env"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! sandbox (make-environment))" env)
+    (kh-eval-in "($define-in! sandbox z 77)" env)
+    (kernel-env-has? (kh-eval-in "sandbox" env) "z"))
+  true)
+
+(kh-test
+  "define-in!: doesn't pollute caller"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! sandbox (make-environment))" env)
+    (kh-eval-in "($define-in! sandbox z 77)" env)
+    (kernel-env-has? env "z"))
+  false)
+
+(kh-test
+  "define-in!: error on non-env target"
+  (guard
+    (e (true :raised))
+    (let
+      ((env (kernel-standard-env)))
+      (kh-eval-in "($define-in! 42 x 1)" env)))
+  :raised)
+
+;; ── Closure does NOT see post-definition caller binds ───────────
+;; The classic "lexical scope wins over dynamic" test.
+
+(kh-test
+  "lexical: closure sees its own static env"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in "($define! get-x ($lambda () x))" env)
+    (kh-eval-in "($define! x 999)" env)
+    (kh-eval-in "(get-x)" env))
+  999)
+
+(kh-test
+  "lexical: $let-bound name invisible outside"
+  (guard
+    (e (true :raised))
+    (let
+      ((env (kernel-standard-env)))
+      (kh-eval-in "($let ((private 42)) private)" env)
+      (kh-eval-in "private" env)))
+  :raised)
+
+;; ── Operative + $let: hygiene compose ───────────────────────────
+
+(kh-test
+  "let-inside-vau: temp doesn't escape body"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in "($define! op ($vau () _ ($let ((x 5)) x)))" env)
+    (kh-eval-in "(op)" env)
+    (kh-eval-in "x" env))
+  1)
+
+;; ── $let* — sequential let ──────────────────────────────────────
+(kh-test "let*: empty bindings"
+  (kh-eval-in "($let* () 42)" (kernel-standard-env)) 42)
+(kh-test "let*: single binding"
+  (kh-eval-in "($let* ((x 5)) (+ x 1))" (kernel-standard-env)) 6)
+(kh-test "let*: later sees earlier"
+  (kh-eval-in "($let* ((x 1) (y (+ x 1)) (z (+ y 1))) z)"
+              (kernel-standard-env)) 3)
+(kh-test "let*: bindings don't leak after"
+  (let ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in "($let* ((x 99) (y (+ x 1))) y)" env)
+    (kh-eval-in "x" env)) 1)
+(kh-test "let*: same-name later binding shadows earlier"
+  (kh-eval-in "($let* ((x 1) (x 2)) x)" (kernel-standard-env)) 2)
+(kh-test "let*: multi-expression body"
+  (kh-eval-in "($let* ((x 5)) ($define! double (+ x x)) double)"
+              (kernel-standard-env)) 10)
+(kh-test "let*: error on malformed binding"
+  (guard (e (true :raised))
+    (kh-eval-in "($let* ((x)) x)" (kernel-standard-env)))
+  :raised)
+(kh-test "let: multi-body"
+  (kh-eval-in "($let ((x 5)) ($define! tmp (+ x 1)) tmp)"
+              (kernel-standard-env)) 6)
+
+(define kh-tests-run! (fn () {:total (+ kh-test-pass kh-test-fail) :passed kh-test-pass :failed kh-test-fail :fails kh-test-fails}))

lib/kernel/tests/metacircular.sx

@@ -0,0 +1,162 @@
+;; lib/kernel/tests/metacircular.sx — Kernel-in-Kernel demo.
+;;
+;; Demonstrates reflective completeness: a Kernel program implements
+;; a recognisable subset of Kernel's own evaluation rules and produces
+;; matching values for a battery of test programs.
+;;
+;; This is a SHALLOW metacircular: it dispatches on expression shape
+;; itself (numbers, booleans, lists, symbols), recursively meta-evals
+;; each argument of an applicative call, and delegates only to the
+;; host evaluator for the leaf cases (operatives, symbol lookup). The
+;; point is to show that env-as-value, first-class operatives, and
+;; first-class evaluators all line up — enough so a Kernel program
+;; can itself reason about Kernel programs.
+
+(define kmc-test-pass 0)
+(define kmc-test-fail 0)
+(define kmc-test-fails (list))
+
+(define
+  kmc-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! kmc-test-pass (+ kmc-test-pass 1))
+      (begin
+        (set! kmc-test-fail (+ kmc-test-fail 1))
+        (append! kmc-test-fails {:name name :actual actual :expected expected})))))
+
+;; Build a Kernel env with m-eval and m-apply defined. The two refer
+;; to each other and to standard primitives, so we use the standard
+;; env as the static-env for both.
+(define
+  kmc-make-env
+  (fn
+    ()
+    (let
+      ((env (kernel-standard-env)))
+      (kernel-eval
+        (kernel-parse
+          "($define! m-eval\n           ($lambda (expr env)\n             ($cond\n               ((number? expr) expr)\n               ((boolean? expr) expr)\n               ((null? expr) expr)\n               ((symbol? expr) (eval expr env))\n               ((list? expr)\n                 ($let ((head-val (m-eval (car expr) env)))\n                   ($cond\n                     ((applicative? head-val)\n                       (apply head-val\n                         (map ($lambda (a) (m-eval a env)) (cdr expr))))\n                     (else (eval expr env)))))\n               (else expr))))")
+        env)
+      env)))
+
+(define
+  kmc-eval
+  (fn
+    (src)
+    (let
+      ((env (kmc-make-env)))
+      (kernel-eval
+        (kernel-parse
+          (str "(m-eval (quote " src ") (get-current-environment))"))
+        env))))
+
+;; ── literals self-evaluate via m-eval ──────────────────────────
+(kmc-test
+  "m-eval: integer literal"
+  (kernel-eval
+    (kernel-parse "(m-eval 42 (get-current-environment))")
+    (kmc-make-env))
+  42)
+
+(kmc-test
+  "m-eval: boolean true"
+  (kernel-eval
+    (kernel-parse "(m-eval #t (get-current-environment))")
+    (kmc-make-env))
+  true)
+
+(kmc-test
+  "m-eval: boolean false"
+  (kernel-eval
+    (kernel-parse "(m-eval #f (get-current-environment))")
+    (kmc-make-env))
+  false)
+
+(kmc-test
+  "m-eval: empty list"
+  (kernel-eval
+    (kernel-parse "(m-eval () (get-current-environment))")
+    (kmc-make-env))
+  (list))
+
+;; ── symbol lookup goes through env ─────────────────────────────
+(kmc-test
+  "m-eval: symbol lookup"
+  (let
+    ((env (kmc-make-env)))
+    (kernel-eval (kernel-parse "($define! shared-x 99)") env)
+    (kernel-eval
+      (kernel-parse "(m-eval ($quote shared-x) (get-current-environment))")
+      env))
+  99)
+
+;; ── applicative calls are dispatched by m-eval recursively ─────
+(kmc-test
+  "m-eval: addition"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote (+ 1 2)) (get-current-environment))")
+    (kmc-make-env))
+  3)
+
+(kmc-test
+  "m-eval: nested arithmetic"
+  (kernel-eval
+    (kernel-parse
+      "(m-eval ($quote (+ (* 2 3) (- 10 4))) (get-current-environment))")
+    (kmc-make-env))
+  12)
+
+(kmc-test
+  "m-eval: variadic +"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote (+ 1 2 3 4 5)) (get-current-environment))")
+    (kmc-make-env))
+  15)
+
+(kmc-test
+  "m-eval: list construction"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote (list 1 2 3)) (get-current-environment))")
+    (kmc-make-env))
+  (list 1 2 3))
+
+(kmc-test "m-eval: cons reverse-style"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote (cons 0 (list 1 2))) (get-current-environment))")
+    (kmc-make-env)) (list 0 1 2))
+
+(kmc-test "m-eval: nested apply"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote (apply + (list 10 20 30))) (get-current-environment))")
+    (kmc-make-env)) 60)
+
+;; ── operatives delegate to host eval (transparently for the caller) ─
+(kmc-test
+  "m-eval: $if true branch (via delegation)"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote ($if #t 1 2)) (get-current-environment))")
+    (kmc-make-env))
+  1)
+
+(kmc-test
+  "m-eval: $if false branch"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote ($if #f 1 2)) (get-current-environment))")
+    (kmc-make-env))
+  2)
+
+;; ── m-eval can call a user-defined lambda ──────────────────────
+(kmc-test
+  "m-eval: user lambda call"
+  (let
+    ((env (kmc-make-env)))
+    (kernel-eval (kernel-parse "($define! sq ($lambda (x) (* x x)))") env)
+    (kernel-eval
+      (kernel-parse "(m-eval ($quote (sq 7)) (get-current-environment))")
+      env))
+  49)
+
+(define kmc-tests-run! (fn () {:total (+ kmc-test-pass kmc-test-fail) :passed kmc-test-pass :failed kmc-test-fail :fails kmc-test-fails}))

lib/kernel/tests/parse.sx

@@ -0,0 +1,158 @@
+;; lib/kernel/tests/parse.sx — exercises lib/kernel/parser.sx.
+
+(define knl-test-pass 0)
+(define knl-test-fail 0)
+(define knl-test-fails (list))
+
+(define
+  knl-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! knl-test-pass (+ knl-test-pass 1))
+      (begin
+        (set! knl-test-fail (+ knl-test-fail 1))
+        (append! knl-test-fails {:name name :actual actual :expected expected})))))
+
+;; ── atoms: numbers ────────────────────────────────────────────────
+(knl-test "num: integer" (kernel-parse "42") 42)
+(knl-test "num: zero" (kernel-parse "0") 0)
+(knl-test "num: negative integer" (kernel-parse "-7") -7)
+(knl-test "num: positive sign" (kernel-parse "+5") 5)
+(knl-test "num: float" (kernel-parse "3.14") 3.14)
+(knl-test "num: negative float" (kernel-parse "-2.5") -2.5)
+(knl-test "num: leading dot" (kernel-parse ".5") 0.5)
+(knl-test "num: exponent" (kernel-parse "1e3") 1000)
+(knl-test "num: exponent with sign" (kernel-parse "2.5e-1") 0.25)
+(knl-test "num: capital E exponent" (kernel-parse "1E2") 100)
+
+;; ── atoms: booleans ───────────────────────────────────────────────
+(knl-test "bool: true" (kernel-parse "#t") true)
+(knl-test "bool: false" (kernel-parse "#f") false)
+
+;; ── atoms: empty list (Kernel nil) ────────────────────────────────
+(knl-test "nil: ()" (kernel-parse "()") (list))
+(knl-test "nil: (= () (list))" (= (kernel-parse "()") (list)) true)
+
+;; ── atoms: symbols ────────────────────────────────────────────────
+(knl-test "sym: word" (kernel-parse "foo") "foo")
+(knl-test "sym: hyphenated" (kernel-parse "foo-bar") "foo-bar")
+(knl-test "sym: dollar-bang" (kernel-parse "$define!") "$define!")
+(knl-test "sym: question" (kernel-parse "null?") "null?")
+(knl-test "sym: lt-eq" (kernel-parse "<=") "<=")
+(knl-test "sym: bare plus" (kernel-parse "+") "+")
+(knl-test "sym: bare minus" (kernel-parse "-") "-")
+(knl-test "sym: plus-letter" (kernel-parse "+a") "+a")
+(knl-test "sym: arrow" (kernel-parse "->") "->")
+(knl-test "sym: dot-prefixed" (kernel-parse ".foo") ".foo")
+
+;; ── atoms: strings ────────────────────────────────────────────────
+(knl-test "str: empty" (kernel-string-value (kernel-parse "\"\"")) "")
+(knl-test
+  "str: hello"
+  (kernel-string-value (kernel-parse "\"hello\""))
+  "hello")
+(knl-test "str: predicate" (kernel-string? (kernel-parse "\"x\"")) true)
+(knl-test "str: not symbol" (kernel-string? (kernel-parse "x")) false)
+(knl-test
+  "str: escape newline"
+  (kernel-string-value (kernel-parse "\"a\\nb\""))
+  "a\nb")
+(knl-test
+  "str: escape tab"
+  (kernel-string-value (kernel-parse "\"a\\tb\""))
+  "a\tb")
+(knl-test
+  "str: escape quote"
+  (kernel-string-value (kernel-parse "\"a\\\"b\""))
+  "a\"b")
+(knl-test
+  "str: escape backslash"
+  (kernel-string-value (kernel-parse "\"a\\\\b\""))
+  "a\\b")
+
+;; ── lists ─────────────────────────────────────────────────────────
+(knl-test "list: flat" (kernel-parse "(a b c)") (list "a" "b" "c"))
+(knl-test
+  "list: nested"
+  (kernel-parse "(a (b c) d)")
+  (list "a" (list "b" "c") "d"))
+(knl-test
+  "list: deeply nested"
+  (kernel-parse "(((x)))")
+  (list (list (list "x"))))
+(knl-test
+  "list: mixed atoms"
+  (kernel-parse "(1 #t foo)")
+  (list 1 true "foo"))
+(knl-test
+  "list: empty inside"
+  (kernel-parse "(a () b)")
+  (list "a" (list) "b"))
+
+;; ── whitespace + comments ─────────────────────────────────────────
+(knl-test "ws: leading" (kernel-parse "   42") 42)
+(knl-test "ws: trailing" (kernel-parse "42   ") 42)
+(knl-test "ws: tabs/newlines" (kernel-parse "\n\t  42 \n") 42)
+(knl-test "comment: line" (kernel-parse "; nope\n42") 42)
+(knl-test "comment: trailing" (kernel-parse "42 ; tail") 42)
+(knl-test
+  "comment: inside list"
+  (kernel-parse "(a ; mid\n  b)")
+  (list "a" "b"))
+
+;; ── parse-all ─────────────────────────────────────────────────────
+(knl-test "all: empty input" (kernel-parse-all "") (list))
+(knl-test "all: only whitespace" (kernel-parse-all "   ") (list))
+(knl-test "all: only comment" (kernel-parse-all "; nope") (list))
+(knl-test
+  "all: three forms"
+  (kernel-parse-all "1 2 3")
+  (list 1 2 3))
+(knl-test
+  "all: mixed"
+  (kernel-parse-all "($if #t 1 2) foo")
+  (list (list "$if" true 1 2) "foo"))
+
+;; ── classic Kernel programs (smoke) ───────────────────────────────
+(knl-test
+  "klisp: vau form"
+  (kernel-parse "($vau (x e) e (eval x e))")
+  (list "$vau" (list "x" "e") "e" (list "eval" "x" "e")))
+(knl-test
+  "klisp: define lambda"
+  (kernel-parse "($define! sq ($lambda (x) (* x x)))")
+  (list "$define!" "sq" (list "$lambda" (list "x") (list "*" "x" "x"))))
+
+;; ── round-trip identity for primitive symbols ─────────────────────
+(knl-test "identity: $vau" (kernel-parse "$vau") "$vau")
+(knl-test "identity: $lambda" (kernel-parse "$lambda") "$lambda")
+(knl-test "identity: wrap" (kernel-parse "wrap") "wrap")
+(knl-test "identity: unwrap" (kernel-parse "unwrap") "unwrap")
+
+;; ── reader macros ─────────────────────────────────────────────────
+(knl-test "reader: 'foo  → ($quote foo)"
+  (kernel-parse "'foo") (list "$quote" "foo"))
+(knl-test "reader: '(a b c)"
+  (kernel-parse "'(a b c)") (list "$quote" (list "a" "b" "c")))
+(knl-test "reader: nested quotes"
+  (kernel-parse "''x")
+  (list "$quote" (list "$quote" "x")))
+(knl-test "reader: ` quasiquote"
+  (kernel-parse "`x") (list "$quasiquote" "x"))
+(knl-test "reader: , unquote"
+  (kernel-parse ",x") (list "$unquote" "x"))
+(knl-test "reader: ,@ unquote-splicing"
+  (kernel-parse ",@x") (list "$unquote-splicing" "x"))
+(knl-test "reader: quasi-mix"
+  (kernel-parse "`(a ,b ,@c)")
+  (list "$quasiquote"
+        (list "a"
+              (list "$unquote" "b")
+              (list "$unquote-splicing" "c"))))
+(knl-test "reader: quote separates from neighbouring atom"
+  (kernel-parse "(a 'b c)")
+  (list "a" (list "$quote" "b") "c"))
+
+(define knl-tests-run! (fn () {:total (+ knl-test-pass knl-test-fail) :passed knl-test-pass :failed knl-test-fail :fails knl-test-fails}))

lib/kernel/tests/standard.sx

@@ -0,0 +1,445 @@
+;; lib/kernel/tests/standard.sx — exercises the Kernel standard env.
+;;
+;; Phase 4 tests verify that the standard env is rich enough to run
+;; classic Kernel programs: factorial via recursion, list operations,
+;; first-class environment manipulation. Each test starts from a fresh
+;; standard env via `(kernel-standard-env)`.
+
+(define ks-test-pass 0)
+(define ks-test-fail 0)
+(define ks-test-fails (list))
+
+(define
+  ks-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! ks-test-pass (+ ks-test-pass 1))
+      (begin
+        (set! ks-test-fail (+ ks-test-fail 1))
+        (append! ks-test-fails {:name name :actual actual :expected expected})))))
+
+(define
+  ks-eval
+  (fn (src) (kernel-eval (kernel-parse src) (kernel-standard-env))))
+
+(define ks-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
+
+(define
+  ks-eval-all
+  (fn (src env) (kernel-eval-program (kernel-parse-all src) env)))
+
+;; ── $if ──────────────────────────────────────────────────────────
+(ks-test "if: true branch" (ks-eval "($if #t 1 2)") 1)
+(ks-test "if: false branch" (ks-eval "($if #f 1 2)") 2)
+(ks-test "if: predicate"
+  (ks-eval "($if (<=? 1 2) ($quote yes) ($quote no))") "yes")
+(ks-test
+  "if: untaken branch not evaluated"
+  (ks-eval "($if #t 42 nope)")
+  42)
+
+;; ── $define! + arithmetic ───────────────────────────────────────
+(ks-test
+  "define!: returns value"
+  (let ((env (kernel-standard-env))) (ks-eval-in "($define! x 5)" env))
+  5)
+
+(ks-test
+  "define!: bound in env"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in "($define! x 5)" env)
+    (ks-eval-in "x" env))
+  5)
+
+(ks-test "arith: +" (ks-eval "(+ 2 3)") 5)
+(ks-test "arith: -" (ks-eval "(- 10 4)") 6)
+(ks-test "arith: *" (ks-eval "(* 6 7)") 42)
+(ks-test "arith: /" (ks-eval "(/ 20 5)") 4)
+(ks-test "cmp: <  true" (ks-eval "(< 1 2)") true)
+(ks-test "cmp: <  false" (ks-eval "(< 2 1)") false)
+(ks-test "cmp: >=" (ks-eval "(>=? 2 2)") true)
+(ks-test "cmp: <=" (ks-eval "(<=? 2 3)") true)
+(ks-test "cmp: =" (ks-eval "(=? 7 7)") true)
+
+;; ── $sequence ────────────────────────────────────────────────────
+(ks-test "sequence: empty" (ks-eval "($sequence)") nil)
+(ks-test "sequence: single" (ks-eval "($sequence 99)") 99)
+(ks-test
+  "sequence: multi-effect"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in "($sequence ($define! a 1) ($define! b 2) (+ a b))" env))
+  3)
+
+;; ── list primitives ──────────────────────────────────────────────
+(ks-test
+  "list: builds"
+  (ks-eval "(list 1 2 3)")
+  (list 1 2 3))
+(ks-test "list: empty" (ks-eval "(list)") (list))
+(ks-test
+  "cons: prepend"
+  (ks-eval "(cons 0 (list 1 2 3))")
+  (list 0 1 2 3))
+(ks-test "car: head" (ks-eval "(car (list 10 20 30))") 10)
+(ks-test
+  "cdr: tail"
+  (ks-eval "(cdr (list 10 20 30))")
+  (list 20 30))
+(ks-test "length: 3" (ks-eval "(length (list 1 2 3))") 3)
+(ks-test "length: 0" (ks-eval "(length (list))") 0)
+(ks-test "null?: empty" (ks-eval "(null? (list))") true)
+(ks-test "null?: nonempty" (ks-eval "(null? (list 1))") false)
+(ks-test "pair?: empty" (ks-eval "(pair? (list))") false)
+(ks-test "pair?: nonempty" (ks-eval "(pair? (list 1))") true)
+
+;; ── $quote ───────────────────────────────────────────────────────
+(ks-test "quote: symbol" (ks-eval "($quote foo)") "foo")
+(ks-test
+  "quote: list"
+  (ks-eval "($quote (+ 1 2))")
+  (list "+" 1 2))
+
+;; ── boolean / not ────────────────────────────────────────────────
+(ks-test "not: true" (ks-eval "(not #t)") false)
+(ks-test "not: false" (ks-eval "(not #f)") true)
+
+;; ── factorial ────────────────────────────────────────────────────
+(ks-test
+  "factorial: 5!"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
+      env)
+    (ks-eval-in "(factorial 5)" env))
+  120)
+
+(ks-test
+  "factorial: 0! = 1"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
+      env)
+    (ks-eval-in "(factorial 0)" env))
+  1)
+
+(ks-test
+  "factorial: 10!"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
+      env)
+    (ks-eval-in "(factorial 10)" env))
+  3628800)
+
+;; ── recursive list operations ────────────────────────────────────
+(ks-test
+  "sum: recursive over list"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! sum ($lambda (xs) ($if (null? xs) 0 (+ (car xs) (sum (cdr xs))))))"
+      env)
+    (ks-eval-in "(sum (list 1 2 3 4 5))" env))
+  15)
+
+(ks-test
+  "len: recursive count"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! mylen ($lambda (xs) ($if (null? xs) 0 (+ 1 (mylen (cdr xs))))))"
+      env)
+    (ks-eval-in "(mylen (list 1 2 3 4))" env))
+  4)
+
+(ks-test
+  "map-add1: build new list"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! add1-all ($lambda (xs) ($if (null? xs) (list) (cons (+ 1 (car xs)) (add1-all (cdr xs))))))"
+      env)
+    (ks-eval-in "(add1-all (list 10 20 30))" env))
+  (list 11 21 31))
+
+;; ── eval as a first-class applicative ────────────────────────────
+(ks-test
+  "eval: applies to constructed form"
+  (ks-eval "(eval (list ($quote +) 2 3) (get-current-environment))")
+  5)
+
+(ks-test
+  "eval: with a fresh make-environment"
+  (guard
+    (e (true :raised))
+    (ks-eval "(eval ($quote (+ 1 2)) (make-environment))"))
+  :raised)
+
+(ks-test
+  "eval: in extended env sees parent's bindings"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in "($define! shared 7)" env)
+    (ks-eval-in
+      "(eval ($quote shared) (make-environment (get-current-environment)))"
+      env))
+  7)
+
+;; ── get-current-environment ──────────────────────────────────────
+(ks-test
+  "get-current-environment: returns env"
+  (kernel-env? (ks-eval "(get-current-environment)"))
+  true)
+
+(ks-test
+  "get-current-environment: contains $if"
+  (let
+    ((env (ks-eval "(get-current-environment)")))
+    (kernel-env-has? env "$if"))
+  true)
+
+(ks-test
+  "make-environment: empty"
+  (let ((env (ks-eval "(make-environment)"))) (kernel-env-has? env "$if"))
+  false)
+
+(ks-test
+  "make-environment: child sees parent"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in "($define! marker 123)" env)
+    (let
+      ((child (ks-eval-in "(make-environment (get-current-environment))" env)))
+      (kernel-env-has? child "marker")))
+  true)
+
+;; ── closures and lexical scope ───────────────────────────────────
+(ks-test
+  "closure: captures binding"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! make-adder ($lambda (n) ($lambda (x) (+ x n))))"
+      env)
+    (ks-eval-in "($define! add5 (make-adder 5))" env)
+    (ks-eval-in "(add5 10)" env))
+  15)
+
+(ks-test
+  "closure: nested lookups"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! curry-add ($lambda (a) ($lambda (b) ($lambda (c) (+ a (+ b c))))))"
+      env)
+    (ks-eval-in "(((curry-add 1) 2) 3)" env))
+  6)
+
+;; ── operative defined in standard env can reach $define! ─────────
+(ks-test
+  "custom: define-via-vau"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! $let-it ($vau (name expr) e ($sequence ($define! tmp (eval expr e)) (eval (list ($quote $define!) name (list ($quote $quote) tmp)) e) tmp)))"
+      env)
+    (ks-eval-in "($let-it z 77)" env)
+    (ks-eval-in "z" env))
+  77)
+
+;; ── quasiquote ──────────────────────────────────────────────────
+(ks-test "qq: plain atom"      (ks-eval "`hello") "hello")
+(ks-test "qq: plain list"      (ks-eval "`(a b c)") (list "a" "b" "c"))
+(ks-test "qq: unquote splices value"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! x 42)" env)
+    (ks-eval-in "`(a ,x b)" env)) (list "a" 42 "b"))
+(ks-test "qq: unquote-splicing splices list"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! xs (list 1 2 3))" env)
+    (ks-eval-in "`(a ,@xs b)" env)) (list "a" 1 2 3 "b"))
+(ks-test "qq: unquote-splicing at end"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! xs (list 9 8))" env)
+    (ks-eval-in "`(a b ,@xs)" env)) (list "a" "b" 9 8))
+(ks-test "qq: unquote-splicing at start"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! xs (list 1 2))" env)
+    (ks-eval-in "`(,@xs c)" env)) (list 1 2 "c"))
+(ks-test "qq: nested list with unquote inside"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! x 5)" env)
+    (ks-eval-in "`(a (b ,x) c)" env))
+  (list "a" (list "b" 5) "c"))
+(ks-test "qq: error on bare unquote-splicing into non-list"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! x 42)" env)
+    (guard (e (true :raised))
+      (ks-eval-in "`(a ,@x b)" env)))
+  :raised)
+
+;; ── $cond / $when / $unless ─────────────────────────────────────
+(ks-test "cond: first match"
+  (ks-eval "($cond (#f 1) (#t 2) (#t 3))") 2)
+(ks-test "cond: else fallback"
+  (ks-eval "($cond (#f 1) (else 99))") 99)
+(ks-test "cond: no match returns nil"
+  (ks-eval "($cond (#f 1) (#f 2))") nil)
+(ks-test "cond: empty clauses returns nil"
+  (ks-eval "($cond)") nil)
+(ks-test "cond: multi-expr body"
+  (ks-eval "($cond (#t 1 2 3))") 3)
+(ks-test "cond: doesn't evaluate untaken clauses"
+  ;; If the second clause's test were evaluated, the unbound `nope` would error.
+  (ks-eval "($cond (#t 7) (nope ignored))") 7)
+(ks-test "cond: predicate evaluation"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! n 5)" env)
+    (ks-eval-in "($cond ((< n 0) ($quote negative)) ((= n 0) ($quote zero)) (else ($quote positive)))" env))
+  "positive")
+
+(ks-test "when: true runs body"
+  (ks-eval "($when #t 1 2 3)") 3)
+(ks-test "when: false returns nil"
+  (ks-eval "($when #f 1 2 3)") nil)
+(ks-test "when: skips body when false"
+  (ks-eval "($when #f nope)") nil)
+
+(ks-test "unless: false runs body"
+  (ks-eval "($unless #f 99)") 99)
+(ks-test "unless: true returns nil"
+  (ks-eval "($unless #t 99)") nil)
+(ks-test "unless: skips body when true"
+  (ks-eval "($unless #t nope)") nil)
+
+;; ── $and? / $or? short-circuit ──────────────────────────────────
+(ks-test "and: empty returns true"   (ks-eval "($and?)") true)
+(ks-test "and: single returns value" (ks-eval "($and? 42)") 42)
+(ks-test "and: all true returns last"
+  (ks-eval "($and? 1 2 3)") 3)
+(ks-test "and: first false short-circuits"
+  (ks-eval "($and? #f nope)") false)
+(ks-test "and: false in middle short-circuits"
+  (ks-eval "($and? 1 #f nope)") false)
+(ks-test "or: empty returns false"  (ks-eval "($or?)") false)
+(ks-test "or: single returns value" (ks-eval "($or? 42)") 42)
+(ks-test "or: first truthy short-circuits"
+  (ks-eval "($or? 99 nope)") 99)
+(ks-test "or: all false returns last"
+  (ks-eval "($or? #f #f #f)") false)
+(ks-test "or: middle truthy"
+  (ks-eval "($or? #f 42 nope)") 42)
+
+;; ── variadic arithmetic ─────────────────────────────────────────
+(ks-test "+: zero args = 0"    (ks-eval "(+)") 0)
+(ks-test "+: one arg = arg"    (ks-eval "(+ 7)") 7)
+(ks-test "+: two args"         (ks-eval "(+ 3 4)") 7)
+(ks-test "+: five args"        (ks-eval "(+ 1 2 3 4 5)") 15)
+
+(ks-test "*: zero args = 1"    (ks-eval "(*)") 1)
+(ks-test "*: one arg"          (ks-eval "(* 7)") 7)
+(ks-test "*: four args"        (ks-eval "(* 1 2 3 4)") 24)
+
+(ks-test "-: one arg negates"  (ks-eval "(- 10)") -10)
+(ks-test "-: two args"         (ks-eval "(- 10 3)") 7)
+(ks-test "-: four args fold"   (ks-eval "(- 100 1 2 3)") 94)
+
+(ks-test "/: two args"         (ks-eval "(/ 20 5)") 4)
+(ks-test "/: three args fold"  (ks-eval "(/ 100 2 5)") 10)
+
+;; ── variadic chained comparison ─────────────────────────────────
+(ks-test "<: chained ascending"  (ks-eval "(< 1 2 3 4 5)") true)
+(ks-test "<: not strict"          (ks-eval "(< 1 2 2 3)") false)
+(ks-test "<: anti-monotonic"      (ks-eval "(< 5 3)") false)
+(ks-test ">: chained descending" (ks-eval "(> 5 4 3 2 1)") true)
+(ks-test "<=? ascending equals"   (ks-eval "(<=? 1 1 2 3 3)") true)
+(ks-test "<=? violation"          (ks-eval "(<=? 1 2 1)") false)
+(ks-test ">=? descending equals" (ks-eval "(>=? 3 3 2 1)") true)
+
+;; ── list combinators ────────────────────────────────────────────
+(ks-test "map: square"
+  (ks-eval "(map ($lambda (x) (* x x)) (list 1 2 3 4))")
+  (list 1 4 9 16))
+(ks-test "map: empty list"
+  (ks-eval "(map ($lambda (x) x) (list))") (list))
+(ks-test "map: identity preserves"
+  (ks-eval "(map ($lambda (x) x) (list 1 2 3))") (list 1 2 3))
+(ks-test "map: with closure over outer"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! k 10)" env)
+    (ks-eval-in "(map ($lambda (x) (+ x k)) (list 1 2 3))" env))
+  (list 11 12 13))
+
+(ks-test "filter: positives"
+  (ks-eval "(filter ($lambda (x) (< 0 x)) (list -2 -1 0 1 2))")
+  (list 1 2))
+(ks-test "filter: empty result"
+  (ks-eval "(filter ($lambda (x) #f) (list 1 2 3))") (list))
+(ks-test "filter: all match"
+  (ks-eval "(filter ($lambda (x) #t) (list 1 2 3))") (list 1 2 3))
+
+(ks-test "reduce: sum"
+  (ks-eval "(reduce ($lambda (a b) (+ a b)) 0 (list 1 2 3 4 5))") 15)
+(ks-test "reduce: product"
+  (ks-eval "(reduce ($lambda (a b) (* a b)) 1 (list 1 2 3 4))") 24)
+(ks-test "reduce: empty returns init"
+  (ks-eval "(reduce ($lambda (a b) (+ a b)) 42 (list))") 42)
+(ks-test "reduce: build list"
+  (ks-eval "(reduce ($lambda (acc x) (cons x acc)) () (list 1 2 3))")
+  (list 3 2 1))
+
+;; ── apply ────────────────────────────────────────────────────────
+(ks-test "apply: + over list"
+  (ks-eval "(apply + (list 1 2 3 4 5))") 15)
+(ks-test "apply: lambda"
+  (ks-eval "(apply ($lambda (a b c) (* a (+ b c))) (list 2 3 4))") 14)
+(ks-test "apply: list identity"
+  (ks-eval "(apply list (list 1 2 3))") (list 1 2 3))
+(ks-test "apply: empty args list"
+  (ks-eval "(apply + (list))") 0)
+(ks-test "apply: single arg list"
+  (ks-eval "(apply ($lambda (x) (* x 10)) (list 7))") 70)
+(ks-test "apply: built via map+apply"
+  ;; (apply + (map ($lambda (x) (* x x)) (list 1 2 3))) → 1+4+9 = 14
+  (ks-eval
+    "(apply + (map ($lambda (x) (* x x)) (list 1 2 3)))") 14)
+(ks-test "apply: error on non-list args"
+  (guard (e (true :raised))
+    (ks-eval "(apply + 5)"))
+  :raised)
+
+;; ── append / reverse ────────────────────────────────────────────
+(ks-test "append: two lists"
+  (ks-eval "(append (list 1 2) (list 3 4))") (list 1 2 3 4))
+(ks-test "append: three lists"
+  (ks-eval "(append (list 1) (list 2) (list 3))") (list 1 2 3))
+(ks-test "append: empty list"
+  (ks-eval "(append)") (list))
+(ks-test "append: one list"
+  (ks-eval "(append (list 1 2 3))") (list 1 2 3))
+(ks-test "append: empty + nonempty"
+  (ks-eval "(append (list) (list 1 2))") (list 1 2))
+(ks-test "append: nonempty + empty"
+  (ks-eval "(append (list 1 2) (list))") (list 1 2))
+(ks-test "append: error on non-list"
+  (guard (e (true :raised))
+    (ks-eval "(append (list 1) 5)"))
+  :raised)
+
+(ks-test "reverse: four elements"
+  (ks-eval "(reverse (list 1 2 3 4))") (list 4 3 2 1))
+(ks-test "reverse: empty"
+  (ks-eval "(reverse (list))") (list))
+(ks-test "reverse: single"
+  (ks-eval "(reverse (list 99))") (list 99))
+(ks-test "reverse: double reverse is identity"
+  (ks-eval "(reverse (reverse (list 1 2 3)))") (list 1 2 3))
+
+(define ks-tests-run! (fn () {:total (+ ks-test-pass ks-test-fail) :passed ks-test-pass :failed ks-test-fail :fails ks-test-fails}))

lib/kernel/tests/vau.sx

@@ -0,0 +1,309 @@
+;; lib/kernel/tests/vau.sx — exercises lib/kernel/runtime.sx.
+;;
+;; Verifies the Phase 3 promise: user-defined operatives and applicatives
+;; constructible from inside the language. Tests build a Kernel
+;; base-env, bind a few helper applicatives (+, *, list, =, $if), and
+;; run programs that construct and use custom combiners.
+
+(define kv-test-pass 0)
+(define kv-test-fail 0)
+(define kv-test-fails (list))
+
+(define
+  kv-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! kv-test-pass (+ kv-test-pass 1))
+      (begin
+        (set! kv-test-fail (+ kv-test-fail 1))
+        (append! kv-test-fails {:name name :actual actual :expected expected})))))
+
+(define kv-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
+
+(define
+  kv-make-env
+  (fn
+    ()
+    (let
+      ((env (kernel-base-env)))
+      (kernel-env-bind!
+        env
+        "+"
+        (kernel-make-primitive-applicative
+          (fn (args) (+ (first args) (nth args 1)))))
+      (kernel-env-bind!
+        env
+        "*"
+        (kernel-make-primitive-applicative
+          (fn (args) (* (first args) (nth args 1)))))
+      (kernel-env-bind!
+        env
+        "-"
+        (kernel-make-primitive-applicative
+          (fn (args) (- (first args) (nth args 1)))))
+      (kernel-env-bind!
+        env
+        "="
+        (kernel-make-primitive-applicative
+          (fn (args) (= (first args) (nth args 1)))))
+      (kernel-env-bind!
+        env
+        "list"
+        (kernel-make-primitive-applicative (fn (args) args)))
+      (kernel-env-bind!
+        env
+        "cons"
+        (kernel-make-primitive-applicative
+          (fn (args) (cons (first args) (nth args 1)))))
+      (kernel-env-bind!
+        env
+        "$quote"
+        (kernel-make-primitive-operative (fn (args dyn-env) (first args))))
+      (kernel-env-bind!
+        env
+        "$if"
+        (kernel-make-primitive-operative
+          (fn
+            (args dyn-env)
+            (if
+              (kernel-eval (first args) dyn-env)
+              (kernel-eval (nth args 1) dyn-env)
+              (kernel-eval (nth args 2) dyn-env)))))
+      env)))
+
+;; ── $vau: builds an operative ───────────────────────────────────
+(kv-test
+  "vau: identity returns first arg unevaluated"
+  (kv-eval-src "(($vau (a) _ a) hello)" (kv-make-env))
+  "hello")
+
+(kv-test
+  "vau: returns args as raw expressions"
+  (kv-eval-src "(($vau (a b) _ (list a b)) (+ 1 2) (+ 3 4))" (kv-make-env))
+  (list (list "+" 1 2) (list "+" 3 4)))
+
+(kv-test
+  "vau: env-param is a kernel env"
+  (kernel-env? (kv-eval-src "(($vau () e e))" (kv-make-env)))
+  true)
+
+(kv-test
+  "vau: returns operative"
+  (kernel-operative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
+  true)
+
+(kv-test
+  "vau: returns operative not applicative"
+  (kernel-applicative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
+  false)
+
+(kv-test
+  "vau: zero-arg body"
+  (kv-eval-src "(($vau () _ 42))" (kv-make-env))
+  42)
+
+(kv-test
+  "vau: static-env closure captured"
+  (let
+    ((outer (kv-make-env)))
+    (kernel-env-bind! outer "captured" 17)
+    (let
+      ((op (kv-eval-src "($vau () _ captured)" outer))
+        (caller (kv-make-env)))
+      (kernel-env-bind! caller "captured" 99)
+      (kernel-combine op (list) caller)))
+  17)
+
+(kv-test
+  "vau: env-param exposes caller's dynamic env"
+  (let
+    ((outer (kv-make-env)))
+    (kernel-env-bind! outer "x" 1)
+    (let
+      ((op (kv-eval-src "($vau () e e)" outer)) (caller (kv-make-env)))
+      (kernel-env-bind! caller "x" 2)
+      (let
+        ((e-val (kernel-combine op (list) caller)))
+        (kernel-env-lookup e-val "x"))))
+  2)
+
+;; ── $lambda: applicatives evaluate their args ───────────────────
+(kv-test
+  "lambda: identity"
+  (kv-eval-src "(($lambda (x) x) 42)" (kv-make-env))
+  42)
+
+(kv-test
+  "lambda: addition"
+  (kv-eval-src "(($lambda (x y) (+ x y)) 3 4)" (kv-make-env))
+  7)
+
+(kv-test
+  "lambda: args are evaluated before bind"
+  (kv-eval-src "(($lambda (x) x) (+ 2 3))" (kv-make-env))
+  5)
+
+(kv-test
+  "lambda: zero args"
+  (kv-eval-src "(($lambda () 99))" (kv-make-env))
+  99)
+
+(kv-test
+  "lambda: returns applicative"
+  (kernel-applicative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
+  true)
+
+(kv-test
+  "lambda: returns applicative not operative"
+  (kernel-operative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
+  false)
+
+(kv-test
+  "lambda: higher-order"
+  (kv-eval-src "(($lambda (f) (f 10)) ($lambda (x) (+ x 1)))" (kv-make-env))
+  11)
+
+;; ── wrap / unwrap as user-callable applicatives ─────────────────
+
+(kv-test
+  "wrap: makes applicative from operative"
+  (kernel-applicative? (kv-eval-src "(wrap ($vau (x) _ x))" (kv-make-env)))
+  true)
+
+(kv-test
+  "wrap: result evaluates its arg"
+  (kv-eval-src "((wrap ($vau (x) _ x)) (+ 1 2))" (kv-make-env))
+  3)
+
+(kv-test
+  "unwrap: extracts operative from applicative"
+  (kernel-operative? (kv-eval-src "(unwrap ($lambda (x) x))" (kv-make-env)))
+  true)
+
+(kv-test
+  "wrap/unwrap roundtrip preserves identity"
+  (kv-eval-src
+    "(($lambda (op) (= op (unwrap (wrap op)))) ($vau (x) _ x))"
+    (kv-make-env))
+  true)
+
+;; ── operative? / applicative? as user-visible predicates ────────
+
+(kv-test
+  "operative? on vau result"
+  (kv-eval-src "(operative? ($vau (x) _ x))" (kv-make-env))
+  true)
+
+(kv-test
+  "operative? on lambda result"
+  (kv-eval-src "(operative? ($lambda (x) x))" (kv-make-env))
+  false)
+
+(kv-test
+  "applicative? on lambda result"
+  (kv-eval-src "(applicative? ($lambda (x) x))" (kv-make-env))
+  true)
+
+(kv-test
+  "applicative? on vau result"
+  (kv-eval-src "(applicative? ($vau (x) _ x))" (kv-make-env))
+  false)
+
+(kv-test
+  "operative? on number"
+  (kv-eval-src "(operative? 42)" (kv-make-env))
+  false)
+
+;; ── Build BOTH layers from user code ────────────────────────────
+;; The headline Phase 3 test: defining an operative on top of an
+;; applicative defined on top of a vau.
+
+(kv-test
+  "custom: applicative + operative compose"
+  (let
+    ((env (kv-make-env)))
+    (kernel-env-bind! env "square" (kv-eval-src "($lambda (x) (* x x))" env))
+    (kv-eval-src "(square 4)" env))
+  16)
+
+(kv-test "custom: operative captures argument syntax"
+  ;; ($capture x) returns the raw expression `x`, regardless of value.
+  (let ((env (kv-make-env)))
+    (kernel-env-bind! env "$capture"
+      (kv-eval-src "($vau (form) _ form)" env))
+    (kv-eval-src "($capture (+ 1 2))" env))
+  (list "+" 1 2))
+
+(kv-test "custom: applicative re-wraps an operative"
+  ;; Build a captured operative, then wrap it into an applicative that
+  ;; evaluates args before re-entry. This exercises wrap+$vau composed.
+  (let ((env (kv-make-env)))
+    (kernel-env-bind! env "id-app"
+      (kv-eval-src "(wrap ($vau (x) _ x))" env))
+    (kv-eval-src "(id-app (+ 10 20))" env))
+  30)
+
+;; ── Error cases ──────────────────────────────────────────────────
+
+(kv-test
+  "vau: rejects non-list formals"
+  (guard (e (true :raised)) (kv-eval-src "($vau x _ x)" (kv-make-env)))
+  :raised)
+
+(kv-test
+  "vau: rejects non-symbol formal"
+  (guard (e (true :raised)) (kv-eval-src "($vau (1) _ x)" (kv-make-env)))
+  :raised)
+
+(kv-test
+  "vau: rejects non-symbol env-param"
+  (guard (e (true :raised)) (kv-eval-src "($vau (x) 7 x)" (kv-make-env)))
+  :raised)
+
+(kv-test
+  "vau: too few args at call site"
+  (guard
+    (e (true :raised))
+    (kv-eval-src "(($vau (x y) _ x) 1)" (kv-make-env)))
+  :raised)
+
+(kv-test
+  "vau: too many args at call site"
+  (guard
+    (e (true :raised))
+    (kv-eval-src "(($vau (x) _ x) 1 2)" (kv-make-env)))
+  :raised)
+
+(kv-test
+  "wrap: rejects non-operative"
+  (guard (e (true :raised)) (kv-eval-src "(wrap 42)" (kv-make-env)))
+  :raised)
+
+(kv-test
+  "unwrap: rejects non-applicative"
+  (guard (e (true :raised)) (kv-eval-src "(unwrap 42)" (kv-make-env)))
+  :raised)
+
+;; ── Multi-expression body (implicit $sequence) ──────────────────
+
+(kv-test "lambda: two body forms — value of last"
+  (kv-eval-src "(($lambda (n) (+ n 1) (+ n 10)) 5)" (kv-make-env)) 15)
+
+(kv-test "lambda: three body forms"
+  (kv-eval-src "(($lambda (n) n (+ n 1) (+ n 2)) 10)" (kv-make-env)) 12)
+
+(kv-test "vau: two body forms"
+  (kv-eval-src "(($vau (a b) _ a (list a b)) 7 8)" (kv-make-env))
+  (list 7 8))
+
+(kv-test "lambda: $define! in early body visible in later body"
+  (kv-eval-src
+    "(($lambda (n) ($define! double (+ n n)) double) 6)"
+    (kv-make-env)) 12)
+
+(kv-test "lambda: zero-arg multi-body"
+  (kv-eval-src "(($lambda () 1 2 3))" (kv-make-env)) 3)
+
+(define kv-tests-run! (fn () {:total (+ kv-test-pass kv-test-fail) :passed kv-test-pass :failed kv-test-fail :fails kv-test-fails}))