kernel: loop summary — 18 commits, 322 tests, 6 reflective API candidates [proposes-reflective-extraction]

Loop closer documenting what 18 feature commits produced. Kernel-on-SX
is 1,398 LoC substrate + 1,747 LoC tests = 3,145 LoC total. Zero
substrate fixes required across the loop. R-1RK core + extras
implemented. Six proposed lib/guest/reflective/ files awaiting second
consumer. Substrate verdict: env-as-value generalises to
evaluator-as-value; the m-eval demo proves it.

hosts/javascript/platform.py

@@ -1129,6 +1129,7 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
   PRIMITIVES["boolean?"] = function(x) { return x === true || x === false; };
   PRIMITIVES["symbol?"] = function(x) { return x != null && x._sym === true; };
   PRIMITIVES["keyword?"] = function(x) { return x != null && x._kw === true; };
+  PRIMITIVES["adt?"] = function(x) { return x !== null && typeof x === "object" && x._adtv === true; };
   PRIMITIVES["component-affinity"] = componentAffinity;
 ''',
 
@@ -1475,6 +1476,22 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
   };
   PRIMITIVES["string-buffer->string"] = function(buf) { return buf.parts.join(""); };
   PRIMITIVES["string-buffer-length"] = function(buf) { return buf.len; };
+
+  // Short aliases — terser names; append accepts any value
+  PRIMITIVES["make-buffer"] = function() { return new SxStringBuffer(); };
+  PRIMITIVES["buffer?"] = function(x) { return x instanceof SxStringBuffer; };
+  PRIMITIVES["buffer-append!"] = function(buf, v) {
+    var s;
+    if (v === null || v === undefined || v === NIL) s = "";
+    else if (typeof v === "string") s = v;
+    else if (typeof v === "boolean") s = v ? "true" : "false";
+    else if (typeof v === "number") s = String(v);
+    else if (v && typeof v === "object" && typeof v.name === "string" && v.constructor && v.constructor.name === "Symbol") s = v.name;
+    else s = (typeof inspect === "function") ? inspect(v) : String(v);
+    buf.parts.push(s); buf.len += s.length; return NIL;
+  };
+  PRIMITIVES["buffer->string"] = function(buf) { return buf.parts.join(""); };
+  PRIMITIVES["buffer-length"] = function(buf) { return buf.len; };
 ''',
 
     "stdlib.format": '''
@@ -1933,12 +1950,30 @@ PLATFORM_JS_PRE = '''
     if (x._regexp) return "regexp";
     if (x._bytevector) return "bytevector";
     if (x._rational) return "rational";
+    if (x._adtv) return x._type;
     if (typeof Node !== "undefined" && x instanceof Node) return "dom-node";
     if (Array.isArray(x)) return "list";
     if (typeof x === "object") return "dict";
     return "unknown";
   }
 
+  // AdtValue — native algebraic data type instance (Step 6 mirror of OCaml Step 5).
+  // Constructed by define-type. Carries _adt:true plus _adtv:true tag so type-of
+  // returns the type name rather than "dict". dict? remains true (shim approach)
+  // so spec-level match-pattern in evaluator.sx works without changes.
+  function makeAdtValue(typeName, ctorName, fields) {
+    return {
+      _adtv: true,
+      _adt: true,
+      _type: typeName,
+      _ctor: ctorName,
+      _fields: fields
+    };
+  }
+  function isAdtValue(x) {
+    return x !== null && typeof x === "object" && x._adtv === true;
+  }
+
   function symbolName(s) { return s.name; }
   function keywordName(k) { return k.name; }
   function makeSymbol(n) { return new Symbol(n); }
@@ -2105,6 +2140,13 @@ PLATFORM_JS_PRE = '''
   // hostError — throw a host-level error that propagates out of cekRun.
   function hostError(msg) { throw new Error(typeof msg === "string" ? msg : inspect(msg)); }
 
+  // hostWarn — emit a host-level warning to console (no-op if console missing).
+  function hostWarn(msg) {
+    var m = typeof msg === "string" ? msg : inspect(msg);
+    if (typeof console !== "undefined" && console.warn) console.warn(m);
+    return NIL;
+  }
+
   // Render dispatch — call the active adapter's render function.
   // Set by each adapter when loaded; defaults to identity (no rendering).
   var _renderExprFn = null;
@@ -2126,7 +2168,16 @@ PLATFORM_JS_PRE = '''
   }
 
   function error(msg) { throw new Error(msg); }
-  function inspect(x) { return JSON.stringify(x); }
+  function inspect(x) {
+    if (x !== null && typeof x === "object" && x._adtv === true) {
+      var fs = x._fields || [];
+      if (fs.length === 0) return "(" + x._ctor + ")";
+      var parts = [];
+      for (var i = 0; i < fs.length; i++) parts.push(inspect(fs[i]));
+      return "(" + x._ctor + " " + parts.join(" ") + ")";
+    }
+    return JSON.stringify(x);
+  }
   function debugLog() { console.error.apply(console, ["[sx-debug]"].concat(Array.prototype.slice.call(arguments))); }
 
 '''
@@ -2450,6 +2501,7 @@ CEK_FIXUPS_JS = '''
   // Platform functions — defined in platform_js.py, not in .sx spec files.
   // Spec defines self-register via js-emit-define; these are the platform interface.
   PRIMITIVES["type-of"] = typeOf;
+  PRIMITIVES["inspect"] = inspect;
   PRIMITIVES["symbol-name"] = symbolName;
   PRIMITIVES["keyword-name"] = keywordName;
   PRIMITIVES["callable?"] = isCallable;
@@ -2771,8 +2823,8 @@ PLATFORM_DOM_JS = """
     // If lambda takes 0 params, call without event arg (convenience for on-click handlers)
     var wrapped = isLambda(handler)
       ? (lambdaParams(handler).length === 0
-        ? function(e) { try { cekCall(handler, NIL); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }
-        : function(e) { try { cekCall(handler, [e]); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } })
+        ? function(e) { try { var r = cekCall(handler, NIL); if (globalThis._driveAsync) globalThis._driveAsync(r); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }
+        : function(e) { try { var r = cekCall(handler, [e]); if (globalThis._driveAsync) globalThis._driveAsync(r); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } })
       : handler;
     if (name === "click") logInfo("domListen: click on <" + (el.tagName||"?").toLowerCase() + "> text=" + (el.textContent||"").substring(0,20) + " isLambda=" + isLambda(handler));
     var passiveEvents = { touchstart: 1, touchmove: 1, wheel: 1, scroll: 1 };
@@ -3981,6 +4033,11 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
   // -----------------------------------------------------------------------
   PRIMITIVES["error"] = function(msg) { throw new Error(msg); };
   PRIMITIVES["host-error"] = function(msg) { throw new Error(typeof msg === "string" ? msg : inspect(msg)); };
+  PRIMITIVES["host-warn"] = function(msg) {
+    var m = typeof msg === "string" ? msg : inspect(msg);
+    if (typeof console !== "undefined" && console.warn) console.warn(m);
+    return NIL;
+  };
   PRIMITIVES["try-catch"] = function(tryFn, catchFn) {
     try {
       return cekRun(continueWithCall(tryFn, [], makeEnv(), [], []));
@@ -4103,7 +4160,56 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
   function clearStores() { _storeRegistry = {}; return NIL; }
   PRIMITIVES["def-store"] = defStore;
   PRIMITIVES["use-store"] = useStore;
-  PRIMITIVES["clear-stores"] = clearStores;''']
+  PRIMITIVES["clear-stores"] = clearStores;
+
+  // -----------------------------------------------------------------------
+  // define-type override — produces native AdtValue instances (Step 6).
+  // The transpiled sfDefineType from evaluator.sx creates plain dict
+  // instances. We override here to construct AdtValue via makeAdtValue so
+  // type-of returns the type name and adt? can distinguish from dicts.
+  // dict? still returns true for AdtValue (shim) so spec-level match-pattern
+  // continues to work without changes.
+  // -----------------------------------------------------------------------
+  var _sfDefineTypeAdt = function(args, env) {
+    var typeSym = first(args);
+    var ctorSpecs = rest(args);
+    var typeName = symbolName(typeSym);
+    var ctorNames = map(function(spec) { return symbolName(first(spec)); }, ctorSpecs);
+    if (!isSxTruthy(envHas(env, "*adt-registry*"))) {
+      envBind(env, "*adt-registry*", {});
+    }
+    envGet(env, "*adt-registry*")[typeName] = ctorNames;
+    envBind(env, typeName + "?", function(v) { return isAdtValue(v) && v._type === typeName; });
+    for (var _i = 0; _i < ctorSpecs.length; _i++) {
+      (function(spec) {
+        var cn = symbolName(first(spec));
+        var fieldNames = map(function(f) { return symbolName(f); }, rest(spec));
+        var arity = fieldNames.length;
+        envBind(env, cn, function() {
+          var ctorArgs = Array.prototype.slice.call(arguments, 0);
+          if (ctorArgs.length !== arity) {
+            throw new Error(cn + ": expected " + arity + " args, got " + ctorArgs.length);
+          }
+          return makeAdtValue(typeName, cn, ctorArgs);
+        });
+        envBind(env, cn + "?", function(v) { return isAdtValue(v) && v._ctor === cn; });
+        for (var _j = 0; _j < fieldNames.length; _j++) {
+          (function(idx, fieldName) {
+            envBind(env, cn + "-" + fieldName, function(v) {
+              if (!isAdtValue(v)) throw new Error(cn + "-" + fieldName + ": not an ADT");
+              if (idx >= v._fields.length) throw new Error(cn + "-" + fieldName + ": index out of bounds");
+              return v._fields[idx];
+            });
+          })(_j, fieldNames[_j]);
+        }
+      })(ctorSpecs[_i]);
+    }
+    return NIL;
+  };
+  PRIMITIVES["sf-define-type"] = _sfDefineTypeAdt;
+  registerSpecialForm("define-type", _sfDefineTypeAdt);
+  PRIMITIVES["make-adt-value"] = makeAdtValue;
+  PRIMITIVES["adt-value?"] = isAdtValue;''']
     if has_deps:
         lines.append('''
   // Platform deps functions (native JS, not transpiled — need explicit registration)

hosts/ocaml/bin/bench_cek.ml

@@ -0,0 +1,73 @@
+(** CEK benchmark — measures throughput of the CEK evaluator on tight loops.
+
+    Usage:
+      dune exec bin/bench_cek.exe
+      dune exec bin/bench_cek.exe -- 5      (5 runs each)
+*)
+
+open Sx_types
+open Sx_parser
+
+let parse_one s =
+  let exprs = parse_all s in
+  match exprs with
+  | e :: _ -> e
+  | [] -> failwith "empty parse"
+
+let parse_many s = parse_all s
+
+let bench_run name setup expr iters =
+  let env = Sx_types.make_env () in
+  (* Run setup forms in env *)
+  List.iter (fun e -> ignore (Sx_ref.eval_expr e (Env env))) setup;
+  let times = ref [] in
+  for _ = 1 to iters do
+    Gc.full_major ();
+    let t0 = Unix.gettimeofday () in
+    let _r = Sx_ref.eval_expr expr (Env env) in
+    let t1 = Unix.gettimeofday () in
+    times := (t1 -. t0) :: !times
+  done;
+  let sorted = List.sort compare !times in
+  let median = List.nth sorted (iters / 2) in
+  let min_t = List.nth sorted 0 in
+  let max_t = List.nth sorted (iters - 1) in
+  Printf.printf "  %-22s  min=%8.2fms  median=%8.2fms  max=%8.2fms\n%!"
+    name (min_t *. 1000.0) (median *. 1000.0) (max_t *. 1000.0);
+  median
+
+let () =
+  let iters =
+    if Array.length Sys.argv > 1
+    then int_of_string Sys.argv.(1)
+    else 5
+  in
+  Printf.printf "CEK benchmark (%d runs each, taking median)\n%!" iters;
+  Printf.printf "==========================================\n%!";
+
+  (* fib 18 — recursive function call benchmark, smallish *)
+  let fib_setup = parse_many "(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))" in
+  let fib_expr = parse_one "(fib 18)" in
+  let _ = bench_run "fib(18)" fib_setup fib_expr iters in
+
+  (* loop 5000 — tight let loop *)
+  let loop_setup = parse_many "(define (loop n acc) (if (= n 0) acc (loop (- n 1) (+ acc 1))))" in
+  let loop_expr = parse_one "(loop 5000 0)" in
+  let _ = bench_run "loop(5000)" loop_setup loop_expr iters in
+
+  (* map+square over 1000 elem list *)
+  let map_setup = parse_many "(define (range-list n) (let loop ((i 0) (acc (list))) (if (= i n) acc (loop (+ i 1) (cons i acc))))) (define xs (range-list 1000))" in
+  let map_expr = parse_one "(map (fn (x) (* x x)) xs)" in
+  let _ = bench_run "map sq xs(1000)" map_setup map_expr iters in
+
+  (* reduce + over 2000 elem list *)
+  let red_setup = parse_many "(define (range-list n) (let loop ((i 0) (acc (list))) (if (= i n) acc (loop (+ i 1) (cons i acc))))) (define ys (range-list 2000))" in
+  let red_expr = parse_one "(reduce + 0 ys)" in
+  let _ = bench_run "reduce + ys(2000)" red_setup red_expr iters in
+
+  (* let-heavy: many bindings + if *)
+  let lh_setup = parse_many "(define (lh n) (let ((a 1) (b 2) (c 3) (d 4)) (if (= n 0) (+ a b c d) (lh (- n 1)))))" in
+  let lh_expr = parse_one "(lh 2000)" in
+  let _ = bench_run "let-heavy(2000)" lh_setup lh_expr iters in
+
+  Printf.printf "\nDone.\n%!"

hosts/ocaml/bin/bench_inspect.ml

@@ -0,0 +1,46 @@
+(* Benchmark inspect on representative SX values.
+   Takes min of 9 runs of n iterations to dampen GC noise. *)
+open Sx_types
+
+let rec make_tree d =
+  if d = 0 then String "leaf"
+  else List [String "node"; make_tree (d - 1); make_tree (d - 1); make_tree (d - 1)]
+
+let bench_min label f n runs =
+  let times = ref [] in
+  for _ = 1 to runs do
+    Gc.compact ();
+    let t0 = Unix.gettimeofday () in
+    for _ = 1 to n do ignore (f ()) done;
+    let t1 = Unix.gettimeofday () in
+    times := (t1 -. t0) :: !times
+  done;
+  let sorted = List.sort compare !times in
+  let min_t = List.nth sorted 0 in
+  let median = List.nth sorted (runs / 2) in
+  Printf.printf "  %-30s  min=%6.2fms  median=%6.2fms  (n=%d * %d runs)\n%!"
+    label (min_t *. 1000.0 /. float_of_int n)
+    (median *. 1000.0 /. float_of_int n) n runs
+
+let () =
+  let tree8 = make_tree 8 in
+  let s = inspect tree8 in
+  Printf.printf "tree-d8 inspect len=%d\n%!" (String.length s);
+  bench_min "inspect tree-d8" (fun () -> inspect tree8) 50 9;
+
+  let tree10 = make_tree 10 in
+  let s = inspect tree10 in
+  Printf.printf "tree-d10 inspect len=%d\n%!" (String.length s);
+  bench_min "inspect tree-d10" (fun () -> inspect tree10) 5 9;
+
+  let dict_xs = make_dict () in
+  for i = 0 to 999 do
+    Hashtbl.replace dict_xs (string_of_int i) (Integer i)
+  done;
+  let d = Dict dict_xs in
+  bench_min "inspect dict-1000" (fun () -> inspect d) 100 9;
+
+  let xs = ref [] in
+  for i = 0 to 1999 do xs := Integer i :: !xs done;
+  let lst = List !xs in
+  bench_min "inspect list-2000" (fun () -> inspect lst) 200 9

hosts/ocaml/bin/bench_vm.ml

@@ -0,0 +1,155 @@
+(** VM bytecode benchmark — measures throughput of the VM (compiled bytecode).
+
+    Loads the SX compiler via CEK, then for each test:
+      1. Define the function via CEK (as a Lambda).
+      2. Trigger JIT compilation via Sx_vm.jit_compile_lambda.
+      3. Call the compiled VmClosure repeatedly via Sx_vm.call_closure.
+
+    This measures pure VM execution time on the JIT path. *)
+
+open Sx_types
+
+let load_compiler env globals =
+  let compiler_path =
+    if Sys.file_exists "lib/compiler.sx" then "lib/compiler.sx"
+    else if Sys.file_exists "../../lib/compiler.sx" then "../../lib/compiler.sx"
+    else if Sys.file_exists "../../../lib/compiler.sx" then "../../../lib/compiler.sx"
+    else failwith "compiler.sx not found"
+  in
+  let ic = open_in compiler_path in
+  let src = really_input_string ic (in_channel_length ic) in
+  close_in ic;
+  let exprs = Sx_parser.parse_all src in
+  List.iter (fun e -> ignore (Sx_ref.eval_expr e (Env env))) exprs;
+  let rec sync e =
+    Hashtbl.iter (fun id v ->
+      let name = Sx_types.unintern id in
+      Hashtbl.replace globals name v) e.bindings;
+    match e.parent with Some p -> sync p | None -> ()
+  in
+  sync env
+
+let _make_globals env =
+  let g = Hashtbl.create 512 in
+  Hashtbl.iter (fun name fn ->
+    Hashtbl.replace g name (NativeFn (name, fn))
+  ) Sx_primitives.primitives;
+  let rec sync e =
+    Hashtbl.iter (fun id v ->
+      let name = Sx_types.unintern id in
+      if not (Hashtbl.mem g name) then Hashtbl.replace g name v) e.bindings;
+    match e.parent with Some p -> sync p | None -> ()
+  in
+  sync env;
+  g
+
+let define_fn env globals name params body_src =
+  (* Define via CEK so we get a Lambda value with proper closure. *)
+  let body_expr = match Sx_parser.parse_all body_src with
+    | [e] -> e
+    | _ -> failwith "expected one body expression"
+  in
+  let param_syms = List (List.map (fun p -> Symbol p) params) in
+  let define_expr = List [Symbol "define"; Symbol name; List [Symbol "fn"; param_syms; body_expr]] in
+  ignore (Sx_ref.eval_expr define_expr (Env env));
+  (* Sync env to globals so JIT can resolve free vars. *)
+  let rec sync e =
+    Hashtbl.iter (fun id v ->
+      let n = Sx_types.unintern id in
+      Hashtbl.replace globals n v) e.bindings;
+    match e.parent with Some p -> sync p | None -> ()
+  in
+  sync env;
+  (* Now find the Lambda and JIT-compile it. *)
+  let lam_val = Hashtbl.find globals name in
+  match lam_val with
+  | Lambda l ->
+    (match Sx_vm.jit_compile_lambda l globals with
+     | Some cl ->
+       l.l_compiled <- Some cl;
+       Hashtbl.replace globals name (NativeFn (name, fun args ->
+         Sx_vm.call_closure cl args globals));
+       cl
+     | None ->
+       failwith (Printf.sprintf "JIT failed for %s" name))
+  | _ -> failwith (Printf.sprintf "%s is not a Lambda after define" name)
+
+let bench_call name cl globals args iters =
+  let times = ref [] in
+  for _ = 1 to iters do
+    Gc.full_major ();
+    let t0 = Unix.gettimeofday () in
+    let _r = Sx_vm.call_closure cl args globals in
+    let t1 = Unix.gettimeofday () in
+    times := (t1 -. t0) :: !times
+  done;
+  let sorted = List.sort compare !times in
+  let median = List.nth sorted (iters / 2) in
+  let min_t = List.nth sorted 0 in
+  let max_t = List.nth sorted (iters - 1) in
+  Printf.printf "  %-22s  min=%8.2fms  median=%8.2fms  max=%8.2fms\n%!"
+    name (min_t *. 1000.0) (median *. 1000.0) (max_t *. 1000.0);
+  median
+
+let () =
+  let iters =
+    if Array.length Sys.argv > 1
+    then int_of_string Sys.argv.(1)
+    else 7
+  in
+  Printf.printf "VM (bytecode/JIT) benchmark (%d runs each, taking median)\n%!" iters;
+  Printf.printf "========================================================\n%!";
+
+  let env = Sx_types.make_env () in
+  let bind n fn = ignore (Sx_types.env_bind env n (NativeFn (n, fn))) in
+  (* Seed env with primitives as NativeFn so CEK lookups work. *)
+  Hashtbl.iter (fun name fn ->
+    Hashtbl.replace env.bindings (Sx_types.intern name) (NativeFn (name, fn))
+  ) Sx_primitives.primitives;
+  (* Helpers the SX compiler relies on but aren't kernel primitives. *)
+  bind "symbol-name" (fun args -> match args with
+    | [Symbol s] -> String s | _ -> raise (Eval_error "symbol-name"));
+  bind "keyword-name" (fun args -> match args with
+    | [Keyword k] -> String k | _ -> raise (Eval_error "keyword-name"));
+  bind "make-symbol" (fun args -> match args with
+    | [String s] -> Symbol s
+    | [v] -> Symbol (Sx_types.value_to_string v)
+    | _ -> raise (Eval_error "make-symbol"));
+  bind "sx-serialize" (fun args -> match args with
+    | [v] -> String (Sx_types.inspect v)
+    | _ -> raise (Eval_error "sx-serialize"));
+  let globals = Hashtbl.create 1024 in
+  Hashtbl.iter (fun name fn ->
+    Hashtbl.replace globals name (NativeFn (name, fn))
+  ) Sx_primitives.primitives;
+  Printf.printf "Loading compiler.sx ... %!";
+  let t0 = Unix.gettimeofday () in
+  load_compiler env globals;
+  Printf.printf "%.0fms\n%!" ((Unix.gettimeofday () -. t0) *. 1000.0);
+
+  (* fib(22) — recursive call benchmark *)
+  let fib_cl = define_fn env globals "fib" ["n"]
+    "(if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))" in
+  let _ = bench_call "fib(22)" fib_cl globals [Number 22.0] iters in
+
+  (* tight loop *)
+  let loop_cl = define_fn env globals "loop" ["n"; "acc"]
+    "(if (= n 0) acc (loop (- n 1) (+ acc 1)))" in
+  let _ = bench_call "loop(200000)" loop_cl globals [Number 200000.0; Number 0.0] iters in
+
+  (* sum-to *)
+  let sum_cl = define_fn env globals "sum_to" ["n"; "acc"]
+    "(if (= n 0) acc (sum_to (- n 1) (+ acc n)))" in
+  let _ = bench_call "sum-to(50000)" sum_cl globals [Number 50000.0; Number 0.0] iters in
+
+  (* count-lt: comparison-heavy *)
+  let cnt_cl = define_fn env globals "count_lt" ["n"; "acc"]
+    "(if (= n 0) acc (count_lt (- n 1) (if (< n 10000) (+ acc 1) acc)))" in
+  let _ = bench_call "count-lt(20000)" cnt_cl globals [Number 20000.0; Number 0.0] iters in
+
+  (* count-eq: equality-heavy on multiples of 7 *)
+  let eq_cl = define_fn env globals "count_eq" ["n"; "acc"]
+    "(if (= n 0) acc (count_eq (- n 1) (if (= 0 (- n (* 7 (/ n 7)))) (+ acc 1) acc)))" in
+  let _ = bench_call "count-eq(20000)" eq_cl globals [Number 20000.0; Number 0.0] iters in
+
+  Printf.printf "\nDone.\n%!"

hosts/ocaml/bin/dune

@@ -1,5 +1,5 @@
 (executables
- (names run_tests debug_set sx_server integration_tests)
+ (names run_tests debug_set sx_server integration_tests bench_cek bench_inspect bench_vm)
  (libraries sx unix threads.posix otfm yojson))
 
 (executable

hosts/ocaml/bin/mcp_tree.ml

@@ -1892,8 +1892,34 @@ let handle_sx_harness_eval args =
     let file = args |> member "file" |> to_string_option in
     let setup_str = args |> member "setup" |> to_string_option in
     let files_json = try args |> member "files" with _ -> `Null in
+    let host_stubs = match args |> member "host_stubs" with `Bool b -> b | _ -> false in
     let e = !env in
     let warnings = ref [] in
+    (* Inject stub host primitives so files using host-get/host-new/etc. can load *)
+    if host_stubs then begin
+      let stubs = {|
+        (define host-global (fn (&rest _) nil))
+        (define host-get (fn (&rest _) nil))
+        (define host-set! (fn (obj k v) v))
+        (define host-call (fn (&rest _) nil))
+        (define host-new (fn (&rest _) (dict)))
+        (define host-callback (fn (f) f))
+        (define host-typeof (fn (&rest _) "string"))
+        (define hs-ref-eq (fn (a b) (identical? a b)))
+        (define host-call-fn (fn (&rest _) nil))
+        (define host-iter? (fn (&rest _) false))
+        (define host-to-list (fn (&rest _) (list)))
+        (define host-await (fn (&rest _) nil))
+        (define host-new-function (fn (&rest _) nil))
+        (define load-library! (fn (&rest _) false))
+      |} in
+      let stub_exprs = Sx_parser.parse_all stubs in
+      List.iter (fun expr ->
+        try ignore (Sx_ref.eval_expr expr (Env e))
+        with exn ->
+          warnings := Printf.sprintf "Stub warning: %s" (Printexc.to_string exn) :: !warnings
+      ) stub_exprs
+    end;
     (* Collect all files to load *)
     let all_files = match files_json with
       | `List items ->
@@ -3018,7 +3044,8 @@ let tool_definitions = `List [
      ("mock", `Assoc [("type", `String "string"); ("description", `String "Optional mock platform overrides as SX dict, e.g. {:fetch (fn (url) {:status 200})}")]);
      ("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")]);
      ("files", `Assoc [("type", `String "array"); ("items", `Assoc [("type", `String "string")]); ("description", `String "Multiple .sx files to load in order")]);
-     ("setup", `Assoc [("type", `String "string"); ("description", `String "SX setup expression to run before main evaluation")])]
+     ("setup", `Assoc [("type", `String "string"); ("description", `String "SX setup expression to run before main evaluation")]);
+     ("host_stubs", `Assoc [("type", `String "boolean"); ("description", `String "If true, inject nil-returning stubs for host-get/host-set!/host-call/host-new/etc. so files that use host primitives can load in the harness")])]
     ["expr"];
   tool "sx_nav" "Manage sx-docs navigation and articles. Modes: list (all nav items with status), check (validate consistency), add (create article + nav entry), delete (remove nav entry + page fn), move (move entry between sections, rewriting hrefs)."
     [("mode", `Assoc [("type", `String "string"); ("description", `String "Mode: list, check, add, delete, or move")]);

hosts/ocaml/bin/run_tests.ml

@@ -2899,6 +2899,9 @@ let run_spec_tests env test_files =
   load_module "parser.sx" hs_dir;
   load_module "compiler.sx" hs_dir;
   load_module "runtime.sx" hs_dir;
+  let hs_plugins_dir = Filename.concat hs_dir "plugins" in
+  load_module "worker.sx" hs_plugins_dir;
+  load_module "prolog.sx" hs_plugins_dir;
   load_module "integration.sx" hs_dir;
   load_module "htmx.sx" hs_dir;
   (* Override console-log to avoid str on circular mock DOM refs *)

hosts/ocaml/bin/sx_server.ml

@@ -703,6 +703,11 @@ let setup_evaluator_bridge env =
     | [expr; e] -> Sx_ref.eval_expr expr (Env (Sx_runtime.unwrap_env e))
     | [expr] -> Sx_ref.eval_expr expr (Env env)
     | _ -> raise (Eval_error "eval-expr: expected (expr env?)"));
+  (* eval-in-env: (env expr) → result.  Evaluates expr in the given env. *)
+  Sx_primitives.register "eval-in-env" (fun args ->
+    match args with
+    | [e; expr] -> Sx_ref.eval_expr expr e
+    | _ -> raise (Eval_error "eval-in-env: (env expr)"));
   bind "trampoline" (fun args ->
     match args with
     | [v] ->
@@ -764,7 +769,13 @@ let setup_evaluator_bridge env =
     | _ -> raise (Eval_error "register-special-form!: expected (name handler)"));
   ignore (env_bind env "*custom-special-forms*" Sx_ref.custom_special_forms);
   ignore (Sx_ref.register_special_form (String "<>") (NativeFn ("<>", fun args ->
-    List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args))))
+    List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args))));
+  (* current-env: special form — returns current lexical env as a first-class value *)
+  ignore (Sx_ref.register_special_form (String "current-env")
+    (NativeFn ("current-env", fun args ->
+      match args with
+      | [_arg_list; env_val] -> env_val
+      | _ -> Nil)))
 
 (* ---- Type predicates and introspection ---- *)
 let setup_introspection env =
@@ -950,7 +961,24 @@ let setup_env_operations env =
   bind "env-has?" (fun args -> match args with [e; String k] -> Bool (Sx_types.env_has (uw e) k) | [e; Keyword k] -> Bool (Sx_types.env_has (uw e) k) | _ -> raise (Eval_error "env-has?: expected env and string"));
   bind "env-bind!" (fun args -> match args with [e; String k; v] -> Sx_types.env_bind (uw e) k v | [e; Keyword k; v] -> Sx_types.env_bind (uw e) k v | _ -> raise (Eval_error "env-bind!: expected env, key, value"));
   bind "env-set!" (fun args -> match args with [e; String k; v] -> Sx_types.env_set (uw e) k v | [e; Keyword k; v] -> Sx_types.env_set (uw e) k v | _ -> raise (Eval_error "env-set!: expected env, key, value"));
-  bind "env-extend" (fun args -> match args with [e] -> Env (Sx_types.env_extend (uw e)) | _ -> raise (Eval_error "env-extend: expected env"));
+  bind "env-extend" (fun args ->
+    match args with
+    | e :: pairs ->
+      let child = Sx_types.env_extend (uw e) in
+      let rec go = function
+        | [] -> ()
+        | k :: v :: rest ->
+          ignore (Sx_types.env_bind child (Sx_runtime.value_to_str k) v); go rest
+        | [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in
+      go pairs; Env child
+    | _ -> raise (Eval_error "env-extend: expected env"));
+  bind "env-lookup" (fun args ->
+    match args with
+    | [e; key] ->
+      let k = Sx_runtime.value_to_str key in
+      let raw = uw e in
+      if Sx_types.env_has raw k then Sx_types.env_get raw k else Nil
+    | _ -> raise (Eval_error "env-lookup: (env key)"));
   bind "env-merge" (fun args -> match args with [a; b] -> Sx_runtime.env_merge a b | _ -> raise (Eval_error "env-merge: expected 2 envs"))
 
 (* ---- Strict mode (gradual type system support) ---- *)

hosts/ocaml/bootstrap.py

@@ -82,7 +82,10 @@ let cek_run_iterative state =
       s := cek_step !s
     done;
     (match cek_suspended_p !s with
-     | Bool true -> raise (Eval_error "IO suspension in non-IO context")
+     | Bool true ->
+       (match !_cek_io_suspend_hook with
+        | Some hook -> hook !s
+        | None -> raise (Eval_error "IO suspension in non-IO context"))
      | _ -> cek_value !s)
   with Eval_error msg ->
     _last_error_kont_ref := cek_kont !s;
@@ -308,6 +311,23 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
         output
     )
 
+    # Patch transpiled cek_run to invoke _cek_io_suspend_hook on suspension
+    # instead of unconditionally raising Eval_error. This is the fix for the
+    # tree-walk eval_expr path: sf_letrec init exprs / non-last body exprs,
+    # macro bodies, qq_expand, dynamic-wind / scope / provide bodies all use
+    # `trampoline (eval_expr ...)` and were swallowing CEK suspensions as
+    # "IO suspension in non-IO context" errors. With the hook, the suspension
+    # propagates as VmSuspended to the outer driver (browser callFn / server
+    # eval_expr_io). When the hook is unset (pure-CEK harness), the legacy
+    # error is preserved as the fallback.
+    output = re.sub(
+        r'\(raise \(Eval_error \(value_to_str \(String "IO suspension in non-IO context"\)\)\)\)',
+        '(match !_cek_io_suspend_hook with Some hook -> hook final | None -> '
+        '(raise (Eval_error (value_to_str (String "IO suspension in non-IO context")))))',
+        output,
+        count=1,
+    )
+
     return output
 
 

hosts/ocaml/bootstrap_vm.py

@@ -355,7 +355,9 @@ let vm_create_closure vm_val frame_val code_val =
   let f = unwrap_frame frame_val in
   let uv_count = match code_val with
     | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
-        | Some (Number n) -> int_of_float n | _ -> 0)
+        | Some (Integer n) -> n
+        | Some (Number n) -> int_of_float n
+        | _ -> 0)
     | _ -> 0
   in
   let upvalues = Array.init uv_count (fun _ ->

hosts/ocaml/browser/bundle.sh

@@ -75,6 +75,9 @@ cp "$ROOT/shared/sx/templates/tw.sx"        "$DIST/sx/"
 for f in tokenizer parser compiler runtime integration htmx; do
   cp "$ROOT/lib/hyperscript/$f.sx" "$DIST/sx/hs-$f.sx"
 done
+for f in worker prolog; do
+  cp "$ROOT/lib/hyperscript/plugins/$f.sx" "$DIST/sx/hs-$f.sx"
+done
 
 # Summary
 WASM_SIZE=$(du -sh "$DIST/sx_browser.bc.wasm.assets" | cut -f1)

hosts/ocaml/browser/compile-modules.js

@@ -85,6 +85,7 @@ const FILES = [
   'harness-web.sx', 'engine.sx', 'orchestration.sx',
   // Hyperscript modules — loaded on demand via transparent lazy loader
   'hs-tokenizer.sx', 'hs-parser.sx', 'hs-compiler.sx', 'hs-runtime.sx',
+  'hs-worker.sx', 'hs-prolog.sx',
   'hs-integration.sx', 'hs-htmx.sx',
   'boot.sx',
 ];
@@ -455,8 +456,10 @@ for (const file of FILES) {
         'hs-parser': ['hs-tokenizer'],
         'hs-compiler': ['hs-tokenizer', 'hs-parser'],
         'hs-runtime': ['hs-tokenizer', 'hs-parser', 'hs-compiler'],
-        'hs-integration': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime'],
-        'hs-htmx': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration'],
+        'hs-worker': ['hs-tokenizer', 'hs-parser'],
+        'hs-prolog': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime'],
+        'hs-integration': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-worker', 'hs-prolog'],
+        'hs-htmx': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-worker', 'hs-prolog', 'hs-integration'],
       };
       manifest[key] = {
         file: sxbcFile,
@@ -477,7 +480,7 @@ if (entryFile) {
   const lazyDeps = entryFile.deps.filter(d => LAZY_ENTRY_DEPS.has(d));
   // Hyperscript modules aren't define-library, so not auto-detected as deps.
   // Load them lazily after boot — eager loading breaks the boot sequence.
-  const HS_LAZY = ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration', 'hs-htmx'];
+  const HS_LAZY = ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-worker', 'hs-prolog', 'hs-integration', 'hs-htmx'];
   for (const m of HS_LAZY) {
     if (manifest[m] && !lazyDeps.includes(m)) lazyDeps.push(m);
   }

hosts/ocaml/browser/sx_browser.ml

@@ -344,6 +344,12 @@ let api_eval src_js =
     sync_env_to_vm ();
     return_via_side_channel (value_to_js result)
   with
+  | Sx_vm.VmSuspended _ ->
+    (* Top-level eval encountered an IO suspension propagated via the
+       cek_run hook (perform inside letrec init / non-last body / macro /
+       qq tree-walked path). K.eval doesn't drive resumption — surface as
+       a clear error so the caller knows to use callFn instead. *)
+    Js.Unsafe.inject (Js.string "Error: IO suspension in non-IO context (use callFn for IO-aware paths)")
   | Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
   | Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
 
@@ -371,6 +377,8 @@ let api_eval_vm src_js =
     ) _vm_globals;
     return_via_side_channel (value_to_js result)
   with
+  | Sx_vm.VmSuspended _ ->
+    Js.Unsafe.inject (Js.string "Error: IO suspension in non-IO context (use callFn for IO-aware paths)")
   | Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
   | Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
   | Not_found -> Js.Unsafe.inject (Js.string "Error: compile-module not loaded")
@@ -381,7 +389,10 @@ let api_eval_expr expr_js _env_js =
     let result = Sx_ref.eval_expr expr (Env global_env) in
     sync_env_to_vm ();
     return_via_side_channel (value_to_js result)
-  with Eval_error msg ->
+  with
+  | Sx_vm.VmSuspended _ ->
+    Js.Unsafe.inject (Js.string "Error: IO suspension in non-IO context (use callFn for IO-aware paths)")
+  | Eval_error msg ->
     Js.Unsafe.inject (Js.string ("Error: " ^ msg))
 
 let api_load src_js =
@@ -704,8 +715,10 @@ let () =
         | List (Symbol "code" :: rest) ->
           let d = Hashtbl.create 8 in
           let rec parse_kv = function
-            | Keyword "arity" :: Number n :: rest -> Hashtbl.replace d "arity" (Number n); parse_kv rest
-            | Keyword "upvalue-count" :: Number n :: rest -> Hashtbl.replace d "upvalue-count" (Number n); parse_kv rest
+            | Keyword "arity" :: (Number _ as n) :: rest -> Hashtbl.replace d "arity" n; parse_kv rest
+            | Keyword "arity" :: (Integer _ as n) :: rest -> Hashtbl.replace d "arity" n; parse_kv rest
+            | Keyword "upvalue-count" :: (Number _ as n) :: rest -> Hashtbl.replace d "upvalue-count" n; parse_kv rest
+            | Keyword "upvalue-count" :: (Integer _ as n) :: rest -> Hashtbl.replace d "upvalue-count" n; parse_kv rest
             | Keyword "bytecode" :: List nums :: rest ->
               Hashtbl.replace d "bytecode" (List nums); parse_kv rest
             | Keyword "constants" :: List consts :: rest ->

hosts/ocaml/browser/test_letrec_resume.js

@@ -0,0 +1,172 @@
+#!/usr/bin/env node
+// Repro: letrec sibling bindings nil after perform/resume in browser kernel
+//
+// Bug: After a CEK IO suspension (perform / hs-wait) resumes in the
+// WASM browser kernel, calling a sibling letrec binding could return
+// nil, with the error surfaced as `[sx] resume: Not callable: nil`.
+//
+// Root cause: cek-run / cek_run_iterative raised
+// `"IO suspension in non-IO context"` when a tree-walked eval_expr
+// (sf_letrec init exprs / non-last body, macro body, qq unquote, scope
+// body, provide body, dynamic-wind) hit a perform. The CEK suspension
+// was created correctly but never propagated through the OCaml-side
+// _cek_io_suspend_hook, so the outer driver never saw VmSuspended.
+//
+// Fix: cek_run / cek_run_iterative now invoke _cek_io_suspend_hook on
+// suspension (raising VmSuspended for the outer driver). When the hook
+// is unset (pure-CEK harness), they fall back to the legacy error.
+//
+// This test exercises the WASM kernel through K.callFn — the path that
+// browser event handlers use. Suspension surfaces as a JS object with
+// {suspended, request, resume(result)} that the test drives synchronously.
+//
+// Companion: spec/tests/test-letrec-resume-treewalk.sx tests the
+// CEK-only path through the OCaml test runner.
+
+const path = require('path');
+const fs = require('fs');
+
+const KERNEL = path.join(__dirname, '..', '_build', 'default', 'browser', 'sx_browser.bc.js');
+if (!fs.existsSync(KERNEL)) {
+  console.error('FATAL: missing ' + KERNEL + ' — run `dune build` from hosts/ocaml first');
+  process.exit(2);
+}
+require(KERNEL);
+const K = globalThis.SxKernel;
+
+let passed = 0, failed = 0;
+const failures = [];
+
+function test(name, fn) {
+  try {
+    const r = fn();
+    if (r === true) {
+      passed++;
+      console.log('  PASS: ' + name);
+    } else {
+      failed++;
+      failures.push({ name, error: 'got ' + JSON.stringify(r) });
+      console.log('  FAIL: ' + name + ' — got ' + JSON.stringify(r));
+    }
+  } catch (e) {
+    failed++;
+    failures.push({ name, error: e.message || String(e) });
+    console.log('  FAIL: ' + name + ' — ' + (e.message || e));
+  }
+}
+
+function driveSync(result) {
+  while (result && typeof result === 'object' && result.suspended) {
+    result = result.resume(null);
+  }
+  return result;
+}
+
+function callExpr(src) {
+  K.eval('(define _t-fn (fn () ' + src + '))');
+  const fn = K.eval('_t-fn');
+  return driveSync(K.callFn(fn, []));
+}
+
+console.log('\n=== letrec + perform/resume regression tests ===\n');
+
+test('basic letrec without perform', () =>
+  callExpr('(letrec ((f (fn () "ok"))) (f))') === 'ok');
+
+test('callFn perform suspends and resumes with nil', () => {
+  K.eval('(define _t-perform (fn () (perform {:op "io"})))');
+  let r = K.callFn(K.eval('_t-perform'), []);
+  if (!r || !r.suspended) return 'no suspension: ' + JSON.stringify(r);
+  return r.resume(null) === null;
+});
+
+test('letrec, single binding, perform/resume', () =>
+  callExpr('(letrec ((f (fn () (perform {:op "io"})))) (f))') === null);
+
+test('letrec, 2 bindings, body calls sibling after suspended call', () =>
+  callExpr(`
+    (letrec
+      ((wait-then (fn () (do (perform {:op "io"}) "wait-done")))
+       (other-fn (fn () "other-result")))
+      (do (wait-then) (other-fn)))`) === 'other-result');
+
+test('letrec, suspending fn calls sibling after own perform', () =>
+  callExpr(`
+    (letrec
+      ((wait-and-call (fn () (do (perform {:op "io"}) (other-fn))))
+       (other-fn (fn () "from-sibling")))
+      (wait-and-call))`) === 'from-sibling');
+
+test('letrec, fn references sibling value after perform/resume', () =>
+  callExpr(`
+    (letrec
+      ((shared "shared-state")
+       (do-fn (fn () (do (perform {:op "io"}) shared))))
+      (do-fn))`) === 'shared-state');
+
+test('letrec, recursive self-call after perform (wait-boot pattern)', () => {
+  K.eval('(define _wb-c 0)');
+  K.eval('(set! _wb-c 0)');
+  return callExpr(`
+    (letrec ((wait-boot (fn ()
+                (do (perform {:op "io"})
+                    (if (>= _wb-c 1)
+                        "done"
+                        (do (set! _wb-c (+ 1 _wb-c))
+                            (wait-boot)))))))
+      (wait-boot))`) === 'done';
+});
+
+test('top-level define + perform + sibling call after resume', () => {
+  K.eval('(define do-suspend-x (fn () (do (perform {:op "io"}) (do-other-x))))');
+  K.eval('(define do-other-x (fn () "ok-from-other"))');
+  return callExpr('(do-suspend-x)') === 'ok-from-other';
+});
+
+test('letrec, two performs (sequential) then sibling call', () =>
+  callExpr(`
+    (letrec
+      ((wait-twice (fn () (do (perform {:op "io1"}) (perform {:op "io2"}) (other))))
+       (other (fn () "after-double")))
+      (wait-twice))`) === 'after-double');
+
+// === Tree-walk paths that previously raised "IO suspension in non-IO context" ===
+
+test('letrec init expr with perform — suspension propagates (no error)', () => {
+  let r;
+  try { r = callExpr('(letrec ((x (perform {:op "io"}))) "ok")'); }
+  catch (e) { return 'threw: ' + e.message; }
+  return r === null || r === 'ok';
+});
+
+test('letrec non-last body with perform — suspension propagates (no error)', () => {
+  let r;
+  try { r = callExpr('(letrec ((x 1)) (perform {:op "io"}) "after")'); }
+  catch (e) { return 'threw: ' + e.message; }
+  return r === null || r === 'after';
+});
+
+test('macro body with perform — suspension propagates', () => {
+  K.eval('(defmacro _m1 (form) (do (perform {:op "io"}) form))');
+  let r;
+  try { r = callExpr('(_m1 "macro-ok")'); }
+  catch (e) { return 'threw: ' + e.message; }
+  return r === 'macro-ok' || r === null;
+});
+
+test('quasiquote unquote with perform — suspension propagates', () => {
+  let r;
+  try { r = callExpr('(let ((y "yyy")) `(a ,(do (perform {:op "io"}) y) c))'); }
+  catch (e) { return 'threw: ' + e.message; }
+  return r !== undefined;
+});
+
+console.log('\n--- Results ---');
+console.log('passed: ' + passed);
+console.log('failed: ' + failed);
+if (failed > 0) {
+  console.log('\nFailures:');
+  failures.forEach(f => console.log('  - ' + f.name + ': ' + f.error));
+  process.exit(1);
+}
+process.exit(0);

hosts/ocaml/lib/dune

@@ -1,4 +1,4 @@
 (library
  (name sx)
  (wrapped false)
- (libraries re re.pcre))
+ (libraries re re.pcre unix))

hosts/ocaml/lib/sx_compiler.ml

@@ -200,7 +200,30 @@ and compile_qq_list em items scope =
 
 (* compile-call *)
 and compile_call em head args scope tail_p =
-  (let is_prim = (let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let name = (symbol_name (head)) in (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "local")]))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "upvalue")]))))) in if not (sx_truthy _and) then _and else (is_primitive (name)))))) in (if sx_truthy (is_prim) then (let name = (symbol_name (head)) in let argc = (len (args)) in let name_idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (let () = ignore ((emit_op (em) ((Number 52.0)))) in (let () = ignore ((emit_u16 (em) (name_idx))) in (emit_byte (em) (argc)))))) else (let () = ignore ((compile_expr (em) (head) (scope) ((Bool false)))) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (if sx_truthy (tail_p) then (let () = ignore ((emit_op (em) ((Number 49.0)))) in (emit_byte (em) ((len (args))))) else (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((len (args))))))))))
+  (let is_prim = (let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let name = (symbol_name (head)) in (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "local")]))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "upvalue")]))))) in if not (sx_truthy _and) then _and else (is_primitive (name)))))) in (if sx_truthy (is_prim) then (let name = (symbol_name (head)) in let argc = (len (args)) in
+    (* Specialized opcode for hot 2-arg / 1-arg primitives. *)
+    let specialized_op = (match name, argc with
+      | String "+",     Number 2.0 -> Some 160
+      | String "-",     Number 2.0 -> Some 161
+      | String "*",     Number 2.0 -> Some 162
+      | String "/",     Number 2.0 -> Some 163
+      | String "=",     Number 2.0 -> Some 164
+      | String "<",     Number 2.0 -> Some 165
+      | String ">",     Number 2.0 -> Some 166
+      | String "cons",  Number 2.0 -> Some 172
+      | String "not",   Number 1.0 -> Some 167
+      | String "len",   Number 1.0 -> Some 168
+      | String "first", Number 1.0 -> Some 169
+      | String "rest",  Number 1.0 -> Some 170
+      | _ -> None) in
+    (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in
+     (match specialized_op with
+      | Some op -> emit_op em (Number (float_of_int op))
+      | None ->
+        let name_idx = (pool_add ((get (em) ((String "pool")))) (name)) in
+        let () = ignore ((emit_op (em) ((Number 52.0)))) in
+        let () = ignore ((emit_u16 (em) (name_idx))) in
+        emit_byte (em) (argc)))) else (let () = ignore ((compile_expr (em) (head) (scope) ((Bool false)))) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (if sx_truthy (tail_p) then (let () = ignore ((emit_op (em) ((Number 49.0)))) in (emit_byte (em) ((len (args))))) else (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((len (args))))))))))
 
 (* compile *)
 and compile expr =

hosts/ocaml/lib/sx_ref.ml

@@ -614,7 +614,7 @@ and cek_step_loop state =
 
 (* cek-run *)
 and cek_run state =
-  (let final = (cek_step_loop (state)) in (if sx_truthy ((cek_suspended_p (final))) then (raise (Eval_error (value_to_str (String "IO suspension in non-IO context")))) else (cek_value (final))))
+  (let final = (cek_step_loop (state)) in (if sx_truthy ((cek_suspended_p (final))) then (match !_cek_io_suspend_hook with Some hook -> hook final | None -> (raise (Eval_error (value_to_str (String "IO suspension in non-IO context"))))) else (cek_value (final))))
 
 (* cek-resume *)
 and cek_resume suspended_state result' =
@@ -759,7 +759,78 @@ and match_pattern pattern value env =
 
 (* step-sf-match *)
 and step_sf_match args env kont =
-  (let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (make_cek_value ((String (sx_str [(String "match: no clause matched "); (inspect (val'))]))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont)))))
+  (let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let () = ignore (match_check_exhaustiveness val' clauses env) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (make_cek_value ((String (sx_str [(String "match: no clause matched "); (inspect (val'))]))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont))))))
+
+(* match-check-exhaustiveness — Step 8 hand-patched into sx_ref.ml *)
+and match_check_exhaustiveness val' clauses env =
+  let is_else_pat p =
+    match p with
+    | Symbol "_" | Symbol "else" -> true
+    | Keyword "else" -> true
+    | _ -> false
+  in
+  let clause_is_else c =
+    match c with
+    | List (p :: _) -> is_else_pat p
+    | _ -> false
+  in
+  let clause_ctor_name c =
+    match c with
+    | List (List (Symbol n :: _) :: _) -> Some n
+    | _ -> None
+  in
+  let type_name_opt = match val' with
+    | AdtValue a -> Some a.av_type
+    | Dict d ->
+      (match Hashtbl.find_opt d "_adt" with
+       | Some (Bool true) ->
+         (match Hashtbl.find_opt d "_type" with
+          | Some (String s) -> Some s
+          | _ -> None)
+       | _ -> None)
+    | _ -> None
+  in
+  match type_name_opt with
+  | None -> Nil
+  | Some type_name ->
+       if not (sx_truthy (env_has env (String "*adt-registry*"))) then Nil
+       else
+         let registry = env_get env (String "*adt-registry*") in
+         let registered = match registry with
+           | Dict r ->
+             (match Hashtbl.find_opt r type_name with
+              | Some (List ctors) -> Some ctors
+              | _ -> None)
+           | _ -> None in
+         (match registered with
+          | None -> Nil
+          | Some ctor_vals ->
+            let clauses_list = match clauses with List xs -> xs | _ -> [] in
+            if List.exists clause_is_else clauses_list then Nil
+            else
+              let clause_ctors = List.filter_map clause_ctor_name clauses_list in
+              let registered_names = List.filter_map (function
+                | String s -> Some s | _ -> None) ctor_vals in
+              let missing = List.filter (fun c -> not (List.mem c clause_ctors)) registered_names in
+              if missing = [] then Nil
+              else begin
+                if not (sx_truthy (env_has env (String "*adt-warned*"))) then
+                  ignore (env_bind env (String "*adt-warned*") (Dict (Hashtbl.create 4)));
+                let warned = env_get env (String "*adt-warned*") in
+                let key = type_name ^ "|" ^ String.concat "," missing in
+                let already = match warned with
+                  | Dict w -> (match Hashtbl.find_opt w key with Some (Bool true) -> true | _ -> false)
+                  | _ -> false in
+                if already then Nil
+                else begin
+                  (match warned with
+                   | Dict w -> Hashtbl.replace w key (Bool true)
+                   | _ -> ());
+                  let msg = "[sx] match: non-exhaustive — " ^ type_name ^ ": missing " ^ String.concat ", " missing in
+                  ignore (host_warn (String msg));
+                  Nil
+                end
+              end)
 
 (* step-sf-handler-bind *)
 and step_sf_handler_bind args env kont =
@@ -981,7 +1052,14 @@ let cek_run_iterative state =
       s := cek_step !s
     done;
     (match cek_suspended_p !s with
-     | Bool true -> raise (Eval_error "IO suspension in non-IO context")
+     | Bool true ->
+       (* Propagate suspension via the OCaml-side hook so it converts to
+          VmSuspended and flows to the outer driver (value_to_js / resume
+          callback). Without the hook (pure CEK harness), keep the legacy
+          error so test runners surface the misuse. *)
+       (match !_cek_io_suspend_hook with
+        | Some hook -> hook !s
+        | None -> raise (Eval_error "IO suspension in non-IO context"))
      | _ -> cek_value !s)
   with Eval_error msg ->
     _last_error_kont_ref := cek_kont !s;
@@ -1054,8 +1132,7 @@ let sf_define_type args env_val =
       (match pargs with
       | [v] ->
         (match v with
-        | Dict d -> Bool (Hashtbl.mem d "_adt" &&
-          (match Hashtbl.find_opt d "_type" with Some (String t) -> t = type_name | _ -> false))
+        | AdtValue a -> Bool (a.av_type = type_name)
         | _ -> Bool false)
       | _ -> Bool false)));
   List.iter (fun spec ->
@@ -1069,21 +1146,18 @@ let sf_define_type args env_val =
           if List.length ctor_args <> arity then
             raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d"
               cn arity (List.length ctor_args)))
-          else begin
-            let d = Hashtbl.create 4 in
-            Hashtbl.replace d "_adt"    (Bool true);
-            Hashtbl.replace d "_type"   (String type_name);
-            Hashtbl.replace d "_ctor"   (String cn);
-            Hashtbl.replace d "_fields" (List ctor_args);
-            Dict d
-          end));
+          else
+            AdtValue {
+              av_type = type_name;
+              av_ctor = cn;
+              av_fields = Array.of_list ctor_args;
+            }));
       env_bind_v (cn ^ "?")
         (NativeFn (cn ^ "?", fun pargs ->
           (match pargs with
           | [v] ->
             (match v with
-            | Dict d -> Bool (Hashtbl.mem d "_adt" &&
-              (match Hashtbl.find_opt d "_ctor" with Some (String c) -> c = cn | _ -> false))
+            | AdtValue a -> Bool (a.av_ctor = cn)
             | _ -> Bool false)
           | _ -> Bool false)));
       List.iteri (fun idx fname ->
@@ -1092,13 +1166,10 @@ let sf_define_type args env_val =
             (match pargs with
             | [v] ->
               (match v with
-              | Dict d ->
-                (match Hashtbl.find_opt d "_fields" with
-                | Some (List fs) ->
-                  if idx < List.length fs then List.nth fs idx
-                  else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds"))
-                | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT")))
-              | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not a dict")))
+              | AdtValue a ->
+                if idx < Array.length a.av_fields then a.av_fields.(idx)
+                else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds"))
+              | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT")))
             | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": expected 1 arg")))))
       ) field_names
     | _ -> ())

hosts/ocaml/lib/sx_runtime.ml

@@ -6,11 +6,72 @@
 
 open Sx_types
 
-(** Call a registered primitive by name. *)
+(** Fast path equality — same as Sx_primitives.safe_eq for the common cases
+    that show up in hot dispatch (string vs string, etc). Falls through to
+    the registered "=" primitive for complex cases. *)
+let rec _fast_eq a b =
+  if a == b then true
+  else match a, b with
+  | String x, String y -> x = y
+  | Integer x, Integer y -> x = y
+  | Number x, Number y -> x = y
+  | Integer x, Number y -> float_of_int x = y
+  | Number x, Integer y -> x = float_of_int y
+  | Bool x, Bool y -> x = y
+  | Nil, Nil -> true
+  | Symbol x, Symbol y -> x = y
+  | Keyword x, Keyword y -> x = y
+  | List la, List lb ->
+    (try List.for_all2 _fast_eq la lb with Invalid_argument _ -> false)
+  | _ -> false
+
+(** Call a registered primitive by name.
+    Fast path for hot dispatch primitives ([=], [<], [>], [<=], [>=], [empty?],
+    [first], [rest], [len]) skips the Hashtbl lookup entirely — these are
+    called millions of times in the CEK [step_continue]/[step_eval] dispatch. *)
 let prim_call name args =
-  match Hashtbl.find_opt Sx_primitives.primitives name with
-  | Some f -> f args
-  | None -> raise (Eval_error ("Unknown primitive: " ^ name))
+  (* Hot path: most-frequently-called primitives by step_continue dispatch *)
+  match name, args with
+  | "=", [a; b] -> Bool (_fast_eq a b)
+  | "empty?", [List []] -> Bool true
+  | "empty?", [List _] -> Bool false
+  | "empty?", [ListRef { contents = [] }] -> Bool true
+  | "empty?", [ListRef _] -> Bool false
+  | "empty?", [Nil] -> Bool true
+  | "first", [List (x :: _)] -> x
+  | "first", [List []] -> Nil
+  | "first", [ListRef { contents = (x :: _) }] -> x
+  | "first", [ListRef _] -> Nil
+  | "first", [Nil] -> Nil
+  | "rest", [List (_ :: xs)] -> List xs
+  | "rest", [List []] -> List []
+  | "rest", [ListRef { contents = (_ :: xs) }] -> List xs
+  | "rest", [ListRef _] -> List []
+  | "rest", [Nil] -> List []
+  | "len", [List l] -> Integer (List.length l)
+  | "len", [ListRef r] -> Integer (List.length !r)
+  | "len", [String s] -> Integer (String.length s)
+  | "len", [Nil] -> Integer 0
+  | "<", [Integer x; Integer y] -> Bool (x < y)
+  | "<", [Number x; Number y] -> Bool (x < y)
+  | "<", [Integer x; Number y] -> Bool (float_of_int x < y)
+  | "<", [Number x; Integer y] -> Bool (x < float_of_int y)
+  | ">", [Integer x; Integer y] -> Bool (x > y)
+  | ">", [Number x; Number y] -> Bool (x > y)
+  | ">", [Integer x; Number y] -> Bool (float_of_int x > y)
+  | ">", [Number x; Integer y] -> Bool (x > float_of_int y)
+  | "<=", [Integer x; Integer y] -> Bool (x <= y)
+  | "<=", [Number x; Number y] -> Bool (x <= y)
+  | "<=", [Integer x; Number y] -> Bool (float_of_int x <= y)
+  | "<=", [Number x; Integer y] -> Bool (x <= float_of_int y)
+  | ">=", [Integer x; Integer y] -> Bool (x >= y)
+  | ">=", [Number x; Number y] -> Bool (x >= y)
+  | ">=", [Integer x; Number y] -> Bool (float_of_int x >= y)
+  | ">=", [Number x; Integer y] -> Bool (x >= float_of_int y)
+  | _ ->
+    match Hashtbl.find_opt Sx_primitives.primitives name with
+    | Some f -> f args
+    | None -> raise (Eval_error ("Unknown primitive: " ^ name))
 
 (** Convert any SX value to an OCaml string (internal). *)
 let value_to_str = function
@@ -209,6 +270,13 @@ let get_val container key =
      | _ -> Nil)
   | Dict d, String k -> dict_get d k
   | Dict d, Keyword k -> dict_get d k
+  | AdtValue a, String k | AdtValue a, Keyword k ->
+    (match k with
+     | "_adt"    -> Bool true
+     | "_type"   -> String a.av_type
+     | "_ctor"   -> String a.av_ctor
+     | "_fields" -> List (Array.to_list a.av_fields)
+     | _         -> Nil)
   | (List l | ListRef { contents = l }), Number n ->
     (try List.nth l (int_of_float n) with _ -> Nil)
   | (List l | ListRef { contents = l }), Integer n ->
@@ -404,6 +472,10 @@ let callcc_continuation_winders_len v = match v with
 let host_error msg =
   raise (Eval_error (value_to_str msg))
 
+let host_warn msg =
+  prerr_endline (value_to_str msg);
+  Nil
+
 let dynamic_wind_call before body after _env =
   ignore (sx_call before []);
   let result = sx_call body [] in
@@ -539,3 +611,4 @@ let jit_try_call f args =
       (match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; _jit_skip_sentinel)
     | _ -> incr _jit_skip; _jit_skip_sentinel
 
+

hosts/ocaml/lib/sx_types.ml

@@ -82,6 +82,16 @@ and value =
   | SxSet of (string, value) Hashtbl.t  (** Mutable set keyed by inspect(value). *)
   | SxRegexp of string * string * Re.re  (** Regexp: source, flags, compiled. *)
   | SxBytevector of bytes  (** Mutable bytevector — R7RS bytevector type. *)
+  | AdtValue of adt_value  (** Native algebraic data type instance — opaque sum type. *)
+
+(** Algebraic data type instance — produced by [define-type] constructors.
+    [av_type] is the type name (e.g. "Maybe"), [av_ctor] is the constructor
+    name (e.g. "Just"), [av_fields] are the positional field values. *)
+and adt_value = {
+  av_type   : string;
+  av_ctor   : string;
+  av_fields : value array;
+}
 
 (** String input port: source string + mutable cursor position. *)
 and sx_port_kind =
@@ -520,6 +530,7 @@ let type_of = function
   | SxSet _          -> "set"
   | SxRegexp _       -> "regexp"
   | SxBytevector _   -> "bytevector"
+  | AdtValue a       -> a.av_type
 
 let is_nil = function Nil -> true | _ -> false
 let is_lambda = function Lambda _ -> true | _ -> false
@@ -806,14 +817,15 @@ let dict_vals (d : dict) =
 
 (** {1 Value display} *)
 
-let rec inspect = function
-  | Nil -> "nil"
-  | Bool true -> "true"
-  | Bool false -> "false"
-  | Integer n -> string_of_int n
-  | Number n -> format_number n
+(* Single shared buffer for the entire inspect recursion — eliminates
+   the per-level [String.concat (List.map inspect ...)] allocation. *)
+let rec inspect_into buf = function
+  | Nil -> Buffer.add_string buf "nil"
+  | Bool true -> Buffer.add_string buf "true"
+  | Bool false -> Buffer.add_string buf "false"
+  | Integer n -> Buffer.add_string buf (string_of_int n)
+  | Number n -> Buffer.add_string buf (format_number n)
   | String s ->
-    let buf = Buffer.create (String.length s + 2) in
     Buffer.add_char buf '"';
     String.iter (function
       | '"'  -> Buffer.add_string buf "\\\""
@@ -822,66 +834,129 @@ let rec inspect = function
       | '\r' -> Buffer.add_string buf "\\r"
       | '\t' -> Buffer.add_string buf "\\t"
       | c    -> Buffer.add_char buf c) s;
-    Buffer.add_char buf '"';
-    Buffer.contents buf
-  | Symbol s -> s
-  | Keyword k -> ":" ^ k
+    Buffer.add_char buf '"'
+  | Symbol s -> Buffer.add_string buf s
+  | Keyword k -> Buffer.add_char buf ':'; Buffer.add_string buf k
   | List items | ListRef { contents = items } ->
-    "(" ^ String.concat " " (List.map inspect items) ^ ")"
+    Buffer.add_char buf '(';
+    (match items with
+     | [] -> ()
+     | x :: rest ->
+       inspect_into buf x;
+       List.iter (fun v -> Buffer.add_char buf ' '; inspect_into buf v) rest);
+    Buffer.add_char buf ')'
   | Dict d ->
-    let pairs = Hashtbl.fold (fun k v acc ->
-      (Printf.sprintf ":%s %s" k (inspect v)) :: acc) d [] in
-    "{" ^ String.concat " " pairs ^ "}"
+    Buffer.add_char buf '{';
+    let first = ref true in
+    Hashtbl.iter (fun k v ->
+      if !first then first := false else Buffer.add_char buf ' ';
+      Buffer.add_char buf ':'; Buffer.add_string buf k;
+      Buffer.add_char buf ' '; inspect_into buf v) d;
+    Buffer.add_char buf '}'
   | Lambda l ->
     let tag = match l.l_name with Some n -> n | None -> "lambda" in
-    Printf.sprintf "<%s(%s)>" tag (String.concat ", " l.l_params)
+    Buffer.add_char buf '<'; Buffer.add_string buf tag;
+    Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " l.l_params);
+    Buffer.add_string buf ")>"
   | Component c ->
-    Printf.sprintf "<Component ~%s(%s)>" c.c_name (String.concat ", " c.c_params)
+    Buffer.add_string buf "<Component ~"; Buffer.add_string buf c.c_name;
+    Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " c.c_params);
+    Buffer.add_string buf ")>"
   | Island i ->
-    Printf.sprintf "<Island ~%s(%s)>" i.i_name (String.concat ", " i.i_params)
+    Buffer.add_string buf "<Island ~"; Buffer.add_string buf i.i_name;
+    Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " i.i_params);
+    Buffer.add_string buf ")>"
   | Macro m ->
     let tag = match m.m_name with Some n -> n | None -> "macro" in
-    Printf.sprintf "<%s(%s)>" tag (String.concat ", " m.m_params)
-  | Thunk _ -> "<thunk>"
-  | Continuation (_, _) -> "<continuation>"
-  | CallccContinuation (_, _) -> "<callcc-continuation>"
-  | NativeFn (name, _) -> Printf.sprintf "<native:%s>" name
-  | Signal _ -> "<signal>"
-  | RawHTML s -> Printf.sprintf "\"<raw-html:%d>\"" (String.length s)
-  | Spread _ -> "<spread>"
-  | SxExpr s -> Printf.sprintf "\"<sx-expr:%d>\"" (String.length s)
-  | Env _ -> "<env>"
-  | CekState _ -> "<cek-state>"
-  | CekFrame f -> Printf.sprintf "<frame:%s>" f.cf_type
-  | VmClosure cl -> Printf.sprintf "<vm:%s>" (match cl.vm_name with Some n -> n | None -> "anon")
+    Buffer.add_char buf '<'; Buffer.add_string buf tag;
+    Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " m.m_params);
+    Buffer.add_string buf ")>"
+  | Thunk _ -> Buffer.add_string buf "<thunk>"
+  | Continuation (_, _) -> Buffer.add_string buf "<continuation>"
+  | CallccContinuation (_, _) -> Buffer.add_string buf "<callcc-continuation>"
+  | NativeFn (name, _) ->
+    Buffer.add_string buf "<native:"; Buffer.add_string buf name; Buffer.add_char buf '>'
+  | Signal _ -> Buffer.add_string buf "<signal>"
+  | RawHTML s ->
+    Buffer.add_string buf "\"<raw-html:";
+    Buffer.add_string buf (string_of_int (String.length s));
+    Buffer.add_string buf ">\""
+  | Spread _ -> Buffer.add_string buf "<spread>"
+  | SxExpr s ->
+    Buffer.add_string buf "\"<sx-expr:";
+    Buffer.add_string buf (string_of_int (String.length s));
+    Buffer.add_string buf ">\""
+  | Env _ -> Buffer.add_string buf "<env>"
+  | CekState _ -> Buffer.add_string buf "<cek-state>"
+  | CekFrame f ->
+    Buffer.add_string buf "<frame:"; Buffer.add_string buf f.cf_type; Buffer.add_char buf '>'
+  | VmClosure cl ->
+    Buffer.add_string buf "<vm:";
+    Buffer.add_string buf (match cl.vm_name with Some n -> n | None -> "anon");
+    Buffer.add_char buf '>'
   | Record r ->
-    let fields = Array.to_list (Array.mapi (fun i v ->
-      Printf.sprintf "%s=%s" r.r_type.rt_fields.(i) (inspect v)
-    ) r.r_fields) in
-    Printf.sprintf "<record:%s %s>" r.r_type.rt_name (String.concat " " fields)
-  | Parameter p -> Printf.sprintf "<parameter:%s>" p.pm_uid
+    Buffer.add_string buf "<record:"; Buffer.add_string buf r.r_type.rt_name;
+    Array.iteri (fun i v ->
+      Buffer.add_char buf ' ';
+      Buffer.add_string buf r.r_type.rt_fields.(i);
+      Buffer.add_char buf '=';
+      inspect_into buf v) r.r_fields;
+    Buffer.add_char buf '>'
+  | Parameter p ->
+    Buffer.add_string buf "<parameter:"; Buffer.add_string buf p.pm_uid; Buffer.add_char buf '>'
   | Vector arr ->
-    let elts = Array.to_list (Array.map inspect arr) in
-    Printf.sprintf "#(%s)" (String.concat " " elts)
-  | VmFrame f -> Printf.sprintf "<vm-frame:ip=%d base=%d>" f.vf_ip f.vf_base
-  | VmMachine m -> Printf.sprintf "<vm-machine:sp=%d frames=%d>" m.vm_sp (List.length m.vm_frames)
-  | StringBuffer buf -> Printf.sprintf "<string-buffer:%d>" (Buffer.length buf)
-  | HashTable ht -> Printf.sprintf "<hash-table:%d>" (Hashtbl.length ht)
+    Buffer.add_string buf "#(";
+    Array.iteri (fun i v ->
+      if i > 0 then Buffer.add_char buf ' ';
+      inspect_into buf v) arr;
+    Buffer.add_char buf ')'
+  | VmFrame f ->
+    Buffer.add_string buf (Printf.sprintf "<vm-frame:ip=%d base=%d>" f.vf_ip f.vf_base)
+  | VmMachine m ->
+    Buffer.add_string buf (Printf.sprintf "<vm-machine:sp=%d frames=%d>" m.vm_sp (List.length m.vm_frames))
+  | StringBuffer b ->
+    Buffer.add_string buf (Printf.sprintf "<string-buffer:%d>" (Buffer.length b))
+  | HashTable ht ->
+    Buffer.add_string buf (Printf.sprintf "<hash-table:%d>" (Hashtbl.length ht))
   | Char n ->
-    let name = match n with
-      | 32 -> "space" | 10 -> "newline" | 9 -> "tab"
-      | 13 -> "return" | 0 -> "nul" | 27 -> "escape"
-      | 127 -> "delete" | 8 -> "backspace"
-      | _ -> let buf = Buffer.create 1 in
-             Buffer.add_utf_8_uchar buf (Uchar.of_int n);
-             Buffer.contents buf
-    in "#\\" ^ name
-  | Eof -> "#!eof"
+    Buffer.add_string buf "#\\";
+    (match n with
+     | 32 -> Buffer.add_string buf "space"
+     | 10 -> Buffer.add_string buf "newline"
+     | 9 -> Buffer.add_string buf "tab"
+     | 13 -> Buffer.add_string buf "return"
+     | 0 -> Buffer.add_string buf "nul"
+     | 27 -> Buffer.add_string buf "escape"
+     | 127 -> Buffer.add_string buf "delete"
+     | 8 -> Buffer.add_string buf "backspace"
+     | _ -> Buffer.add_utf_8_uchar buf (Uchar.of_int n))
+  | Eof -> Buffer.add_string buf "#!eof"
   | Port { sp_kind = PortInput (_, pos); sp_closed } ->
-    Printf.sprintf "<input-port:pos=%d%s>" !pos (if sp_closed then ":closed" else "")
-  | Port { sp_kind = PortOutput buf; sp_closed } ->
-    Printf.sprintf "<output-port:len=%d%s>" (Buffer.length buf) (if sp_closed then ":closed" else "")
-  | Rational (n, d) -> Printf.sprintf "%d/%d" n d
-  | SxSet ht -> Printf.sprintf "<set:%d>" (Hashtbl.length ht)
-  | SxRegexp (src, flags, _) -> Printf.sprintf "#/%s/%s" src flags
-  | SxBytevector b -> Printf.sprintf "#u8(%s)" (String.concat " " (List.init (Bytes.length b) (fun i -> string_of_int (Char.code (Bytes.get b i)))))
+    Buffer.add_string buf (Printf.sprintf "<input-port:pos=%d%s>" !pos (if sp_closed then ":closed" else ""))
+  | Port { sp_kind = PortOutput b; sp_closed } ->
+    Buffer.add_string buf (Printf.sprintf "<output-port:len=%d%s>" (Buffer.length b) (if sp_closed then ":closed" else ""))
+  | Rational (n, d) ->
+    Buffer.add_string buf (string_of_int n); Buffer.add_char buf '/';
+    Buffer.add_string buf (string_of_int d)
+  | SxSet ht ->
+    Buffer.add_string buf (Printf.sprintf "<set:%d>" (Hashtbl.length ht))
+  | SxRegexp (src, flags, _) ->
+    Buffer.add_string buf "#/"; Buffer.add_string buf src;
+    Buffer.add_char buf '/'; Buffer.add_string buf flags
+  | SxBytevector b ->
+    Buffer.add_string buf "#u8(";
+    let n = Bytes.length b in
+    for i = 0 to n - 1 do
+      if i > 0 then Buffer.add_char buf ' ';
+      Buffer.add_string buf (string_of_int (Char.code (Bytes.get b i)))
+    done;
+    Buffer.add_char buf ')'
+  | AdtValue a ->
+    Buffer.add_char buf '('; Buffer.add_string buf a.av_ctor;
+    Array.iter (fun v -> Buffer.add_char buf ' '; inspect_into buf v) a.av_fields;
+    Buffer.add_char buf ')'
+
+let inspect v =
+  let buf = Buffer.create 64 in
+  inspect_into buf v;
+  Buffer.contents buf

hosts/ocaml/lib/sx_vm.ml

@@ -327,7 +327,18 @@ and call_closure_reuse cl args =
        vm.sp <- saved_sp;
        raise e);
     vm.frames <- saved_frames;
-    pop vm
+    (* Snapshot/restore sp around the popped result.
+       OP_RETURN normally leaves sp = saved_sp + 1, but the bytecode-exhausted
+       path (or a callee that returns a closure whose own RETURN leaves extra
+       stack residue) can leave sp inconsistent. Read the result at the
+       expected slot and reset sp explicitly so the parent frame's
+       intermediate values are not corrupted. *)
+    let result =
+      if vm.sp > saved_sp then vm.stack.(vm.sp - 1)
+      else Nil
+    in
+    vm.sp <- saved_sp;
+    result
   | None ->
     call_closure cl args cl.vm_env_ref
 
@@ -631,7 +642,9 @@ and run vm =
           (* Read upvalue descriptors from bytecode *)
           let uv_count = match code_val with
             | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
-                | Some (Number n) -> int_of_float n | _ -> 0)
+                | Some (Integer n) -> n
+                | Some (Number n) -> int_of_float n
+                | _ -> 0)
             | _ -> 0
           in
           let upvalues = Array.init uv_count (fun _ ->
@@ -731,38 +744,57 @@ and run vm =
         | 160 (* OP_ADD *) ->
           let b = pop vm and a = pop vm in
           push vm (match a, b with
+            | Integer x, Integer y -> Integer (x + y)
             | Number x, Number y -> Number (x +. y)
+            | Integer x, Number y -> Number (float_of_int x +. y)
+            | Number x, Integer y -> Number (x +. float_of_int y)
             | _ -> (Hashtbl.find Sx_primitives.primitives "+") [a; b])
         | 161 (* OP_SUB *) ->
           let b = pop vm and a = pop vm in
           push vm (match a, b with
+            | Integer x, Integer y -> Integer (x - y)
             | Number x, Number y -> Number (x -. y)
+            | Integer x, Number y -> Number (float_of_int x -. y)
+            | Number x, Integer y -> Number (x -. float_of_int y)
             | _ -> (Hashtbl.find Sx_primitives.primitives "-") [a; b])
         | 162 (* OP_MUL *) ->
           let b = pop vm and a = pop vm in
           push vm (match a, b with
+            | Integer x, Integer y -> Integer (x * y)
             | Number x, Number y -> Number (x *. y)
+            | Integer x, Number y -> Number (float_of_int x *. y)
+            | Number x, Integer y -> Number (x *. float_of_int y)
             | _ -> (Hashtbl.find Sx_primitives.primitives "*") [a; b])
         | 163 (* OP_DIV *) ->
           let b = pop vm and a = pop vm in
           push vm (match a, b with
+            | Integer x, Integer y when y <> 0 && x mod y = 0 -> Integer (x / y)
+            | Integer x, Integer y -> Number (float_of_int x /. float_of_int y)
             | Number x, Number y -> Number (x /. y)
+            | Integer x, Number y -> Number (float_of_int x /. y)
+            | Number x, Integer y -> Number (x /. float_of_int y)
             | _ -> (Hashtbl.find Sx_primitives.primitives "/") [a; b])
         | 164 (* OP_EQ *) ->
           let b = pop vm and a = pop vm in
-          push vm ((Hashtbl.find Sx_primitives.primitives "=") [a; b])
+          push vm (Bool (Sx_runtime._fast_eq a b))
         | 165 (* OP_LT *) ->
           let b = pop vm and a = pop vm in
           push vm (match a, b with
+            | Integer x, Integer y -> Bool (x < y)
             | Number x, Number y -> Bool (x < y)
+            | Integer x, Number y -> Bool (float_of_int x < y)
+            | Number x, Integer y -> Bool (x < float_of_int y)
             | String x, String y -> Bool (x < y)
-            | _ -> (Hashtbl.find Sx_primitives.primitives "<") [a; b])
+            | _ -> Sx_runtime.prim_call "<" [a; b])
         | 166 (* OP_GT *) ->
           let b = pop vm and a = pop vm in
           push vm (match a, b with
+            | Integer x, Integer y -> Bool (x > y)
             | Number x, Number y -> Bool (x > y)
+            | Integer x, Number y -> Bool (float_of_int x > y)
+            | Number x, Integer y -> Bool (x > float_of_int y)
             | String x, String y -> Bool (x > y)
-            | _ -> (Hashtbl.find Sx_primitives.primitives ">") [a; b])
+            | _ -> Sx_runtime.prim_call ">" [a; b])
         | 167 (* OP_NOT *) ->
           let v = pop vm in
           push vm (Bool (not (sx_truthy v)))
@@ -885,9 +917,17 @@ let resume_vm vm result =
   let rec restore_reuse pending =
     match pending with
     | [] -> ()
-    | (saved_frames, _saved_sp) :: rest ->
+    | (saved_frames, saved_sp) :: rest ->
       let callback_result = pop vm in
       vm.frames <- saved_frames;
+      (* Restore sp to the value captured before the suspended callee was
+         pushed. The callee's locals/temps may still be on the stack above
+         saved_sp; without this reset, subsequent LOCAL_GET/SET in the
+         caller frame (e.g. letrec sibling bindings waiting on the call)
+         see stale callee data instead of their own slots. Mirrors the
+         OP_RETURN+sp-reset semantics that sync `call_closure_reuse`
+         relies on for clean caller-frame state. *)
+      if saved_sp < vm.sp then vm.sp <- saved_sp;
       push vm callback_result;
       (try
         run vm;
@@ -1269,7 +1309,9 @@ let trace_run src globals =
             let code_val2 = frame.closure.vm_code.vc_constants.(idx) in
             let uv_count = match code_val2 with
               | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
-                  | Some (Number n) -> int_of_float n | _ -> 0)
+                  | Some (Integer n) -> n
+                  | Some (Number n) -> int_of_float n
+                  | _ -> 0)
               | _ -> 0 in
             let upvalues = Array.init uv_count (fun _ ->
               let is_local = read_u8 frame in
@@ -1390,7 +1432,9 @@ let disassemble (code : vm_code) =
         if op = 51 && idx < Array.length consts then begin
           let uv_count = match consts.(idx) with
             | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
-                | Some (Number n) -> int_of_float n | _ -> 0)
+                | Some (Integer n) -> n
+                | Some (Number n) -> int_of_float n
+                | _ -> 0)
             | _ -> 0 in
           ip := !ip + uv_count * 2
         end

hosts/ocaml/lib/sx_vm_ref.ml

@@ -270,7 +270,9 @@ let vm_create_closure vm_val frame_val code_val =
   let f = unwrap_frame frame_val in
   let uv_count = match code_val with
     | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
-        | Some (Number n) -> int_of_float n | _ -> 0)
+        | Some (Integer n) -> n
+        | Some (Number n) -> int_of_float n
+        | _ -> 0)
     | _ -> 0
   in
   let upvalues = Array.init uv_count (fun _ ->

hosts/ocaml/sx_vm_ref.ml

@@ -265,7 +265,9 @@ let vm_create_closure vm_val frame_val code_val =
   let f = unwrap_frame frame_val in
   let uv_count = match code_val with
     | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
-        | Some (Number n) -> int_of_float n | _ -> 0)
+        | Some (Integer n) -> n
+        | Some (Number n) -> int_of_float n
+        | _ -> 0)
     | _ -> 0
   in
   let upvalues = Array.init uv_count (fun _ ->

lib/apl/parser.sx

@@ -416,20 +416,10 @@
                 ((apl-parse-op-glyph? tv)
                   (if
                     (or (= tv "/") (= tv "⌿") (= tv "\\") (= tv "⍀"))
-                    (let
-                      ((next-i (+ i 1)))
-                      (let
-                        ((next-tok (if (< next-i n) (nth tokens next-i) nil)))
-                        (let
-                          ((mod (if (and next-tok (= (tok-type next-tok) :glyph) (or (= (get next-tok :value) "⍨") (= (get next-tok :value) "¨"))) (get next-tok :value) nil))
-                            (base-fn-node (list :fn-glyph tv)))
-                          (let
-                            ((node (if mod (list :derived-fn mod base-fn-node) base-fn-node))
-                              (advance (if mod 2 1)))
-                            (collect-segments-loop
-                              tokens
-                              (+ i advance)
-                              (append acc {:kind "fn" :node node}))))))
+                    (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

@@ -65,30 +65,10 @@
             (get a :shape)
             (map (fn (x) (f x sv)) (get a :ravel)))))
       (else
-        (let
-          ((a-shape (get a :shape)) (b-shape (get b :shape)))
-          (cond
-            ((equal? a-shape b-shape)
-              (make-array a-shape (map f (get a :ravel) (get b :ravel))))
-            ((and (= (len a-shape) 1) (> (len b-shape) 1))
-              (make-array
-                (append a-shape b-shape)
-                (flatten
-                  (map
-                    (fn
-                      (x)
-                      (get (broadcast-dyadic f (apl-scalar x) b) :ravel))
-                    (get a :ravel)))))
-            ((and (= (len b-shape) 1) (> (len a-shape) 1))
-              (make-array
-                (append a-shape b-shape)
-                (flatten
-                  (map
-                    (fn
-                      (acell)
-                      (get (broadcast-dyadic f (apl-scalar acell) b) :ravel))
-                    (get a :ravel)))))
-            (else (error "length error: shape mismatch"))))))))
+        (if
+          (equal? (get a :shape) (get b :shape))
+          (make-array (get a :shape) (map f (get a :ravel) (get b :ravel)))
+          (error "length error: shape mismatch"))))))
 
 ; ============================================================
 ; Arithmetic primitives
@@ -847,106 +827,6 @@
               ((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-where
-  (fn
-    (arr)
-    (let
-      ((ravel (get arr :ravel)) (io (disclose (apl-quad-io))))
-      (let
-        ((indices (filter (fn (i) (not (= (nth ravel i) 0))) (range 0 (len ravel)))))
-        (apl-vector (map (fn (i) (+ i io)) indices))))))
-
-(define
-  apl-interval-index
-  (fn
-    (breaks vals)
-    (let
-      ((b-ravel (get breaks :ravel))
-        (v-ravel
-          (if (scalar? vals) (list (disclose vals)) (get vals :ravel))))
-      (let
-        ((result (map (fn (y) (len (filter (fn (b) (<= b y)) b-ravel))) v-ravel)))
-        (if
-          (scalar? vals)
-          (apl-scalar (first result))
-          (make-array (get vals :shape) result))))))
-
-(define
-  apl-unique
-  (fn
-    (arr)
-    (let
-      ((ravel (if (scalar? arr) (list (disclose arr)) (get arr :ravel))))
-      (let
-        ((dedup (reduce (fn (acc x) (if (index-of acc x) acc (append acc (list x)))) (list) ravel)))
-        (apl-vector dedup)))))
-
-(define
-  apl-union
-  (fn
-    (a b)
-    (let
-      ((a-ravel (if (scalar? a) (list (disclose a)) (get a :ravel)))
-        (b-ravel (if (scalar? b) (list (disclose b)) (get b :ravel))))
-      (let
-        ((a-dedup (reduce (fn (acc x) (if (index-of acc x) acc (append acc (list x)))) (list) a-ravel)))
-        (let
-          ((b-extra (filter (fn (x) (not (index-of a-dedup x))) b-ravel)))
-          (let
-            ((b-extra-dedup (reduce (fn (acc x) (if (index-of acc x) acc (append acc (list x)))) (list) b-extra)))
-            (apl-vector (append a-dedup b-extra-dedup))))))))
-
-(define
-  apl-intersect
-  (fn
-    (a b)
-    (let
-      ((a-ravel (if (scalar? a) (list (disclose a)) (get a :ravel)))
-        (b-ravel (if (scalar? b) (list (disclose b)) (get b :ravel))))
-      (apl-vector (filter (fn (x) (index-of b-ravel x)) a-ravel)))))
-
-(define
-  apl-decode
-  (fn
-    (base digits)
-    (let
-      ((d-ravel (if (scalar? digits) (list (disclose digits)) (get digits :ravel))))
-      (let
-        ((d-len (len d-ravel)))
-        (let
-          ((b-ravel (if (scalar? base) (let ((b (disclose base))) (map (fn (i) b) (range 0 d-len))) (get base :ravel))))
-          (let
-            ((result (reduce (fn (acc i) (if (= i 0) (nth d-ravel 0) (+ (* acc (nth b-ravel i)) (nth d-ravel i)))) 0 (range 0 d-len))))
-            (apl-scalar result)))))))
-
-(define
-  apl-encode
-  (fn
-    (base val)
-    (let
-      ((b-ravel (if (scalar? base) (list (disclose base)) (get base :ravel)))
-        (n (if (scalar? val) (disclose val) (first (get val :ravel)))))
-      (let
-        ((b-len (len b-ravel)))
-        (let
-          ((result (reduce (fn (acc-and-n i) (let ((acc (first acc-and-n)) (rem (nth acc-and-n 1))) (let ((b (nth b-ravel (- (- b-len 1) i)))) (if (= b 0) (list (cons rem acc) 0) (list (cons (modulo rem b) acc) (floor (/ rem b))))))) (list (list) n) (range 0 b-len))))
-          (apl-vector (first result)))))))
-
-(define
-  apl-partition
-  (fn
-    (mask val)
-    (let
-      ((m-ravel (if (scalar? mask) (list (disclose mask)) (get mask :ravel)))
-        (v-ravel
-          (if (scalar? val) (list (disclose val)) (get val :ravel))))
-      (let
-        ((n (len m-ravel)))
-        (let
-          ((built (reduce (fn (acc-and-prev i) (let ((acc (first acc-and-prev)) (prev (nth acc-and-prev 1))) (let ((mi (nth m-ravel i)) (vi (nth v-ravel i))) (cond ((= mi 0) (list acc 0)) ((> mi prev) (list (append acc (list (list vi))) mi)) (else (let ((idx (- (len acc) 1))) (list (append (slice acc 0 idx) (list (append (nth acc idx) (list vi)))) mi))))))) (list (list) 0) (range 0 n))))
-          (apl-vector (map (fn (part) (apl-vector part)) (first built))))))))
-
 (define
   apl-primes
   (fn
@@ -1194,9 +1074,11 @@
             (if
               (= n 0)
               (apl-scalar 0)
-              (let
-                ((rr (reduce (fn (a b) (let ((wa (if (= (type-of a) "dict") a (apl-scalar a))) (wb (if (= (type-of b) "dict") b (apl-scalar b)))) (let ((r (f wa wb))) (if (scalar? r) (disclose r) r)))) (first ravel) (rest ravel))))
-                (if (= (type-of rr) "dict") rr (apl-scalar rr)))))
+              (apl-scalar
+                (reduce
+                  (fn (a b) (disclose (f (apl-scalar a) (apl-scalar b))))
+                  (first ravel)
+                  (rest ravel)))))
           (let
             ((last-dim (last shape))
               (pre-shape (take shape (- (len shape) 1)))
@@ -1218,13 +1100,7 @@
                       (reduce
                         (fn
                           (a b)
-                          (let
-                            ((wa (if (= (type-of a) "dict") a (apl-scalar a)))
-                              (wb
-                                (if (= (type-of b) "dict") b (apl-scalar b))))
-                            (let
-                              ((r (f wa wb)))
-                              (if (scalar? r) (disclose r) r))))
+                          (disclose (f (apl-scalar a) (apl-scalar b))))
                         (first elems)
                         (rest elems)))))
                 (range 0 pre-size)))))))))
@@ -1365,29 +1241,13 @@
     (cond
       ((and (scalar? a) (scalar? b)) (apl-scalar (disclose (f a b))))
       ((scalar? a)
-        (let
-          ((a-eff (let ((d (disclose a))) (if (= (type-of d) "dict") d a))))
-          (make-array
-            (get b :shape)
-            (map
-              (fn
-                (x)
-                (let
-                  ((r (f a-eff (apl-scalar x))))
-                  (if (scalar? r) (disclose r) r)))
-              (get b :ravel)))))
+        (make-array
+          (get b :shape)
+          (map (fn (x) (disclose (f a (apl-scalar x)))) (get b :ravel))))
       ((scalar? b)
-        (let
-          ((b-eff (let ((d (disclose b))) (if (= (type-of d) "dict") d b))))
-          (make-array
-            (get a :shape)
-            (map
-              (fn
-                (x)
-                (let
-                  ((r (f (apl-scalar x) b-eff)))
-                  (if (scalar? r) (disclose r) r)))
-              (get a :ravel)))))
+        (make-array
+          (get a :shape)
+          (map (fn (x) (disclose (f (apl-scalar x) b))) (get a :ravel))))
       (else
         (if
           (equal? (get a :shape) (get b :shape))
@@ -1408,22 +1268,16 @@
         (b-shape (get b :shape))
         (a-ravel (get a :ravel))
         (b-ravel (get b :ravel)))
-      (let
-        ((wrap (fn (x) (if (= (type-of x) "dict") x (apl-scalar x)))))
-        (make-array
-          (append a-shape b-shape)
-          (flatten
-            (map
-              (fn
-                (x)
-                (map
-                  (fn
-                    (y)
-                    (let
-                      ((r (f (wrap x) (wrap y))))
-                      (if (scalar? r) (disclose r) r)))
-                  b-ravel))
-              a-ravel)))))))
+      (make-array
+        (append a-shape b-shape)
+        (flatten
+          (map
+            (fn
+              (x)
+              (map
+                (fn (y) (disclose (f (apl-scalar x) (apl-scalar y))))
+                b-ravel))
+            a-ravel))))))
 
 (define
   apl-inner
@@ -1447,12 +1301,25 @@
               ((a-pre-size (reduce * 1 a-pre))
                 (b-post-size (reduce * 1 b-post))
                 (new-shape (append a-pre b-post)))
-              (let
-                ((result (make-array new-shape (flatten (map (fn (i) (map (fn (j) (let ((pairs (map (fn (k) (let ((a-elem (nth a-ravel (+ (* i inner-dim) k))) (b-elem (nth b-ravel (+ (* k b-post-size) j)))) (let ((a-cell (if (= (type-of a-elem) "dict") (nth (get a-elem :ravel) j) a-elem)) (b-cell (if (= (type-of b-elem) "dict") (nth (get b-elem :ravel) 0) b-elem))) (disclose (g (apl-scalar a-cell) (apl-scalar b-cell)))))) (range 0 inner-dim)))) (reduce (fn (x y) (let ((wx (if (= (type-of x) "dict") x (apl-scalar x))) (wy (if (= (type-of y) "dict") y (apl-scalar y)))) (let ((r (f wx wy))) (if (scalar? r) (disclose r) r)))) (first pairs) (rest pairs)))) (range 0 b-post-size))) (range 0 a-pre-size))))))
-                (if
-                  (some (fn (x) (= (type-of x) "dict")) a-ravel)
-                  (enclose result)
-                  result)))))))))
+              (make-array
+                new-shape
+                (flatten
+                  (map
+                    (fn
+                      (i)
+                      (map
+                        (fn
+                          (j)
+                          (let
+                            ((pairs (map (fn (k) (disclose (g (apl-scalar (nth a-ravel (+ (* i inner-dim) k))) (apl-scalar (nth b-ravel (+ (* k b-post-size) j)))))) (range 0 inner-dim))))
+                            (reduce
+                              (fn
+                                (x y)
+                                (disclose (f (apl-scalar x) (apl-scalar y))))
+                              (first pairs)
+                              (rest pairs))))
+                        (range 0 b-post-size)))
+                    (range 0 a-pre-size)))))))))))
 
 (define apl-commute (fn (f x) (f x x)))
 

lib/apl/tests/pipeline.sx

@@ -455,233 +455,3 @@
   (list 1 2 3))
 
 (apl-test "⍕ 42 → \"42\" (alias for ⎕FMT)" (apl-run "⍕ 42") "42")
-
-(begin
-  (apl-test
-    "⍸ where: indices of truthy cells"
-    (mkrv (apl-run "⍸ 0 1 0 1 1"))
-    (list 2 4 5))
-  (apl-test
-    "⍸ where: leading truthy"
-    (mkrv (apl-run "⍸ 1 0 0 1 1"))
-    (list 1 4 5))
-  (apl-test
-    "⍸ where: all-zero → empty"
-    (mkrv (apl-run "⍸ 0 0 0"))
-    (list))
-  (apl-test
-    "⍸ where: all-truthy"
-    (mkrv (apl-run "⍸ 1 1 1"))
-    (list 1 2 3))
-  (apl-test
-    "⍸ where: ⎕IO=1 (1-based)"
-    (mkrv (apl-run "⍸ (⍳5)=3"))
-    (list 3))
-  (apl-test
-    "⍸ interval-index: 2 4 6 ⍸ 5 → 2"
-    (mkrv (apl-run "2 4 6 ⍸ 5"))
-    (list 2))
-  (apl-test
-    "⍸ interval-index: 2 4 6 ⍸ 1 3 5 6 7 → 0 1 2 3 3"
-    (mkrv (apl-run "2 4 6 ⍸ 1 3 5 6 7"))
-    (list 0 1 2 3 3))
-  (apl-test
-    "⍸ interval-index: ⍳5 ⍸ 3 → 3"
-    (mkrv (apl-run "(⍳5) ⍸ 3"))
-    (list 3))
-  (apl-test
-    "⍸ interval-index: y below all → 0"
-    (mkrv (apl-run "10 20 30 ⍸ 5"))
-    (list 0))
-  (apl-test
-    "⍸ interval-index: y above all → len breaks"
-    (mkrv (apl-run "10 20 30 ⍸ 100"))
-    (list 3)))
-
-(begin
-  (apl-test
-    "∪ unique: dedup keeps first-occurrence order"
-    (mkrv (apl-run "∪ 1 2 1 3 2 1 4"))
-    (list 1 2 3 4))
-  (apl-test
-    "∪ unique: already-unique unchanged"
-    (mkrv (apl-run "∪ 5 4 3 2 1"))
-    (list 5 4 3 2 1))
-  (apl-test "∪ unique: scalar" (mkrv (apl-run "∪ 7")) (list 7))
-  (apl-test
-    "∪ unique: string mississippi → misp"
-    (mkrv (apl-run "∪ 'mississippi'"))
-    (list "m" "i" "s" "p"))
-  (apl-test
-    "∪ union: 1 2 3 ∪ 3 4 5 → 1 2 3 4 5"
-    (mkrv (apl-run "1 2 3 ∪ 3 4 5"))
-    (list 1 2 3 4 5))
-  (apl-test
-    "∪ union: dedups left side too"
-    (mkrv (apl-run "1 2 1 ∪ 1 3 2"))
-    (list 1 2 3))
-  (apl-test
-    "∪ union: disjoint → catenated"
-    (mkrv (apl-run "1 2 ∪ 3 4"))
-    (list 1 2 3 4))
-  (apl-test
-    "∩ intersection: 1 2 3 4 ∩ 2 4 6 → 2 4"
-    (mkrv (apl-run "1 2 3 4 ∩ 2 4 6"))
-    (list 2 4))
-  (apl-test
-    "∩ intersection: disjoint → empty"
-    (mkrv (apl-run "1 2 3 ∩ 4 5 6"))
-    (list))
-  (apl-test
-    "∩ intersection: preserves left order"
-    (mkrv (apl-run "(⍳5) ∩ 5 3 1"))
-    (list 1 3 5))
-  (apl-test
-    "∩ intersection: identical"
-    (mkrv (apl-run "1 2 3 ∩ 1 2 3"))
-    (list 1 2 3))
-  (apl-test
-    "∪/∩ identity: A ∪ A = ∪A"
-    (mkrv (apl-run "1 2 1 ∪ 1 2 1"))
-    (list 1 2)))
-
-(begin
-  (apl-test
-    "⊥ decode: 2 2 2 ⊥ 1 0 1 → 5"
-    (mkrv (apl-run "2 2 2 ⊥ 1 0 1"))
-    (list 5))
-  (apl-test
-    "⊥ decode: 10 10 10 ⊥ 1 2 3 → 123"
-    (mkrv (apl-run "10 10 10 ⊥ 1 2 3"))
-    (list 123))
-  (apl-test
-    "⊥ decode: 24 60 60 ⊥ 2 3 4 → 7384 (mixed-radix HMS)"
-    (mkrv (apl-run "24 60 60 ⊥ 2 3 4"))
-    (list 7384))
-  (apl-test
-    "⊥ decode: scalar base 2 ⊥ 1 0 1 0 → 10"
-    (mkrv (apl-run "2 ⊥ 1 0 1 0"))
-    (list 10))
-  (apl-test
-    "⊥ decode: 16 16 ⊥ 15 15 → 255"
-    (mkrv (apl-run "16 16 ⊥ 15 15"))
-    (list 255))
-  (apl-test
-    "⊤ encode: 2 2 2 ⊤ 5 → 1 0 1"
-    (mkrv (apl-run "2 2 2 ⊤ 5"))
-    (list 1 0 1))
-  (apl-test
-    "⊤ encode: 24 60 60 ⊤ 7384 → 2 3 4 (HMS)"
-    (mkrv (apl-run "24 60 60 ⊤ 7384"))
-    (list 2 3 4))
-  (apl-test
-    "⊤ encode: 2 2 2 2 ⊤ 13 → 1 1 0 1"
-    (mkrv (apl-run "2 2 2 2 ⊤ 13"))
-    (list 1 1 0 1))
-  (apl-test
-    "⊤ encode: 10 10 ⊤ 42 → 4 2"
-    (mkrv (apl-run "10 10 ⊤ 42"))
-    (list 4 2))
-  (apl-test
-    "⊤ encode: round-trip B⊥(B⊤N) = N"
-    (mkrv (apl-run "24 60 60 ⊥ 24 60 60 ⊤ 7384"))
-    (list 7384))
-  (apl-test
-    "⊥ decode: round-trip B⊤(B⊥V) = V"
-    (mkrv (apl-run "2 2 2 ⊤ 2 2 2 ⊥ 1 0 1"))
-    (list 1 0 1)))
-
-(begin
-  (define
-    mk-parts
-    (fn (s) (map (fn (p) (get p :ravel)) (get (apl-run s) :ravel))))
-  (apl-test
-    "⊆ partition: 1 1 0 1 1 ⊆ 'abcde' → ('ab' 'de')"
-    (mk-parts "1 1 0 1 1 ⊆ 'abcde'")
-    (list (list "a" "b") (list "d" "e")))
-  (apl-test
-    "⊆ partition: 1 0 0 1 1 ⊆ ⍳5 → ((1) (4 5))"
-    (mk-parts "1 0 0 1 1 ⊆ ⍳5")
-    (list (list 1) (list 4 5)))
-  (apl-test
-    "⊆ partition: all-zero mask → empty"
-    (len (get (apl-run "0 0 0 ⊆ 1 2 3") :ravel))
-    0)
-  (apl-test
-    "⊆ partition: all-one mask → single partition"
-    (mk-parts "1 1 1 ⊆ 7 8 9")
-    (list (list 7 8 9)))
-  (apl-test
-    "⊆ partition: strict increase 1 2 starts new"
-    (mk-parts "1 2 ⊆ 10 20")
-    (list (list 10) (list 20)))
-  (apl-test
-    "⊆ partition: same level continues 2 2 → one partition"
-    (mk-parts "2 2 ⊆ 10 20")
-    (list (list 10 20)))
-  (apl-test
-    "⊆ partition: 0 separates"
-    (mk-parts "1 1 0 0 1 ⊆ 1 2 3 4 5")
-    (list (list 1 2) (list 5)))
-  (apl-test
-    "⊆ partition: outer length matches partition count"
-    (len (get (apl-run "1 0 1 0 1 ⊆ ⍳5") :ravel))
-    3))
-
-(begin
-  (apl-test
-    "⍎ execute: ⍎ '1 + 2' → 3"
-    (mkrv (apl-run "⍎ '1 + 2'"))
-    (list 3))
-  (apl-test
-    "⍎ execute: ⍎ '+/⍳10' → 55"
-    (mkrv (apl-run "⍎ '+/⍳10'"))
-    (list 55))
-  (apl-test
-    "⍎ execute: ⍎ '⌈/ 1 3 9 5 7' → 9"
-    (mkrv (apl-run "⍎ '⌈/ 1 3 9 5 7'"))
-    (list 9))
-  (apl-test
-    "⍎ execute: ⍎ '⍳5' → 1..5"
-    (mkrv (apl-run "⍎ '⍳5'"))
-    (list 1 2 3 4 5))
-  (apl-test
-    "⍎ execute: ⍎ '×/⍳5' → 120"
-    (mkrv (apl-run "⍎ '×/⍳5'"))
-    (list 120))
-  (apl-test
-    "⍎ execute: round-trip ⍎ ⎕FMT 42 → 42"
-    (mkrv (apl-run "⍎ ⎕FMT 42"))
-    (list 42))
-  (apl-test
-    "⍎ execute: nested ⍎ ⍎"
-    (mkrv (apl-run "⍎ '⍎ ''2 × 3'''"))
-    (list 6))
-  (apl-test
-    "⍎ execute: with assignment side-effect"
-    (mkrv (apl-run "⍎ 'q ← 99 ⋄ q + 1'"))
-    (list 100)))
-
-(begin
-  (apl-test
-    "het-inner: 1 ⍵ ∨.∧ X — result is enclosed (5 5)"
-    (let
-      ((r (apl-run "B ← 5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 ⋄ X ← 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂B ⋄ 1 B ∨.∧ X")))
-      (list
-        (len (get r :shape))
-        (= (type-of (first (get r :ravel))) "dict")))
-    (list 0 true))
-  (apl-test
-    "het-inner: ⊃ unwraps to (5 5) board"
-    (mksh
-      (apl-run
-        "B ← 5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 ⋄ X ← 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂B ⋄ ⊃ 1 B ∨.∧ X"))
-    (list 5 5))
-  (apl-test
-    "het-inner: homogeneous inner product unaffected"
-    (mkrv (apl-run "1 2 3 +.× 4 5 6"))
-    (list 32))
-  (apl-test
-    "het-inner: matrix inner product unaffected"
-    (mkrv (apl-run "(2 2 ⍴ 1 2 3 4) +.× 2 2 ⍴ 5 6 7 8"))
-    (list 19 22 43 50)))

lib/apl/tests/programs-e2e.sx

@@ -94,96 +94,3 @@
   "e2e: sqrt-via-newton 1 step from 1 → 2.5"
   (mkrv (apl-run "step ← {(⍵+⍺÷⍵)÷2} ⋄ 4 step 1"))
   (list 2.5))
-
-(begin
-  (apl-test
-    "life.apl: blinker 5×5 → vertical blinker"
-    (mkrv
-      (apl-run
-        "life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} ⋄ life 5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0"))
-    (list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0))
-  (apl-test
-    "life.apl: blinker oscillates (period 2)"
-    (mkrv
-      (apl-run
-        "life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} ⋄ life life 5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0"))
-    (list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))
-  (apl-test
-    "life.apl: 2×2 block stable"
-    (mkrv
-      (apl-run
-        "life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} ⋄ life 4 4 ⍴ 0 0 0 0 0 1 1 0 0 1 1 0 0 0 0 0"))
-    (list 0 0 0 0 0 1 1 0 0 1 1 0 0 0 0 0))
-  (apl-test
-    "life.apl: empty grid stays empty"
-    (mkrv
-      (apl-run
-        "life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} ⋄ life 5 5 ⍴ 0"))
-    (list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
-  (apl-test
-    "life.apl: source-file as-written runs"
-    (let
-      ((dfn (apl-run-file "lib/apl/tests/programs/life.apl"))
-        (board
-          (apl-run "5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0")))
-      (get (apl-call-dfn-m dfn board) :ravel))
-    (list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0)))
-
-(begin
-  (apl-test
-    "quicksort.apl: 11-element with duplicates"
-    (begin
-      (apl-rng-seed! 42)
-      (mkrv
-        (apl-run
-          "quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort 3 1 4 1 5 9 2 6 5 3 5")))
-    (list 1 1 2 3 3 4 5 5 5 6 9))
-  (apl-test
-    "quicksort.apl: already sorted"
-    (begin
-      (apl-rng-seed! 42)
-      (mkrv
-        (apl-run
-          "quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort 1 2 3 4 5")))
-    (list 1 2 3 4 5))
-  (apl-test
-    "quicksort.apl: reverse sorted"
-    (begin
-      (apl-rng-seed! 42)
-      (mkrv
-        (apl-run
-          "quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort 5 4 3 2 1")))
-    (list 1 2 3 4 5))
-  (apl-test
-    "quicksort.apl: all equal"
-    (begin
-      (apl-rng-seed! 42)
-      (mkrv
-        (apl-run
-          "quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort 7 7 7 7")))
-    (list 7 7 7 7))
-  (apl-test
-    "quicksort.apl: single element"
-    (begin
-      (apl-rng-seed! 42)
-      (mkrv
-        (apl-run
-          "quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort ,42")))
-    (list 42))
-  (apl-test
-    "quicksort.apl: matches grade-up"
-    (begin
-      (apl-rng-seed! 42)
-      (mkrv
-        (apl-run
-          "V ← 8 3 1 9 2 7 5 6 4 ⋄ quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort V")))
-    (list 1 2 3 4 5 6 7 8 9))
-  (apl-test
-    "quicksort.apl: source-file as-written runs"
-    (begin
-      (apl-rng-seed! 42)
-      (let
-        ((dfn (apl-run-file "lib/apl/tests/programs/quicksort.apl"))
-          (vec (apl-run "5 2 8 1 9 3 7 4 6")))
-        (get (apl-call-dfn-m dfn vec) :ravel)))
-    (list 1 2 3 4 5 6 7 8 9)))

lib/apl/tests/programs/life.apl

@@ -8,9 +8,9 @@
 ⍝   ¯1 0 1 ⌽¨ ⊂⍵      : produce 3 horizontally-shifted copies
 ⍝   ¯1 0 1 ∘.⊖ …      : outer-product with vertical shifts → 3×3 = 9 shifts
 ⍝   +/ +/ …           : sum the 9 boards element-wise → neighbor-count + self
-⍝   3 4 = …           : leading-axis-extended boolean — count is 3 (born) or 4 (survive)
+⍝   3 4 = …           : boolean — count is exactly 3 or exactly 4
 ⍝   1 ⍵ ∨.∧ …         : "alive next" iff (count=3) or (alive AND count=4)
-⍝   ⊃ …               : disclose the enclosed result back to a 2D board
+⍝   ⊃ …               : disclose back to a 2D board
 ⍝
 ⍝ Rules in plain language:
 ⍝   - dead cell + 3 live neighbors → born

lib/apl/tokenizer.sx

@@ -19,180 +19,162 @@
              (and (>= ch "A") (<= ch "Z"))
              (= ch "_")))))
 
-(define
-  apl-tokenize
-  (fn
-    (source)
-    (let
-      ((pos 0) (src-len (len source)) (tokens (list)))
-      (define tok-push! (fn (type value) (append! tokens {:value value :type type})))
-      (define
-        cur-sw?
-        (fn
-          (ch)
+(define apl-tokenize
+  (fn (source)
+    (let ((pos 0)
+          (src-len (len source))
+          (tokens (list)))
+
+      (define tok-push!
+        (fn (type value)
+          (append! tokens {:type type :value value})))
+
+      (define cur-sw?
+        (fn (ch)
           (and (< pos src-len) (starts-with? (slice source pos) ch))))
-      (define cur-byte (fn () (if (< pos src-len) (nth source pos) nil)))
-      (define advance! (fn () (set! pos (+ pos 1))))
-      (define consume! (fn (ch) (set! pos (+ pos (len ch)))))
-      (define
-        find-glyph
-        (fn
-          ()
-          (let
-            ((rem (slice source pos)))
-            (let
-              ((matches (filter (fn (g) (starts-with? rem g)) apl-glyph-set)))
+
+      (define cur-byte
+        (fn ()
+          (if (< pos src-len) (nth source pos) nil)))
+
+      (define advance!
+        (fn ()
+          (set! pos (+ pos 1))))
+
+      (define consume!
+        (fn (ch)
+          (set! pos (+ pos (len ch)))))
+
+      (define find-glyph
+        (fn ()
+          (let ((rem (slice source pos)))
+            (let ((matches (filter (fn (g) (starts-with? rem g)) apl-glyph-set)))
               (if (> (len matches) 0) (first matches) nil)))))
-      (define
-        read-digits!
-        (fn
-          (acc)
-          (if
-            (and (< pos src-len) (apl-digit? (cur-byte)))
-            (let
-              ((ch (cur-byte)))
-              (begin (advance!) (read-digits! (str acc ch))))
+
+      (define read-digits!
+        (fn (acc)
+          (if (and (< pos src-len) (apl-digit? (cur-byte)))
+            (let ((ch (cur-byte)))
+              (begin
+                (advance!)
+                (read-digits! (str acc ch))))
             acc)))
-      (define
-        read-ident-cont!
-        (fn
-          ()
-          (when
-            (and
-              (< pos src-len)
-              (let
-                ((ch (cur-byte)))
-                (or (apl-alpha? ch) (apl-digit? ch))))
-            (begin (advance!) (read-ident-cont!)))))
-      (define
-        read-string!
-        (fn
-          (acc)
+
+      (define read-ident-cont!
+        (fn ()
+          (when (and (< pos src-len)
+                     (let ((ch (cur-byte)))
+                       (or (apl-alpha? ch) (apl-digit? ch))))
+            (begin
+              (advance!)
+              (read-ident-cont!)))))
+
+      (define read-string!
+        (fn (acc)
           (cond
             ((>= pos src-len) acc)
             ((cur-sw? "'")
-              (if
-                (and (< (+ pos 1) src-len) (cur-sw? "'"))
-                (begin (advance!) (advance!) (read-string! (str acc "'")))
-                (begin (advance!) acc)))
+             (if (and (< (+ pos 1) src-len) (cur-sw? "'"))
+               (begin
+                 (advance!)
+                 (advance!)
+                 (read-string! (str acc "'")))
+               (begin (advance!) acc)))
             (true
-              (let
-                ((ch (cur-byte)))
-                (begin (advance!) (read-string! (str acc ch))))))))
-      (define
-        skip-line!
-        (fn
-          ()
-          (when
-            (and (< pos src-len) (not (cur-sw? "\n")))
-            (begin (advance!) (skip-line!)))))
-      (define
-        scan!
-        (fn
-          ()
-          (when
-            (< pos src-len)
-            (let
-              ((ch (cur-byte)))
+             (let ((ch (cur-byte)))
+               (begin
+                 (advance!)
+                 (read-string! (str acc ch))))))))
+
+      (define skip-line!
+        (fn ()
+          (when (and (< pos src-len) (not (cur-sw? "\n")))
+            (begin
+              (advance!)
+              (skip-line!)))))
+
+      (define scan!
+        (fn ()
+          (when (< pos src-len)
+            (let ((ch (cur-byte)))
               (cond
                 ((or (= ch " ") (= ch "\t") (= ch "\r"))
-                  (begin (advance!) (scan!)))
+                 (begin (advance!) (scan!)))
                 ((= ch "\n")
-                  (begin (advance!) (tok-push! :newline nil) (scan!)))
-                ((cur-sw? "⍝") (begin (skip-line!) (scan!)))
+                 (begin (advance!) (tok-push! :newline nil) (scan!)))
+                ((cur-sw? "⍝")
+                 (begin (skip-line!) (scan!)))
                 ((cur-sw? "⋄")
-                  (begin (consume! "⋄") (tok-push! :diamond nil) (scan!)))
+                 (begin (consume! "⋄") (tok-push! :diamond nil) (scan!)))
                 ((= ch "(")
-                  (begin (advance!) (tok-push! :lparen nil) (scan!)))
+                 (begin (advance!) (tok-push! :lparen nil) (scan!)))
                 ((= ch ")")
-                  (begin (advance!) (tok-push! :rparen nil) (scan!)))
+                 (begin (advance!) (tok-push! :rparen nil) (scan!)))
                 ((= ch "[")
-                  (begin (advance!) (tok-push! :lbracket nil) (scan!)))
+                 (begin (advance!) (tok-push! :lbracket nil) (scan!)))
                 ((= ch "]")
-                  (begin (advance!) (tok-push! :rbracket nil) (scan!)))
+                 (begin (advance!) (tok-push! :rbracket nil) (scan!)))
                 ((= ch "{")
-                  (begin (advance!) (tok-push! :lbrace nil) (scan!)))
+                 (begin (advance!) (tok-push! :lbrace nil) (scan!)))
                 ((= ch "}")
-                  (begin (advance!) (tok-push! :rbrace nil) (scan!)))
+                 (begin (advance!) (tok-push! :rbrace nil) (scan!)))
                 ((= ch ";")
-                  (begin (advance!) (tok-push! :semi nil) (scan!)))
+                 (begin (advance!) (tok-push! :semi nil) (scan!)))
                 ((cur-sw? "←")
-                  (begin (consume! "←") (tok-push! :assign nil) (scan!)))
+                 (begin (consume! "←") (tok-push! :assign nil) (scan!)))
                 ((= ch ":")
-                  (let
-                    ((start pos))
-                    (begin
-                      (advance!)
-                      (if
-                        (and (< pos src-len) (apl-alpha? (cur-byte)))
-                        (begin
-                          (read-ident-cont!)
-                          (tok-push! :keyword (slice source start pos)))
-                        (tok-push! :colon nil))
-                      (scan!))))
-                ((and (cur-sw? "¯") (< (+ pos (len "¯")) src-len) (apl-digit? (nth source (+ pos (len "¯")))))
-                  (begin
-                    (consume! "¯")
-                    (let
-                      ((digits (read-digits! "")))
-                      (if
-                        (and
-                          (< pos src-len)
-                          (= (cur-byte) ".")
-                          (< (+ pos 1) src-len)
-                          (apl-digit? (nth source (+ pos 1))))
-                        (begin
-                          (advance!)
-                          (let
-                            ((frac (read-digits! "")))
-                            (tok-push!
-                              :num (- 0 (string->number (str digits "." frac))))))
-                        (tok-push! :num (- 0 (parse-int digits 0)))))
-                    (scan!)))
+                 (let ((start pos))
+                   (begin
+                     (advance!)
+                     (if (and (< pos src-len) (apl-alpha? (cur-byte)))
+                       (begin
+                         (read-ident-cont!)
+                         (tok-push! :keyword (slice source start pos)))
+                       (tok-push! :colon nil))
+                     (scan!))))
+                ((and (cur-sw? "¯")
+                      (< (+ pos (len "¯")) src-len)
+                      (apl-digit? (nth source (+ pos (len "¯")))))
+                 (begin
+                   (consume! "¯")
+                   (let ((digits (read-digits! "")))
+                     (if (and (< pos src-len) (= (cur-byte) ".")
+                              (< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1))))
+                       (begin (advance!)
+                              (let ((frac (read-digits! "")))
+                                (tok-push! :num (- 0 (string->number (str digits "." frac))))))
+                       (tok-push! :num (- 0 (parse-int digits 0)))))
+                   (scan!)))
                 ((apl-digit? ch)
-                  (begin
-                    (let
-                      ((digits (read-digits! "")))
-                      (if
-                        (and
-                          (< pos src-len)
-                          (= (cur-byte) ".")
-                          (< (+ pos 1) src-len)
-                          (apl-digit? (nth source (+ pos 1))))
-                        (begin
-                          (advance!)
-                          (let
-                            ((frac (read-digits! "")))
-                            (tok-push!
-                              :num (string->number (str digits "." frac)))))
-                        (tok-push! :num (parse-int digits 0))))
-                    (scan!)))
+                 (begin
+                   (let ((digits (read-digits! "")))
+                     (if (and (< pos src-len) (= (cur-byte) ".")
+                              (< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1))))
+                       (begin (advance!)
+                              (let ((frac (read-digits! "")))
+                                (tok-push! :num (string->number (str digits "." frac)))))
+                       (tok-push! :num (parse-int digits 0))))
+                   (scan!)))
                 ((= ch "'")
-                  (begin
-                    (advance!)
-                    (let ((s (read-string! ""))) (tok-push! :str s))
-                    (scan!)))
+                 (begin
+                   (advance!)
+                   (let ((s (read-string! "")))
+                     (tok-push! :str s))
+                   (scan!)))
                 ((or (apl-alpha? ch) (cur-sw? "⎕"))
-                  (let
-                    ((start pos))
-                    (begin
-                      (if
-                        (cur-sw? "⎕")
-                        (begin
-                          (consume! "⎕")
-                          (if
-                            (and (< pos src-len) (cur-sw? "←"))
-                            (consume! "←")
-                            (read-ident-cont!)))
-                        (begin (advance!) (read-ident-cont!)))
-                      (tok-push! :name (slice source start pos))
-                      (scan!))))
+                 (let ((start pos))
+                   (begin
+                     (if (cur-sw? "⎕") (consume! "⎕") (advance!))
+                     (if (and (< pos src-len) (cur-sw? "←"))
+                       (consume! "←")
+                       (read-ident-cont!))
+                     (tok-push! :name (slice source start pos))
+                     (scan!))))
                 (true
-                  (let
-                    ((g (find-glyph)))
-                    (if
-                      g
-                      (begin (consume! g) (tok-push! :glyph g) (scan!))
-                      (begin (advance!) (scan!))))))))))
+                 (let ((g (find-glyph)))
+                   (if g
+                     (begin (consume! g) (tok-push! :glyph g) (scan!))
+                     (begin (advance!) (scan!))))))))))
+
       (scan!)
       tokens)))

lib/apl/transpile.sx

@@ -46,9 +46,6 @@
       ((= g "⍕") apl-quad-fmt)
       ((= g "⎕FMT") apl-quad-fmt)
       ((= g "⎕←") apl-quad-print)
-      ((= g "⍸") apl-where)
-      ((= g "∪") apl-unique)
-      ((= g "⍎") apl-execute)
       (else (error "no monadic fn for glyph")))))
 
 (define
@@ -93,12 +90,6 @@
       ((= g "⍉") apl-transpose-dyadic)
       ((= g "⊢") (fn (a b) b))
       ((= g "⊣") (fn (a b) a))
-      ((= g "⍸") apl-interval-index)
-      ((= g "∪") apl-union)
-      ((= g "∩") apl-intersect)
-      ((= g "⊥") apl-decode)
-      ((= g "⊤") apl-encode)
-      ((= g "⊆") apl-partition)
       (else (error "no dyadic fn for glyph")))))
 
 (define
@@ -133,14 +124,7 @@
               ((vals (map (fn (n) (apl-eval-ast n env)) items)))
               (make-array
                 (list (len vals))
-                (map
-                  (fn
-                    (v)
-                    (if
-                      (= (len (get v :shape)) 0)
-                      (first (get v :ravel))
-                      v))
-                  vals)))))
+                (map (fn (v) (first (get v :ravel))) vals)))))
         ((= tag :name)
           (let
             ((nm (nth node 1)))
@@ -582,11 +566,3 @@
 (define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
 
 (define apl-run-file (fn (path) (apl-run (file-read path))))
-
-(define
-  apl-execute
-  (fn
-    (arr)
-    (let
-      ((src (cond ((string? arr) arr) ((scalar? arr) (disclose arr)) (else (reduce str "" (get arr :ravel))))))
-      (apl-run src))))

lib/common-lisp/conformance.sh

@@ -30,7 +30,7 @@ run_suite() {
   local name="$1" load_files="$2" pass_var="$3" fail_var="$4" failures_var="$5"
   local TMP; TMP=$(mktemp)
   {
-    printf '(epoch 1)\n(load "spec/stdlib.sx")\n'
+    printf '(epoch 1)\n(load "spec/stdlib.sx")\n(load "lib/guest/prefix.sx")\n'
     local i=2
     for f in $load_files; do
       printf '(epoch %d)\n(load "%s")\n' "$i" "$f"

lib/common-lisp/runtime.sx

@@ -23,13 +23,19 @@
   (cl-numberp? x)
   (let ((t (type-of x))) (or (= t "number") (= t "rational"))))
 
-(define cl-integerp? integer?)
-(define cl-floatp? float?)
-(define cl-rationalp? rational?)
+(prefix-rename "cl-"
+  '(
+    (integerp? integer?)
+    (floatp? float?)
+    (rationalp? rational?)
+    ))
 
 (define (cl-realp? x) (or (integer? x) (float? x) (rational? x)))
 
-(define cl-characterp? char?)
+(prefix-rename "cl-"
+  '(
+    (characterp? char?)
+    ))
 (define cl-stringp? (fn (x) (= (type-of x) "string")))
 (define cl-symbolp? (fn (x) (= (type-of x) "symbol")))
 (define cl-keywordp? (fn (x) (= (type-of x) "keyword")))
@@ -44,8 +50,11 @@
       (= t "native-fn")
       (= t "component"))))
 
-(define cl-vectorp? vector?)
-(define cl-arrayp? vector?)
+(prefix-rename "cl-"
+  '(
+    (vectorp? vector?)
+    (arrayp? vector?)
+    ))
 
 ;; sx_server: (rest (list x)) returns () not nil — cl-empty? handles both
 (define
@@ -56,19 +65,25 @@
 ;; 2.  Arithmetic — thin aliases to spec primitives
 ;; ---------------------------------------------------------------------------
 
-(define cl-mod modulo)
-(define cl-rem remainder)
-(define cl-gcd gcd)
-(define cl-lcm lcm)
-(define cl-expt expt)
-(define cl-floor floor)
-(define cl-ceiling ceil)
-(define cl-truncate truncate)
-(define cl-round round)
+(prefix-rename "cl-"
+  '(
+    (mod modulo)
+    (rem remainder)
+    gcd
+    lcm
+    expt
+    floor
+    (ceiling ceil)
+    truncate
+    round
+    ))
 (define cl-abs (fn (x) (if (< x 0) (- 0 x) x)))
 (define cl-min (fn (a b) (if (< a b) a b)))
 (define cl-max (fn (a b) (if (> a b) a b)))
-(define cl-quotient quotient)
+(prefix-rename "cl-"
+  '(
+    quotient
+    ))
 
 (define
   (cl-signum x)
@@ -87,21 +102,27 @@
 ;; 3.  Character functions — alias spec char primitives + CL name mapping
 ;; ---------------------------------------------------------------------------
 
-(define cl-char->integer char->integer)
-(define cl-integer->char integer->char)
-(define cl-char-upcase char-upcase)
-(define cl-char-downcase char-downcase)
-(define cl-char-code char->integer)
-(define cl-code-char integer->char)
+(prefix-rename "cl-"
+  '(
+    char->integer
+    integer->char
+    char-upcase
+    char-downcase
+    (char-code char->integer)
+    (code-char integer->char)
+    ))
 
-(define cl-char=? char=?)
-(define cl-char<? char<?)
-(define cl-char>? char>?)
-(define cl-char<=? char<=?)
-(define cl-char>=? char>=?)
-(define cl-char-ci=? char-ci=?)
-(define cl-char-ci<? char-ci<?)
-(define cl-char-ci>? char-ci>?)
+(prefix-rename "cl-"
+  '(
+    char=?
+    char<?
+    char>?
+    char<=?
+    char>=?
+    char-ci=?
+    char-ci<?
+    char-ci>?
+    ))
 
 ;; Inline predicates — char-alphabetic?/char-numeric? unreliable in sx_server
 (define
@@ -152,8 +173,11 @@
   (cl-format dest template &rest args)
   (let ((s (apply format (cons template args)))) (if (= dest nil) s s)))
 
-(define cl-write-to-string write-to-string)
-(define cl-princ-to-string display-to-string)
+(prefix-rename "cl-"
+  '(
+    write-to-string
+    (princ-to-string display-to-string)
+    ))
 
 ;; CL read-from-string: parse value from a string using SX port
 (define
@@ -161,18 +185,27 @@
   (let ((p (open-input-string s))) (read p)))
 
 ;; String stream (output)
-(define cl-make-string-output-stream open-output-string)
-(define cl-get-output-stream-string get-output-string)
+(prefix-rename "cl-"
+  '(
+    (make-string-output-stream open-output-string)
+    (get-output-stream-string get-output-string)
+    ))
 
 ;; String stream (input)
-(define cl-make-string-input-stream open-input-string)
+(prefix-rename "cl-"
+  '(
+    (make-string-input-stream open-input-string)
+    ))
 
 ;; ---------------------------------------------------------------------------
 ;; 5.  Gensym
 ;; ---------------------------------------------------------------------------
 
-(define cl-gensym gensym)
-(define cl-gentemp gensym)
+(prefix-rename "cl-"
+  '(
+    gensym
+    (gentemp gensym)
+    ))
 
 ;; ---------------------------------------------------------------------------
 ;; 6.  Multiple values (CL: values / nth-value)
@@ -203,16 +236,19 @@
 ;; 7.  Sets (CL: adjoin / member / union / intersection / set-difference)
 ;; ---------------------------------------------------------------------------
 
-(define cl-make-set make-set)
-(define cl-set? set?)
-(define cl-set-add set-add!)
-(define cl-set-memberp set-member?)
-(define cl-set-remove set-remove!)
-(define cl-set-union set-union)
-(define cl-set-intersect set-intersection)
-(define cl-set-difference set-difference)
-(define cl-list->set list->set)
-(define cl-set->list set->list)
+(prefix-rename "cl-"
+  '(
+    make-set
+    set?
+    (set-add set-add!)
+    (set-memberp set-member?)
+    (set-remove set-remove!)
+    set-union
+    (set-intersect set-intersection)
+    set-difference
+    list->set
+    set->list
+    ))
 
 ;; CL: (member item list) — returns tail starting at item, or nil
 (define

lib/common-lisp/scoreboard.json

@@ -1,5 +1,5 @@
 {
-  "generated": "2026-05-05T12:35:09Z",
+  "generated": "2026-05-06T22:55:42Z",
   "total_pass": 518,
   "total_fail": 0,
   "suites": [

lib/common-lisp/scoreboard.md

@@ -1,6 +1,6 @@
 # Common Lisp on SX — Scoreboard
 
-_Generated: 2026-05-05 12:35 UTC_
+_Generated: 2026-05-06 22:55 UTC_
 
 | Suite | Pass | Fail | Status |
 |-------|------|------|--------|

lib/compiler.sx

@@ -1008,11 +1008,27 @@
             (let
               ((name (symbol-name head))
                 (argc (len args))
-                (name-idx (pool-add (get em "pool") name)))
+                (specialized-op (cond
+                  (and (= argc 2) (= name "+")) 160
+                  (and (= argc 2) (= name "-")) 161
+                  (and (= argc 2) (= name "*")) 162
+                  (and (= argc 2) (= name "/")) 163
+                  (and (= argc 2) (= name "=")) 164
+                  (and (= argc 2) (= name "<")) 165
+                  (and (= argc 2) (= name ">")) 166
+                  (and (= argc 2) (= name "cons")) 172
+                  (and (= argc 1) (= name "not")) 167
+                  (and (= argc 1) (= name "len")) 168
+                  (and (= argc 1) (= name "first")) 169
+                  (and (= argc 1) (= name "rest")) 170
+                  :else nil)))
               (for-each (fn (a) (compile-expr em a scope false)) args)
-              (emit-op em 52)
-              (emit-u16 em name-idx)
-              (emit-byte em argc))
+              (if specialized-op
+                (emit-op em specialized-op)
+                (let ((name-idx (pool-add (get em "pool") name)))
+                  (emit-op em 52)
+                  (emit-u16 em name-idx)
+                  (emit-byte em argc))))
             (do
               (compile-expr em head scope false)
               (for-each (fn (a) (compile-expr em a scope false)) args)

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/fiber.sx

@@ -0,0 +1,44 @@
+; lib/fiber.sx — pure SX fiber library using call/cc
+;
+; A fiber is a cooperative coroutine with true suspension (no eager
+; pre-execution). Each fiber is a dict {:resume fn :done? fn}.
+;
+; make-fiber body   → fiber dict
+;   body = (fn (yield init-val) ...)  — body receives yield + first resume val
+;   yield = (fn (val) ...)            — suspends fiber, returns val to resumer
+;
+; fiber-resume f v  → next yielded value, or nil when body returns
+; fiber-done? f     → true after body has returned
+
+(define make-fiber
+  (fn (body)
+    (let
+      ((resume-k nil)
+        (caller-k nil)
+        (done false))
+      (let
+        ((yield
+            (fn (val)
+              (call/cc
+                (fn (k)
+                  (set! resume-k k)
+                  (caller-k val))))))
+        {:resume
+         (fn (val)
+           (if
+             done
+             nil
+             (call/cc
+               (fn (k)
+                 (set! caller-k k)
+                 (if
+                   (nil? resume-k)
+                   (begin
+                     (body yield val)
+                     (set! done true)
+                     (k nil))
+                   (resume-k val))))))
+         :done? (fn () done)}))))
+
+(define fiber-resume (fn (f v) ((get f :resume) v)))
+(define fiber-done?  (fn (f) ((get f :done?))))

lib/guest/ast.sx

@@ -0,0 +1,92 @@
+;; lib/guest/ast.sx — canonical AST node shapes.
+;;
+;; A guest's parser may emit its own AST in whatever shape is convenient
+;; for that language's evaluator/transpiler. This file gives a SHARED
+;; canonical shape that cross-language tools (formatters, highlighters,
+;; debuggers) can target without per-language adapters.
+;;
+;; Each canonical node is a tagged list: (KIND ...payload).
+;;
+;; Constructors (return a canonical node):
+;;
+;;   (ast-literal       VALUE)               — number / string / bool / nil
+;;   (ast-var           NAME)                — identifier reference
+;;   (ast-app           FN ARGS)             — function application
+;;   (ast-lambda        PARAMS BODY)         — anonymous function
+;;   (ast-let           BINDINGS BODY)       — local bindings
+;;   (ast-letrec        BINDINGS BODY)       — recursive local bindings
+;;   (ast-if            TEST THEN ELSE)      — conditional
+;;   (ast-match-clause  PATTERN BODY)        — one match arm
+;;   (ast-module        NAME BODY)           — module declaration
+;;   (ast-import        NAME)                — import directive
+;;
+;; Predicates: (ast-literal? X), (ast-var? X), …
+;; Generic:    (ast? X)         — any canonical node
+;;             (ast-kind X)     — :literal / :var / :app / …
+;;
+;; Accessors  (one per payload field):
+;;   (ast-literal-value N)
+;;   (ast-var-name N)
+;;   (ast-app-fn N)             (ast-app-args N)
+;;   (ast-lambda-params N)      (ast-lambda-body N)
+;;   (ast-let-bindings N)       (ast-let-body N)
+;;   (ast-letrec-bindings N)    (ast-letrec-body N)
+;;   (ast-if-test N)            (ast-if-then N)         (ast-if-else N)
+;;   (ast-match-clause-pattern N)
+;;   (ast-match-clause-body N)
+;;   (ast-module-name N)        (ast-module-body N)
+;;   (ast-import-name N)
+
+(define ast-literal      (fn (v)         (list :literal v)))
+(define ast-var          (fn (n)         (list :var n)))
+(define ast-app          (fn (f args)    (list :app f args)))
+(define ast-lambda       (fn (ps body)   (list :lambda ps body)))
+(define ast-let          (fn (bs body)   (list :let bs body)))
+(define ast-letrec       (fn (bs body)   (list :letrec bs body)))
+(define ast-if           (fn (t th el)   (list :if t th el)))
+(define ast-match-clause (fn (p body)    (list :match-clause p body)))
+(define ast-module       (fn (n body)    (list :module n body)))
+(define ast-import       (fn (n)         (list :import n)))
+
+(define ast-kind (fn (x) (if (and (list? x) (not (empty? x))) (first x) nil)))
+
+(define
+  ast?
+  (fn (x)
+    (and (list? x)
+         (not (empty? x))
+         (let ((k (first x)))
+           (or (= k :literal) (= k :var) (= k :app)
+               (= k :lambda)  (= k :let) (= k :letrec)
+               (= k :if)      (= k :match-clause)
+               (= k :module)  (= k :import))))))
+
+(define ast-literal?      (fn (x) (and (ast? x) (= (first x) :literal))))
+(define ast-var?          (fn (x) (and (ast? x) (= (first x) :var))))
+(define ast-app?          (fn (x) (and (ast? x) (= (first x) :app))))
+(define ast-lambda?       (fn (x) (and (ast? x) (= (first x) :lambda))))
+(define ast-let?          (fn (x) (and (ast? x) (= (first x) :let))))
+(define ast-letrec?       (fn (x) (and (ast? x) (= (first x) :letrec))))
+(define ast-if?           (fn (x) (and (ast? x) (= (first x) :if))))
+(define ast-match-clause? (fn (x) (and (ast? x) (= (first x) :match-clause))))
+(define ast-module?       (fn (x) (and (ast? x) (= (first x) :module))))
+(define ast-import?       (fn (x) (and (ast? x) (= (first x) :import))))
+
+(define ast-literal-value (fn (n) (nth n 1)))
+(define ast-var-name      (fn (n) (nth n 1)))
+(define ast-app-fn        (fn (n) (nth n 1)))
+(define ast-app-args      (fn (n) (nth n 2)))
+(define ast-lambda-params (fn (n) (nth n 1)))
+(define ast-lambda-body   (fn (n) (nth n 2)))
+(define ast-let-bindings  (fn (n) (nth n 1)))
+(define ast-let-body      (fn (n) (nth n 2)))
+(define ast-letrec-bindings (fn (n) (nth n 1)))
+(define ast-letrec-body     (fn (n) (nth n 2)))
+(define ast-if-test       (fn (n) (nth n 1)))
+(define ast-if-then       (fn (n) (nth n 2)))
+(define ast-if-else       (fn (n) (nth n 3)))
+(define ast-match-clause-pattern (fn (n) (nth n 1)))
+(define ast-match-clause-body    (fn (n) (nth n 2)))
+(define ast-module-name   (fn (n) (nth n 1)))
+(define ast-module-body   (fn (n) (nth n 2)))
+(define ast-import-name   (fn (n) (nth n 1)))

lib/guest/baseline/apl.json

@@ -0,0 +1,18 @@
+{
+  "lang": "apl",
+  "captured": "2026-05-06T22:01:00Z",
+  "suite_command": "bash lib/apl/test.sh",
+  "totals": {
+    "pass": 73,
+    "fail": 0,
+    "total": 73
+  },
+  "suites": [
+    {
+      "name": "all",
+      "pass": 73,
+      "fail": 0,
+      "total": 73
+    }
+  ]
+}

lib/guest/baseline/common-lisp.json

@@ -0,0 +1,86 @@
+{
+  "lang": "common-lisp",
+  "captured": "2026-05-06T22:59:46Z",
+  "suite_command": "bash lib/common-lisp/conformance.sh",
+  "totals": {
+    "pass": 518,
+    "fail": 0,
+    "total": 518
+  },
+  "suites": [
+    {
+      "name": "Phase 1: tokenizer/reader",
+      "pass": 79,
+      "fail": 0,
+      "total": 79
+    },
+    {
+      "name": "Phase 1: parser/lambda-lists",
+      "pass": 31,
+      "fail": 0,
+      "total": 31
+    },
+    {
+      "name": "Phase 2: evaluator",
+      "pass": 182,
+      "fail": 0,
+      "total": 182
+    },
+    {
+      "name": "Phase 3: condition system",
+      "pass": 59,
+      "fail": 0,
+      "total": 59
+    },
+    {
+      "name": "Phase 3: restart-demo",
+      "pass": 7,
+      "fail": 0,
+      "total": 7
+    },
+    {
+      "name": "Phase 3: parse-recover",
+      "pass": 6,
+      "fail": 0,
+      "total": 6
+    },
+    {
+      "name": "Phase 3: interactive-debugger",
+      "pass": 7,
+      "fail": 0,
+      "total": 7
+    },
+    {
+      "name": "Phase 4: CLOS",
+      "pass": 41,
+      "fail": 0,
+      "total": 41
+    },
+    {
+      "name": "Phase 4: geometry",
+      "pass": 12,
+      "fail": 0,
+      "total": 12
+    },
+    {
+      "name": "Phase 4: mop-trace",
+      "pass": 13,
+      "fail": 0,
+      "total": 13
+    },
+    {
+      "name": "Phase 5: macros+LOOP",
+      "pass": 27,
+      "fail": 0,
+      "total": 27
+    },
+    {
+      "name": "Phase 6: stdlib",
+      "pass": 54,
+      "fail": 0,
+      "total": 54
+    }
+  ],
+  "source_scoreboard": "lib/common-lisp/scoreboard.json",
+  "note": "Step 2: previous baseline (309) was lower because Phase 2 (evaluator, +182 tests) and Phase 6 (stdlib, +27 tests) results were under-counted by the original conformance.sh's parser. Re-running with prefix.sx loaded reveals true counts. No tests regressed."
+}

lib/guest/baseline/erlang.json

@@ -0,0 +1,67 @@
+{
+  "lang": "erlang",
+  "captured": "2026-05-06T22:01:00Z",
+  "suite_command": "bash lib/erlang/conformance.sh",
+  "totals": {
+    "pass": 0,
+    "fail": 0,
+    "total": 0
+  },
+  "suites": [
+    {
+      "name": "tokenize",
+      "pass": 0,
+      "fail": 0,
+      "total": 0
+    },
+    {
+      "name": "parse",
+      "pass": 0,
+      "fail": 0,
+      "total": 0
+    },
+    {
+      "name": "eval",
+      "pass": 0,
+      "fail": 0,
+      "total": 0
+    },
+    {
+      "name": "runtime",
+      "pass": 0,
+      "fail": 0,
+      "total": 0
+    },
+    {
+      "name": "ring",
+      "pass": 0,
+      "fail": 0,
+      "total": 0
+    },
+    {
+      "name": "ping-pong",
+      "pass": 0,
+      "fail": 0,
+      "total": 0
+    },
+    {
+      "name": "bank",
+      "pass": 0,
+      "fail": 0,
+      "total": 0
+    },
+    {
+      "name": "echo",
+      "pass": 0,
+      "fail": 0,
+      "total": 0
+    },
+    {
+      "name": "fib",
+      "pass": 0,
+      "fail": 0,
+      "total": 0
+    }
+  ],
+  "source_scoreboard": "lib/erlang/scoreboard.json"
+}

lib/guest/baseline/forth.json

@@ -0,0 +1,18 @@
+{
+  "lang": "forth",
+  "captured": "2026-05-06T22:01:00Z",
+  "suite_command": "bash lib/forth/test.sh",
+  "totals": {
+    "pass": 64,
+    "fail": 0,
+    "total": 64
+  },
+  "suites": [
+    {
+      "name": "all",
+      "pass": 64,
+      "fail": 0,
+      "total": 64
+    }
+  ]
+}

lib/guest/baseline/haskell.json

@@ -0,0 +1,122 @@
+{
+  "lang": "haskell",
+  "captured": "2026-05-06T22:46:16Z",
+  "suite_command": "bash lib/haskell/conformance.sh",
+  "totals": {
+    "pass": 156,
+    "fail": 0,
+    "total": 156
+  },
+  "suites": [
+    {
+      "name": "fib",
+      "pass": 2,
+      "fail": 0,
+      "total": 2
+    },
+    {
+      "name": "sieve",
+      "pass": 2,
+      "fail": 0,
+      "total": 2
+    },
+    {
+      "name": "quicksort",
+      "pass": 5,
+      "fail": 0,
+      "total": 5
+    },
+    {
+      "name": "nqueens",
+      "pass": 2,
+      "fail": 0,
+      "total": 2
+    },
+    {
+      "name": "calculator",
+      "pass": 5,
+      "fail": 0,
+      "total": 5
+    },
+    {
+      "name": "collatz",
+      "pass": 11,
+      "fail": 0,
+      "total": 11
+    },
+    {
+      "name": "palindrome",
+      "pass": 8,
+      "fail": 0,
+      "total": 8
+    },
+    {
+      "name": "maybe",
+      "pass": 12,
+      "fail": 0,
+      "total": 12
+    },
+    {
+      "name": "fizzbuzz",
+      "pass": 12,
+      "fail": 0,
+      "total": 12
+    },
+    {
+      "name": "anagram",
+      "pass": 9,
+      "fail": 0,
+      "total": 9
+    },
+    {
+      "name": "roman",
+      "pass": 14,
+      "fail": 0,
+      "total": 14
+    },
+    {
+      "name": "binary",
+      "pass": 12,
+      "fail": 0,
+      "total": 12
+    },
+    {
+      "name": "either",
+      "pass": 12,
+      "fail": 0,
+      "total": 12
+    },
+    {
+      "name": "primes",
+      "pass": 12,
+      "fail": 0,
+      "total": 12
+    },
+    {
+      "name": "zipwith",
+      "pass": 9,
+      "fail": 0,
+      "total": 9
+    },
+    {
+      "name": "matrix",
+      "pass": 8,
+      "fail": 0,
+      "total": 8
+    },
+    {
+      "name": "wordcount",
+      "pass": 7,
+      "fail": 0,
+      "total": 7
+    },
+    {
+      "name": "powers",
+      "pass": 14,
+      "fail": 0,
+      "total": 14
+    }
+  ],
+  "source_scoreboard": "lib/haskell/scoreboard.json",
+  "note": "Step 1: previous baseline (0/18) was an artefact of the old conformance.sh bug \u2014 its (ok-len 3 ...) grep never matched, defaulting every program to 0 pass / 1 fail. Shared driver in Step 1 reads counters correctly."
+}

lib/guest/baseline/js.json

@@ -0,0 +1,75 @@
+{
+  "lang": "js",
+  "captured": "2026-05-06T22:01:00Z",
+  "suite_command": "bash lib/js/conformance.sh",
+  "totals": {
+    "pass": 94,
+    "fail": 54,
+    "total": 148
+  },
+  "suites": [
+    {
+      "name": "test262-slice",
+      "pass": 94,
+      "fail": 54,
+      "total": 148,
+      "failing_tests": [
+        "arithmetic/bitnot",
+        "arithmetic/mixed_concat",
+        "async/await_promise_all",
+        "closures/sum_sq",
+        "coercion/implicit_str_add",
+        "collections/array_index",
+        "collections/array_nested",
+        "collections/string_index",
+        "functions/rest_param",
+        "loops/for_break",
+        "loops/for_continue",
+        "loops/nested_for",
+        "loops/while_basic",
+        "loops/while_break_infinite",
+        "objects/array_filter_reduce",
+        "objects/array_map",
+        "objects/array_method_chain",
+        "objects/array_mutate",
+        "objects/array_push_length",
+        "objects/arrow_lexical_this",
+        "objects/class_basic",
+        "objects/class_extend_chain",
+        "objects/class_inherit",
+        "objects/counter_closure",
+        "objects/in_operator",
+        "objects/instanceof",
+        "objects/method_this",
+        "objects/new_constructor",
+        "objects/object_mutate",
+        "objects/prototype_chain",
+        "objects/string_method",
+        "objects/string_slice",
+        "promises/executor_throws",
+        "promises/finally_passthrough",
+        "promises/microtask_ordering",
+        "promises/new_promise_reject",
+        "promises/new_promise_resolve",
+        "promises/promise_all",
+        "promises/promise_all_empty",
+        "promises/promise_all_nonpromise",
+        "promises/promise_all_reject",
+        "promises/promise_race",
+        "promises/promise_resolve_already_promise",
+        "promises/reject_catch",
+        "promises/resolve_adopts",
+        "promises/resolve_then",
+        "promises/then_chain",
+        "promises/then_throw_catch",
+        "statements/block_scope",
+        "statements/const_multi",
+        "statements/if_else_false",
+        "statements/if_else_true",
+        "statements/let_init",
+        "statements/var_decl"
+      ]
+    }
+  ],
+  "source_scoreboard": "lib/js/conformance.sh-output"
+}

lib/guest/baseline/lua.json

@@ -0,0 +1,18 @@
+{
+  "lang": "lua",
+  "captured": "2026-05-06T22:01:00Z",
+  "suite_command": "bash lib/lua/test.sh",
+  "totals": {
+    "pass": 185,
+    "fail": 0,
+    "total": 185
+  },
+  "suites": [
+    {
+      "name": "all",
+      "pass": 185,
+      "fail": 0,
+      "total": 185
+    }
+  ]
+}

lib/guest/baseline/prolog.json

@@ -0,0 +1,187 @@
+{
+  "lang": "prolog",
+  "captured": "2026-05-06T22:01:00Z",
+  "suite_command": "bash lib/prolog/conformance.sh",
+  "totals": {
+    "pass": 590,
+    "fail": 0,
+    "total": 590
+  },
+  "suites": [
+    {
+      "name": "parse",
+      "pass": 25,
+      "fail": 0,
+      "total": 25
+    },
+    {
+      "name": "unify",
+      "pass": 47,
+      "fail": 0,
+      "total": 47
+    },
+    {
+      "name": "clausedb",
+      "pass": 14,
+      "fail": 0,
+      "total": 14
+    },
+    {
+      "name": "solve",
+      "pass": 62,
+      "fail": 0,
+      "total": 62
+    },
+    {
+      "name": "operators",
+      "pass": 19,
+      "fail": 0,
+      "total": 19
+    },
+    {
+      "name": "dynamic",
+      "pass": 11,
+      "fail": 0,
+      "total": 11
+    },
+    {
+      "name": "findall",
+      "pass": 11,
+      "fail": 0,
+      "total": 11
+    },
+    {
+      "name": "term_inspect",
+      "pass": 14,
+      "fail": 0,
+      "total": 14
+    },
+    {
+      "name": "append",
+      "pass": 6,
+      "fail": 0,
+      "total": 6
+    },
+    {
+      "name": "reverse",
+      "pass": 6,
+      "fail": 0,
+      "total": 6
+    },
+    {
+      "name": "member",
+      "pass": 7,
+      "fail": 0,
+      "total": 7
+    },
+    {
+      "name": "nqueens",
+      "pass": 6,
+      "fail": 0,
+      "total": 6
+    },
+    {
+      "name": "family",
+      "pass": 10,
+      "fail": 0,
+      "total": 10
+    },
+    {
+      "name": "atoms",
+      "pass": 34,
+      "fail": 0,
+      "total": 34
+    },
+    {
+      "name": "query_api",
+      "pass": 16,
+      "fail": 0,
+      "total": 16
+    },
+    {
+      "name": "iso_predicates",
+      "pass": 29,
+      "fail": 0,
+      "total": 29
+    },
+    {
+      "name": "meta_predicates",
+      "pass": 25,
+      "fail": 0,
+      "total": 25
+    },
+    {
+      "name": "list_predicates",
+      "pass": 33,
+      "fail": 0,
+      "total": 33
+    },
+    {
+      "name": "meta_call",
+      "pass": 15,
+      "fail": 0,
+      "total": 15
+    },
+    {
+      "name": "set_predicates",
+      "pass": 15,
+      "fail": 0,
+      "total": 15
+    },
+    {
+      "name": "char_predicates",
+      "pass": 27,
+      "fail": 0,
+      "total": 27
+    },
+    {
+      "name": "io_predicates",
+      "pass": 24,
+      "fail": 0,
+      "total": 24
+    },
+    {
+      "name": "assert_rules",
+      "pass": 15,
+      "fail": 0,
+      "total": 15
+    },
+    {
+      "name": "string_agg",
+      "pass": 25,
+      "fail": 0,
+      "total": 25
+    },
+    {
+      "name": "advanced",
+      "pass": 21,
+      "fail": 0,
+      "total": 21
+    },
+    {
+      "name": "compiler",
+      "pass": 17,
+      "fail": 0,
+      "total": 17
+    },
+    {
+      "name": "cross_validate",
+      "pass": 17,
+      "fail": 0,
+      "total": 17
+    },
+    {
+      "name": "integration",
+      "pass": 20,
+      "fail": 0,
+      "total": 20
+    },
+    {
+      "name": "hs_bridge",
+      "pass": 19,
+      "fail": 0,
+      "total": 19
+    }
+  ],
+  "source_scoreboard": "lib/prolog/scoreboard.json"
+}

lib/guest/baseline/ruby.json

@@ -0,0 +1,18 @@
+{
+  "lang": "ruby",
+  "captured": "2026-05-06T22:01:00Z",
+  "suite_command": "bash lib/ruby/test.sh",
+  "totals": {
+    "pass": 76,
+    "fail": 0,
+    "total": 76
+  },
+  "suites": [
+    {
+      "name": "all",
+      "pass": 76,
+      "fail": 0,
+      "total": 76
+    }
+  ]
+}

lib/guest/baseline/smalltalk.json

@@ -0,0 +1,25 @@
+{
+  "lang": "smalltalk",
+  "captured": "2026-05-06T22:01:00Z",
+  "suite_command": "bash lib/smalltalk/conformance.sh",
+  "totals": {
+    "pass": 625,
+    "fail": 4,
+    "total": 629
+  },
+  "suites": [
+    {
+      "name": "all",
+      "pass": 625,
+      "fail": 4,
+      "total": 629
+    },
+    {
+      "name": "classic-corpus",
+      "pass": 4,
+      "fail": 1,
+      "total": 5
+    }
+  ],
+  "source_scoreboard": "lib/smalltalk/scoreboard.json"
+}

lib/guest/baseline/tcl.json

@@ -0,0 +1,37 @@
+{
+  "lang": "tcl",
+  "captured": "2026-05-06T22:01:00Z",
+  "suite_command": "bash lib/tcl/conformance.sh",
+  "totals": {
+    "pass": 3,
+    "fail": 1,
+    "total": 4
+  },
+  "suites": [
+    {
+      "name": "assert",
+      "pass": 1,
+      "fail": 0,
+      "total": 1
+    },
+    {
+      "name": "event-loop",
+      "pass": 0,
+      "fail": 1,
+      "total": 1
+    },
+    {
+      "name": "for-each-line",
+      "pass": 1,
+      "fail": 0,
+      "total": 1
+    },
+    {
+      "name": "with-temp-var",
+      "pass": 1,
+      "fail": 0,
+      "total": 1
+    }
+  ],
+  "source_scoreboard": "lib/tcl/scoreboard.json"
+}

lib/guest/conformance.sh

@@ -0,0 +1,221 @@
+#!/usr/bin/env bash
+# lib/guest/conformance.sh — shared, config-driven conformance driver.
+#
+# Usage:
+#   bash lib/guest/conformance.sh <conf-file>
+#
+# The conf file is a bash file that sets:
+#   LANG_NAME           e.g. prolog
+#   PRELOADS=( ... )    .sx files to load before any suite (path from repo root)
+#   SUITES=( ... )      colon-separated entries; format depends on MODE
+#   MODE                "dict" or "counters"
+#   COUNTERS_PASS       (counters mode) global symbol for the pass counter
+#   COUNTERS_FAIL       (counters mode) global symbol for the fail counter
+#   TIMEOUT_PER_SUITE   (optional, counters mode) seconds per suite, default 120
+#   SCOREBOARD_DIR      (optional) defaults to lib/$LANG_NAME
+#
+# It may override the bash functions emit_scoreboard_json / emit_scoreboard_md
+# to produce the per-language scoreboard schema. Defaults are provided.
+#
+# Suite formats:
+#   MODE=dict       — "name:test-file:(runner-fn)"
+#                     The runner expression is evaluated and is expected to
+#                     return a dict with :passed/:failed/:total.
+#   MODE=counters   — "name:test-file"
+#                     Each suite is run in a fresh sx_server session: preloads
+#                     are loaded, then the test file, then counters are read.
+#                     The suite is treated as starting from counters (0, 0).
+#
+# Output:
+#   Writes $SCOREBOARD_DIR/scoreboard.json and $SCOREBOARD_DIR/scoreboard.md.
+#   Exits 0 if every suite is green, 1 otherwise.
+
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+
+if [ "$#" -lt 1 ]; then
+  echo "usage: $0 <conf-file>" >&2
+  exit 2
+fi
+
+CONF="$1"
+if [ ! -f "$CONF" ]; then
+  echo "config not found: $CONF" >&2
+  exit 2
+fi
+
+# Defaults — the conf file may override these.
+LANG_NAME=
+PRELOADS=()
+SUITES=()
+MODE=dict
+COUNTERS_PASS=
+COUNTERS_FAIL=
+TIMEOUT_PER_SUITE=120
+SCOREBOARD_DIR=
+
+emit_scoreboard_json() {
+  # Generic schema. Per-lang configs override this for byte-equality with
+  # historical scoreboards.
+  local n=${#GC_NAMES[@]} i sep
+  printf '{\n'
+  printf '  "lang": "%s",\n' "$LANG_NAME"
+  printf '  "total_passed": %d,\n' "$GC_TOTAL_PASS"
+  printf '  "total_failed": %d,\n' "$GC_TOTAL_FAIL"
+  printf '  "total": %d,\n' "$GC_TOTAL"
+  printf '  "suites": ['
+  for ((i=0; i<n; i++)); do
+    sep=","; [ $i -eq $((n-1)) ] && sep=""
+    printf '\n    {"name":"%s","passed":%d,"failed":%d,"total":%d}%s' \
+      "${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_FAIL[$i]}" "${GC_TOTAL_S[$i]}" "$sep"
+  done
+  printf '\n  ],\n'
+  printf '  "generated": "%s"\n' "$(date -Iseconds 2>/dev/null || date)"
+  printf '}\n'
+}
+
+emit_scoreboard_md() {
+  local n=${#GC_NAMES[@]} i status
+  printf '# %s scoreboard\n\n' "$LANG_NAME"
+  printf '**%d / %d passing** (%d failure(s)).\n\n' "$GC_TOTAL_PASS" "$GC_TOTAL" "$GC_TOTAL_FAIL"
+  printf '| Suite | Passed | Total | Status |\n'
+  printf '|-------|--------|-------|--------|\n'
+  for ((i=0; i<n; i++)); do
+    status="ok"; [ "${GC_FAIL[$i]}" -gt 0 ] && status="FAIL"
+    printf '| %s | %d | %d | %s |\n' \
+      "${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_TOTAL_S[$i]}" "$status"
+  done
+}
+
+# shellcheck disable=SC1090
+source "$CONF"
+
+if [ -z "$LANG_NAME" ]; then
+  echo "LANG_NAME not set in $CONF" >&2
+  exit 2
+fi
+SCOREBOARD_DIR="${SCOREBOARD_DIR:-lib/$LANG_NAME}"
+
+SX="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
+if [ ! -x "$SX" ]; then
+  MAIN_ROOT=$(git worktree list 2>/dev/null | head -1 | awk '{print $1}')
+  if [ -n "${MAIN_ROOT:-}" ] && [ -x "$MAIN_ROOT/$SX" ]; then
+    SX="$MAIN_ROOT/$SX"
+  else
+    echo "ERROR: sx_server.exe not found (set SX_SERVER to override)." >&2
+    exit 2
+  fi
+fi
+
+GC_NAMES=()
+GC_PASS=()
+GC_FAIL=()
+GC_TOTAL_S=()
+
+parse_result_line() {
+  # Match a (gc-result "name" P F T) line.
+  local line="$1"
+  if [[ "$line" =~ ^\(gc-result\ \"([^\"]+)\"\ ([0-9]+)\ ([0-9]+)\ ([0-9]+)\)$ ]]; then
+    GC_NAMES+=("${BASH_REMATCH[1]}")
+    GC_PASS+=("${BASH_REMATCH[2]}")
+    GC_FAIL+=("${BASH_REMATCH[3]}")
+    GC_TOTAL_S+=("${BASH_REMATCH[4]}")
+    return 0
+  fi
+  return 1
+}
+
+case "$MODE" in
+  dict)
+    SCRIPT='(epoch 1)
+'
+    for f in "${PRELOADS[@]}"; do
+      SCRIPT+='(load "'"$f"'")
+'
+    done
+    SCRIPT+='(load "lib/guest/conformance.sx")
+'
+    for entry in "${SUITES[@]}"; do
+      IFS=: read -r _ file _ <<< "$entry"
+      SCRIPT+='(load "'"$file"'")
+'
+    done
+    SCRIPT+='(epoch 2)
+'
+    for entry in "${SUITES[@]}"; do
+      IFS=: read -r name _ runner <<< "$entry"
+      SCRIPT+='(eval "(gc-dict-result \"'"$name"'\" '"$runner"')")
+'
+    done
+    OUTPUT=$(printf '%s' "$SCRIPT" | "$SX" 2>&1)
+    expected=${#SUITES[@]}
+    matched=0
+    while IFS= read -r line; do
+      if parse_result_line "$line"; then
+        matched=$((matched + 1))
+      fi
+    done <<< "$OUTPUT"
+    if [ "$matched" -ne "$expected" ]; then
+      echo "Expected $expected suite results, got $matched" >&2
+      echo "---- raw output ----" >&2
+      printf '%s\n' "$OUTPUT" >&2
+      exit 3
+    fi
+    ;;
+  counters)
+    if [ -z "$COUNTERS_PASS" ] || [ -z "$COUNTERS_FAIL" ]; then
+      echo "MODE=counters requires COUNTERS_PASS and COUNTERS_FAIL in $CONF" >&2
+      exit 2
+    fi
+    for entry in "${SUITES[@]}"; do
+      IFS=: read -r name file <<< "$entry"
+      TMPFILE=$(mktemp)
+      {
+        printf '(epoch 1)\n'
+        for f in "${PRELOADS[@]}"; do printf '(load "%s")\n' "$f"; done
+        printf '(load "lib/guest/conformance.sx")\n'
+        printf '(epoch 2)\n'
+        printf '(load "%s")\n' "$file"
+        printf '(epoch 3)\n'
+        printf '(eval "(gc-counters-result \\"%s\\" 0 0 %s %s)")\n' \
+          "$name" "$COUNTERS_PASS" "$COUNTERS_FAIL"
+      } > "$TMPFILE"
+      OUTPUT=$(timeout "$TIMEOUT_PER_SUITE" "$SX" < "$TMPFILE" 2>&1 || true)
+      rm -f "$TMPFILE"
+      result=$(printf '%s\n' "$OUTPUT" | grep -E '^\(gc-result ' | tail -1 || true)
+      if [ -n "$result" ] && parse_result_line "$result"; then
+        :
+      else
+        # Suite hung or crashed before emitting a result. Record 0/1 so it
+        # shows up as a failure rather than vanishing.
+        GC_NAMES+=("$name")
+        GC_PASS+=(0)
+        GC_FAIL+=(1)
+        GC_TOTAL_S+=(1)
+      fi
+    done
+    ;;
+  *)
+    echo "Unknown MODE=$MODE in $CONF (expected dict|counters)" >&2
+    exit 2
+    ;;
+esac
+
+GC_TOTAL_PASS=0
+GC_TOTAL_FAIL=0
+GC_TOTAL=0
+for ((i=0; i<${#GC_NAMES[@]}; i++)); do
+  GC_TOTAL_PASS=$((GC_TOTAL_PASS + GC_PASS[i]))
+  GC_TOTAL_FAIL=$((GC_TOTAL_FAIL + GC_FAIL[i]))
+  GC_TOTAL=$((GC_TOTAL + GC_TOTAL_S[i]))
+done
+
+mkdir -p "$SCOREBOARD_DIR"
+emit_scoreboard_json > "$SCOREBOARD_DIR/scoreboard.json"
+emit_scoreboard_md > "$SCOREBOARD_DIR/scoreboard.md"
+
+if [ "$GC_TOTAL_FAIL" -gt 0 ]; then
+  echo "$GC_TOTAL_FAIL failure(s) across $GC_TOTAL tests" >&2
+  exit 1
+fi
+echo "All $GC_TOTAL tests pass."

lib/guest/conformance.sx

@@ -0,0 +1,40 @@
+;; lib/guest/conformance.sx — shared helpers for the guest conformance driver.
+;;
+;; The bash driver lib/guest/conformance.sh loads this file and then for each
+;; suite emits an (eval "...") form whose result is a tagged list:
+;;
+;;     (gc-result NAME PASSED FAILED TOTAL)
+;;
+;; The driver greps these from sx_server's output and aggregates them.
+;;
+;; Two suite shapes are supported:
+;;
+;;   :dict     — runner expression returns a dict with :passed/:failed/:total.
+;;               (gc-dict-result "parse" (pl-parse-tests-run!))
+;;
+;;   :counters — runner has no return value, mutates pass/fail global counters.
+;;               (gc-counters-result NAME P0 F0 PASS FAIL)
+;;               where P0/F0 are the counters captured BEFORE the suite ran
+;;               and PASS/FAIL are the counters AFTER.
+
+(define
+  gc-dict-result
+  (fn
+    (name r)
+    (list
+      (quote gc-result)
+      name
+      (get r :passed)
+      (get r :failed)
+      (get r :total))))
+
+(define
+  gc-counters-result
+  (fn
+    (name p0 f0 p1 f1)
+    (list
+      (quote gc-result)
+      name
+      (- p1 p0)
+      (- f1 f0)
+      (- (+ p1 f1) (+ p0 f0)))))

lib/guest/hm.sx

@@ -0,0 +1,180 @@
+;; lib/guest/hm.sx — Hindley-Milner type-inference foundations.
+;;
+;; Builds on lib/guest/match.sx (terms + unify) and ast.sx (canonical
+;; AST shapes). This file ships the ALGEBRA — types, schemes, free
+;; type-vars, generalize / instantiate, substitution composition — so a
+;; full Algorithm W (or J) can be assembled on top either inside this
+;; file or in a host-specific consumer (haskell/infer.sx,
+;; lib/ocaml/types.sx, …).
+;;
+;; Per the brief the second consumer for this step is OCaml-on-SX
+;; Phase 5 (paired sequencing). Until that lands, the algebra is the
+;; deliverable; the host-flavoured assembly (lambda / app / let
+;; inference rules with substitution threading) lives in the host.
+;;
+;; Types
+;; -----
+;; A type is a canonical match.sx term — type variables use mk-var,
+;; type constructors use mk-ctor:
+;;   (hm-tv NAME)              type variable
+;;   (hm-arrow A B)             A -> B
+;;   (hm-con NAME ARGS)         named n-ary constructor
+;;   (hm-int) / (hm-bool) / (hm-string)   primitive constructors
+;;
+;; Schemes
+;; -------
+;;   (hm-scheme VARS TYPE)        ∀ VARS . TYPE
+;;   (hm-monotype TYPE)           empty quantifier
+;;   (hm-scheme? S) (hm-scheme-vars S) (hm-scheme-type S)
+;;
+;; Free type variables
+;; -------------------
+;;   (hm-ftv TYPE)                names occurring in TYPE
+;;   (hm-ftv-scheme S)            free names (minus quantifiers)
+;;   (hm-ftv-env ENV)             free across an env (name -> scheme)
+;;
+;; Substitution
+;; ------------
+;;   (hm-apply SUBST TYPE)        substitute through a type
+;;   (hm-apply-scheme SUBST S)    leaves bound vars alone
+;;   (hm-apply-env SUBST ENV)
+;;   (hm-compose S2 S1)           apply S1 then S2
+;;
+;; Generalize / Instantiate
+;; ------------------------
+;;   (hm-generalize TYPE ENV)      → scheme over ftv(t) - ftv(env)
+;;   (hm-instantiate SCHEME COUNTER) → fresh-var instance
+;;   (hm-fresh-tv COUNTER)         → (:var "tN"), bumps COUNTER
+;;
+;; Inference (literal only — the rest of Algorithm W lives in the host)
+;; --------------------------------------------------------------------
+;;   (hm-infer-literal EXPR)       → {:subst {} :type T}
+;;
+;; A complete Algorithm W consumes this kit by assembling lambda / app
+;; / let rules in the host language file.
+
+(define hm-tv     (fn (name) (list :var name)))
+(define hm-con    (fn (name args) (list :ctor name args)))
+(define hm-arrow  (fn (a b) (hm-con "->" (list a b))))
+(define hm-int    (fn () (hm-con "Int" (list))))
+(define hm-bool   (fn () (hm-con "Bool" (list))))
+(define hm-string (fn () (hm-con "String" (list))))
+
+(define hm-scheme        (fn (vars t) (list :scheme vars t)))
+(define hm-monotype      (fn (t) (hm-scheme (list) t)))
+(define hm-scheme?       (fn (s) (and (list? s) (not (empty? s)) (= (first s) :scheme))))
+(define hm-scheme-vars   (fn (s) (nth s 1)))
+(define hm-scheme-type   (fn (s) (nth s 2)))
+
+(define
+  hm-fresh-tv
+  (fn (counter)
+    (let ((n (first counter)))
+      (begin
+        (set-nth! counter 0 (+ n 1))
+        (hm-tv (str "t" (+ n 1)))))))
+
+(define
+  hm-ftv-acc
+  (fn (t acc)
+    (cond
+      ((is-var? t)
+        (if (some (fn (n) (= n (var-name t))) acc) acc (cons (var-name t) acc)))
+      ((is-ctor? t)
+        (let ((a acc))
+          (begin
+            (for-each (fn (x) (set! a (hm-ftv-acc x a))) (ctor-args t))
+            a)))
+      (:else acc))))
+
+(define hm-ftv (fn (t) (hm-ftv-acc t (list))))
+
+(define
+  hm-ftv-scheme
+  (fn (s)
+    (let ((qs (hm-scheme-vars s))
+          (all (hm-ftv (hm-scheme-type s))))
+      (filter (fn (n) (not (some (fn (q) (= q n)) qs))) all))))
+
+(define
+  hm-ftv-env
+  (fn (env)
+    (let ((acc (list)))
+      (begin
+        (for-each
+          (fn (k)
+            (for-each
+              (fn (n)
+                (when (not (some (fn (m) (= m n)) acc))
+                  (set! acc (cons n acc))))
+              (hm-ftv-scheme (get env k))))
+          (keys env))
+        acc))))
+
+(define hm-apply (fn (subst t) (walk* t subst)))
+
+(define
+  hm-apply-scheme
+  (fn (subst s)
+    (let ((qs (hm-scheme-vars s))
+          (d {}))
+      (begin
+        (for-each
+          (fn (k)
+            (when (not (some (fn (q) (= q k)) qs))
+              (dict-set! d k (get subst k))))
+          (keys subst))
+        (hm-scheme qs (walk* (hm-scheme-type s) d))))))
+
+(define
+  hm-apply-env
+  (fn (subst env)
+    (let ((d {}))
+      (begin
+        (for-each
+          (fn (k) (dict-set! d k (hm-apply-scheme subst (get env k))))
+          (keys env))
+        d))))
+
+(define
+  hm-compose
+  (fn (s2 s1)
+    (let ((d {}))
+      (begin
+        (for-each (fn (k) (dict-set! d k (walk* (get s1 k) s2))) (keys s1))
+        (for-each
+          (fn (k) (when (not (has-key? d k)) (dict-set! d k (get s2 k))))
+          (keys s2))
+        d))))
+
+(define
+  hm-generalize
+  (fn (t env)
+    (let ((tvars (hm-ftv t))
+          (evars (hm-ftv-env env)))
+      (let ((qs (filter (fn (n) (not (some (fn (m) (= m n)) evars))) tvars)))
+        (hm-scheme qs t)))))
+
+(define
+  hm-instantiate
+  (fn (s counter)
+    (let ((qs (hm-scheme-vars s))
+          (subst {}))
+      (begin
+        (for-each
+          (fn (q) (set! subst (assoc subst q (hm-fresh-tv counter))))
+          qs)
+        (walk* (hm-scheme-type s) subst)))))
+
+;; Literal inference — the only AST kind whose typing rule is closed
+;; in the kit. Lambda / app / let live in host code so the host's own
+;; AST conventions stay untouched.
+(define
+  hm-infer-literal
+  (fn (expr)
+    (let ((v (ast-literal-value expr)))
+      (cond
+        ((number? v)  {:subst {} :type (hm-int)})
+        ((string? v)  {:subst {} :type (hm-string)})
+        ((boolean? v) {:subst {} :type (hm-bool)})
+        (:else (error (str "hm-infer-literal: unknown kind: " v)))))))

lib/guest/layout.sx

@@ -0,0 +1,145 @@
+;; lib/guest/layout.sx — configurable off-side / layout-sensitive lexer.
+;;
+;; Inserts virtual open / close / separator tokens based on indentation.
+;; Configurable enough to encode either the Haskell 98 layout rule (let /
+;; where / do / of opens a virtual brace at the next token's column) or
+;; a Python-ish indent / dedent rule (a colon at the end of a line opens
+;; a block at the next non-blank line's column).
+;;
+;; Token shape (input + output)
+;; ----------------------------
+;; Each token is a dict {:type :value :line :col …}. The kit reads
+;; only :type / :value / :line / :col and passes everything else
+;; through. The input stream MUST be free of newline filler tokens
+;; (preprocess them away with your tokenizer) — line breaks are detected
+;; by comparing :line of consecutive tokens.
+;;
+;; Config
+;; ------
+;;   :open-keywords    list of strings; a token whose :value matches
+;;                     opens a new layout block at the next token's
+;;                     column (Haskell: let/where/do/of).
+;;   :open-trailing-fn (fn (tok) -> bool) — alternative trigger that
+;;                     fires AFTER the token is emitted. Use for
+;;                     Python-style trailing `:`.
+;;   :open-token / :close-token / :sep-token
+;;                     templates {:type :value} merged with :line and
+;;                     :col when virtual tokens are emitted.
+;;   :explicit-open?   (fn (tok) -> bool) — if the next token after a
+;;                     trigger satisfies this, suppress virtual layout
+;;                     for that block (Haskell: `{`).
+;;   :module-prelude?  if true, wrap whole input in an implicit block
+;;                     at the first token's column (Haskell yes,
+;;                     Python no).
+;;
+;; Public entry
+;; ------------
+;;   (layout-pass cfg tokens) -> tokens with virtual layout inserted.
+
+(define
+  layout-mk-virtual
+  (fn (template line col)
+    (assoc (assoc template :line line) :col col)))
+
+(define
+  layout-is-open-kw?
+  (fn (tok open-kws)
+    (and (= (get tok :type) "reserved")
+         (some (fn (k) (= k (get tok :value))) open-kws))))
+
+(define
+  layout-pass
+  (fn (cfg tokens)
+    (let ((open-kws (get cfg :open-keywords))
+          (trailing-fn (get cfg :open-trailing-fn))
+          (open-tmpl (get cfg :open-token))
+          (close-tmpl (get cfg :close-token))
+          (sep-tmpl (get cfg :sep-token))
+          (mod-prelude? (get cfg :module-prelude?))
+          (expl?-fn (get cfg :explicit-open?))
+          (out (list))
+          (stack (list))
+          (n (len tokens))
+          (i 0)
+          (prev-line -1)
+          (pending-open false)
+          (just-opened false))
+      (define
+        emit-closes-while-greater
+        (fn (col line)
+          (when (and (not (empty? stack)) (> (first stack) col))
+            (do
+              (append! out (layout-mk-virtual close-tmpl line col))
+              (set! stack (rest stack))
+              (emit-closes-while-greater col line)))))
+      (define
+        emit-pending-open
+        (fn (line col)
+          (do
+            (append! out (layout-mk-virtual open-tmpl line col))
+            (set! stack (cons col stack))
+            (set! pending-open false)
+            (set! just-opened true))))
+      (define
+        layout-step
+        (fn ()
+          (when (< i n)
+            (let ((tok (nth tokens i)))
+              (let ((line (get tok :line)) (col (get tok :col)))
+                (cond
+                  (pending-open
+                    (cond
+                      ((and (not (= expl?-fn nil)) (expl?-fn tok))
+                        (do
+                          (set! pending-open false)
+                          (append! out tok)
+                          (set! prev-line line)
+                          (set! i (+ i 1))
+                          (layout-step)))
+                      (:else
+                        (do
+                          (emit-pending-open line col)
+                          (layout-step)))))
+                  (:else
+                    (let ((on-fresh-line? (and (> prev-line 0) (> line prev-line))))
+                      (do
+                        (when on-fresh-line?
+                          (let ((stack-before stack))
+                            (begin
+                              (emit-closes-while-greater col line)
+                              (when (and (not (empty? stack))
+                                         (= (first stack) col)
+                                         (not just-opened)
+                                         ;; suppress separator if a dedent fired
+                                         ;; — the dedent is itself the separator
+                                         (= (len stack) (len stack-before)))
+                                (append! out (layout-mk-virtual sep-tmpl line col))))))
+                        (set! just-opened false)
+                        (append! out tok)
+                        (set! prev-line line)
+                        (set! i (+ i 1))
+                        (cond
+                          ((layout-is-open-kw? tok open-kws)
+                            (set! pending-open true))
+                          ((and (not (= trailing-fn nil)) (trailing-fn tok))
+                            (set! pending-open true)))
+                        (layout-step))))))))))
+      (begin
+        ;; Module prelude: implicit layout block at the first token's column.
+        (when (and mod-prelude? (> n 0))
+          (let ((tok (nth tokens 0)))
+            (do
+              (append! out (layout-mk-virtual open-tmpl (get tok :line) (get tok :col)))
+              (set! stack (cons (get tok :col) stack))
+              (set! just-opened true))))
+        (layout-step)
+        ;; EOF: close every remaining block.
+        (define close-rest
+          (fn ()
+            (when (not (empty? stack))
+              (do
+                (append! out (layout-mk-virtual close-tmpl 0 0))
+                (set! stack (rest stack))
+                (close-rest)))))
+        (close-rest)
+        out))))

lib/guest/lex.sx

@@ -0,0 +1,67 @@
+;; lib/guest/lex.sx — character-class predicates and token primitives shared
+;; across guest tokenisers.
+;;
+;; All predicates are nil-safe — they accept nil (end-of-input) and return
+;; false. This matches the convention used by the existing per-language
+;; tokenisers (cur returns nil at EOF).
+;;
+;; Char classes
+;; ------------
+;;   lex-digit?       — 0-9
+;;   lex-hex-digit?   — 0-9, a-f, A-F
+;;   lex-alpha?       — a-z, A-Z (alias: lex-letter?)
+;;   lex-alnum?       — alpha or digit
+;;   lex-ident-start? — alpha or underscore
+;;   lex-ident-char?  — ident-start or digit
+;;   lex-space?       — " ", "\t", "\r"           (no newline)
+;;   lex-whitespace?  — " ", "\t", "\r", "\n"     (includes newline)
+;;
+;; Token record
+;; ------------
+;;   (lex-make-token TYPE VALUE POS)        — {:type :value :pos}
+;;   (lex-make-token-spanning TYPE VALUE POS END)
+;;                                          — {:type :value :pos :end}
+;;   (lex-token-type TOK)
+;;   (lex-token-value TOK)
+;;   (lex-token-pos TOK)
+
+(define lex-digit? (fn (c) (and (not (= c nil)) (>= c "0") (<= c "9"))))
+
+(define
+  lex-hex-digit?
+  (fn
+    (c)
+    (and
+      (not (= c nil))
+      (or
+        (lex-digit? c)
+        (and (>= c "a") (<= c "f"))
+        (and (>= c "A") (<= c "F"))))))
+
+(define
+  lex-alpha?
+  (fn
+    (c)
+    (and
+      (not (= c nil))
+      (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))))
+
+(define lex-letter? lex-alpha?)
+
+(define lex-alnum? (fn (c) (or (lex-alpha? c) (lex-digit? c))))
+
+(define lex-ident-start? (fn (c) (or (lex-alpha? c) (= c "_"))))
+
+(define lex-ident-char? (fn (c) (or (lex-ident-start? c) (lex-digit? c))))
+
+(define lex-space? (fn (c) (or (= c " ") (= c "\t") (= c "\r"))))
+
+(define lex-whitespace? (fn (c) (or (lex-space? c) (= c "\n"))))
+
+(define lex-make-token (fn (type value pos) {:pos pos :value value :type type}))
+
+(define lex-make-token-spanning (fn (type value pos end) {:pos pos :end end :value value :type type}))
+
+(define lex-token-type (fn (tok) (get tok :type)))
+(define lex-token-value (fn (tok) (get tok :value)))
+(define lex-token-pos (fn (tok) (get tok :pos)))

lib/guest/match.sx

@@ -0,0 +1,185 @@
+;; lib/guest/match.sx — pure pattern-match + unification kit.
+;;
+;; Shipped for miniKanren / Datalog / future logic-flavoured guests that
+;; want immutable unification without writing it from scratch. The two
+;; existing prolog/haskell engines stay as-is — porting them in place
+;; risks the 746 tests they currently pass; consumers can migrate
+;; gradually via the converters in lib/guest/ast.sx.
+;;
+;; Term shapes (canonical wire format)
+;; -----------------------------------
+;;   var          (:var NAME)            NAME a string
+;;   constructor  (:ctor HEAD ARGS)      HEAD a string, ARGS a list of terms
+;;   literal      number / string / boolean / nil
+;;
+;; Guests with their own shape pass adapter callbacks via the cfg arg —
+;; see (unify-with cfg ...) and (match-pat-with cfg ...) below. The
+;; default canonical entry points (unify / match-pat) use the wire shape.
+;;
+;; Substitution / env
+;; ------------------
+;; A substitution is a SX dict mapping VAR-NAME → term. There are no
+;; trails, no mutation: each step either returns an extended dict or nil.
+;;
+;;   (empty-subst)                  → {}
+;;   (walk term s)                  → term with top-level vars resolved
+;;   (walk* term s)                 → term with all vars resolved (recursive)
+;;   (extend name term s)           → s with NAME → term added
+;;   (occurs? name term s)          → bool
+;;
+;; Unify (symmetric, miniKanren-flavour)
+;; -------------------------------------
+;;   (unify u v s)                  → extended subst or nil
+;;   (unify-with cfg u v s)         → ditto, with adapter callbacks:
+;;                                      :var? :var-name :ctor? :ctor-head
+;;                                      :ctor-args :occurs-check?
+;;
+;; Match (asymmetric, haskell-flavour: pattern → value, vars only in pat)
+;; ---------------------------------------------------------------------
+;;   (match-pat pat val env)        → extended env or nil
+;;   (match-pat-with cfg pat val env)
+
+(define mk-var  (fn (name) (list :var name)))
+(define mk-ctor (fn (head args) (list :ctor head args)))
+
+(define is-var?    (fn (t) (and (list? t) (not (empty? t)) (= (first t) :var))))
+(define is-ctor?   (fn (t) (and (list? t) (not (empty? t)) (= (first t) :ctor))))
+(define var-name   (fn (t) (nth t 1)))
+(define ctor-head  (fn (t) (nth t 1)))
+(define ctor-args  (fn (t) (nth t 2)))
+
+(define empty-subst (fn () {}))
+
+(define
+  walk
+  (fn (t s)
+    (if (and (is-var? t) (has-key? s (var-name t)))
+      (walk (get s (var-name t)) s)
+      t)))
+
+(define
+  walk*
+  (fn (t s)
+    (let ((w (walk t s)))
+      (cond
+        ((is-ctor? w)
+          (mk-ctor (ctor-head w) (map (fn (a) (walk* a s)) (ctor-args w))))
+        (:else w)))))
+
+(define
+  extend
+  (fn (name term s)
+    (assoc s name term)))
+
+(define
+  occurs?
+  (fn (name term s)
+    (let ((w (walk term s)))
+      (cond
+        ((is-var? w) (= (var-name w) name))
+        ((is-ctor? w) (some (fn (a) (occurs? name a s)) (ctor-args w)))
+        (:else false)))))
+
+(define
+  unify-with
+  (fn (cfg u v s)
+    (let ((var?-fn (get cfg :var?))
+          (var-name-fn (get cfg :var-name))
+          (ctor?-fn (get cfg :ctor?))
+          (ctor-head-fn (get cfg :ctor-head))
+          (ctor-args-fn (get cfg :ctor-args))
+          (occurs?-on (get cfg :occurs-check?)))
+      (let ((wu (walk-with cfg u s))
+            (wv (walk-with cfg v s)))
+        (cond
+          ((and (var?-fn wu) (var?-fn wv) (= (var-name-fn wu) (var-name-fn wv))) s)
+          ((var?-fn wu)
+            (if (and occurs?-on (occurs-with cfg (var-name-fn wu) wv s))
+              nil
+              (extend (var-name-fn wu) wv s)))
+          ((var?-fn wv)
+            (if (and occurs?-on (occurs-with cfg (var-name-fn wv) wu s))
+              nil
+              (extend (var-name-fn wv) wu s)))
+          ((and (ctor?-fn wu) (ctor?-fn wv))
+            (if (= (ctor-head-fn wu) (ctor-head-fn wv))
+              (unify-list-with
+                cfg
+                (ctor-args-fn wu)
+                (ctor-args-fn wv)
+                s)
+              nil))
+          (:else (if (= wu wv) s nil)))))))
+
+(define
+  walk-with
+  (fn (cfg t s)
+    (if (and ((get cfg :var?) t) (has-key? s ((get cfg :var-name) t)))
+      (walk-with cfg (get s ((get cfg :var-name) t)) s)
+      t)))
+
+(define
+  occurs-with
+  (fn (cfg name term s)
+    (let ((w (walk-with cfg term s)))
+      (cond
+        (((get cfg :var?) w) (= ((get cfg :var-name) w) name))
+        (((get cfg :ctor?) w)
+          (some (fn (a) (occurs-with cfg name a s)) ((get cfg :ctor-args) w)))
+        (:else false)))))
+
+(define
+  unify-list-with
+  (fn (cfg xs ys s)
+    (cond
+      ((and (empty? xs) (empty? ys)) s)
+      ((or (empty? xs) (empty? ys)) nil)
+      (:else
+        (let ((s2 (unify-with cfg (first xs) (first ys) s)))
+          (if (= s2 nil)
+            nil
+            (unify-list-with cfg (rest xs) (rest ys) s2)))))))
+
+(define canonical-cfg
+  {:var? is-var? :var-name var-name
+   :ctor? is-ctor? :ctor-head ctor-head :ctor-args ctor-args
+   :occurs-check? true})
+
+(define unify (fn (u v s) (unify-with canonical-cfg u v s)))
+
+;; Asymmetric pattern match (haskell-style): only patterns may contain vars;
+;; values are concrete. On a var pattern, bind name to value.
+(define
+  match-pat-with
+  (fn (cfg pat val env)
+    (let ((var?-fn (get cfg :var?))
+          (var-name-fn (get cfg :var-name))
+          (ctor?-fn (get cfg :ctor?))
+          (ctor-head-fn (get cfg :ctor-head))
+          (ctor-args-fn (get cfg :ctor-args)))
+      (cond
+        ((var?-fn pat) (extend (var-name-fn pat) val env))
+        ((and (ctor?-fn pat) (ctor?-fn val))
+          (if (= (ctor-head-fn pat) (ctor-head-fn val))
+            (match-list-pat-with
+              cfg
+              (ctor-args-fn pat)
+              (ctor-args-fn val)
+              env)
+            nil))
+        ((ctor?-fn pat) nil)
+        (:else (if (= pat val) env nil))))))
+
+(define
+  match-list-pat-with
+  (fn (cfg pats vals env)
+    (cond
+      ((and (empty? pats) (empty? vals)) env)
+      ((or (empty? pats) (empty? vals)) nil)
+      (:else
+        (let ((env2 (match-pat-with cfg (first pats) (first vals) env)))
+          (if (= env2 nil)
+            nil
+            (match-list-pat-with cfg (rest pats) (rest vals) env2)))))))
+
+(define match-pat (fn (pat val env) (match-pat-with canonical-cfg pat val env)))

lib/guest/pratt.sx

@@ -0,0 +1,28 @@
+;; lib/guest/pratt.sx — operator-table format + lookup for Pratt-style
+;; precedence climbing.
+;;
+;; The climbing loop stays per-language because the two canaries use
+;; opposite conventions (Lua: higher prec = tighter; Prolog: lower prec =
+;; tighter, with xfx/xfy/yfx assoc tags). Forcing a single loop adds
+;; callback indirection that obscures more than it shares.
+;;
+;; What IS shared and gets extracted: the operator-table format and lookup.
+;; "Grammar is a dict, not hardcoded cond."
+;;
+;; Entry shape: (NAME PREC ASSOC).
+;;   NAME   — string, the operator's source token.
+;;   PREC   — integer, in the host's own convention.
+;;   ASSOC  — :left | :right | :none for languages with traditional
+;;            associativity, or "xfx" / "xfy" / "yfx" for Prolog-style.
+
+(define
+  pratt-op-lookup
+  (fn (table name)
+    (cond
+      ((empty? table) nil)
+      ((= (first (first table)) name) (first table))
+      (:else (pratt-op-lookup (rest table) name)))))
+
+(define pratt-op-name  (fn (entry) (first entry)))
+(define pratt-op-prec  (fn (entry) (nth entry 1)))
+(define pratt-op-assoc (fn (entry) (nth entry 2)))

lib/guest/prefix.sx

@@ -0,0 +1,46 @@
+;; lib/guest/prefix.sx — prefix-rename macro.
+;;
+;; A guest runtime often re-exports a stretch of host primitives under a
+;; language-specific prefix. The prefix-rename macro replaces the repeated
+;; (define lang-foo foo) boilerplate with a single declarative call.
+;;
+;; Two entry shapes are supported:
+;;
+;;   (prefix-rename "cl-" '(gcd lcm expt floor truncate))
+;;     ;; expands to (begin (define cl-gcd gcd)
+;;     ;;                   (define cl-lcm lcm) ...)
+;;
+;;   (prefix-rename "cl-"
+;;     '((mod modulo)
+;;       (arrayp? vector?)
+;;       (ceiling ceil)))
+;;     ;; expands to (begin (define cl-mod modulo)
+;;     ;;                   (define cl-arrayp? vector?)
+;;     ;;                   (define cl-ceiling ceil))
+;;
+;; Mixed lists are supported — bare symbols are same-name aliases, two-element
+;; lists are (alias target) pairs.
+
+(defmacro
+  prefix-rename
+  (prefix entries-q)
+  (let
+    ((entries (nth entries-q 1)))
+    (cons
+      (quote begin)
+      (map
+        (fn
+          (entry)
+          (cond
+            ((= (type-of entry) "symbol")
+              (list
+                (quote define)
+                (make-symbol (str prefix (symbol-name entry)))
+                entry))
+            ((and (list? entry) (= (len entry) 2))
+              (list
+                (quote define)
+                (make-symbol (str prefix (symbol-name (first entry))))
+                (nth entry 1)))
+            (:else (error (str "prefix-rename: invalid entry " entry)))))
+        entries))))

lib/guest/tests/ast.sx

@@ -0,0 +1,63 @@
+;; lib/guest/tests/ast.sx — exercises every constructor / predicate /
+;; accessor in lib/guest/ast.sx so future ports have a stable contract
+;; to point at.
+
+(define gast-test-pass 0)
+(define gast-test-fail 0)
+(define gast-test-fails (list))
+
+(define
+  gast-test
+  (fn (name actual expected)
+    (if (= actual expected)
+      (set! gast-test-pass (+ gast-test-pass 1))
+      (begin
+        (set! gast-test-fail (+ gast-test-fail 1))
+        (append! gast-test-fails {:name name :expected expected :actual actual})))))
+
+;; Constructors round-trip.
+(gast-test "literal-int"    (ast-literal-value (ast-literal 42)) 42)
+(gast-test "literal-str"    (ast-literal-value (ast-literal "hi")) "hi")
+(gast-test "literal-bool"   (ast-literal-value (ast-literal true)) true)
+(gast-test "var-name"       (ast-var-name (ast-var "x")) "x")
+(gast-test "app-fn"         (ast-app-fn (ast-app (ast-var "f") (list (ast-literal 1)))) (ast-var "f"))
+(gast-test "app-args-len"   (len (ast-app-args (ast-app (ast-var "f") (list (ast-literal 1))))) 1)
+(gast-test "lambda-params"  (ast-lambda-params (ast-lambda (list "x" "y") (ast-var "x"))) (list "x" "y"))
+(gast-test "lambda-body"    (ast-lambda-body (ast-lambda (list "x") (ast-var "x"))) (ast-var "x"))
+(gast-test "let-bindings"   (len (ast-let-bindings (ast-let (list {:name "x" :value (ast-literal 1)}) (ast-var "x")))) 1)
+(gast-test "letrec-body"    (ast-letrec-body (ast-letrec (list) (ast-literal 0))) (ast-literal 0))
+(gast-test "if-test"        (ast-if-test (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal true))
+(gast-test "if-then"        (ast-if-then (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal 1))
+(gast-test "if-else"        (ast-if-else (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal 0))
+(gast-test "match-pattern"  (ast-match-clause-pattern (ast-match-clause "P" (ast-literal 1))) "P")
+(gast-test "match-body"     (ast-match-clause-body (ast-match-clause "P" (ast-literal 1))) (ast-literal 1))
+(gast-test "module-name"    (ast-module-name (ast-module "m" (list))) "m")
+(gast-test "import-name"    (ast-import-name (ast-import "lib/foo")) "lib/foo")
+
+;; Predicates fire only on matching kinds.
+(gast-test "is-literal"     (ast-literal? (ast-literal 1)) true)
+(gast-test "not-literal"    (ast-literal? (ast-var "x")) false)
+(gast-test "is-var"         (ast-var? (ast-var "x")) true)
+(gast-test "is-app"         (ast-app? (ast-app (ast-var "f") (list))) true)
+(gast-test "is-lambda"      (ast-lambda? (ast-lambda (list) (ast-literal 0))) true)
+(gast-test "is-let"         (ast-let? (ast-let (list) (ast-literal 0))) true)
+(gast-test "is-letrec"      (ast-letrec? (ast-letrec (list) (ast-literal 0))) true)
+(gast-test "is-if"          (ast-if? (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) true)
+(gast-test "is-match"       (ast-match-clause? (ast-match-clause "P" (ast-literal 1))) true)
+(gast-test "is-module"      (ast-module? (ast-module "m" (list))) true)
+(gast-test "is-import"      (ast-import? (ast-import "x")) true)
+
+;; ast? recognises any canonical node.
+(gast-test "ast?-literal"   (ast? (ast-literal 0)) true)
+(gast-test "ast?-foreign"   (ast? (list "lua-num" 0)) false)
+(gast-test "ast?-non-list"  (ast? 42) false)
+
+;; ast-kind dispatch.
+(gast-test "kind-literal"   (ast-kind (ast-literal 0)) :literal)
+(gast-test "kind-import"    (ast-kind (ast-import "x")) :import)
+
+(define gast-tests-run!
+  (fn ()
+    {:passed gast-test-pass
+     :failed gast-test-fail
+     :total  (+ gast-test-pass gast-test-fail)}))

lib/guest/tests/hm.sx

@@ -0,0 +1,89 @@
+;; lib/guest/tests/hm.sx — exercises lib/guest/hm.sx algebra.
+
+(define ghm-test-pass 0)
+(define ghm-test-fail 0)
+(define ghm-test-fails (list))
+
+(define
+  ghm-test
+  (fn (name actual expected)
+    (if (= actual expected)
+      (set! ghm-test-pass (+ ghm-test-pass 1))
+      (begin
+        (set! ghm-test-fail (+ ghm-test-fail 1))
+        (append! ghm-test-fails {:name name :expected expected :actual actual})))))
+
+;; ── Type constructors ─────────────────────────────────────────────
+(ghm-test "tv"           (hm-tv "a") (list :var "a"))
+(ghm-test "int"          (hm-int)    (list :ctor "Int" (list)))
+(ghm-test "arrow"        (ctor-head (hm-arrow (hm-int) (hm-bool))) "->")
+(ghm-test "arrow-args-len" (len (ctor-args (hm-arrow (hm-int) (hm-bool)))) 2)
+
+;; ── Schemes ───────────────────────────────────────────────────────
+(ghm-test "scheme-vars"  (hm-scheme-vars (hm-scheme (list "a") (hm-tv "a"))) (list "a"))
+(ghm-test "monotype-vars" (hm-scheme-vars (hm-monotype (hm-int))) (list))
+(ghm-test "scheme?-yes"  (hm-scheme? (hm-monotype (hm-int))) true)
+(ghm-test "scheme?-no"   (hm-scheme? (hm-int)) false)
+
+;; ── Fresh tyvars ──────────────────────────────────────────────────
+(ghm-test "fresh-1"
+  (let ((c (list 0))) (var-name (hm-fresh-tv c))) "t1")
+(ghm-test "fresh-bumps"
+  (let ((c (list 5))) (begin (hm-fresh-tv c) (first c))) 6)
+
+;; ── Free type variables ──────────────────────────────────────────
+(ghm-test "ftv-int"      (hm-ftv (hm-int)) (list))
+(ghm-test "ftv-tv"       (hm-ftv (hm-tv "a")) (list "a"))
+(ghm-test "ftv-arrow"
+  (len (hm-ftv (hm-arrow (hm-tv "a") (hm-arrow (hm-tv "b") (hm-tv "a"))))) 2)
+(ghm-test "ftv-scheme-quantified"
+  (hm-ftv-scheme (hm-scheme (list "a") (hm-arrow (hm-tv "a") (hm-tv "b")))) (list "b"))
+(ghm-test "ftv-env"
+  (let ((env (assoc {} "f" (hm-monotype (hm-arrow (hm-tv "x") (hm-tv "y"))))))
+    (len (hm-ftv-env env))) 2)
+
+;; ── Substitution / apply / compose ───────────────────────────────
+(ghm-test "apply-tv"
+  (hm-apply (assoc {} "a" (hm-int)) (hm-tv "a")) (hm-int))
+(ghm-test "apply-arrow"
+  (ctor-head
+    (hm-apply (assoc {} "a" (hm-int))
+              (hm-arrow (hm-tv "a") (hm-tv "b")))) "->")
+(ghm-test "compose-1-then-2"
+  (var-name
+    (hm-apply
+      (hm-compose (assoc {} "b" (hm-tv "c")) (assoc {} "a" (hm-tv "b")))
+      (hm-tv "a"))) "c")
+
+;; ── Generalize / Instantiate ─────────────────────────────────────
+;;   forall a. a -> a   instantiated twice yields fresh vars each time
+(ghm-test "generalize-id"
+  (len (hm-scheme-vars (hm-generalize (hm-arrow (hm-tv "a") (hm-tv "a")) {}))) 1)
+
+(ghm-test "generalize-skips-env"
+  ;; ftv(t)={a,b}, ftv(env)={a}, qs={b}
+  (let ((env (assoc {} "x" (hm-monotype (hm-tv "a")))))
+    (len (hm-scheme-vars
+           (hm-generalize (hm-arrow (hm-tv "a") (hm-tv "b")) env)))) 1)
+
+(ghm-test "instantiate-fresh"
+  (let ((s (hm-scheme (list "a") (hm-arrow (hm-tv "a") (hm-tv "a"))))
+        (c (list 0)))
+    (let ((t1 (hm-instantiate s c)) (t2 (hm-instantiate s c)))
+      (not (= (var-name (first (ctor-args t1)))
+              (var-name (first (ctor-args t2)))))))
+  true)
+
+;; ── Inference (literal only) ─────────────────────────────────────
+(ghm-test "infer-int"
+  (ctor-head (get (hm-infer-literal (ast-literal 42)) :type)) "Int")
+(ghm-test "infer-string"
+  (ctor-head (get (hm-infer-literal (ast-literal "hi")) :type)) "String")
+(ghm-test "infer-bool"
+  (ctor-head (get (hm-infer-literal (ast-literal true)) :type)) "Bool")
+
+(define ghm-tests-run!
+  (fn ()
+    {:passed ghm-test-pass
+     :failed ghm-test-fail
+     :total  (+ ghm-test-pass ghm-test-fail)}))

lib/guest/tests/layout.sx

@@ -0,0 +1,180 @@
+;; lib/guest/tests/layout.sx — synthetic Python-ish off-side fixture.
+;;
+;; Exercises lib/guest/layout.sx with a config different from Haskell's
+;; (no module-prelude, layout opens via trailing `:` not via reserved
+;; keyword) to prove the kit isn't Haskell-shaped.
+
+(define glayout-test-pass 0)
+(define glayout-test-fail 0)
+(define glayout-test-fails (list))
+
+(define
+  glayout-test
+  (fn (name actual expected)
+    (if (= actual expected)
+      (set! glayout-test-pass (+ glayout-test-pass 1))
+      (begin
+        (set! glayout-test-fail (+ glayout-test-fail 1))
+        (append! glayout-test-fails {:name name :expected expected :actual actual})))))
+
+;; Convenience: build a token from {type value line col}.
+(define
+  glayout-tok
+  (fn (ty val line col)
+    {:type ty :value val :line line :col col}))
+
+;; Project a token list to ((type value) ...) for compact comparison.
+(define
+  glayout-shape
+  (fn (toks)
+    (map (fn (t) (list (get t :type) (get t :value))) toks)))
+
+;; ── Haskell-flavour: keyword opens block ─────────────────────────
+(define
+  glayout-haskell-cfg
+  {:open-keywords (list "let" "where" "do" "of")
+   :open-trailing-fn nil
+   :open-token   {:type "vlbrace" :value "{"}
+   :close-token  {:type "vrbrace" :value "}"}
+   :sep-token    {:type "vsemi"   :value ";"}
+   :module-prelude? false
+   :explicit-open? (fn (tok) (= (get tok :type) "lbrace"))})
+
+;;   do
+;;     a
+;;     b
+;;   c       ← outside the do-block
+(glayout-test "haskell-do-block"
+  (glayout-shape
+    (layout-pass
+      glayout-haskell-cfg
+      (list (glayout-tok "reserved" "do" 1 1)
+            (glayout-tok "ident" "a" 2 3)
+            (glayout-tok "ident" "b" 3 3)
+            (glayout-tok "ident" "c" 4 1))))
+  (list (list "reserved" "do")
+        (list "vlbrace" "{")
+        (list "ident" "a")
+        (list "vsemi" ";")
+        (list "ident" "b")
+        (list "vrbrace" "}")
+        (list "ident" "c")))
+
+;; Explicit `{` after `do` suppresses virtual layout.
+(glayout-test "haskell-explicit-brace"
+  (glayout-shape
+    (layout-pass
+      glayout-haskell-cfg
+      (list (glayout-tok "reserved" "do" 1 1)
+            (glayout-tok "lbrace" "{" 1 4)
+            (glayout-tok "ident" "a" 1 6)
+            (glayout-tok "rbrace" "}" 1 8))))
+  (list (list "reserved" "do")
+        (list "lbrace" "{")
+        (list "ident" "a")
+        (list "rbrace" "}")))
+
+;; Single-statement do-block on the same line.
+(glayout-test "haskell-do-inline"
+  (glayout-shape
+    (layout-pass
+      glayout-haskell-cfg
+      (list (glayout-tok "reserved" "do" 1 1)
+            (glayout-tok "ident" "a" 1 4))))
+  (list (list "reserved" "do")
+        (list "vlbrace" "{")
+        (list "ident" "a")
+        (list "vrbrace" "}")))
+
+;; Module-prelude: wrap whole input in implicit layout block at first
+;; tok's column.
+(glayout-test "haskell-module-prelude"
+  (glayout-shape
+    (layout-pass
+      (assoc glayout-haskell-cfg :module-prelude? true)
+      (list (glayout-tok "ident" "x" 1 1)
+            (glayout-tok "ident" "y" 2 1)
+            (glayout-tok "ident" "z" 3 1))))
+  (list (list "vlbrace" "{")
+        (list "ident" "x")
+        (list "vsemi" ";")
+        (list "ident" "y")
+        (list "vsemi" ";")
+        (list "ident" "z")
+        (list "vrbrace" "}")))
+
+;; ── Python-flavour: trailing `:` opens block ─────────────────────
+(define
+  glayout-python-cfg
+  {:open-keywords (list)
+   :open-trailing-fn (fn (tok) (and (= (get tok :type) "punct")
+                                    (= (get tok :value) ":")))
+   :open-token   {:type "indent" :value "INDENT"}
+   :close-token  {:type "dedent" :value "DEDENT"}
+   :sep-token    {:type "newline" :value "NEWLINE"}
+   :module-prelude? false
+   :explicit-open? nil})
+
+;;   if x:
+;;       a
+;;       b
+;;   c
+(glayout-test "python-if-block"
+  (glayout-shape
+    (layout-pass
+      glayout-python-cfg
+      (list (glayout-tok "reserved" "if" 1 1)
+            (glayout-tok "ident" "x" 1 4)
+            (glayout-tok "punct" ":" 1 5)
+            (glayout-tok "ident" "a" 2 5)
+            (glayout-tok "ident" "b" 3 5)
+            (glayout-tok "ident" "c" 4 1))))
+  (list (list "reserved" "if")
+        (list "ident" "x")
+        (list "punct" ":")
+        (list "indent" "INDENT")
+        (list "ident" "a")
+        (list "newline" "NEWLINE")
+        (list "ident" "b")
+        (list "dedent" "DEDENT")
+        (list "ident" "c")))
+
+;; Nested Python-style blocks.
+;;   def f():
+;;       if x:
+;;           a
+;;       b
+(glayout-test "python-nested"
+  (glayout-shape
+    (layout-pass
+      glayout-python-cfg
+      (list (glayout-tok "reserved" "def" 1 1)
+            (glayout-tok "ident" "f" 1 5)
+            (glayout-tok "punct" "(" 1 6)
+            (glayout-tok "punct" ")" 1 7)
+            (glayout-tok "punct" ":" 1 8)
+            (glayout-tok "reserved" "if" 2 5)
+            (glayout-tok "ident" "x" 2 8)
+            (glayout-tok "punct" ":" 2 9)
+            (glayout-tok "ident" "a" 3 9)
+            (glayout-tok "ident" "b" 4 5))))
+  (list (list "reserved" "def")
+        (list "ident" "f")
+        (list "punct" "(")
+        (list "punct" ")")
+        (list "punct" ":")
+        (list "indent" "INDENT")
+        (list "reserved" "if")
+        (list "ident" "x")
+        (list "punct" ":")
+        (list "indent" "INDENT")
+        (list "ident" "a")
+        (list "dedent" "DEDENT")
+        (list "ident" "b")
+        (list "dedent" "DEDENT")))
+
+(define glayout-tests-run!
+  (fn ()
+    {:passed glayout-test-pass
+     :failed glayout-test-fail
+     :total  (+ glayout-test-pass glayout-test-fail)}))

lib/guest/tests/match.sx

@@ -0,0 +1,108 @@
+;; lib/guest/tests/match.sx — exercises lib/guest/match.sx.
+
+(define gmatch-test-pass 0)
+(define gmatch-test-fail 0)
+(define gmatch-test-fails (list))
+
+(define
+  gmatch-test
+  (fn (name actual expected)
+    (if (= actual expected)
+      (set! gmatch-test-pass (+ gmatch-test-pass 1))
+      (begin
+        (set! gmatch-test-fail (+ gmatch-test-fail 1))
+        (append! gmatch-test-fails {:name name :expected expected :actual actual})))))
+
+;; ── walk / extend / occurs ────────────────────────────────────────
+(gmatch-test "walk-direct"
+  (walk (mk-var "x") (extend "x" 5 (empty-subst))) 5)
+
+(gmatch-test "walk-chain"
+  (walk (mk-var "a") (extend "a" (mk-var "b") (extend "b" 7 (empty-subst)))) 7)
+
+(gmatch-test "walk-no-binding"
+  (let ((v (mk-var "u"))) (= (walk v (empty-subst)) v)) true)
+
+(gmatch-test "walk*-recursive"
+  (walk* (mk-ctor "Just" (list (mk-var "x"))) (extend "x" 9 (empty-subst)))
+  (mk-ctor "Just" (list 9)))
+
+(gmatch-test "occurs-direct"
+  (occurs? "x" (mk-var "x") (empty-subst)) true)
+
+(gmatch-test "occurs-nested"
+  (occurs? "x" (mk-ctor "f" (list (mk-var "x"))) (empty-subst)) true)
+
+(gmatch-test "occurs-not"
+  (occurs? "x" (mk-var "y") (empty-subst)) false)
+
+;; ── unify (symmetric) ─────────────────────────────────────────────
+(gmatch-test "unify-equal-literals"
+  (len (unify 5 5 (empty-subst))) 0)
+
+(gmatch-test "unify-different-literals"
+  (unify 5 6 (empty-subst)) nil)
+
+(gmatch-test "unify-var-literal"
+  (get (unify (mk-var "x") 5 (empty-subst)) "x") 5)
+
+(gmatch-test "unify-literal-var"
+  (get (unify 5 (mk-var "x") (empty-subst)) "x") 5)
+
+(gmatch-test "unify-same-var"
+  (len (unify (mk-var "x") (mk-var "x") (empty-subst))) 0)
+
+(gmatch-test "unify-two-vars"
+  (let ((s (unify (mk-var "x") (mk-var "y") (empty-subst))))
+    (or (= (get s "x") (mk-var "y")) (= (get s "y") (mk-var "x")))) true)
+
+(gmatch-test "unify-ctor-equal"
+  (len (unify (mk-ctor "f" (list 1 2)) (mk-ctor "f" (list 1 2)) (empty-subst))) 0)
+
+(gmatch-test "unify-ctor-with-var"
+  (get (unify (mk-ctor "Just" (list (mk-var "x"))) (mk-ctor "Just" (list 7)) (empty-subst)) "x") 7)
+
+(gmatch-test "unify-ctor-head-mismatch"
+  (unify (mk-ctor "Just" (list 1)) (mk-ctor "Nothing" (list)) (empty-subst)) nil)
+
+(gmatch-test "unify-ctor-arity-mismatch"
+  (unify (mk-ctor "f" (list 1 2)) (mk-ctor "f" (list 1)) (empty-subst)) nil)
+
+(gmatch-test "unify-occurs-check"
+  (unify (mk-var "x") (mk-ctor "f" (list (mk-var "x"))) (empty-subst)) nil)
+
+(gmatch-test "unify-transitive-vars"
+  (let ((s (unify (mk-var "x") (mk-var "y") (empty-subst))))
+    (let ((s2 (unify (mk-var "y") 42 s)))
+      (walk (mk-var "x") s2))) 42)
+
+;; ── match-pat (asymmetric) ────────────────────────────────────────
+(gmatch-test "match-var-binds"
+  (get (match-pat (mk-var "x") 99 (empty-subst)) "x") 99)
+
+(gmatch-test "match-literal-equal"
+  (len (match-pat 5 5 (empty-subst))) 0)
+
+(gmatch-test "match-literal-mismatch"
+  (match-pat 5 6 (empty-subst)) nil)
+
+(gmatch-test "match-ctor-binds"
+  (get (match-pat (mk-ctor "Just" (list (mk-var "y")))
+                  (mk-ctor "Just" (list 11))
+                  (empty-subst)) "y") 11)
+
+(gmatch-test "match-ctor-head-mismatch"
+  (match-pat (mk-ctor "Just" (list (mk-var "y")))
+             (mk-ctor "Nothing" (list))
+             (empty-subst)) nil)
+
+(gmatch-test "match-ctor-arity-mismatch"
+  (match-pat (mk-ctor "f" (list (mk-var "x") (mk-var "y")))
+             (mk-ctor "f" (list 1))
+             (empty-subst)) nil)
+
+(define gmatch-tests-run!
+  (fn ()
+    {:passed gmatch-test-pass
+     :failed gmatch-test-fail
+     :total  (+ gmatch-test-pass gmatch-test-fail)}))

lib/haskell/conformance.conf

@@ -0,0 +1,96 @@
+# Haskell-on-SX conformance config — sourced by lib/guest/conformance.sh.
+
+LANG_NAME=haskell
+MODE=counters
+COUNTERS_PASS=hk-test-pass
+COUNTERS_FAIL=hk-test-fail
+TIMEOUT_PER_SUITE=120
+
+PRELOADS=(
+  lib/haskell/tokenizer.sx
+  lib/haskell/layout.sx
+  lib/haskell/parser.sx
+  lib/haskell/desugar.sx
+  lib/haskell/runtime.sx
+  lib/haskell/match.sx
+  lib/haskell/eval.sx
+  lib/haskell/map.sx
+  lib/haskell/set.sx
+  lib/haskell/testlib.sx
+)
+
+SUITES=(
+  "fib:lib/haskell/tests/program-fib.sx"
+  "sieve:lib/haskell/tests/program-sieve.sx"
+  "quicksort:lib/haskell/tests/program-quicksort.sx"
+  "nqueens:lib/haskell/tests/program-nqueens.sx"
+  "calculator:lib/haskell/tests/program-calculator.sx"
+  "collatz:lib/haskell/tests/program-collatz.sx"
+  "palindrome:lib/haskell/tests/program-palindrome.sx"
+  "maybe:lib/haskell/tests/program-maybe.sx"
+  "fizzbuzz:lib/haskell/tests/program-fizzbuzz.sx"
+  "anagram:lib/haskell/tests/program-anagram.sx"
+  "roman:lib/haskell/tests/program-roman.sx"
+  "binary:lib/haskell/tests/program-binary.sx"
+  "either:lib/haskell/tests/program-either.sx"
+  "primes:lib/haskell/tests/program-primes.sx"
+  "zipwith:lib/haskell/tests/program-zipwith.sx"
+  "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() {
+  local n=${#GC_NAMES[@]} i sep date_only
+  date_only=$(date '+%Y-%m-%d')
+  printf '{\n'
+  printf '  "date": "%s",\n' "$date_only"
+  printf '  "total_pass": %d,\n' "$GC_TOTAL_PASS"
+  printf '  "total_fail": %d,\n' "$GC_TOTAL_FAIL"
+  printf '  "programs": {\n'
+  for ((i=0; i<n; i++)); do
+    sep=","; [ $i -eq $((n-1)) ] && sep=""
+    printf '    "%s": {"pass": %d, "fail": %d}%s\n' \
+      "${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_FAIL[$i]}" "$sep"
+  done
+  printf '  }\n'
+  printf '}\n'
+}
+
+emit_scoreboard_md() {
+  local n=${#GC_NAMES[@]}
+  local i status p f t prog_pass=0 prog_total=$n date_only
+  date_only=$(date '+%Y-%m-%d')
+  for ((i=0; i<n; i++)); do
+    [ "${GC_FAIL[$i]}" -eq 0 ] && prog_pass=$((prog_pass + 1))
+  done
+  printf '# Haskell-on-SX Scoreboard\n\n'
+  printf 'Updated %s · Phase 6 (prelude extras + 18 programs)\n\n' "$date_only"
+  printf '| Program | Tests | Status |\n'
+  printf '|---------|-------|--------|\n'
+  for ((i=0; i<n; i++)); do
+    p=${GC_PASS[$i]}; f=${GC_FAIL[$i]}; t=${GC_TOTAL_S[$i]}
+    [ "$f" -eq 0 ] && status="✓" || status="✗"
+    printf '| %s.hs | %d/%d | %s |\n' "${GC_NAMES[$i]}" "$p" "$t" "$status"
+  done
+  printf '| **Total** | **%d/%d** | **%d/%d programs** |\n' \
+    "$GC_TOTAL_PASS" "$GC_TOTAL" "$prog_pass" "$prog_total"
+}

lib/haskell/conformance.sh

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

lib/haskell/desugar.sx

@@ -0,0 +1,410 @@
+;; Desugar the Haskell surface AST into a smaller core AST.
+;;
+;; Eliminates the three surface-only shapes produced by the parser:
+;;   :where BODY DECLS     →  :let DECLS BODY
+;;   :guarded GUARDS       →  :if C1 E1 (:if C2 E2 … (:app error …))
+;;   :list-comp EXPR QUALS →  concatMap-based expression (§3.11)
+;;
+;; Everything else (:app, :op, :lambda, :let, :case, :do, :tuple,
+;; :list, :range, :if, :neg, :sect-left / :sect-right, plus all
+;; leaf forms and pattern / type nodes) is passed through after
+;; recursing into children.
+
+(define
+  hk-guards-to-if
+  (fn
+    (guards)
+    (cond
+      ((empty? guards)
+        (list
+          :app
+          (list :var "error")
+          (list :string "Non-exhaustive guards")))
+      (:else
+        (let
+          ((g (first guards)))
+          (list
+            :if
+            (hk-desugar (nth g 1))
+            (hk-desugar (nth g 2))
+            (hk-guards-to-if (rest guards))))))))
+
+;; do-notation desugaring (Haskell 98 §3.14):
+;;   do { e }              =  e
+;;   do { e ; ss }         =  e >> do { ss }
+;;   do { p <- e ; ss }    =  e >>= \p -> do { ss }
+;;   do { let decls ; ss } =  let decls in do { ss }
+(define
+  hk-desugar-do
+  (fn
+    (stmts)
+    (cond
+      ((empty? stmts) (raise "empty do block"))
+      ((empty? (rest stmts))
+        (let ((s (first stmts)))
+          (cond
+            ((= (first s) "do-expr") (hk-desugar (nth s 1)))
+            (:else
+              (raise "do block must end with an expression")))))
+      (:else
+        (let
+          ((s (first stmts)) (rest-stmts (rest stmts)))
+          (let
+            ((rest-do (hk-desugar-do rest-stmts)))
+            (cond
+              ((= (first s) "do-expr")
+                (list
+                  :app
+                  (list
+                    :app
+                    (list :var ">>")
+                    (hk-desugar (nth s 1)))
+                  rest-do))
+              ((= (first s) "do-bind")
+                (list
+                  :app
+                  (list
+                    :app
+                    (list :var ">>=")
+                    (hk-desugar (nth s 2)))
+                  (list :lambda (list (nth s 1)) rest-do)))
+              ((= (first s) "do-let")
+                (list
+                  :let
+                  (map hk-desugar (nth s 1))
+                  rest-do))
+              (:else (raise "unknown do-stmt tag")))))))))
+
+;; List-comprehension desugaring (Haskell 98 §3.11):
+;;   [e |             ]  =  [e]
+;;   [e | b,     Q    ]  =  if b then [e | Q] else []
+;;   [e | p <- l, Q    ]  =  concatMap (\p -> [e | Q]) l
+;;   [e | let ds, Q    ]  =  let ds in [e | Q]
+(define
+  hk-lc-desugar
+  (fn
+    (e quals)
+    (cond
+      ((empty? quals) (list :list (list e)))
+      (:else
+        (let
+          ((q (first quals)))
+          (let
+            ((qtag (first q)))
+            (cond
+              ((= qtag "q-guard")
+                (list
+                  :if
+                  (hk-desugar (nth q 1))
+                  (hk-lc-desugar e (rest quals))
+                  (list :list (list))))
+              ((= qtag "q-gen")
+                (list
+                  :app
+                  (list
+                    :app
+                    (list :var "concatMap")
+                    (list
+                      :lambda
+                      (list (nth q 1))
+                      (hk-lc-desugar e (rest quals))))
+                  (hk-desugar (nth q 2))))
+              ((= qtag "q-let")
+                (list
+                  :let
+                  (map hk-desugar (nth q 1))
+                  (hk-lc-desugar e (rest quals))))
+              (:else
+                (raise
+                  (str
+                    "hk-lc-desugar: unknown qualifier tag "
+                    qtag))))))))))
+
+(define
+  hk-desugar
+  (fn
+    (node)
+    (cond
+      ((not (list? node)) node)
+      ((empty? node) node)
+      (:else
+        (let
+          ((tag (first node)))
+          (cond
+            ((= tag "where")
+              (list
+                :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)))
+            ((= tag "app")
+              (list
+                :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)
+                (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))
+                (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 "range")
+              (list
+                :range (hk-desugar (nth node 1))
+                (hk-desugar (nth node 2))))
+            ((= tag "range-step")
+              (list
+                :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))))
+            ((= tag "let")
+              (list
+                :let (map hk-desugar (nth node 1))
+                (hk-desugar (nth node 2))))
+            ((= tag "case")
+              (list
+                :case (hk-desugar (nth node 1))
+                (map hk-desugar (nth node 2))))
+            ((= tag "alt")
+              (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))))
+            ((= tag "sect-right")
+              (list :sect-right (nth node 1) (hk-desugar (nth node 2))))
+            ((= tag "program")
+              (list :program (map hk-desugar (hk-expand-records (nth node 1)))))
+            ((= tag "module")
+              (list
+                :module (nth node 1)
+                (nth node 2)
+                (nth node 3)
+                (map hk-desugar (hk-expand-records (nth node 4)))))
+            ((= tag "fun-clause")
+              (list
+                :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))))
+            ((= tag "bind")
+              (list :bind (nth node 1) (hk-desugar (nth node 2))))
+            (:else node)))))))
+
+;; Convenience — tokenize + layout + parse + desugar.
+(define hk-record-fields (dict))
+
+(define
+  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/infer.sx

@@ -0,0 +1,658 @@
+;; infer.sx — Hindley-Milner Algorithm W for Haskell-on-SX (Phase 4).
+;;
+;; Types: TVar, TCon, TArr, TApp, TTuple, TScheme
+;; Substitution: apply, compose, restrict
+;; Unification (with occurs check)
+;; Instantiation + generalization (let-polymorphism)
+;; Algorithm W for: literals, var, con, lambda, app, let, if, op, tuple, list
+
+;; ─── Type constructors ────────────────────────────────────────────────────────
+
+(define hk-tvar (fn (n) (list "TVar" n)))
+(define hk-tcon (fn (s) (list "TCon" s)))
+(define hk-tarr (fn (a b) (list "TArr" a b)))
+(define hk-tapp (fn (a b) (list "TApp" a b)))
+(define hk-ttuple (fn (ts) (list "TTuple" ts)))
+(define hk-tscheme (fn (vs t) (list "TScheme" vs t)))
+
+(define hk-tvar? (fn (t) (and (list? t) (not (empty? t)) (= (first t) "TVar"))))
+(define hk-tcon? (fn (t) (and (list? t) (not (empty? t)) (= (first t) "TCon"))))
+(define hk-tarr? (fn (t) (and (list? t) (not (empty? t)) (= (first t) "TArr"))))
+(define hk-tapp? (fn (t) (and (list? t) (not (empty? t)) (= (first t) "TApp"))))
+(define hk-ttuple? (fn (t) (and (list? t) (not (empty? t)) (= (first t) "TTuple"))))
+(define hk-tscheme? (fn (t) (and (list? t) (not (empty? t)) (= (first t) "TScheme"))))
+
+(define hk-tvar-name (fn (t) (nth t 1)))
+(define hk-tcon-name (fn (t) (nth t 1)))
+(define hk-tarr-t1 (fn (t) (nth t 1)))
+(define hk-tarr-t2 (fn (t) (nth t 2)))
+(define hk-tapp-t1 (fn (t) (nth t 1)))
+(define hk-tapp-t2 (fn (t) (nth t 2)))
+(define hk-ttuple-ts (fn (t) (nth t 1)))
+(define hk-tscheme-vs (fn (t) (nth t 1)))
+(define hk-tscheme-type (fn (t) (nth t 2)))
+
+(define hk-t-int    (hk-tcon "Int"))
+(define hk-t-bool   (hk-tcon "Bool"))
+(define hk-t-string (hk-tcon "String"))
+(define hk-t-char   (hk-tcon "Char"))
+(define hk-t-float  (hk-tcon "Float"))
+(define hk-t-list (fn (t) (hk-tapp (hk-tcon "[]") t)))
+
+;; ─── Type formatter ──────────────────────────────────────────────────────────
+
+(define
+  hk-type->str
+  (fn
+    (t)
+    (cond
+      ((hk-tvar? t)   (hk-tvar-name t))
+      ((hk-tcon? t)   (hk-tcon-name t))
+      ((hk-tarr? t)
+       (let ((s1 (if (hk-tarr? (hk-tarr-t1 t))
+                   (str "(" (hk-type->str (hk-tarr-t1 t)) ")")
+                   (hk-type->str (hk-tarr-t1 t)))))
+         (str s1 " -> " (hk-type->str (hk-tarr-t2 t)))))
+      ((hk-tapp? t)
+       (let ((h (hk-tapp-t1 t)))
+         (cond
+           ((and (hk-tcon? h) (= (hk-tcon-name h) "[]"))
+            (str "[" (hk-type->str (hk-tapp-t2 t)) "]"))
+           (:else
+            (str "(" (hk-type->str h) " " (hk-type->str (hk-tapp-t2 t)) ")")))))
+      ((hk-ttuple? t)
+       (str "(" (join ", " (map hk-type->str (hk-ttuple-ts t))) ")"))
+      ((hk-tscheme? t)
+       (str "forall " (join " " (hk-tscheme-vs t)) ". " (hk-type->str (hk-tscheme-type t))))
+      (:else "<?>"))))
+
+;; ─── Fresh variable counter ───────────────────────────────────────────────────
+
+(define hk-fresh-ctr 0)
+(define hk-fresh (fn () (set! hk-fresh-ctr (+ hk-fresh-ctr 1)) (hk-tvar (str "t" hk-fresh-ctr))))
+(define hk-reset-fresh (fn () (set! hk-fresh-ctr 0)))
+
+;; ─── Utilities ───────────────────────────────────────────────────────────────
+
+(define hk-infer-member? (fn (x lst) (some (fn (y) (= x y)) lst)))
+
+(define
+  hk-nub
+  (fn (lst)
+    (reduce (fn (acc x) (if (hk-infer-member? x acc) acc (append acc (list x)))) (list) lst)))
+
+;; ─── Free type variables ──────────────────────────────────────────────────────
+
+(define
+  hk-ftv
+  (fn
+    (t)
+    (cond
+      ((hk-tvar? t)    (list (hk-tvar-name t)))
+      ((hk-tcon? t)    (list))
+      ((hk-tarr? t)    (append (hk-ftv (hk-tarr-t1 t)) (hk-ftv (hk-tarr-t2 t))))
+      ((hk-tapp? t)    (append (hk-ftv (hk-tapp-t1 t)) (hk-ftv (hk-tapp-t2 t))))
+      ((hk-ttuple? t)  (reduce append (list) (map hk-ftv (hk-ttuple-ts t))))
+      ((hk-tscheme? t)
+       (filter
+         (fn (v) (not (hk-infer-member? v (hk-tscheme-vs t))))
+         (hk-ftv (hk-tscheme-type t))))
+      (:else (list)))))
+
+(define
+  hk-ftv-env
+  (fn (env)
+    (reduce (fn (acc k) (append acc (hk-ftv (get env k)))) (list) (keys env))))
+
+;; ─── Substitution ─────────────────────────────────────────────────────────────
+
+(define hk-subst-empty (dict))
+
+(define
+  hk-subst-restrict
+  (fn
+    (s exclude)
+    (let ((r (dict)))
+      (for-each
+        (fn (k)
+          (when (not (hk-infer-member? k exclude))
+            (dict-set! r k (get s k))))
+        (keys s))
+      r)))
+
+(define
+  hk-subst-apply
+  (fn
+    (s t)
+    (cond
+      ((hk-tvar? t)
+       (let ((v (get s (hk-tvar-name t))))
+         (if (nil? v) t (hk-subst-apply s v))))
+      ((hk-tarr? t)
+       (hk-tarr (hk-subst-apply s (hk-tarr-t1 t))
+                (hk-subst-apply s (hk-tarr-t2 t))))
+      ((hk-tapp? t)
+       (hk-tapp (hk-subst-apply s (hk-tapp-t1 t))
+                (hk-subst-apply s (hk-tapp-t2 t))))
+      ((hk-ttuple? t)
+       (hk-ttuple (map (fn (u) (hk-subst-apply s u)) (hk-ttuple-ts t))))
+      ((hk-tscheme? t)
+       (let ((s2 (hk-subst-restrict s (hk-tscheme-vs t))))
+         (hk-tscheme (hk-tscheme-vs t)
+                     (hk-subst-apply s2 (hk-tscheme-type t)))))
+      (:else t))))
+
+(define
+  hk-subst-compose
+  (fn
+    (s2 s1)
+    (let ((r (hk-dict-copy s2)))
+      (for-each
+        (fn (k)
+          (when (nil? (get r k))
+            (dict-set! r k (hk-subst-apply s2 (get s1 k)))))
+        (keys s1))
+      r)))
+
+(define
+  hk-env-apply-subst
+  (fn
+    (s env)
+    (let ((r (dict)))
+      (for-each (fn (k) (dict-set! r k (hk-subst-apply s (get env k)))) (keys env))
+      r)))
+
+;; ─── Unification ─────────────────────────────────────────────────────────────
+
+(define
+  hk-bind-var
+  (fn
+    (v t)
+    (cond
+      ((and (hk-tvar? t) (= (hk-tvar-name t) v))
+       hk-subst-empty)
+      ((hk-infer-member? v (hk-ftv t))
+       (raise (str "Occurs check failed: " v " in " (hk-type->str t))))
+      (:else
+       (let ((s (dict)))
+         (dict-set! s v t)
+         s)))))
+
+(define
+  hk-zip-unify
+  (fn
+    (ts1 ts2 acc)
+    (if (or (empty? ts1) (empty? ts2))
+      acc
+      (let ((s (hk-unify (hk-subst-apply acc (first ts1))
+                         (hk-subst-apply acc (first ts2)))))
+        (hk-zip-unify (rest ts1) (rest ts2) (hk-subst-compose s acc))))))
+
+(define
+  hk-unify
+  (fn
+    (t1 t2)
+    (cond
+      ((and (hk-tvar? t1) (hk-tvar? t2) (= (hk-tvar-name t1) (hk-tvar-name t2)))
+       hk-subst-empty)
+      ((hk-tvar? t1) (hk-bind-var (hk-tvar-name t1) t2))
+      ((hk-tvar? t2) (hk-bind-var (hk-tvar-name t2) t1))
+      ((and (hk-tcon? t1) (hk-tcon? t2) (= (hk-tcon-name t1) (hk-tcon-name t2)))
+       hk-subst-empty)
+      ((and (hk-tarr? t1) (hk-tarr? t2))
+       (let ((s1 (hk-unify (hk-tarr-t1 t1) (hk-tarr-t1 t2))))
+         (let ((s2 (hk-unify (hk-subst-apply s1 (hk-tarr-t2 t1))
+                             (hk-subst-apply s1 (hk-tarr-t2 t2)))))
+           (hk-subst-compose s2 s1))))
+      ((and (hk-tapp? t1) (hk-tapp? t2))
+       (let ((s1 (hk-unify (hk-tapp-t1 t1) (hk-tapp-t1 t2))))
+         (let ((s2 (hk-unify (hk-subst-apply s1 (hk-tapp-t2 t1))
+                             (hk-subst-apply s1 (hk-tapp-t2 t2)))))
+           (hk-subst-compose s2 s1))))
+      ((and (hk-ttuple? t1) (hk-ttuple? t2)
+            (= (length (hk-ttuple-ts t1)) (length (hk-ttuple-ts t2))))
+       (hk-zip-unify (hk-ttuple-ts t1) (hk-ttuple-ts t2) hk-subst-empty))
+      (:else
+       (raise (str "Cannot unify " (hk-type->str t1) " with " (hk-type->str t2)))))))
+
+;; ─── Instantiation and generalization ────────────────────────────────────────
+
+(define
+  hk-instantiate
+  (fn
+    (t)
+    (if (not (hk-tscheme? t))
+      t
+      (let ((s (dict)))
+        (for-each (fn (v) (dict-set! s v (hk-fresh))) (hk-tscheme-vs t))
+        (hk-subst-apply s (hk-tscheme-type t))))))
+
+(define
+  hk-generalize
+  (fn
+    (env t)
+    (let ((free-t   (hk-nub (hk-ftv t)))
+          (free-env (hk-nub (hk-ftv-env env))))
+      (let ((bound (filter (fn (v) (not (hk-infer-member? v free-env))) free-t)))
+        (if (empty? bound)
+          t
+          (hk-tscheme bound t))))))
+
+;; ─── Pattern binding extraction ──────────────────────────────────────────────
+;; Returns a dict of name → type bindings introduced by matching pat against tv.
+
+(define
+  hk-w-pat
+  (fn
+    (pat tv)
+    (let ((tag (first pat)))
+      (cond
+        ((= tag "p-var")  (let ((d (dict))) (dict-set! d (nth pat 1) tv) d))
+        ((= tag "p-wild") (dict))
+        (:else            (dict))))))
+
+;; ─── Algorithm W ─────────────────────────────────────────────────────────────
+;; hk-w : env × expr → (list subst type)
+
+(define
+  hk-w-let
+  (fn
+    (env binds body)
+    ;; Infer types for each binding in order, generalising at each step.
+    (let
+      ((env2
+        (reduce
+          (fn
+            (cur-env b)
+            (let ((tag (first b)))
+              (cond
+                ;; Simple pattern binding: let x = expr
+                ((or (= tag "bind") (= tag "pat-bind"))
+                 (let ((pat  (nth b 1))
+                       (rhs  (nth b 2)))
+                   (let ((tv (hk-fresh)))
+                     (let ((r (hk-w cur-env rhs)))
+                       (let ((s1 (first r)) (t1 (nth r 1)))
+                         (let ((s2 (hk-unify (hk-subst-apply s1 tv) t1)))
+                           (let ((s (hk-subst-compose s2 s1)))
+                             (let ((t-gen (hk-generalize (hk-env-apply-subst s cur-env)
+                                                         (hk-subst-apply s t1))))
+                               (let ((bindings (hk-w-pat pat t-gen)))
+                                 (let ((r2 (hk-dict-copy cur-env)))
+                                   (for-each
+                                     (fn (k) (dict-set! r2 k (get bindings k)))
+                                     (keys bindings))
+                                   r2))))))))))
+                ;; Function clause: let f x y = expr
+                ((= tag "fun-clause")
+                 (let ((name (nth b 1))
+                       (pats (nth b 2))
+                       (body2 (nth b 3)))
+                   ;; Treat as: let name = lambda pats body2
+                   (let ((rhs (if (empty? pats)
+                                body2
+                                (list "lambda" pats body2))))
+                     (let ((tv (hk-fresh)))
+                       (let ((env-rec (hk-dict-copy cur-env)))
+                         (dict-set! env-rec name tv)
+                         (let ((r (hk-w env-rec rhs)))
+                           (let ((s1 (first r)) (t1 (nth r 1)))
+                             (let ((s2 (hk-unify (hk-subst-apply s1 tv) t1)))
+                               (let ((s (hk-subst-compose s2 s1)))
+                                 (let ((t-gen (hk-generalize
+                                                (hk-env-apply-subst s cur-env)
+                                                (hk-subst-apply s t1))))
+                                   (let ((r2 (hk-dict-copy cur-env)))
+                                     (dict-set! r2 name t-gen)
+                                     r2)))))))))))
+                (:else cur-env))))
+          env
+          binds)))
+      (hk-w env2 body))))
+
+(define
+  hk-w
+  (fn
+    (env expr)
+    (let ((tag (first expr)))
+      (cond
+        ;; Literals
+        ((= tag "int")    (list hk-subst-empty hk-t-int))
+        ((= tag "float")  (list hk-subst-empty hk-t-float))
+        ((= tag "string") (list hk-subst-empty hk-t-string))
+        ((= tag "char")   (list hk-subst-empty hk-t-char))
+
+        ;; Variable
+        ((= tag "var")
+         (let ((name (nth expr 1)))
+           (let ((scheme (get env name)))
+             (if (nil? scheme)
+               (raise (str "Unbound variable: " name))
+               (list hk-subst-empty (hk-instantiate scheme))))))
+
+        ;; Constructor (same lookup as var)
+        ((= tag "con")
+         (let ((name (nth expr 1)))
+           (let ((scheme (get env name)))
+             (if (nil? scheme)
+               (list hk-subst-empty (hk-fresh))
+               (list hk-subst-empty (hk-instantiate scheme))))))
+
+        ;; Unary negation
+        ((= tag "neg")
+         (let ((r (hk-w env (nth expr 1))))
+           (let ((s1 (first r)) (t1 (nth r 1)))
+             (let ((s2 (hk-unify t1 hk-t-int)))
+               (list (hk-subst-compose s2 s1) hk-t-int)))))
+
+        ;; Lambda: ("lambda" pats body)
+        ((= tag "lambda")
+         (let ((pats (nth expr 1))
+               (body (nth expr 2)))
+           (if (empty? pats)
+             (hk-w env body)
+             (let ((pat  (first pats))
+                   (rest (rest pats)))
+               (let ((tv (hk-fresh)))
+                 (let ((bindings (hk-w-pat pat tv)))
+                   (let ((env2 (hk-dict-copy env)))
+                     (for-each (fn (k) (dict-set! env2 k (get bindings k))) (keys bindings))
+                     (let ((inner (if (empty? rest)
+                                    body
+                                    (list "lambda" rest body))))
+                       (let ((r (hk-w env2 inner)))
+                         (let ((s1 (first r)) (t1 (nth r 1)))
+                           (list s1 (hk-tarr (hk-subst-apply s1 tv) t1))))))))))))
+
+        ;; Application: ("app" f x)
+        ((= tag "app")
+         (let ((tv (hk-fresh)))
+           (let ((r1 (hk-w env (nth expr 1))))
+             (let ((s1 (first r1)) (tf (nth r1 1)))
+               (let ((r2 (hk-w (hk-env-apply-subst s1 env) (nth expr 2))))
+                 (let ((s2 (first r2)) (tx (nth r2 1)))
+                   (let ((s3 (hk-unify (hk-subst-apply s2 tf) (hk-tarr tx tv))))
+                     (let ((s (hk-subst-compose s3 (hk-subst-compose s2 s1))))
+                       (list s (hk-subst-apply s3 tv))))))))))
+
+        ;; Let: ("let" binds body)
+        ((= tag "let")
+         (hk-w-let env (nth expr 1) (nth expr 2)))
+
+        ;; If: ("if" cond then else)
+        ((= tag "if")
+         (let ((r1 (hk-w env (nth expr 1))))
+           (let ((s1 (first r1)) (tc (nth r1 1)))
+             (let ((s2 (hk-unify tc hk-t-bool)))
+               (let ((s12 (hk-subst-compose s2 s1)))
+                 (let ((r2 (hk-w (hk-env-apply-subst s12 env) (nth expr 2))))
+                   (let ((s3 (first r2)) (tt (nth r2 1)))
+                     (let ((s123 (hk-subst-compose s3 s12)))
+                       (let ((r3 (hk-w (hk-env-apply-subst s123 env) (nth expr 3))))
+                         (let ((s4 (first r3)) (te (nth r3 1)))
+                           (let ((s5 (hk-unify (hk-subst-apply s4 tt) te)))
+                             (let ((s (hk-subst-compose s5 (hk-subst-compose s4 s123))))
+                               (list s (hk-subst-apply s5 te))))))))))))))
+
+        ;; Binary operator: ("op" op-name left right)
+        ;; Desugar to double application.
+        ((= tag "op")
+         (hk-w env
+               (list "app"
+                     (list "app" (list "var" (nth expr 1)) (nth expr 2))
+                     (nth expr 3))))
+
+        ;; Tuple: ("tuple" [e1 e2 ...])
+        ((= tag "tuple")
+         (let ((elems (nth expr 1)))
+           (let ((s-acc hk-subst-empty)
+                 (ts    (list)))
+             (for-each
+               (fn (e)
+                 (let ((r (hk-w (hk-env-apply-subst s-acc env) e)))
+                   (set! s-acc (hk-subst-compose (first r) s-acc))
+                   (set! ts    (append ts (list (nth r 1))))))
+               elems)
+             (list s-acc (hk-ttuple (map (fn (t) (hk-subst-apply s-acc t)) ts))))))
+
+        ;; List literal: ("list" [e1 e2 ...])
+        ((= tag "list")
+         (let ((elems (nth expr 1)))
+           (if (empty? elems)
+             (list hk-subst-empty (hk-t-list (hk-fresh)))
+             (let ((tv (hk-fresh)))
+               (let ((s-acc hk-subst-empty))
+                 (for-each
+                   (fn (e)
+                     (let ((r (hk-w (hk-env-apply-subst s-acc env) e)))
+                       (let ((s2 (first r)) (te (nth r 1)))
+                         (let ((s3 (hk-unify (hk-subst-apply s2 tv) te)))
+                           (set! s-acc (hk-subst-compose s3 (hk-subst-compose s2 s-acc)))))))
+                   elems)
+                 (list s-acc (hk-t-list (hk-subst-apply s-acc tv))))))))
+
+        ;; Location annotation: just delegate — position is for outer context.
+        ((= tag "loc")
+         (hk-w env (nth expr 3)))
+
+        (:else
+         (raise (str "hk-w: unhandled tag: " tag)))))))
+
+;; ─── Initial type environment ─────────────────────────────────────────────────
+;; Monomorphic numeric ops (no Num typeclass yet — upgraded in Phase 5).
+
+(define
+  hk-type-env0
+  (fn ()
+    (let ((env (dict)))
+      ;; Integer arithmetic
+      (for-each
+        (fn (op)
+          (dict-set! env op (hk-tarr hk-t-int (hk-tarr hk-t-int hk-t-int))))
+        (list "+" "-" "*" "div" "mod" "quot" "rem"))
+      ;; Integer comparison → Bool
+      (for-each
+        (fn (op)
+          (dict-set! env op (hk-tarr hk-t-int (hk-tarr hk-t-int hk-t-bool))))
+        (list "==" "/=" "<" "<=" ">" ">="))
+      ;; Boolean operators
+      (dict-set! env "&&" (hk-tarr hk-t-bool (hk-tarr hk-t-bool hk-t-bool)))
+      (dict-set! env "||" (hk-tarr hk-t-bool (hk-tarr hk-t-bool hk-t-bool)))
+      (dict-set! env "not" (hk-tarr hk-t-bool hk-t-bool))
+      ;; Constructors
+      (dict-set! env "True"  hk-t-bool)
+      (dict-set! env "False" hk-t-bool)
+      ;; Polymorphic list ops (using TScheme)
+      (let ((a (hk-tvar "a")))
+        (dict-set! env "head"  (hk-tscheme (list "a") (hk-tarr (hk-t-list a) a)))
+        (dict-set! env "tail"  (hk-tscheme (list "a") (hk-tarr (hk-t-list a) (hk-t-list a))))
+        (dict-set! env "null"  (hk-tscheme (list "a") (hk-tarr (hk-t-list a) hk-t-bool)))
+        (dict-set! env "length" (hk-tscheme (list "a") (hk-tarr (hk-t-list a) hk-t-int)))
+        (dict-set! env "reverse" (hk-tscheme (list "a") (hk-tarr (hk-t-list a) (hk-t-list a))))
+        (dict-set! env ":"
+          (hk-tscheme (list "a") (hk-tarr a (hk-tarr (hk-t-list a) (hk-t-list a))))))
+      ;; negate
+      (dict-set! env "negate" (hk-tarr hk-t-int hk-t-int))
+      (dict-set! env "abs"    (hk-tarr hk-t-int hk-t-int))
+      env)))
+
+;; ─── Expression brief printer ────────────────────────────────────────────────
+;; Produces a short human-readable label for an AST node used in error messages.
+
+(define
+  hk-expr->brief
+  (fn
+    (expr)
+    (cond
+      ((not (list? expr)) (str expr))
+      ((empty? expr)      "()")
+      (:else
+       (let ((tag (first expr)))
+         (cond
+           ((= tag "var")    (nth expr 1))
+           ((= tag "con")    (nth expr 1))
+           ((= tag "int")    (str (nth expr 1)))
+           ((= tag "float")  (str (nth expr 1)))
+           ((= tag "string") (str "\"" (nth expr 1) "\""))
+           ((= tag "char")   (str "'" (nth expr 1) "'"))
+           ((= tag "neg")    (str "(-" (hk-expr->brief (nth expr 1)) ")"))
+           ((= tag "app")
+            (str "(" (hk-expr->brief (nth expr 1))
+                 " " (hk-expr->brief (nth expr 2)) ")"))
+           ((= tag "op")
+            (str "(" (hk-expr->brief (nth expr 2))
+                 " " (nth expr 1)
+                 " " (hk-expr->brief (nth expr 3)) ")"))
+           ((= tag "lambda") "(\\ ...)")
+           ((= tag "let")    "(let ...)")
+           ((= tag "if")     "(if ...)")
+           ((= tag "tuple")  "(tuple ...)")
+           ((= tag "list")   "[...]")
+           ((= tag "loc")    (hk-expr->brief (nth expr 3)))
+           (:else            (str "(" tag " ..."))))))))
+
+;; ─── Loc-annotated inference ──────────────────────────────────────────────────
+;; ("loc" LINE COL INNER) node: hk-w catches any error and re-raises with
+;; "at LINE:COL: " prepended.  Emitted by the parser or test scaffolding.
+
+;; Extended hk-w handles "loc" — handled inline in the cond below.
+
+;; ─── Program-level inference ─────────────────────────────────────────────────
+;; hk-infer-decl : env × decl → ("ok" name type-str) | ("err" msg) | nil
+;;   Uses tagged results so callers don't need re-raise.
+
+(define
+  hk-infer-decl
+  (fn
+    (env decl)
+    (let
+      ((tag (first decl)))
+      (cond
+        ((= tag "fun-clause")
+          (let
+            ((name (nth decl 1)) (pats (nth decl 2)) (body (nth decl 3)))
+            (let
+              ((rhs (if (empty? pats) body (list "lambda" pats body))))
+              (guard
+                (e (#t (list "err" (str "in '" name "': " e))))
+                (begin
+                  (hk-reset-fresh)
+                  (let
+                    ((r (hk-w env rhs)))
+                    (let
+                      ((final-type (hk-subst-apply (first r) (nth r 1))))
+                      (list "ok" name (hk-type->str final-type) final-type))))))))
+        ((or (= tag "bind") (= tag "pat-bind"))
+          (let
+            ((pat (nth decl 1)) (body (nth decl 2)))
+            (let
+              ((label (if (and (list? pat) (= (first pat) "p-var")) (nth pat 1) "<binding>")))
+              (guard
+                (e (#t (list "err" (str "in '" label "': " e))))
+                (begin
+                  (hk-reset-fresh)
+                  (let
+                    ((r (hk-w env body)))
+                    (let
+                      ((final-type (hk-subst-apply (first r) (nth r 1))))
+                      (list "ok" label (hk-type->str final-type) final-type))))))))
+        (:else nil)))))
+
+;; hk-infer-prog : program-ast × env → list of ("ok" name type) | ("err" msg)
+
+(define
+  hk-ast-type
+  (fn
+    (ast)
+    (let
+      ((tag (first ast)))
+      (cond
+        ((= tag "t-con") (list "TCon" (nth ast 1)))
+        ((= tag "t-var") (list "TVar" (nth ast 1)))
+        ((= tag "t-fun")
+          (list "TArr" (hk-ast-type (nth ast 1)) (hk-ast-type (nth ast 2))))
+        ((= tag "t-app")
+          (list "TApp" (hk-ast-type (nth ast 1)) (hk-ast-type (nth ast 2))))
+        ((= tag "t-list")
+          (list "TApp" (list "TCon" "[]") (hk-ast-type (nth ast 1))))
+        ((= tag "t-tuple") (list "TTuple" (map hk-ast-type (nth ast 1))))
+        (:else (raise (str "unknown type node: " (first ast))))))))
+
+;; ─── Convenience ─────────────────────────────────────────────────────────────
+;; hk-infer-type : Haskell expression source → inferred type string
+
+(define
+  hk-collect-tvars
+  (fn
+    (t acc)
+    (cond
+      ((= (first t) "TVar")
+        (if
+          (some (fn (v) (= v (nth t 1))) acc)
+          acc
+          (begin (append! acc (nth t 1)) acc)))
+      ((= (first t) "TArr")
+        (hk-collect-tvars (nth t 2) (hk-collect-tvars (nth t 1) acc)))
+      ((= (first t) "TApp")
+        (hk-collect-tvars (nth t 2) (hk-collect-tvars (nth t 1) acc)))
+      ((= (first t) "TTuple")
+        (reduce (fn (a elem) (hk-collect-tvars elem a)) acc (nth t 1)))
+      (:else acc))))
+
+(define
+  hk-check-sig
+  (fn
+    (declared-ast inferred-type)
+    (let
+      ((declared (hk-ast-type declared-ast)))
+      (let
+        ((tvars (hk-collect-tvars declared (list))))
+        (let
+          ((scheme (if (empty? tvars) declared (list "TScheme" tvars declared))))
+          (let
+            ((inst (hk-instantiate scheme)))
+            (hk-unify inst inferred-type)))))))
+
+(define
+  hk-infer-prog
+  (fn
+    (prog env)
+    (let
+      ((decls (cond ((and (list? prog) (= (first prog) "program")) (nth prog 1)) ((and (list? prog) (= (first prog) "module")) (nth prog 3)) (:else (list))))
+        (results (list))
+        (sigs (dict)))
+      (for-each
+        (fn
+          (d)
+          (when
+            (= (first d) "type-sig")
+            (let
+              ((names (nth d 1)) (type-ast (nth d 2)))
+              (for-each (fn (n) (dict-set! sigs n type-ast)) names))))
+        decls)
+      (for-each
+        (fn
+          (d)
+          (let
+            ((r (hk-infer-decl env d)))
+            (when
+              (not (nil? r))
+              (let
+                ((checked (if (and (= (first r) "ok") (has-key? sigs (nth r 1))) (guard (e (true (list "err" (str "in '" (nth r 1) "': declared type mismatch: " e)))) (begin (hk-check-sig (get sigs (nth r 1)) (nth r 3)) r)) r)))
+                (append! results checked)
+                (when
+                  (= (first checked) "ok")
+                  (dict-set! env (nth checked 1) (nth checked 3)))))))
+        decls)
+      results)))
+
+(define
+  hk-infer-type
+  (fn
+    (src)
+    (hk-reset-fresh)
+    (let
+      ((ast (hk-core-expr src)) (env (hk-type-env0)))
+      (let
+        ((r (hk-w env ast)))
+        (hk-type->str (hk-subst-apply (first r) (nth r 1)))))))

lib/haskell/layout.sx

@@ -0,0 +1,329 @@
+;; Haskell 98 layout algorithm (§10.3).
+;;
+;; Consumes the raw token stream produced by hk-tokenize and inserts
+;; virtual braces / semicolons (types vlbrace / vrbrace / vsemi) based
+;; on indentation. Newline tokens are consumed and stripped.
+;;
+;;   (hk-layout (hk-tokenize src))  →  tokens-with-virtual-layout
+
+;; ── Pre-pass ──────────────────────────────────────────────────────
+;;
+;; Walks the raw token list and emits an augmented stream containing
+;; two fresh pseudo-tokens:
+;;
+;;   {:type "layout-open"   :col N :keyword K}
+;;     At stream start (K = "<module>") unless the first real token is
+;;     `module` or `{`. Also immediately after every `let` / `where` /
+;;     `do` / `of` whose following token is NOT `{`. N is the column
+;;     of the token that follows.
+;;
+;;   {:type "layout-indent" :col N}
+;;     Before any token whose line is strictly greater than the line
+;;     of the previously emitted real token, EXCEPT when that token
+;;     is already preceded by a layout-open (Haskell 98 §10.3 note 3).
+;;
+;; Raw newline tokens are dropped.
+
+(define
+  hk-layout-keyword?
+  (fn
+    (tok)
+    (and
+      (= (get tok "type") "reserved")
+      (or
+        (= (get tok "value") "let")
+        (= (get tok "value") "where")
+        (= (get tok "value") "do")
+        (= (get tok "value") "of")))))
+
+(define
+  hk-layout-pre
+  (fn
+    (tokens)
+    (let
+      ((result (list))
+        (n (len tokens))
+        (i 0)
+        (prev-line -1)
+        (first-real-emitted false)
+        (suppress-next-indent false))
+      (define
+        hk-next-real-idx
+        (fn
+          (start)
+          (let
+            ((j start))
+            (define
+              hk-nri-loop
+              (fn
+                ()
+                (when
+                  (and
+                    (< j n)
+                    (= (get (nth tokens j) "type") "newline"))
+                  (do (set! j (+ j 1)) (hk-nri-loop)))))
+            (hk-nri-loop)
+            j)))
+      (define
+        hk-pre-step
+        (fn
+          ()
+          (when
+            (< i n)
+            (let
+              ((tok (nth tokens i)) (ty (get tok "type")))
+              (cond
+                ((= ty "newline") (do (set! i (+ i 1)) (hk-pre-step)))
+                (:else
+                  (do
+                    (when
+                      (not first-real-emitted)
+                      (do
+                        (set! first-real-emitted true)
+                        (when
+                          (not
+                            (or
+                              (and
+                                (= ty "reserved")
+                                (= (get tok "value") "module"))
+                              (= ty "lbrace")))
+                          (do
+                            (append!
+                              result
+                              {:type "layout-open"
+                                :col (get tok "col")
+                                :keyword "<module>"
+                                :line (get tok "line")})
+                            (set! suppress-next-indent true)))))
+                    (when
+                      (and
+                        (>= prev-line 0)
+                        (> (get tok "line") prev-line)
+                        (not suppress-next-indent))
+                      (append!
+                        result
+                        {:type "layout-indent"
+                          :col (get tok "col")
+                          :line (get tok "line")}))
+                    (set! suppress-next-indent false)
+                    (set! prev-line (get tok "line"))
+                    (append! result tok)
+                    (when
+                      (hk-layout-keyword? tok)
+                      (let
+                        ((j (hk-next-real-idx (+ i 1))))
+                        (cond
+                          ((>= j n)
+                            (do
+                              (append!
+                                result
+                                {:type "layout-open"
+                                  :col 0
+                                  :keyword (get tok "value")
+                                  :line (get tok "line")})
+                              (set! suppress-next-indent true)))
+                          ((= (get (nth tokens j) "type") "lbrace") nil)
+                          (:else
+                            (do
+                              (append!
+                                result
+                                {:type "layout-open"
+                                  :col (get (nth tokens j) "col")
+                                  :keyword (get tok "value")
+                                  :line (get tok "line")})
+                              (set! suppress-next-indent true))))))
+                    (set! i (+ i 1))
+                    (hk-pre-step))))))))
+      (hk-pre-step)
+      result)))
+
+;; ── Main pass: L algorithm ────────────────────────────────────────
+;;
+;; Stack is a list; the head is the top of stack. Each entry is
+;; either the keyword :explicit (pushed by an explicit `{`) or a dict
+;; {:col N :keyword K} pushed by a layout-open marker.
+;;
+;; Rules (following Haskell 98 §10.3):
+;;
+;;   layout-open(n)  vs stack:
+;;     empty or explicit top                 → push n; emit {
+;;     n > top-col                           → push n; emit {
+;;     otherwise                             → emit { }; retry as indent(n)
+;;
+;;   layout-indent(n) vs stack:
+;;     empty or explicit top                 → drop
+;;     n == top-col                          → emit ;
+;;     n <  top-col                          → emit }; pop; recurse
+;;     n >  top-col                          → drop
+;;
+;;   lbrace                                  → push :explicit; emit {
+;;   rbrace                                  → pop if :explicit; emit }
+;;   `in` with implicit let on top           → emit }; pop; emit in
+;;   any other token                         → emit
+;;
+;; EOF: emit } for every remaining implicit context.
+
+(define
+  hk-layout-L
+  (fn
+    (pre-toks)
+    (let
+      ((result (list))
+        (stack (list))
+        (n (len pre-toks))
+        (i 0))
+      (define hk-emit (fn (t) (append! result t)))
+      (define
+        hk-indent-at
+        (fn
+          (col line)
+          (cond
+            ((or (empty? stack) (= (first stack) :explicit)) nil)
+            (:else
+              (let
+                ((top-col (get (first stack) "col")))
+                (cond
+                  ((= col top-col)
+                    (hk-emit
+                      {:type "vsemi" :value ";" :line line :col col}))
+                  ((< col top-col)
+                    (do
+                      (hk-emit
+                        {:type "vrbrace" :value "}" :line line :col col})
+                      (set! stack (rest stack))
+                      (hk-indent-at col line)))
+                  (:else nil)))))))
+      (define
+        hk-open-at
+        (fn
+          (col keyword line)
+          (cond
+            ((and
+                (> col 0)
+                (or
+                  (empty? stack)
+                  (= (first stack) :explicit)
+                  (> col (get (first stack) "col"))))
+              (do
+                (hk-emit
+                  {:type "vlbrace" :value "{" :line line :col col})
+                (set! stack (cons {:col col :keyword keyword} stack))))
+            (:else
+              (do
+                (hk-emit
+                  {:type "vlbrace" :value "{" :line line :col col})
+                (hk-emit
+                  {:type "vrbrace" :value "}" :line line :col col})
+                (hk-indent-at col line))))))
+      (define
+        hk-close-eof
+        (fn
+          ()
+          (when
+            (and
+              (not (empty? stack))
+              (not (= (first stack) :explicit)))
+            (do
+              (hk-emit {:type "vrbrace" :value "}" :line 0 :col 0})
+              (set! stack (rest stack))
+              (hk-close-eof)))))
+      ;; Peek past further layout-indent / layout-open markers to find
+      ;; the next real token's value when its type is `reserved`.
+      ;; Returns nil if no such token.
+      (define
+        hk-peek-next-reserved
+        (fn
+          (start)
+          (let ((j (+ start 1)) (found nil) (done false))
+            (define
+              hk-pnr-loop
+              (fn
+                ()
+                (when
+                  (and (not done) (< j n))
+                  (let
+                    ((t (nth pre-toks j)) (ty (get t "type")))
+                    (cond
+                      ((or
+                          (= ty "layout-indent")
+                          (= ty "layout-open"))
+                        (do (set! j (+ j 1)) (hk-pnr-loop)))
+                      ((= ty "reserved")
+                        (do (set! found (get t "value")) (set! done true)))
+                      (:else (set! done true)))))))
+            (hk-pnr-loop)
+            found)))
+      (define
+        hk-layout-step
+        (fn
+          ()
+          (when
+            (< i n)
+            (let
+              ((tok (nth pre-toks i)) (ty (get tok "type")))
+              (cond
+                ((= ty "eof")
+                  (do
+                    (hk-close-eof)
+                    (hk-emit tok)
+                    (set! i (+ i 1))
+                    (hk-layout-step)))
+                ((= ty "layout-open")
+                  (do
+                    (hk-open-at
+                      (get tok "col")
+                      (get tok "keyword")
+                      (get tok "line"))
+                    (set! i (+ i 1))
+                    (hk-layout-step)))
+                ((= ty "layout-indent")
+                  (cond
+                    ((= (hk-peek-next-reserved i) "in")
+                      (do (set! i (+ i 1)) (hk-layout-step)))
+                    (:else
+                      (do
+                        (hk-indent-at (get tok "col") (get tok "line"))
+                        (set! i (+ i 1))
+                        (hk-layout-step)))))
+                ((= ty "lbrace")
+                  (do
+                    (set! stack (cons :explicit stack))
+                    (hk-emit tok)
+                    (set! i (+ i 1))
+                    (hk-layout-step)))
+                ((= ty "rbrace")
+                  (do
+                    (when
+                      (and
+                        (not (empty? stack))
+                        (= (first stack) :explicit))
+                      (set! stack (rest stack)))
+                    (hk-emit tok)
+                    (set! i (+ i 1))
+                    (hk-layout-step)))
+                ((and
+                    (= ty "reserved")
+                    (= (get tok "value") "in")
+                    (not (empty? stack))
+                    (not (= (first stack) :explicit))
+                    (= (get (first stack) "keyword") "let"))
+                  (do
+                    (hk-emit
+                      {:type "vrbrace"
+                        :value "}"
+                        :line (get tok "line")
+                        :col (get tok "col")})
+                    (set! stack (rest stack))
+                    (hk-emit tok)
+                    (set! i (+ i 1))
+                    (hk-layout-step)))
+                (:else
+                  (do
+                    (hk-emit tok)
+                    (set! i (+ i 1))
+                    (hk-layout-step))))))))
+      (hk-layout-step)
+      (hk-close-eof)
+      result)))
+
+(define hk-layout (fn (tokens) (hk-layout-L (hk-layout-pre tokens))))

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

@@ -0,0 +1,197 @@
+;; Value-level pattern matching.
+;;
+;; Constructor values are tagged lists whose first element is the
+;; constructor name (a string). Tuples use the special tag "Tuple".
+;; Lists use the spine of `:` cons and `[]` nil.
+;;
+;;   Just 5         →  ("Just" 5)
+;;   Nothing        →  ("Nothing")
+;;   (1, 2)         →  ("Tuple" 1 2)
+;;   [1, 2]         →  (":" 1 (":" 2 ("[]")))
+;;   ()             →  ("()")
+;;
+;; Primitive values (numbers, strings, chars) are stored raw.
+;;
+;; The matcher takes a pattern AST node, a value, and an environment
+;; dict; it returns an extended dict on success, or `nil` on failure.
+
+;; ── Value builders ──────────────────────────────────────────
+(define
+  hk-mk-con
+  (fn
+    (cname args)
+    (let ((result (list cname)))
+      (for-each (fn (a) (append! result a)) args)
+      result)))
+
+(define
+  hk-mk-tuple
+  (fn
+    (items)
+    (let ((result (list "Tuple")))
+      (for-each (fn (x) (append! result x)) items)
+      result)))
+
+(define hk-mk-nil (fn () (list "[]")))
+
+(define hk-mk-cons (fn (h t) (list ":" h t)))
+
+(define
+  hk-mk-list
+  (fn
+    (items)
+    (cond
+      ((empty? items) (hk-mk-nil))
+      (:else
+        (hk-mk-cons (first items) (hk-mk-list (rest items)))))))
+
+;; ── Predicates / accessors on constructor values ───────────
+(define
+  hk-is-con-val?
+  (fn
+    (v)
+    (and
+      (list? v)
+      (not (empty? v))
+      (string? (first v)))))
+
+(define hk-val-con-name (fn (v) (first v)))
+
+(define hk-val-con-args (fn (v) (rest v)))
+
+;; ── The matcher ────────────────────────────────────────────
+;;
+;; Pattern match forces the scrutinee to WHNF before inspecting it
+;; — except for `p-wild`, `p-var`, and `p-lazy`, which never need
+;; to look at the value. Args of constructor / tuple / list values
+;; remain thunked (they're forced only when their own pattern needs
+;; to inspect them, recursively).
+(define
+  hk-match
+  (fn
+    (pat val env)
+    (cond
+      ((not (list? pat)) nil)
+      ((empty? pat) nil)
+      (:else
+        (let
+          ((tag (first pat)))
+          (cond
+            ((= tag "p-wild") env)
+            ((= tag "p-var") (assoc env (nth pat 1) val))
+            ((= tag "p-lazy") (hk-match (nth pat 1) val env))
+            ((= tag "p-as")
+              (let
+                ((res (hk-match (nth pat 2) val env)))
+                (cond
+                  ((nil? res) nil)
+                  (:else (assoc res (nth pat 1) val)))))
+            (:else
+              (let
+                ((fv (hk-force val)))
+                (cond
+                  ((= tag "p-int")
+                    (if (and (number? fv) (= fv (nth pat 1))) env nil))
+                  ((= tag "p-float")
+                    (if (and (number? fv) (= fv (nth pat 1))) env nil))
+                  ((= tag "p-string")
+                    (if (and (string? fv) (= fv (nth pat 1))) env nil))
+                  ((= tag "p-char")
+                    (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 val-args) (len pat-args))) nil)
+                              (:else (hk-match-all pat-args val-args env))))))))
+                  ((= tag "p-tuple")
+                    (let
+                      ((items (nth pat 1)))
+                      (cond
+                        ((not (hk-is-con-val? fv)) nil)
+                        ((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 nil))))))))))
+
+(define
+  hk-match-all
+  (fn
+    (pats vals env)
+    (cond
+      ((empty? pats) env)
+      (:else
+        (let
+          ((res (hk-match (first pats) (first vals) env)))
+          (cond
+            ((nil? res) nil)
+            (:else
+              (hk-match-all (rest pats) (rest vals) res))))))))
+
+(define
+  hk-match-list-pat
+  (fn
+    (items val env)
+    (let
+      ((fv (hk-force val)))
+      (cond
+        ((empty? items)
+          (if
+            (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
+              (let
+                ((args (hk-val-con-args fv)))
+                (let
+                  ((h (first args)) (t (first (rest args))))
+                  (let
+                    ((res (hk-match (first items) h env)))
+                    (cond
+                      ((nil? res) nil)
+                      (: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` —
+;; to extract a pattern AST.)
+(define
+  hk-parse-pat-source
+  (fn
+    (src)
+    (let
+      ((expr (hk-parse (str "case 0 of " src " -> 0"))))
+      (nth (nth (nth expr 2) 0) 1))))

lib/haskell/runtime.sx

@@ -1,507 +1,150 @@
-;; lib/haskell/runtime.sx — Haskell-on-SX runtime layer
+;; Haskell runtime: constructor registry.
 ;;
-;; Covers the Haskell primitives now reachable via SX spec:
-;;  1. Numeric type class helpers (Num / Integral / Fractional)
-;;  2. Rational numbers (dict-based: {:_rational true :num n :den d})
-;;  3. Lazy evaluation — hk-force for promises created by delay
-;;  4. Char utilities (Data.Char)
-;;  5. Data.Set wrappers
-;;  6. Data.List utilities
-;;  7. Maybe / Either ADTs
-;;  8. Tuples (lists, since list->vector unreliable in sx_server)
-;;  9. String helpers (words/lines/isPrefixOf/etc.)
-;; 10. Show helper
+;; A mutable dict keyed by constructor name (e.g. "Just", "[]") with
+;; entries of shape  {:arity N :type TYPE-NAME-STRING}.
+;; Populated by ingesting `data` / `newtype` decls from parsed ASTs.
+;; Pre-registers a small set of constructors tied to Haskell syntactic
+;; forms (Bool, list, unit) — every nontrivial program depends on
+;; these, and the parser/desugar pipeline emits them as (:var "True")
+;; etc. without a corresponding `data` decl.
 
-;; ===========================================================================
-;; 1. Numeric type class helpers
-;; ===========================================================================
+(define hk-constructors (dict))
 
-(define hk-is-integer? integer?)
-(define hk-is-float? float?)
-(define hk-is-num? number?)
-
-;; fromIntegral — coerce integer to Float
-(define (hk-to-float x) (exact->inexact x))
-
-;; truncate / round toward zero
-(define hk-to-integer truncate)
-(define hk-from-integer (fn (n) n))
-
-;; Haskell div: floor division (rounds toward -inf)
 (define
-  (hk-div a b)
-  (let
-    ((q (quotient a b)) (r (remainder a b)))
+  hk-register-con!
+  (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)))
+
+(define
+  hk-con-arity
+  (fn
+    (name)
     (if
-      (and
-        (not (= r 0))
-        (or
-          (and (< a 0) (> b 0))
-          (and (> a 0) (< b 0))))
-      (- q 1)
-      q)))
-
-;; Haskell mod: result has same sign as divisor
-(define hk-mod modulo)
-
-;; Haskell rem: result has same sign as dividend
-(define hk-rem remainder)
-
-;; Haskell quot: truncation division
-(define hk-quot quotient)
-
-;; divMod and quotRem return pairs (lists)
-(define (hk-div-mod a b) (list (hk-div a b) (hk-mod a b)))
-(define (hk-quot-rem a b) (list (hk-quot a b) (hk-rem a b)))
-
-(define (hk-abs x) (if (< x 0) (- 0 x) x))
-(define
-  (hk-signum x)
-  (cond
-    ((> x 0) 1)
-    ((< x 0) -1)
-    (else 0)))
-
-(define hk-gcd gcd)
-(define hk-lcm lcm)
-
-(define (hk-even? n) (= (modulo n 2) 0))
-(define (hk-odd? n) (not (= (modulo n 2) 0)))
-
-;; ===========================================================================
-;; 2. Rational numbers (dict implementation — no built-in rational in sx_server)
-;; ===========================================================================
+      (has-key? hk-constructors name)
+      (get (get hk-constructors name) "arity")
+      nil)))
 
 (define
-  (hk-make-rational n d)
-  (let
-    ((g (gcd (hk-abs n) (hk-abs d))))
-    (if (< d 0) {:num (quotient (- 0 n) g) :den (quotient (- 0 d) g) :_rational true} {:num (quotient n g) :den (quotient d g) :_rational true})))
+  hk-con-type
+  (fn
+    (name)
+    (if
+      (has-key? hk-constructors name)
+      (get (get hk-constructors name) "type")
+      nil)))
+
+(define hk-con-names (fn () (keys hk-constructors)))
+
+;; ── Registration from AST ────────────────────────────────────
+;; (:data NAME TVARS ((:con-def CNAME FIELDS) …))
+(define
+  hk-register-data!
+  (fn
+    (data-node)
+    (let
+      ((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))
+        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))))
+
+;; Walk a decls list, registering every `data` / `newtype` decl.
+(define
+  hk-register-decls!
+  (fn
+    (decls)
+    (for-each
+      (fn
+        (d)
+        (cond
+          ((and (list? d) (not (empty? d)) (= (first d) "data"))
+            (hk-register-data! d))
+          ((and (list? d) (not (empty? d)) (= (first d) "newtype"))
+            (hk-register-newtype! d))
+          (:else nil)))
+      decls)))
 
 (define
-  (hk-rational? x)
-  (and (dict? x) (not (= (get x :_rational) nil))))
-(define (hk-numerator r) (get r :num))
-(define (hk-denominator r) (get r :den))
-
-(define
-  (hk-rational-add r1 r2)
-  (hk-make-rational
-    (+
-      (* (hk-numerator r1) (hk-denominator r2))
-      (* (hk-numerator r2) (hk-denominator r1)))
-    (* (hk-denominator r1) (hk-denominator r2))))
-
-(define
-  (hk-rational-sub r1 r2)
-  (hk-make-rational
-    (-
-      (* (hk-numerator r1) (hk-denominator r2))
-      (* (hk-numerator r2) (hk-denominator r1)))
-    (* (hk-denominator r1) (hk-denominator r2))))
-
-(define
-  (hk-rational-mul r1 r2)
-  (hk-make-rational
-    (* (hk-numerator r1) (hk-numerator r2))
-    (* (hk-denominator r1) (hk-denominator r2))))
-
-(define
-  (hk-rational-div r1 r2)
-  (hk-make-rational
-    (* (hk-numerator r1) (hk-denominator r2))
-    (* (hk-denominator r1) (hk-numerator r2))))
-
-(define
-  (hk-rational-to-float r)
-  (exact->inexact (/ (hk-numerator r) (hk-denominator r))))
-
-(define (hk-show-rational r) (str (hk-numerator r) "%" (hk-denominator r)))
-
-;; ===========================================================================
-;; 3. Lazy evaluation — promises (created via SX delay)
-;; ===========================================================================
-
-(define
-  (hk-force p)
-  (if
-    (and (dict? p) (not (= (get p :_promise) nil)))
-    (if (get p :forced) (get p :value) ((get p :thunk)))
-    p))
-
-;; ===========================================================================
-;; 4. Char utilities (Data.Char)
-;; ===========================================================================
-
-(define hk-ord char->integer)
-(define hk-chr integer->char)
-
-;; Inline ASCII predicates — char-alphabetic?/char-numeric? unreliable in sx_server
-(define
-  (hk-is-alpha? c)
-  (let
-    ((n (char->integer c)))
-    (or
-      (and (>= n 65) (<= n 90))
-      (and (>= n 97) (<= n 122)))))
-
-(define
-  (hk-is-digit? c)
-  (let ((n (char->integer c))) (and (>= n 48) (<= n 57))))
-
-(define
-  (hk-is-alnum? c)
-  (let
-    ((n (char->integer c)))
-    (or
-      (and (>= n 48) (<= n 57))
-      (and (>= n 65) (<= n 90))
-      (and (>= n 97) (<= n 122)))))
-
-(define
-  (hk-is-upper? c)
-  (let ((n (char->integer c))) (and (>= n 65) (<= n 90))))
-
-(define
-  (hk-is-lower? c)
-  (let ((n (char->integer c))) (and (>= n 97) (<= n 122))))
-
-(define
-  (hk-is-space? c)
-  (let
-    ((n (char->integer c)))
-    (or
-      (= n 32)
-      (= n 9)
-      (= n 10)
-      (= n 13)
-      (= n 12)
-      (= n 11))))
-
-(define hk-to-upper char-upcase)
-(define hk-to-lower char-downcase)
-
-;; digitToInt: '0'-'9' → 0-9, 'a'-'f'/'A'-'F' → 10-15
-(define
-  (hk-digit-to-int c)
-  (let
-    ((n (char->integer c)))
+  hk-register-program!
+  (fn
+    (ast)
     (cond
-      ((and (>= n 48) (<= n 57)) (- n 48))
-      ((and (>= n 65) (<= n 70)) (- n 55))
-      ((and (>= n 97) (<= n 102)) (- n 87))
-      (else (error (str "hk-digit-to-int: not a hex digit: " c))))))
+      ((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)))
+      (:else nil))))
 
-;; intToDigit: 0-15 → char
-(define
-  (hk-int-to-digit n)
-  (cond
-    ((and (>= n 0) (<= n 9))
-      (integer->char (+ n 48)))
-    ((and (>= n 10) (<= n 15))
-      (integer->char (+ n 87)))
-    (else (error (str "hk-int-to-digit: out of range: " n)))))
+;; Convenience: source → AST → desugar → register.
+(define hk-load-source! (fn (src) (hk-register-program! (hk-core src))))
 
-;; ===========================================================================
-;; 5. Data.Set wrappers
-;; ===========================================================================
-
-(define (hk-set-empty) (make-set))
-(define hk-set? set?)
-(define hk-set-member? set-member?)
-
-(define (hk-set-insert x s) (begin (set-add! s x) s))
-
-(define (hk-set-delete x s) (begin (set-remove! s x) s))
-
-(define hk-set-union set-union)
-(define hk-set-intersection set-intersection)
-(define hk-set-difference set-difference)
-(define hk-set-from-list list->set)
-(define hk-set-to-list set->list)
-(define (hk-set-null? s) (= (len (set->list s)) 0))
-(define (hk-set-size s) (len (set->list s)))
-
-(define (hk-set-singleton x) (let ((s (make-set))) (set-add! s x) s))
-
-;; ===========================================================================
-;; 6. Data.List utilities
-;; ===========================================================================
-
-(define hk-head first)
-(define hk-tail rest)
-(define (hk-null? lst) (= (len lst) 0))
-(define hk-length len)
+;; ── Built-in constructors pre-registered ─────────────────────
+;; Bool — used implicitly by `if`, comparison operators.
+(hk-register-con! "True" 0 "Bool")
+(hk-register-con! "False" 0 "Bool")
+;; List — used by list literals, range syntax, and cons operator.
+(hk-register-con! "[]" 0 "List")
+(hk-register-con! ":" 2 "List")
+;; Unit — produced by empty parens `()`.
+(hk-register-con! "()" 0 "Unit")
+;; 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! "LT" 0 "Ordering")
+(hk-register-con! "EQ" 0 "Ordering")
+(hk-register-con! "GT" 0 "Ordering")
+(hk-register-con! "SomeException" 1 "SomeException")
 
 (define
-  (hk-take n lst)
-  (if
-    (or (= n 0) (= (len lst) 0))
-    (list)
-    (cons (first lst) (hk-take (- n 1) (rest lst)))))
+  hk-str?
+  (fn (v) (or (string? v) (and (dict? v) (has-key? v "hk-str")))))
 
 (define
-  (hk-drop n lst)
-  (if
-    (or (= n 0) (= (len lst) 0))
-    lst
-    (hk-drop (- n 1) (rest lst))))
+  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-take-while pred lst)
-  (if
-    (or (= (len lst) 0) (not (pred (first lst))))
-    (list)
-    (cons (first lst) (hk-take-while pred (rest lst)))))
+  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-drop-while pred lst)
-  (if
-    (or (= (len lst) 0) (not (pred (first lst))))
-    lst
-    (hk-drop-while pred (rest lst))))
+  hk-str-null?
+  (fn
+    (v)
+    (if
+      (string? v)
+      (= (string-length v) 0)
+      (>= (get v "hk-off") (string-length (get v "hk-str"))))))
 
 (define
-  (hk-zip a b)
-  (if
-    (or (= (len a) 0) (= (len b) 0))
-    (list)
-    (cons (list (first a) (first b)) (hk-zip (rest a) (rest b)))))
-
-(define
-  (hk-zip-with f a b)
-  (if
-    (or (= (len a) 0) (= (len b) 0))
-    (list)
-    (cons (f (first a) (first b)) (hk-zip-with f (rest a) (rest b)))))
-
-(define
-  (hk-unzip pairs)
-  (list
-    (map (fn (p) (first p)) pairs)
-    (map (fn (p) (nth p 1)) pairs)))
-
-(define
-  (hk-elem x lst)
-  (cond
-    ((= (len lst) 0) false)
-    ((= x (first lst)) true)
-    (else (hk-elem x (rest lst)))))
-
-(define (hk-not-elem x lst) (not (hk-elem x lst)))
-
-(define
-  (hk-nub lst)
-  (letrec
-    ((go (fn (seen acc items) (if (= (len items) 0) (reverse acc) (let ((h (first items)) (t (rest items))) (if (hk-elem h seen) (go seen acc t) (go (cons h seen) (cons h acc) t)))))))
-    (go (list) (list) lst)))
-
-(define (hk-sum lst) (reduce + 0 lst))
-(define (hk-product lst) (reduce * 1 lst))
-
-(define
-  (hk-maximum lst)
-  (reduce (fn (a b) (if (> a b) a b)) (first lst) (rest lst)))
-
-(define
-  (hk-minimum lst)
-  (reduce (fn (a b) (if (< a b) a b)) (first lst) (rest lst)))
-
-(define (hk-concat lsts) (reduce append (list) lsts))
-
-(define (hk-concat-map f lst) (hk-concat (map f lst)))
-
-(define hk-sort sort)
-
-(define
-  (hk-span pred lst)
-  (list (hk-take-while pred lst) (hk-drop-while pred lst)))
-
-(define (hk-break pred lst) (hk-span (fn (x) (not (pred x))) lst))
-
-(define
-  (hk-foldl f acc lst)
-  (if
-    (= (len lst) 0)
-    acc
-    (hk-foldl f (f acc (first lst)) (rest lst))))
-
-(define
-  (hk-foldr f z lst)
-  (if
-    (= (len lst) 0)
-    z
-    (f (first lst) (hk-foldr f z (rest lst)))))
-
-(define
-  (hk-scanl f acc lst)
-  (if
-    (= (len lst) 0)
-    (list acc)
-    (cons acc (hk-scanl f (f acc (first lst)) (rest lst)))))
-
-(define
-  (hk-replicate n x)
-  (if (= n 0) (list) (cons x (hk-replicate (- n 1) x))))
-
-(define
-  (hk-intersperse sep lst)
-  (if
-    (or (= (len lst) 0) (= (len lst) 1))
-    lst
-    (cons (first lst) (cons sep (hk-intersperse sep (rest lst))))))
-
-;; ===========================================================================
-;; 7. Maybe / Either ADTs
-;; ===========================================================================
-
-(define hk-nothing {:_maybe true :_tag "nothing"})
-(define (hk-just x) {:_maybe true :value x :_tag "just"})
-(define (hk-is-nothing? m) (= (get m :_tag) "nothing"))
-(define (hk-is-just? m) (= (get m :_tag) "just"))
-(define (hk-from-just m) (get m :value))
-(define (hk-from-maybe def m) (if (hk-is-nothing? m) def (hk-from-just m)))
-(define
-  (hk-maybe def f m)
-  (if (hk-is-nothing? m) def (f (hk-from-just m))))
-
-(define (hk-left x) {:value x :_either true :_tag "left"})
-(define (hk-right x) {:value x :_either true :_tag "right"})
-(define (hk-is-left? e) (= (get e :_tag) "left"))
-(define (hk-is-right? e) (= (get e :_tag) "right"))
-(define (hk-from-left e) (get e :value))
-(define (hk-from-right e) (get e :value))
-(define
-  (hk-either f g e)
-  (if (hk-is-left? e) (f (hk-from-left e)) (g (hk-from-right e))))
-
-;; ===========================================================================
-;; 8. Tuples (lists — list->vector unreliable in sx_server)
-;; ===========================================================================
-
-(define (hk-pair a b) (list a b))
-(define hk-fst first)
-(define (hk-snd t) (nth t 1))
-
-(define (hk-triple a b c) (list a b c))
-(define hk-fst3 first)
-(define (hk-snd3 t) (nth t 1))
-(define (hk-thd3 t) (nth t 2))
-
-(define (hk-curry f) (fn (a) (fn (b) (f a b))))
-(define (hk-uncurry f) (fn (p) (f (hk-fst p) (hk-snd p))))
-
-;; ===========================================================================
-;; 9. String helpers (Data.List / Data.Char for strings)
-;; ===========================================================================
-
-;; words: split on whitespace
-(define
-  (hk-words s)
-  (letrec
-    ((slen (len s))
-      (skip-ws
-        (fn
-          (i)
-          (if
-            (>= i slen)
-            (list)
-            (let
-              ((c (substring s i (+ i 1))))
-              (if
-                (or (= c " ") (= c "\t") (= c "\n"))
-                (skip-ws (+ i 1))
-                (collect-word i (+ i 1)))))))
-      (collect-word
-        (fn
-          (start i)
-          (if
-            (>= i slen)
-            (list (substring s start i))
-            (let
-              ((c (substring s i (+ i 1))))
-              (if
-                (or (= c " ") (= c "\t") (= c "\n"))
-                (cons (substring s start i) (skip-ws (+ i 1)))
-                (collect-word start (+ i 1))))))))
-    (skip-ws 0)))
-
-;; unwords: join with spaces
-(define
-  (hk-unwords lst)
-  (if
-    (= (len lst) 0)
-    ""
-    (reduce (fn (a b) (str a " " b)) (first lst) (rest lst))))
-
-;; lines: split on newline
-(define
-  (hk-lines s)
-  (letrec
-    ((slen (len s))
-      (go
-        (fn
-          (start i acc)
-          (if
-            (>= i slen)
-            (reverse (cons (substring s start i) acc))
-            (if
-              (= (substring s i (+ i 1)) "\n")
-              (go
-                (+ i 1)
-                (+ i 1)
-                (cons (substring s start i) acc))
-              (go start (+ i 1) acc))))))
-    (if (= slen 0) (list) (go 0 0 (list)))))
-
-;; unlines: join, each with trailing newline
-(define (hk-unlines lst) (reduce (fn (a b) (str a b "\n")) "" lst))
-
-;; isPrefixOf
-(define
-  (hk-is-prefix-of pre s)
-  (and (<= (len pre) (len s)) (= pre (substring s 0 (len pre)))))
-
-;; isSuffixOf
-(define
-  (hk-is-suffix-of suf s)
-  (let
-    ((sl (len suf)) (tl (len s)))
-    (and (<= sl tl) (= suf (substring s (- tl sl) tl)))))
-
-;; isInfixOf — linear scan
-(define
-  (hk-is-infix-of pat s)
-  (let
-    ((plen (len pat)) (slen (len s)))
-    (letrec
-      ((go (fn (i) (if (> (+ i plen) slen) false (if (= pat (substring s i (+ i plen))) true (go (+ i 1)))))))
-      (if (= plen 0) true (go 0)))))
-
-;; ===========================================================================
-;; 10. Show helper
-;; ===========================================================================
-
-(define
-  (hk-show x)
-  (cond
-    ((= x nil) "Nothing")
-    ((= x true) "True")
-    ((= x false) "False")
-    ((hk-rational? x) (hk-show-rational x))
-    ((integer? x) (str x))
-    ((float? x) (str x))
-    ((= (type-of x) "string") (str "\"" x "\""))
-    ((= (type-of x) "char") (str "'" (str x) "'"))
-    ((list? x)
-      (str
-        "["
-        (if
-          (= (len x) 0)
+  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)))
           ""
-          (reduce
-            (fn (a b) (str a "," (hk-show b)))
-            (hk-show (first x))
-            (rest x)))
-        "]"))
-    (else (str x))))
+          (range off (string-length buf)))))))

lib/haskell/scoreboard.json

@@ -0,0 +1,43 @@
+{
+  "date": "2026-05-08",
+  "total_pass": 285,
+  "total_fail": 0,
+  "programs": {
+    "fib": {"pass": 2, "fail": 0},
+    "sieve": {"pass": 2, "fail": 0},
+    "quicksort": {"pass": 5, "fail": 0},
+    "nqueens": {"pass": 2, "fail": 0},
+    "calculator": {"pass": 5, "fail": 0},
+    "collatz": {"pass": 11, "fail": 0},
+    "palindrome": {"pass": 12, "fail": 0},
+    "maybe": {"pass": 12, "fail": 0},
+    "fizzbuzz": {"pass": 12, "fail": 0},
+    "anagram": {"pass": 9, "fail": 0},
+    "roman": {"pass": 14, "fail": 0},
+    "binary": {"pass": 12, "fail": 0},
+    "either": {"pass": 12, "fail": 0},
+    "primes": {"pass": 12, "fail": 0},
+    "zipwith": {"pass": 9, "fail": 0},
+    "matrix": {"pass": 8, "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

@@ -0,0 +1,43 @@
+# Haskell-on-SX Scoreboard
+
+Updated 2026-05-08 · Phase 6 (prelude extras + 18 programs)
+
+| Program | Tests | Status |
+|---------|-------|--------|
+| fib.hs | 2/2 | ✓ |
+| sieve.hs | 2/2 | ✓ |
+| quicksort.hs | 5/5 | ✓ |
+| nqueens.hs | 2/2 | ✓ |
+| calculator.hs | 5/5 | ✓ |
+| collatz.hs | 11/11 | ✓ |
+| palindrome.hs | 12/12 | ✓ |
+| maybe.hs | 12/12 | ✓ |
+| fizzbuzz.hs | 12/12 | ✓ |
+| anagram.hs | 9/9 | ✓ |
+| roman.hs | 14/14 | ✓ |
+| binary.hs | 12/12 | ✓ |
+| either.hs | 12/12 | ✓ |
+| primes.hs | 12/12 | ✓ |
+| zipwith.hs | 9/9 | ✓ |
+| matrix.hs | 8/8 | ✓ |
+| wordcount.hs | 10/10 | ✓ |
+| powers.hs | 14/14 | ✓ |
+| 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

@@ -14,7 +14,7 @@ cd "$(git rev-parse --show-toplevel)"
 SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
 if [ ! -x "$SX_SERVER" ]; then
   # Fall back to the main-repo build if we're in a worktree.
-  MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
+  MAIN_ROOT=$(git worktree list | awk 'NR==1{print $1}')
   if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
     SX_SERVER="$MAIN_ROOT/$SX_SERVER"
   else
@@ -42,25 +42,37 @@ FAILED_FILES=()
 
 for FILE in "${FILES[@]}"; do
   [ -f "$FILE" ] || { echo "skip $FILE (not found)"; continue; }
+  # Load infer.sx only for infer/typecheck test files (it adds ~6s overhead).
+  INFER_LOAD=""
+  case "$FILE" in *infer*|*typecheck*) INFER_LOAD='(load "lib/haskell/infer.sx")' ;; esac
   TMPFILE=$(mktemp)
   cat > "$TMPFILE" <<EPOCHS
 (epoch 1)
 (load "lib/haskell/tokenizer.sx")
+(load "lib/haskell/layout.sx")
+(load "lib/haskell/parser.sx")
+(load "lib/haskell/desugar.sx")
 (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)
 (load "$FILE")
 (epoch 3)
 (eval "(list hk-test-pass hk-test-fail)")
 EPOCHS
 
-  OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
+  OUTPUT=$(timeout 360 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
   rm -f "$TMPFILE"
 
   # Output format: either "(ok 3 (P F))" on one line (short result) or
   # "(ok-len 3 N)\n(P F)" where the value appears on the following line.
   LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}')
   if [ -z "$LINE" ]; then
-    LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
+    LINE=$(echo "$OUTPUT" | { grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' || true; } | tail -1 \
             | sed -E 's/^\(ok 3 //; s/\)$//')
   fi
   if [ -z "$LINE" ]; then
@@ -82,13 +94,22 @@ EPOCHS
     cat > "$TMPFILE2" <<EPOCHS
 (epoch 1)
 (load "lib/haskell/tokenizer.sx")
+(load "lib/haskell/layout.sx")
+(load "lib/haskell/parser.sx")
+(load "lib/haskell/desugar.sx")
 (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)
 (load "$FILE")
 (epoch 3)
 (eval "(map (fn (f) (get f \"name\")) hk-test-fails)")
 EPOCHS
-    FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>&1 | grep -E '^\(ok 3 ' || true)
+    FAILS=$(timeout 360 "$SX_SERVER" < "$TMPFILE2" 2>&1 | grep -E '^\(ok 3 ' || true)
     rm -f "$TMPFILE2"
     echo "    $FAILS"
   elif [ "$VERBOSE" = "1" ]; then

lib/haskell/testlib.sx

@@ -0,0 +1,76 @@
+;; Shared test harness for Haskell-on-SX tests.
+;; Each test file expects hk-test / hk-deep=? / counters to already be bound.
+
+(define
+  hk-deep=?
+  (fn
+    (a b)
+    (cond
+      ((= a b) true)
+      ((and (dict? a) (dict? b))
+        (let
+          ((ak (keys a)) (bk (keys b)))
+          (if
+            (not (= (len ak) (len bk)))
+            false
+            (every?
+              (fn
+                (k)
+                (and (has-key? b k) (hk-deep=? (get a k) (get b k))))
+              ak))))
+      ((and (list? a) (list? b))
+        (if
+          (not (= (len a) (len b)))
+          false
+          (let
+            ((i 0) (ok true))
+            (define
+              hk-de-loop
+              (fn
+                ()
+                (when
+                  (and ok (< i (len a)))
+                  (do
+                    (when
+                      (not (hk-deep=? (nth a i) (nth b i)))
+                      (set! ok false))
+                    (set! i (+ i 1))
+                    (hk-de-loop)))))
+            (hk-de-loop)
+            ok)))
+      (:else false))))
+
+(define hk-test-pass 0)
+(define hk-test-fail 0)
+(define hk-test-fails (list))
+
+(define
+  hk-test
+  (fn
+    (name actual expected)
+    (if
+      (hk-deep=? actual expected)
+      (set! hk-test-pass (+ hk-test-pass 1))
+      (do
+        (set! hk-test-fail (+ hk-test-fail 1))
+        (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/class.sx

@@ -0,0 +1,60 @@
+;; class.sx — tests for class/instance parsing and evaluation.
+
+(define prog-class1 (hk-core "class MyEq a where\n  myEq :: a -> a -> Bool"))
+(define prog-inst1 (hk-core "instance MyEq Int where\n  myEq x y = x == y"))
+
+;; ─── class-decl AST ───────────────────────────────────────────────────────────
+(define cd1 (first (nth prog-class1 1)))
+(hk-test "class-decl tag" (first cd1) "class-decl")
+(hk-test "class-decl name" (nth cd1 1) "MyEq")
+(hk-test "class-decl tvar" (nth cd1 2) "a")
+(hk-test "class-decl methods" (len (nth cd1 3)) 1)
+
+;; ─── instance-decl AST ────────────────────────────────────────────────────────
+(define id1 (first (nth prog-inst1 1)))
+(hk-test "instance-decl tag" (first id1) "instance-decl")
+(hk-test "instance-decl class" (nth id1 1) "MyEq")
+(hk-test "instance-decl type tag" (first (nth id1 2)) "t-con")
+(hk-test "instance-decl type name" (nth (nth id1 2) 1) "Int")
+(hk-test "instance-decl method count" (len (nth id1 3)) 1)
+
+;; ─── eval: instance dict is built ────────────────────────────────────────────
+(define
+  prog-full
+  (hk-core
+    "class MyEq a where\n  myEq :: a -> a -> Bool\ninstance MyEq Int where\n  myEq x y = x == y"))
+(define env-full (hk-eval-program prog-full))
+
+(hk-test "instance dict in env" (has-key? env-full "dictMyEq_Int") true)
+
+(hk-test
+  "instance dict has method"
+  (has-key? (get env-full "dictMyEq_Int") "myEq")
+  true)
+
+(hk-test
+  "dispatch: single-arg method works"
+  (hk-deep-force
+    (hk-run
+      "class Describable a where\n  describe :: a -> String\ninstance Describable Int where\n  describe x = \"an integer\"\nmain = describe 42"))
+  "an integer")
+
+(hk-test
+  "dispatch: second instance (Bool)"
+  (hk-deep-force
+    (hk-run
+      "class Describable a where\n  describe :: a -> String\ninstance Describable Bool where\n  describe x = \"a boolean\"\ninstance Describable Int where\n  describe x = \"an integer\"\nmain = describe True"))
+  "a boolean")
+
+(hk-test
+  "dispatch: error on unknown instance"
+  (guard
+    (e (true (>= (index-of e "No instance") 0)))
+    (begin
+      (hk-deep-force
+        (hk-run
+          "class Describable a where\n  describe :: a -> String\nmain = describe 42"))
+      false))
+  true)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/deriving.sx

@@ -0,0 +1,107 @@
+;; deriving.sx — tests for deriving (Eq, Show) on ADTs.
+
+;; ─── Show ────────────────────────────────────────────────────────────────────
+
+(hk-test
+  "deriving Show: nullary constructor"
+  (hk-deep-force
+    (hk-run "data Color = Red | Green | Blue deriving (Show)\nmain = show Red"))
+  "Red")
+
+(hk-test
+  "deriving Show: constructor with arg"
+  (hk-deep-force
+    (hk-run "data Wrapper = Wrap Int deriving (Show)\nmain = show (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")
+
+(hk-test
+  "deriving Show: second constructor"
+  (hk-deep-force
+    (hk-run
+      "data Color = Red | Green | Blue deriving (Show)\nmain = show Green"))
+  "Green")
+
+;; ─── 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
+    (hk-run
+      "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red == Red)"))
+  "True")
+
+(hk-test
+  "deriving Eq: different constructors"
+  (hk-deep-force
+    (hk-run
+      "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red == Blue)"))
+  "False")
+
+(hk-test
+  "deriving Eq: /= same"
+  (hk-deep-force
+    (hk-run
+      "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Red)"))
+  "False")
+
+(hk-test
+  "deriving Eq: /= different"
+  (hk-deep-force
+    (hk-run
+      "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Blue)"))
+  "True")
+
+(hk-test
+  "deriving Eq Show: combined"
+  (hk-deep-force
+    (hk-run
+      "data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 5)"))
+  "Circle 5")
+
+(hk-test
+  "deriving Eq Show: eq on constructor with arg"
+  (hk-deep-force
+    (hk-run
+      "data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 3 == Circle 3)"))
+  "True")
+
+(hk-test
+  "deriving Eq Show: different constructors with args"
+  (hk-deep-force
+    (hk-run
+      "data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 3 == Square 3)"))
+  "False")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/desugar.sx

@@ -0,0 +1,305 @@
+;; Desugar tests — surface AST → core AST.
+;;   :guarded   →  nested :if
+;;   :where     →  :let
+;;   :list-comp →  concatMap-based tree
+
+(define
+  hk-prog
+  (fn (&rest decls) (list :program decls)))
+
+;; ── Guards → if ──
+(hk-test
+  "two-way guarded rhs"
+  (hk-desugar (hk-parse-top "abs x | x < 0 = - x\n      | otherwise = x"))
+  (hk-prog
+    (list
+      :fun-clause
+      "abs"
+      (list (list :p-var "x"))
+      (list
+        :if
+        (list :op "<" (list :var "x") (list :int 0))
+        (list :neg (list :var "x"))
+        (list
+          :if
+          (list :var "otherwise")
+          (list :var "x")
+          (list
+            :app
+            (list :var "error")
+            (list :string "Non-exhaustive guards")))))))
+
+(hk-test
+  "three-way guarded rhs"
+  (hk-desugar
+    (hk-parse-top "sign n | n > 0 = 1\n       | n < 0 = -1\n       | otherwise = 0"))
+  (hk-prog
+    (list
+      :fun-clause
+      "sign"
+      (list (list :p-var "n"))
+      (list
+        :if
+        (list :op ">" (list :var "n") (list :int 0))
+        (list :int 1)
+        (list
+          :if
+          (list :op "<" (list :var "n") (list :int 0))
+          (list :neg (list :int 1))
+          (list
+            :if
+            (list :var "otherwise")
+            (list :int 0)
+            (list
+              :app
+              (list :var "error")
+              (list :string "Non-exhaustive guards"))))))))
+
+(hk-test
+  "case-alt guards desugared too"
+  (hk-desugar
+    (hk-parse "case x of\n  Just y | y > 0 -> y\n         | otherwise -> 0\n  Nothing -> -1"))
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list
+          :if
+          (list :op ">" (list :var "y") (list :int 0))
+          (list :var "y")
+          (list
+            :if
+            (list :var "otherwise")
+            (list :int 0)
+            (list
+              :app
+              (list :var "error")
+              (list :string "Non-exhaustive guards")))))
+      (list
+        :alt
+        (list :p-con "Nothing" (list))
+        (list :neg (list :int 1))))))
+
+;; ── Where → let ──
+(hk-test
+  "where with single binding"
+  (hk-desugar (hk-parse-top "f x = y\n  where y = x + 1"))
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :let
+        (list
+          (list
+            :fun-clause
+            "y"
+            (list)
+            (list :op "+" (list :var "x") (list :int 1))))
+        (list :var "y")))))
+
+(hk-test
+  "where with two bindings"
+  (hk-desugar
+    (hk-parse-top "f x = y + z\n  where y = x + 1\n        z = x - 1"))
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :let
+        (list
+          (list
+            :fun-clause
+            "y"
+            (list)
+            (list :op "+" (list :var "x") (list :int 1)))
+          (list
+            :fun-clause
+            "z"
+            (list)
+            (list :op "-" (list :var "x") (list :int 1))))
+        (list :op "+" (list :var "y") (list :var "z"))))))
+
+(hk-test
+  "guards + where — guarded body inside let"
+  (hk-desugar
+    (hk-parse-top "f x | x > 0 = y\n    | otherwise = 0\n  where y = 99"))
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :let
+        (list (list :fun-clause "y" (list) (list :int 99)))
+        (list
+          :if
+          (list :op ">" (list :var "x") (list :int 0))
+          (list :var "y")
+          (list
+            :if
+            (list :var "otherwise")
+            (list :int 0)
+            (list
+              :app
+              (list :var "error")
+              (list :string "Non-exhaustive guards"))))))))
+
+;; ── List comprehensions → concatMap / if / let ──
+(hk-test
+  "list-comp: single generator"
+  (hk-core-expr "[x | x <- xs]")
+  (list
+    :app
+    (list
+      :app
+      (list :var "concatMap")
+      (list
+        :lambda
+        (list (list :p-var "x"))
+        (list :list (list (list :var "x")))))
+    (list :var "xs")))
+
+(hk-test
+  "list-comp: generator then guard"
+  (hk-core-expr "[x * 2 | x <- xs, x > 0]")
+  (list
+    :app
+    (list
+      :app
+      (list :var "concatMap")
+      (list
+        :lambda
+        (list (list :p-var "x"))
+        (list
+          :if
+          (list :op ">" (list :var "x") (list :int 0))
+          (list
+            :list
+            (list (list :op "*" (list :var "x") (list :int 2))))
+          (list :list (list)))))
+    (list :var "xs")))
+
+(hk-test
+  "list-comp: generator then let"
+  (hk-core-expr "[y | x <- xs, let y = x + 1]")
+  (list
+    :app
+    (list
+      :app
+      (list :var "concatMap")
+      (list
+        :lambda
+        (list (list :p-var "x"))
+        (list
+          :let
+          (list
+            (list
+              :bind
+              (list :p-var "y")
+              (list :op "+" (list :var "x") (list :int 1))))
+          (list :list (list (list :var "y"))))))
+    (list :var "xs")))
+
+(hk-test
+  "list-comp: two generators (nested concatMap)"
+  (hk-core-expr "[(x, y) | x <- xs, y <- ys]")
+  (list
+    :app
+    (list
+      :app
+      (list :var "concatMap")
+      (list
+        :lambda
+        (list (list :p-var "x"))
+        (list
+          :app
+          (list
+            :app
+            (list :var "concatMap")
+            (list
+              :lambda
+              (list (list :p-var "y"))
+              (list
+                :list
+                (list
+                  (list
+                    :tuple
+                    (list (list :var "x") (list :var "y")))))))
+          (list :var "ys"))))
+    (list :var "xs")))
+
+;; ── Pass-through cases ──
+(hk-test
+  "plain int literal unchanged"
+  (hk-core-expr "42")
+  (list :int 42))
+
+(hk-test
+  "lambda + if passes through"
+  (hk-core-expr "\\x -> if x > 0 then x else - x")
+  (list
+    :lambda
+    (list (list :p-var "x"))
+    (list
+      :if
+      (list :op ">" (list :var "x") (list :int 0))
+      (list :var "x")
+      (list :neg (list :var "x")))))
+
+(hk-test
+  "simple fun-clause (no guards/where) passes through"
+  (hk-desugar (hk-parse-top "id x = x"))
+  (hk-prog
+    (list
+      :fun-clause
+      "id"
+      (list (list :p-var "x"))
+      (list :var "x"))))
+
+(hk-test
+  "data decl passes through"
+  (hk-desugar (hk-parse-top "data Maybe a = Nothing | Just a"))
+  (hk-prog
+    (list
+      :data
+      "Maybe"
+      (list "a")
+      (list
+        (list :con-def "Nothing" (list))
+        (list :con-def "Just" (list (list :t-var "a")))))))
+
+(hk-test
+  "module header passes through, body desugared"
+  (hk-desugar
+    (hk-parse-top "module M where\nf x | x > 0 = 1\n    | otherwise = 0"))
+  (list
+    :module
+    "M"
+    nil
+    (list)
+    (list
+      (list
+        :fun-clause
+        "f"
+        (list (list :p-var "x"))
+        (list
+          :if
+          (list :op ">" (list :var "x") (list :int 0))
+          (list :int 1)
+          (list
+            :if
+            (list :var "otherwise")
+            (list :int 0)
+            (list
+              :app
+              (list :var "error")
+              (list :string "Non-exhaustive guards"))))))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/do-io.sx

@@ -0,0 +1,117 @@
+;; do-notation + stub IO monad. Desugaring is per Haskell 98 §3.14:
+;;   do { e ; ss }      = e >> do { ss }
+;;   do { p <- e ; ss } = e >>= \p -> do { ss }
+;;   do { let ds ; ss } = let ds in do { ss }
+;;   do { e }           = e
+;; The IO type is just `("IO" payload)` for now — no real side
+;; effects yet. `return`, `>>=`, `>>` are built-ins.
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+;; ── Single-statement do ──
+(hk-test
+  "do with a single expression"
+  (hk-eval-expr-source "do { return 5 }")
+  (list "IO" 5))
+
+(hk-test
+  "return wraps any expression"
+  (hk-eval-expr-source "return (1 + 2 * 3)")
+  (list "IO" 7))
+
+;; ── Bind threads results ──
+(hk-test
+  "single bind"
+  (hk-eval-expr-source
+    "do { x <- return 5 ; return (x + 1) }")
+  (list "IO" 6))
+
+(hk-test
+  "two binds"
+  (hk-eval-expr-source
+    "do\n  x <- return 5\n  y <- return 7\n  return (x + y)")
+  (list "IO" 12))
+
+(hk-test
+  "three binds — accumulating"
+  (hk-eval-expr-source
+    "do\n  a <- return 1\n  b <- return 2\n  c <- return 3\n  return (a + b + c)")
+  (list "IO" 6))
+
+;; ── Mixing >> and >>= ──
+(hk-test
+  ">> sequencing — last wins"
+  (hk-eval-expr-source
+    "do\n  return 1\n  return 2\n  return 3")
+  (list "IO" 3))
+
+(hk-test
+  ">> then >>= — last bind wins"
+  (hk-eval-expr-source
+    "do\n  return 99\n  x <- return 5\n  return x")
+  (list "IO" 5))
+
+;; ── do-let ──
+(hk-test
+  "do-let single binding"
+  (hk-eval-expr-source
+    "do\n  let x = 3\n  return (x * 2)")
+  (list "IO" 6))
+
+(hk-test
+  "do-let multi-bind, used after"
+  (hk-eval-expr-source
+    "do\n  let x = 4\n      y = 5\n  return (x * y)")
+  (list "IO" 20))
+
+(hk-test
+  "do-let interleaved with bind"
+  (hk-eval-expr-source
+    "do\n  x <- return 10\n  let y = x + 1\n  return (x * y)")
+  (list "IO" 110))
+
+;; ── Bind + pattern ──
+(hk-test
+  "bind to constructor pattern"
+  (hk-eval-expr-source
+    "do\n  Just x <- return (Just 7)\n  return (x + 100)")
+  (list "IO" 107))
+
+(hk-test
+  "bind to tuple pattern"
+  (hk-eval-expr-source
+    "do\n  (a, b) <- return (3, 4)\n  return (a * b)")
+  (list "IO" 12))
+
+;; ── User-defined IO functions ──
+(hk-test
+  "do inside top-level fun"
+  (hk-prog-val
+    "addM x y = do\n  a <- return x\n  b <- return y\n  return (a + b)\nresult = addM 5 6"
+    "result")
+  (list "IO" 11))
+
+(hk-test
+  "nested do"
+  (hk-eval-expr-source
+    "do\n  x <- do { y <- return 3 ; return (y + 1) }\n  return (x * 2)")
+  (list "IO" 8))
+
+;; ── (>>=) and (>>) used directly as functions ──
+(hk-test
+  ">>= used directly"
+  (hk-eval-expr-source
+    "(return 4) >>= (\\x -> return (x + 100))")
+  (list "IO" 104))
+
+(hk-test
+  ">> used directly"
+  (hk-eval-expr-source
+    "(return 1) >> (return 2)")
+  (list "IO" 2))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

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

@@ -0,0 +1,343 @@
+;; Strict evaluator tests. Each test parses, desugars, and evaluates
+;; either an expression (hk-eval-expr-source) or a full program
+;; (hk-eval-program → look up a named value).
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+;; ── Literals ──
+(hk-test "int literal" (hk-eval-expr-source "42") 42)
+(hk-test "float literal" (hk-eval-expr-source "3.14") 3.14)
+(hk-test "string literal" (hk-eval-expr-source "\"hi\"") "hi")
+(hk-test "char literal" (hk-eval-expr-source "'a'") "a")
+(hk-test "negative literal" (hk-eval-expr-source "- 5") -5)
+
+;; ── Arithmetic ──
+(hk-test "addition" (hk-eval-expr-source "1 + 2") 3)
+(hk-test
+  "precedence"
+  (hk-eval-expr-source "1 + 2 * 3")
+  7)
+(hk-test
+  "parens override precedence"
+  (hk-eval-expr-source "(1 + 2) * 3")
+  9)
+(hk-test
+  "subtraction left-assoc"
+  (hk-eval-expr-source "10 - 3 - 2")
+  5)
+
+;; ── Comparison + Bool ──
+(hk-test
+  "less than is True"
+  (hk-eval-expr-source "3 < 5")
+  (list "True"))
+(hk-test
+  "equality is False"
+  (hk-eval-expr-source "1 == 2")
+  (list "False"))
+(hk-test
+  "&& shortcuts"
+  (hk-eval-expr-source "(1 == 1) && (2 == 2)")
+  (list "True"))
+
+;; ── if / otherwise ──
+(hk-test
+  "if True"
+  (hk-eval-expr-source "if True then 1 else 2")
+  1)
+(hk-test
+  "if comparison branch"
+  (hk-eval-expr-source "if 5 > 3 then \"yes\" else \"no\"")
+  "yes")
+(hk-test "otherwise is True" (hk-eval-expr-source "otherwise") (list "True"))
+
+;; ── let ──
+(hk-test
+  "let single binding"
+  (hk-eval-expr-source "let x = 5 in x + 1")
+  6)
+(hk-test
+  "let two bindings"
+  (hk-eval-expr-source "let x = 1; y = 2 in x + y")
+  3)
+(hk-test
+  "let recursive: factorial 5"
+  (hk-eval-expr-source
+    "let f n = if n == 0 then 1 else n * f (n - 1) in f 5")
+  120)
+
+;; ── Lambdas ──
+(hk-test
+  "lambda apply"
+  (hk-eval-expr-source "(\\x -> x + 1) 5")
+  6)
+(hk-test
+  "lambda multi-arg"
+  (hk-eval-expr-source "(\\x y -> x * y) 3 4")
+  12)
+(hk-test
+  "lambda with constructor pattern"
+  (hk-eval-expr-source "(\\(Just x) -> x + 1) (Just 7)")
+  8)
+
+;; ── Constructors ──
+(hk-test
+  "0-arity constructor"
+  (hk-eval-expr-source "Nothing")
+  (list "Nothing"))
+(hk-test
+  "1-arity constructor applied"
+  (hk-eval-expr-source "Just 5")
+  (list "Just" 5))
+(hk-test
+  "True / False as bools"
+  (hk-eval-expr-source "True")
+  (list "True"))
+
+;; ── case ──
+(hk-test
+  "case Just"
+  (hk-eval-expr-source
+    "case Just 7 of Just x -> x ; Nothing -> 0")
+  7)
+(hk-test
+  "case Nothing"
+  (hk-eval-expr-source
+    "case Nothing of Just x -> x ; Nothing -> 99")
+  99)
+(hk-test
+  "case literal pattern"
+  (hk-eval-expr-source
+    "case 0 of 0 -> \"zero\" ; n -> \"other\"")
+  "zero")
+(hk-test
+  "case tuple"
+  (hk-eval-expr-source
+    "case (1, 2) of (a, b) -> a + b")
+  3)
+(hk-test
+  "case wildcard fallback"
+  (hk-eval-expr-source
+    "case 5 of 0 -> \"z\" ; _ -> \"nz\"")
+  "nz")
+
+;; ── List literals + cons ──
+(hk-test
+  "list literal as cons spine"
+  (hk-eval-expr-source "[1, 2, 3]")
+  (list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))
+(hk-test
+  "empty list literal"
+  (hk-eval-expr-source "[]")
+  (list "[]"))
+(hk-test
+  "cons via :"
+  (hk-eval-expr-source "1 : []")
+  (list ":" 1 (list "[]")))
+(hk-test
+  "++ concatenates lists"
+  (hk-eval-expr-source "[1, 2] ++ [3]")
+  (list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))
+
+;; ── Tuples ──
+(hk-test
+  "2-tuple"
+  (hk-eval-expr-source "(1, 2)")
+  (list "Tuple" 1 2))
+(hk-test
+  "3-tuple"
+  (hk-eval-expr-source "(\"a\", 5, True)")
+  (list "Tuple" "a" 5 (list "True")))
+
+;; ── Sections ──
+(hk-test
+  "right section (+ 1) applied"
+  (hk-eval-expr-source "(+ 1) 5")
+  6)
+(hk-test
+  "left section (10 -) applied"
+  (hk-eval-expr-source "(10 -) 4")
+  6)
+
+;; ── Multi-clause top-level functions ──
+(hk-test
+  "multi-clause: factorial"
+  (hk-prog-val
+    "fact 0 = 1\nfact n = n * fact (n - 1)\nresult = fact 6"
+    "result")
+  720)
+
+(hk-test
+  "multi-clause: list length via cons pattern"
+  (hk-prog-val
+    "len [] = 0\nlen (x:xs) = 1 + len xs\nresult = len [10, 20, 30, 40]"
+    "result")
+  4)
+
+(hk-test
+  "multi-clause: Maybe handler"
+  (hk-prog-val
+    "fromMaybe d Nothing = d\nfromMaybe _ (Just x) = x\nresult = fromMaybe 0 (Just 9)"
+    "result")
+  9)
+
+(hk-test
+  "multi-clause: Maybe with default"
+  (hk-prog-val
+    "fromMaybe d Nothing = d\nfromMaybe _ (Just x) = x\nresult = fromMaybe 0 Nothing"
+    "result")
+  0)
+
+;; ── User-defined data and matching ──
+(hk-test
+  "custom data with pattern match"
+  (hk-prog-val
+    "data Color = Red | Green | Blue\nname Red = \"red\"\nname Green = \"green\"\nname Blue = \"blue\"\nresult = name Green"
+    "result")
+  "green")
+
+(hk-test
+  "custom binary tree height"
+  (hk-prog-val
+    "data Tree = Leaf | Node Tree Tree\nh Leaf = 0\nh (Node l r) = 1 + max (h l) (h r)\nmax a b = if a > b then a else b\nresult = h (Node (Node Leaf Leaf) Leaf)"
+    "result")
+  2)
+
+;; ── Currying ──
+(hk-test
+  "partial application"
+  (hk-prog-val
+    "add x y = x + y\nadd5 = add 5\nresult = add5 7"
+    "result")
+  12)
+
+;; ── Higher-order ──
+(hk-test
+  "higher-order: function as arg"
+  (hk-prog-val
+    "twice f x = f (f x)\ninc x = x + 1\nresult = twice inc 10"
+    "result")
+  12)
+
+;; ── Error built-in ──
+(hk-test
+  "error short-circuits via if"
+  (hk-eval-expr-source
+    "if True then 1 else error \"unreachable\"")
+  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\")")
+  1)
+
+(hk-test
+  "first arg never forced"
+  (hk-eval-expr-source "(\\x y -> y) (error \"never\") 99")
+  99)
+
+(hk-test
+  "constructor argument is lazy under wildcard pattern"
+  (hk-eval-expr-source
+    "case Just (error \"deeply\") of Just _ -> 7 ; Nothing -> 0")
+  7)
+
+(hk-test
+  "lazy: const drops its second argument"
+  (hk-prog-val "const x y = x\nresult = const 5 (error \"boom\")" "result")
+  5)
+
+(hk-test
+  "lazy: head ignores tail"
+  (hk-prog-val
+    "myHead (x:_) = x\nresult = myHead (1 : (error \"tail\") : [])"
+    "result")
+  1)
+
+(hk-test
+  "lazy: Just on undefined evaluates only on force"
+  (hk-prog-val
+    "wrapped = Just (error \"oh no\")\nresult = case wrapped of Just _ -> True ; Nothing -> False"
+    "result")
+  (list "True"))
+
+(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/infer.sx

@@ -0,0 +1,181 @@
+;; infer.sx tests — Algorithm W: literals, vars, lambdas, application, let,
+;; if, operators, tuples, lists, let-polymorphism.
+
+(define hk-t (fn (src expected)
+  (hk-test (str "infer: " src) (hk-infer-type src) expected)))
+
+;; ─── Literals ────────────────────────────────────────────────────────────────
+(hk-t "1"          "Int")
+(hk-t "3.14"       "Float")
+(hk-t "\"hello\""  "String")
+(hk-t "'x'"        "Char")
+(hk-t "True"       "Bool")
+(hk-t "False"      "Bool")
+
+;; ─── Arithmetic and boolean operators ────────────────────────────────────────
+(hk-t "1 + 2"      "Int")
+(hk-t "3 * 4"      "Int")
+(hk-t "10 - 3"     "Int")
+(hk-t "True && False" "Bool")
+(hk-t "True || False" "Bool")
+(hk-t "not True"   "Bool")
+(hk-t "1 == 1"     "Bool")
+(hk-t "1 < 2"      "Bool")
+
+;; ─── Lambda ───────────────────────────────────────────────────────────────────
+;; \x -> x   (identity)  should get t1 -> t1
+(hk-test "infer: identity lambda" (hk-infer-type "\\x -> x") "t1 -> t1")
+
+;; \x -> x + 1 : Int -> Int
+(hk-test "infer: lambda add" (hk-infer-type "\\x -> x + 1") "Int -> Int")
+
+;; \x -> not x : Bool -> Bool
+(hk-test "infer: lambda not" (hk-infer-type "\\x -> not x") "Bool -> Bool")
+
+;; \x y -> x + y : Int -> Int -> Int
+(hk-test "infer: two-arg lambda" (hk-infer-type "\\x -> \\y -> x + y") "Int -> Int -> Int")
+
+;; ─── Application ─────────────────────────────────────────────────────────────
+(hk-t "not True"    "Bool")
+(hk-t "negate 1"    "Int")
+
+;; ─── If-then-else ─────────────────────────────────────────────────────────────
+(hk-t "if True then 1 else 2"     "Int")
+(hk-t "if 1 == 2 then True else False" "Bool")
+
+;; ─── Let bindings ─────────────────────────────────────────────────────────────
+;; let x = 1 in x + 2
+(hk-t "let x = 1 in x + 2" "Int")
+
+;; let f x = x + 1 in f 5
+(hk-t "let f x = x + 1 in f 5" "Int")
+
+;; let-polymorphism: let id x = x in id 1
+(hk-t "let id x = x in id 1" "Int")
+
+;; ─── Tuples ───────────────────────────────────────────────────────────────────
+(hk-t "(1, True)"       "(Int, Bool)")
+(hk-t "(1, 2, 3)"       "(Int, Int, Int)")
+
+;; ─── Lists ───────────────────────────────────────────────────────────────────
+(hk-t "[1, 2, 3]"    "[Int]")
+(hk-t "[True, False]" "[Bool]")
+
+;; ─── Polymorphic list functions ───────────────────────────────────────────────
+(hk-t "length [1, 2, 3]"   "Int")
+(hk-t "null []"             "Bool")
+(hk-t "head [1, 2, 3]"     "Int")
+
+;; ─── hk-expr->brief ──────────────────────────────────────────────────────────
+(hk-test "brief var"    (hk-expr->brief (list "var" "x"))           "x")
+(hk-test "brief con"    (hk-expr->brief (list "con" "Just"))        "Just")
+(hk-test "brief int"    (hk-expr->brief (list "int" 42))            "42")
+(hk-test "brief app"    (hk-expr->brief (list "app" (list "var" "f") (list "var" "x"))) "(f x)")
+(hk-test "brief op"     (hk-expr->brief (list "op" "+" (list "int" 1) (list "int" 2))) "(1 + 2)")
+(hk-test "brief lambda" (hk-expr->brief (list "lambda" (list) (list "var" "x"))) "(\\ ...)")
+(hk-test "brief loc"    (hk-expr->brief (list "loc" 3 7 (list "var" "x"))) "x")
+
+;; ─── Type error messages ─────────────────────────────────────────────────────
+;; Helper: catch the error and check it contains a substring.
+(define hk-str-has? (fn (s sub) (>= (index-of s sub) 0)))
+
+(define hk-te
+  (fn (label src sub)
+    (hk-test label
+      (guard (e (#t (hk-str-has? e sub)))
+        (begin (hk-infer-type src) false))
+      true)))
+
+;; Unbound variable error includes the variable name.
+(hk-te "error unbound name" "foo + 1"    "foo")
+(hk-te "error unbound unk"  "unknown"    "unknown")
+
+;; Unification error mentions the conflicting types.
+(hk-te "error unify int-bool-1" "1 + True"  "Int")
+(hk-te "error unify int-bool-2" "1 + True"  "Bool")
+
+;; ─── Loc node: passes through to inner (position decorates outer context) ────
+(define hk-loc-err-msg
+  (fn ()
+    (guard (e (#t e))
+      (begin
+        (hk-reset-fresh)
+        (hk-w (hk-type-env0) (list "loc" 5 10 (list "var" "mystery")))
+        "no-error"))))
+(hk-test "loc passes through to var error"
+  (hk-str-has? (hk-loc-err-msg) "mystery")
+  true)
+
+;; ─── hk-infer-decl ───────────────────────────────────────────────────────────
+;; Returns ("ok" name type) | ("err" msg)
+(define hk-env0-t (hk-type-env0))
+
+(define prog1 (hk-core "f x = x + 1"))
+(define decl1 (first (nth prog1 1)))
+(define res1 (hk-infer-decl hk-env0-t decl1))
+(hk-test "decl result tag"  (first res1)    "ok")
+(hk-test "decl result name" (nth res1 1)    "f")
+(hk-test "decl result type" (nth res1 2)    "Int -> Int")
+
+;; Error decl: result is ("err" "in 'g': ...")
+(define prog2 (hk-core "g x = x + True"))
+(define decl2 (first (nth prog2 1)))
+(define res2 (hk-infer-decl hk-env0-t decl2))
+(hk-test "decl error tag"    (first res2)                  "err")
+(hk-test "decl error has g"  (hk-str-has? (nth res2 1) "g")   true)
+(hk-test "decl error has msg" (hk-str-has? (nth res2 1) "unify") true)
+
+;; ─── hk-infer-prog ───────────────────────────────────────────────────────────
+;; Returns list of ("ok"/"err" ...) tagged results.
+(define prog3 (hk-core "double x = x + x\ntwice f x = f (f x)"))
+(define results3 (hk-infer-prog prog3 hk-env0-t))
+;; results3 = (("ok" "double" "Int -> Int") ("ok" "twice" "..."))
+(hk-test "infer-prog count"  (len results3)               2)
+(hk-test "infer-prog double" (nth (nth results3 0) 2)     "Int -> Int")
+(hk-test "infer-prog twice"  (nth (nth results3 1) 2)     "(t3 -> t3) -> t3 -> t3")
+
+(hk-t "let id x = x in id 1" "Int")
+
+(hk-t "let id x = x in id True" "Bool")
+
+(hk-t "let id x = x in (id 1, id True)" "(Int, Bool)")
+
+(hk-t "let const x y = x in (const 1 True, const True 1)" "(Int, Bool)")
+
+(hk-t "let f x = x in let g y = f y in (g 1, g True)" "(Int, Bool)")
+
+(hk-t "let twice f x = f (f x) in twice (\x -> x + 1) 5" "Int")
+
+(hk-t "not (not True)" "Bool")
+
+(hk-t "negate (negate 1)" "Int")
+
+(hk-t "\\x -> \\y -> x && y" "Bool -> Bool -> Bool")
+
+(hk-t "\\x -> x == 1" "Int -> Bool")
+
+(hk-t "let x = True in if x then 1 else 0" "Int")
+
+(hk-t "let f x = not x in f True" "Bool")
+
+(hk-t "let f x = (x, x + 1) in f 5" "(Int, Int)")
+
+(hk-t "let x = 1 in let y = 2 in x + y" "Int")
+
+(hk-t "let f x = x + 1 in f (f 5)" "Int")
+
+(hk-t "if 1 < 2 then True else False" "Bool")
+
+(hk-t "if True then 1 + 1 else 2 + 2" "Int")
+
+(hk-t "(1 + 2, True && False)" "(Int, Bool)")
+
+(hk-t "(1 == 1, 2 < 3)" "(Bool, Bool)")
+
+(hk-t "length [True, False]" "Int")
+
+(hk-t "null [1]" "Bool")
+
+(hk-t "[True]" "[Bool]")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/infinite.sx

@@ -0,0 +1,137 @@
+;; Infinite structures + Prelude tests. The lazy `:` operator builds
+;; cons cells with thunked head/tail so recursive list-defining
+;; functions terminate when only a finite prefix is consumed.
+
+(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-eval-list
+  (fn (src) (hk-as-list (hk-eval-expr-source src))))
+
+;; ── Prelude basics ──
+(hk-test "head of literal" (hk-eval-expr-source "head [1, 2, 3]") 1)
+(hk-test
+  "tail of literal"
+  (hk-eval-list "tail [1, 2, 3]")
+  (list 2 3))
+(hk-test "length" (hk-eval-expr-source "length [10, 20, 30, 40]") 4)
+(hk-test "length empty" (hk-eval-expr-source "length []") 0)
+(hk-test
+  "map with section"
+  (hk-eval-list "map (+ 1) [1, 2, 3]")
+  (list 2 3 4))
+(hk-test
+  "filter"
+  (hk-eval-list "filter (\\x -> x > 2) [1, 2, 3, 4, 5]")
+  (list 3 4 5))
+(hk-test
+  "drop"
+  (hk-eval-list "drop 2 [10, 20, 30, 40]")
+  (list 30 40))
+(hk-test "fst" (hk-eval-expr-source "fst (7, 9)") 7)
+(hk-test "snd" (hk-eval-expr-source "snd (7, 9)") 9)
+(hk-test
+  "zipWith"
+  (hk-eval-list "zipWith plus [1, 2, 3] [10, 20, 30]")
+  (list 11 22 33))
+
+;; ── Infinite structures ──
+(hk-test
+  "take from repeat"
+  (hk-eval-list "take 5 (repeat 7)")
+  (list 7 7 7 7 7))
+(hk-test
+  "take 0 from repeat returns empty"
+  (hk-eval-list "take 0 (repeat 7)")
+  (list))
+(hk-test
+  "take from iterate"
+  (hk-eval-list "take 5 (iterate (\\x -> x + 1) 0)")
+  (list 0 1 2 3 4))
+(hk-test
+  "iterate with multiplication"
+  (hk-eval-list "take 4 (iterate (\\x -> x * 2) 1)")
+  (list 1 2 4 8))
+(hk-test
+  "head of repeat"
+  (hk-eval-expr-source "head (repeat 99)")
+  99)
+
+;; ── Fibonacci stream ──
+(hk-test
+  "first 10 Fibonacci numbers"
+  (hk-eval-list "take 10 fibs")
+  (list 0 1 1 2 3 5 8 13 21 34))
+(hk-test
+  "fib at position 8"
+  (hk-eval-expr-source "head (drop 8 fibs)")
+  21)
+
+;; ── Building infinite structures in user code ──
+(hk-test
+  "user-defined infinite ones"
+  (hk-prog-val
+    "ones = 1 : ones\nresult = take 6 ones"
+    "result")
+  (list ":" 1 (list ":" 1 (list ":" 1 (list ":" 1 (list ":" 1 (list ":" 1 (list "[]"))))))))
+
+(hk-test
+  "user-defined nats"
+  (hk-prog-val
+    "nats = naturalsFrom 1\nnaturalsFrom n = n : naturalsFrom (n + 1)\nresult = take 5 nats"
+    "result")
+  (list ":" 1 (list ":" 2 (list ":" 3 (list ":" 4 (list ":" 5 (list "[]")))))))
+
+;; ── Range syntax ──
+(hk-test
+  "finite range [1..5]"
+  (hk-eval-list "[1..5]")
+  (list 1 2 3 4 5))
+(hk-test
+  "empty range when from > to"
+  (hk-eval-list "[10..3]")
+  (list))
+(hk-test
+  "stepped range"
+  (hk-eval-list "[1, 3..10]")
+  (list 1 3 5 7 9))
+(hk-test
+  "open range — head"
+  (hk-eval-expr-source "head [1..]")
+  1)
+(hk-test
+  "open range — drop then head"
+  (hk-eval-expr-source "head (drop 99 [1..])")
+  100)
+(hk-test
+  "open range — take 5"
+  (hk-eval-list "take 5 [10..]")
+  (list 10 11 12 13 14))
+
+;; ── Composing Prelude functions ──
+(hk-test
+  "map then filter"
+  (hk-eval-list
+    "filter (\\x -> x > 5) (map (\\x -> x * 2) [1, 2, 3, 4])")
+  (list 6 8))
+
+(hk-test
+  "sum-via-foldless"
+  (hk-prog-val
+    "mySum [] = 0\nmySum (x:xs) = x + mySum xs\nresult = mySum (take 5 (iterate (\\x -> x + 1) 1))"
+    "result")
+  15)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

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

@@ -0,0 +1,84 @@
+;; io-input.sx — tests for getLine, getContents, readFile, writeFile.
+
+(hk-test
+  "getLine reads single line"
+  (hk-run-io-with-input "main = getLine >>= putStrLn" (list "hello"))
+  (list "hello"))
+
+(hk-test
+  "getLine reads two lines"
+  (hk-run-io-with-input
+    "main = do { line1 <- getLine; line2 <- getLine; putStrLn line1; putStrLn line2 }"
+    (list "first" "second"))
+  (list "first" "second"))
+
+(hk-test
+  "getLine bind in layout do"
+  (hk-run-io-with-input
+    "main = do\n  line <- getLine\n  putStrLn line"
+    (list "world"))
+  (list "world"))
+
+(hk-test
+  "getLine echo with prefix"
+  (hk-run-io-with-input
+    "main = do\n  line <- getLine\n  putStrLn (\"Got: \" ++ line)"
+    (list "test"))
+  (list "Got: test"))
+
+(hk-test
+  "getContents reads all lines joined"
+  (hk-run-io-with-input
+    "main = getContents >>= putStr"
+    (list "line1" "line2" "line3"))
+  (list "line1\nline2\nline3"))
+
+(hk-test
+  "getContents empty stdin"
+  (hk-run-io-with-input "main = getContents >>= putStr" (list))
+  (list ""))
+
+(hk-test
+  "readFile reads pre-loaded content"
+  (begin
+    (set! hk-vfs (dict))
+    (dict-set! hk-vfs "hello.txt" "Hello, World!")
+    (hk-run-io "main = readFile \"hello.txt\" >>= putStrLn"))
+  (list "Hello, World!"))
+
+(hk-test
+  "writeFile creates file"
+  (begin
+    (set! hk-vfs (dict))
+    (hk-run-io "main = writeFile \"out.txt\" \"written content\"")
+    (get hk-vfs "out.txt"))
+  "written content")
+
+(hk-test
+  "writeFile then readFile roundtrip"
+  (begin
+    (set! hk-vfs (dict))
+    (hk-run-io
+      "main = do { writeFile \"f.txt\" \"round trip\"; readFile \"f.txt\" >>= putStrLn }"))
+  (list "round trip"))
+
+(hk-test
+  "readFile error on missing file"
+  (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
+  "getLine then writeFile combined"
+  (begin
+    (set! hk-vfs (dict))
+    (hk-run-io-with-input
+      "main = do\n  line <- getLine\n  writeFile \"cap.txt\" line"
+      (list "captured"))
+    (get hk-vfs "cap.txt"))
+  "captured")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

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/layout.sx

@@ -0,0 +1,245 @@
+;; Haskell layout-rule tests. hk-tokenizer + hk-layout produce a
+;; virtual-brace-annotated stream; these tests cover the algorithm
+;; from Haskell 98 §10.3 plus the pragmatic let/in single-line rule.
+
+;; Convenience — tokenize, run layout, strip eof, keep :type/:value.
+(define
+  hk-lay
+  (fn
+    (src)
+    (map
+      (fn (tok) {:value (get tok "value") :type (get tok "type")})
+      (filter
+        (fn (tok) (not (= (get tok "type") "eof")))
+        (hk-layout (hk-tokenize src))))))
+
+;; ── 1. Basics ──
+(hk-test
+  "empty input produces empty module { }"
+  (hk-lay "")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "}" :type "vrbrace"}))
+
+(hk-test
+  "single token → module open+close"
+  (hk-lay "foo")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "foo" :type "varid"}
+    {:value "}" :type "vrbrace"}))
+
+(hk-test
+  "two top-level decls get vsemi between"
+  (hk-lay "foo = 1\nbar = 2")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "foo" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value ";" :type "vsemi"}
+    {:value "bar" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 2 :type "integer"}
+    {:value "}" :type "vrbrace"}))
+
+;; ── 2. Layout keywords — do / let / where / of ──
+(hk-test
+  "do block with two stmts"
+  (hk-lay "f = do\n  x\n  y")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "f" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value "do" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "x" :type "varid"}
+    {:value ";" :type "vsemi"}
+    {:value "y" :type "varid"}
+    {:value "}" :type "vrbrace"}
+    {:value "}" :type "vrbrace"}))
+
+(hk-test
+  "single-line let ... in"
+  (hk-lay "let x = 1 in x")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "let" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "x" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value "}" :type "vrbrace"}
+    {:value "in" :type "reserved"}
+    {:value "x" :type "varid"}
+    {:value "}" :type "vrbrace"}))
+
+(hk-test
+  "where block with two bindings"
+  (hk-lay "f = g\n  where\n    g = 1\n    h = 2")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "f" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value "g" :type "varid"}
+    {:value "where" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "g" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value ";" :type "vsemi"}
+    {:value "h" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 2 :type "integer"}
+    {:value "}" :type "vrbrace"}
+    {:value "}" :type "vrbrace"}))
+
+(hk-test
+  "case … of with arms"
+  (hk-lay "f x = case x of\n  Just y -> y\n  Nothing -> 0")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "f" :type "varid"}
+    {:value "x" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value "case" :type "reserved"}
+    {:value "x" :type "varid"}
+    {:value "of" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "Just" :type "conid"}
+    {:value "y" :type "varid"}
+    {:value "->" :type "reservedop"}
+    {:value "y" :type "varid"}
+    {:value ";" :type "vsemi"}
+    {:value "Nothing" :type "conid"}
+    {:value "->" :type "reservedop"}
+    {:value 0 :type "integer"}
+    {:value "}" :type "vrbrace"}
+    {:value "}" :type "vrbrace"}))
+
+;; ── 3. Explicit braces disable layout ──
+(hk-test
+  "explicit braces — no implicit vlbrace/vsemi/vrbrace inside"
+  (hk-lay "do { x ; y }")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "do" :type "reserved"}
+    {:value "{" :type "lbrace"}
+    {:value "x" :type "varid"}
+    {:value ";" :type "semi"}
+    {:value "y" :type "varid"}
+    {:value "}" :type "rbrace"}
+    {:value "}" :type "vrbrace"}))
+
+;; ── 4. Dedent closes nested blocks ──
+(hk-test
+  "dedent back to module level closes do block"
+  (hk-lay "f = do\n  x\n  y\ng = 2")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "f" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value "do" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "x" :type "varid"}
+    {:value ";" :type "vsemi"}
+    {:value "y" :type "varid"}
+    {:value "}" :type "vrbrace"}
+    {:value ";" :type "vsemi"}
+    {:value "g" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 2 :type "integer"}
+    {:value "}" :type "vrbrace"}))
+
+(hk-test
+  "dedent closes inner let, emits vsemi at outer do level"
+  (hk-lay "main = do\n  let x = 1\n  print x")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "main" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value "do" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "let" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "x" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value "}" :type "vrbrace"}
+    {:value ";" :type "vsemi"}
+    {:value "print" :type "varid"}
+    {:value "x" :type "varid"}
+    {:value "}" :type "vrbrace"}
+    {:value "}" :type "vrbrace"}))
+
+;; ── 5. Module header skips outer implicit open ──
+(hk-test
+  "module M where — only where opens a block"
+  (hk-lay "module M where\n  f = 1")
+  (list
+    {:value "module" :type "reserved"}
+    {:value "M" :type "conid"}
+    {:value "where" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "f" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value "}" :type "vrbrace"}))
+
+;; ── 6. Newlines are stripped ──
+(hk-test
+  "newline tokens do not appear in output"
+  (let
+    ((toks (hk-layout (hk-tokenize "foo\nbar"))))
+    (every?
+      (fn (t) (not (= (get t "type") "newline")))
+      toks))
+  true)
+
+;; ── 7. Continuation — deeper indent does NOT emit vsemi ──
+(hk-test
+  "line continuation (deeper indent) just merges"
+  (hk-lay "foo = 1 +\n   2")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "foo" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value "+" :type "varsym"}
+    {:value 2 :type "integer"}
+    {:value "}" :type "vrbrace"}))
+
+;; ── 8. Stack closing at EOF ──
+(hk-test
+  "EOF inside nested do closes all implicit blocks"
+  (let
+    ((toks (hk-lay "main = do\n  do\n    x")))
+    (let
+      ((n (len toks)))
+      (list
+        (get (nth toks (- n 1)) "type")
+        (get (nth toks (- n 2)) "type")
+        (get (nth toks (- n 3)) "type"))))
+  (list "vrbrace" "vrbrace" "vrbrace"))
+
+;; ── 9. Qualified-newline: x at deeper col than stack top does nothing ──
+(hk-test
+  "mixed where + do"
+  (hk-lay "f = do\n    x\n  where\n    x = 1")
+  (list
+    {:value "{" :type "vlbrace"}
+    {:value "f" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value "do" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "x" :type "varid"}
+    {:value "}" :type "vrbrace"}
+    {:value "where" :type "reserved"}
+    {:value "{" :type "vlbrace"}
+    {:value "x" :type "varid"}
+    {:value "=" :type "reservedop"}
+    {:value 1 :type "integer"}
+    {:value "}" :type "vrbrace"}
+    {:value "}" :type "vrbrace"}))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

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/match.sx

@@ -0,0 +1,256 @@
+;; Pattern-matcher tests. The matcher takes (pat val env) and returns
+;; an extended env dict on success, or `nil` on failure. Constructor
+;; values are tagged lists (con-name first); tuples use the "Tuple"
+;; tag; lists use chained `:` cons with `[]` nil.
+
+;; ── Atomic patterns ──
+(hk-test
+  "wildcard always matches"
+  (hk-match (list :p-wild) 42 (dict))
+  (dict))
+
+(hk-test
+  "var binds value"
+  (hk-match (list :p-var "x") 42 (dict))
+  {:x 42})
+
+(hk-test
+  "var preserves prior env"
+  (hk-match (list :p-var "y") 7 {:x 1})
+  {:x 1 :y 7})
+
+(hk-test
+  "int literal matches equal"
+  (hk-match (list :p-int 5) 5 (dict))
+  (dict))
+
+(hk-test
+  "int literal fails on mismatch"
+  (hk-match (list :p-int 5) 6 (dict))
+  nil)
+
+(hk-test
+  "negative int literal matches"
+  (hk-match (list :p-int -3) -3 (dict))
+  (dict))
+
+(hk-test
+  "string literal matches"
+  (hk-match (list :p-string "hi") "hi" (dict))
+  (dict))
+
+(hk-test
+  "string literal fails"
+  (hk-match (list :p-string "hi") "bye" (dict))
+  nil)
+
+(hk-test
+  "char literal matches"
+  (hk-match (list :p-char "a") "a" (dict))
+  (dict))
+
+;; ── Constructor patterns ──
+(hk-test
+  "0-arity con matches"
+  (hk-match
+    (list :p-con "Nothing" (list))
+    (hk-mk-con "Nothing" (list))
+    (dict))
+  (dict))
+
+(hk-test
+  "1-arity con matches and binds"
+  (hk-match
+    (list :p-con "Just" (list (list :p-var "y")))
+    (hk-mk-con "Just" (list 9))
+    (dict))
+  {:y 9})
+
+(hk-test
+  "con name mismatch fails"
+  (hk-match
+    (list :p-con "Just" (list (list :p-var "y")))
+    (hk-mk-con "Nothing" (list))
+    (dict))
+  nil)
+
+(hk-test
+  "con arity mismatch fails"
+  (hk-match
+    (list :p-con "Pair" (list (list :p-var "a") (list :p-var "b")))
+    (hk-mk-con "Pair" (list 1))
+    (dict))
+  nil)
+
+(hk-test
+  "nested con: Just (Just x)"
+  (hk-match
+    (list
+      :p-con
+      "Just"
+      (list
+        (list
+          :p-con
+          "Just"
+          (list (list :p-var "x")))))
+    (hk-mk-con "Just" (list (hk-mk-con "Just" (list 42))))
+    (dict))
+  {:x 42})
+
+;; ── Tuple patterns ──
+(hk-test
+  "2-tuple matches and binds"
+  (hk-match
+    (list
+      :p-tuple
+      (list (list :p-var "a") (list :p-var "b")))
+    (hk-mk-tuple (list 10 20))
+    (dict))
+  {:a 10 :b 20})
+
+(hk-test
+  "tuple arity mismatch fails"
+  (hk-match
+    (list
+      :p-tuple
+      (list (list :p-var "a") (list :p-var "b")))
+    (hk-mk-tuple (list 10 20 30))
+    (dict))
+  nil)
+
+;; ── List patterns ──
+(hk-test
+  "[] pattern matches empty list"
+  (hk-match (list :p-list (list)) (hk-mk-nil) (dict))
+  (dict))
+
+(hk-test
+  "[] pattern fails on non-empty"
+  (hk-match (list :p-list (list)) (hk-mk-list (list 1)) (dict))
+  nil)
+
+(hk-test
+  "[a] pattern matches singleton"
+  (hk-match
+    (list :p-list (list (list :p-var "a")))
+    (hk-mk-list (list 7))
+    (dict))
+  {:a 7})
+
+(hk-test
+  "[a, b] pattern matches pair-list and binds"
+  (hk-match
+    (list
+      :p-list
+      (list (list :p-var "a") (list :p-var "b")))
+    (hk-mk-list (list 1 2))
+    (dict))
+  {:a 1 :b 2})
+
+(hk-test
+  "[a, b] fails on too-long list"
+  (hk-match
+    (list
+      :p-list
+      (list (list :p-var "a") (list :p-var "b")))
+    (hk-mk-list (list 1 2 3))
+    (dict))
+  nil)
+
+;; Cons-style infix pattern (which the parser produces as :p-con ":")
+(hk-test
+  "cons (h:t) on non-empty list"
+  (hk-match
+    (list
+      :p-con
+      ":"
+      (list (list :p-var "h") (list :p-var "t")))
+    (hk-mk-list (list 1 2 3))
+    (dict))
+  {:h 1 :t (list ":" 2 (list ":" 3 (list "[]")))})
+
+(hk-test
+  "cons fails on empty list"
+  (hk-match
+    (list
+      :p-con
+      ":"
+      (list (list :p-var "h") (list :p-var "t")))
+    (hk-mk-nil)
+    (dict))
+  nil)
+
+;; ── as patterns ──
+(hk-test
+  "as binds whole + sub-pattern"
+  (hk-match
+    (list
+      :p-as
+      "all"
+      (list :p-con "Just" (list (list :p-var "x"))))
+    (hk-mk-con "Just" (list 99))
+    (dict))
+  {:all (list "Just" 99) :x 99})
+
+(hk-test
+  "as on wildcard binds whole"
+  (hk-match
+    (list :p-as "v" (list :p-wild))
+    "anything"
+    (dict))
+  {:v "anything"})
+
+(hk-test
+  "as fails when sub-pattern fails"
+  (hk-match
+    (list
+      :p-as
+      "n"
+      (list :p-con "Just" (list (list :p-var "x"))))
+    (hk-mk-con "Nothing" (list))
+    (dict))
+  nil)
+
+;; ── lazy ~ pattern (eager equivalent for now) ──
+(hk-test
+  "lazy pattern eager-matches its inner"
+  (hk-match
+    (list :p-lazy (list :p-var "y"))
+    42
+    (dict))
+  {:y 42})
+
+;; ── Source-driven: parse a real Haskell pattern, match a value ──
+(hk-test
+  "parsed pattern: Just x against Just 5"
+  (hk-match
+    (hk-parse-pat-source "Just x")
+    (hk-mk-con "Just" (list 5))
+    (dict))
+  {:x 5})
+
+(hk-test
+  "parsed pattern: x : xs against [10, 20, 30]"
+  (hk-match
+    (hk-parse-pat-source "x : xs")
+    (hk-mk-list (list 10 20 30))
+    (dict))
+  {:x 10 :xs (list ":" 20 (list ":" 30 (list "[]")))})
+
+(hk-test
+  "parsed pattern: (a, b) against (1, 2)"
+  (hk-match
+    (hk-parse-pat-source "(a, b)")
+    (hk-mk-tuple (list 1 2))
+    (dict))
+  {:a 1 :b 2})
+
+(hk-test
+  "parsed pattern: n@(Just x) against Just 7"
+  (hk-match
+    (hk-parse-pat-source "n@(Just x)")
+    (hk-mk-con "Just" (list 7))
+    (dict))
+  {:n (list "Just" 7) :x 7})
+
+{: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/parse.sx

@@ -3,60 +3,8 @@
 ;; Lightweight runner: each test checks actual vs expected with
 ;; structural (deep) equality and accumulates pass/fail counters.
 ;; Final value of this file is a summary dict with :pass :fail :fails.
-
-(define
-  hk-deep=?
-  (fn
-    (a b)
-    (cond
-      ((= a b) true)
-      ((and (dict? a) (dict? b))
-        (let
-          ((ak (keys a)) (bk (keys b)))
-          (if
-            (not (= (len ak) (len bk)))
-            false
-            (every?
-              (fn
-                (k)
-                (and (has-key? b k) (hk-deep=? (get a k) (get b k))))
-              ak))))
-      ((and (list? a) (list? b))
-        (if
-          (not (= (len a) (len b)))
-          false
-          (let
-            ((i 0) (ok true))
-            (define
-              hk-de-loop
-              (fn
-                ()
-                (when
-                  (and ok (< i (len a)))
-                  (do
-                    (when
-                      (not (hk-deep=? (nth a i) (nth b i)))
-                      (set! ok false))
-                    (set! i (+ i 1))
-                    (hk-de-loop)))))
-            (hk-de-loop)
-            ok)))
-      (:else false))))
-
-(define hk-test-pass 0)
-(define hk-test-fail 0)
-(define hk-test-fails (list))
-
-(define
-  hk-test
-  (fn
-    (name actual expected)
-    (if
-      (hk-deep=? actual expected)
-      (set! hk-test-pass (+ hk-test-pass 1))
-      (do
-        (set! hk-test-fail (+ hk-test-fail 1))
-        (append! hk-test-fails {:actual actual :expected expected :name name})))))
+;; The hk-test / hk-deep=? helpers live in lib/haskell/testlib.sx
+;; and are preloaded by lib/haskell/test.sh.
 
 ;; Convenience: tokenize and drop newline + eof tokens so tests focus
 ;; on meaningful content. Returns list of {:type :value} pairs.

lib/haskell/tests/parser-case-do.sx

@@ -0,0 +1,278 @@
+;; case-of and do-notation parser tests.
+;; Covers the minimal patterns needed to make these meaningful: var,
+;; wildcard, literal, constructor (with and without args), tuple, list.
+
+;; ── Patterns (in case arms) ──
+(hk-test
+  "wildcard pat"
+  (hk-parse "case x of _ -> 0")
+  (list
+    :case
+    (list :var "x")
+    (list (list :alt (list :p-wild) (list :int 0)))))
+
+(hk-test
+  "var pat"
+  (hk-parse "case x of y -> y")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list :alt (list :p-var "y") (list :var "y")))))
+
+(hk-test
+  "0-arity constructor pat"
+  (hk-parse "case x of\n  Nothing -> 0\n  Just y -> y")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list :alt (list :p-con "Nothing" (list)) (list :int 0))
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list :var "y")))))
+
+(hk-test
+  "int literal pat"
+  (hk-parse "case n of\n  0 -> 1\n  _ -> n")
+  (list
+    :case
+    (list :var "n")
+    (list
+      (list :alt (list :p-int 0) (list :int 1))
+      (list :alt (list :p-wild) (list :var "n")))))
+
+(hk-test
+  "string literal pat"
+  (hk-parse "case s of\n  \"hi\" -> 1\n  _ -> 0")
+  (list
+    :case
+    (list :var "s")
+    (list
+      (list :alt (list :p-string "hi") (list :int 1))
+      (list :alt (list :p-wild) (list :int 0)))))
+
+(hk-test
+  "tuple pat"
+  (hk-parse "case p of (a, b) -> a")
+  (list
+    :case
+    (list :var "p")
+    (list
+      (list
+        :alt
+        (list
+          :p-tuple
+          (list (list :p-var "a") (list :p-var "b")))
+        (list :var "a")))))
+
+(hk-test
+  "list pat"
+  (hk-parse "case xs of\n  [] -> 0\n  [a] -> a")
+  (list
+    :case
+    (list :var "xs")
+    (list
+      (list :alt (list :p-list (list)) (list :int 0))
+      (list
+        :alt
+        (list :p-list (list (list :p-var "a")))
+        (list :var "a")))))
+
+(hk-test
+  "nested constructor pat"
+  (hk-parse "case x of\n  Just (a, b) -> a\n  _ -> 0")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list
+          :p-con
+          "Just"
+          (list
+            (list
+              :p-tuple
+              (list (list :p-var "a") (list :p-var "b")))))
+        (list :var "a"))
+      (list :alt (list :p-wild) (list :int 0)))))
+
+(hk-test
+  "constructor with multiple var args"
+  (hk-parse "case t of Pair a b -> a")
+  (list
+    :case
+    (list :var "t")
+    (list
+      (list
+        :alt
+        (list
+          :p-con
+          "Pair"
+          (list (list :p-var "a") (list :p-var "b")))
+        (list :var "a")))))
+
+;; ── case-of shapes ──
+(hk-test
+  "case with explicit braces"
+  (hk-parse "case x of { Just y -> y ; Nothing -> 0 }")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list :var "y"))
+      (list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
+
+(hk-test
+  "case scrutinee is a full expression"
+  (hk-parse "case f x + 1 of\n  y -> y")
+  (list
+    :case
+    (list
+      :op
+      "+"
+      (list :app (list :var "f") (list :var "x"))
+      (list :int 1))
+    (list (list :alt (list :p-var "y") (list :var "y")))))
+
+(hk-test
+  "case arm body is full expression"
+  (hk-parse "case x of\n  Just y -> y + 1")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list :op "+" (list :var "y") (list :int 1))))))
+
+;; ── do blocks ──
+(hk-test
+  "do with two expressions"
+  (hk-parse "do\n  putStrLn \"hi\"\n  return 0")
+  (list
+    :do
+    (list
+      (list
+        :do-expr
+        (list :app (list :var "putStrLn") (list :string "hi")))
+      (list
+        :do-expr
+        (list :app (list :var "return") (list :int 0))))))
+
+(hk-test
+  "do with bind"
+  (hk-parse "do\n  x <- getLine\n  putStrLn x")
+  (list
+    :do
+    (list
+      (list :do-bind (list :p-var "x") (list :var "getLine"))
+      (list
+        :do-expr
+        (list :app (list :var "putStrLn") (list :var "x"))))))
+
+(hk-test
+  "do with let"
+  (hk-parse "do\n  let y = 5\n  print y")
+  (list
+    :do
+    (list
+      (list
+        :do-let
+        (list (list :bind (list :p-var "y") (list :int 5))))
+      (list
+        :do-expr
+        (list :app (list :var "print") (list :var "y"))))))
+
+(hk-test
+  "do with multiple let bindings"
+  (hk-parse "do\n  let x = 1\n      y = 2\n  print (x + y)")
+  (list
+    :do
+    (list
+      (list
+        :do-let
+        (list
+          (list :bind (list :p-var "x") (list :int 1))
+          (list :bind (list :p-var "y") (list :int 2))))
+      (list
+        :do-expr
+        (list
+          :app
+          (list :var "print")
+          (list :op "+" (list :var "x") (list :var "y")))))))
+
+(hk-test
+  "do with bind using constructor pat"
+  (hk-parse "do\n  Just x <- getMaybe\n  return x")
+  (list
+    :do
+    (list
+      (list
+        :do-bind
+        (list :p-con "Just" (list (list :p-var "x")))
+        (list :var "getMaybe"))
+      (list
+        :do-expr
+        (list :app (list :var "return") (list :var "x"))))))
+
+(hk-test
+  "do with explicit braces"
+  (hk-parse "do { x <- a ; y <- b ; return (x + y) }")
+  (list
+    :do
+    (list
+      (list :do-bind (list :p-var "x") (list :var "a"))
+      (list :do-bind (list :p-var "y") (list :var "b"))
+      (list
+        :do-expr
+        (list
+          :app
+          (list :var "return")
+          (list :op "+" (list :var "x") (list :var "y")))))))
+
+;; ── Mixing case/do inside expressions ──
+(hk-test
+  "case inside let"
+  (hk-parse "let f = \\x -> case x of\n                 Just y -> y\n                 _ -> 0\nin f 5")
+  (list
+    :let
+    (list
+      (list
+        :bind
+        (list :p-var "f")
+        (list
+          :lambda
+          (list (list :p-var "x"))
+          (list
+            :case
+            (list :var "x")
+            (list
+              (list
+                :alt
+                (list :p-con "Just" (list (list :p-var "y")))
+                (list :var "y"))
+              (list :alt (list :p-wild) (list :int 0)))))))
+    (list :app (list :var "f") (list :int 5))))
+
+(hk-test
+  "lambda containing do"
+  (hk-parse "\\x -> do\n  y <- x\n  return y")
+  (list
+    :lambda
+    (list (list :p-var "x"))
+    (list
+      :do
+      (list
+        (list :do-bind (list :p-var "y") (list :var "x"))
+        (list
+          :do-expr
+          (list :app (list :var "return") (list :var "y")))))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/parser-decls.sx

@@ -0,0 +1,273 @@
+;; Top-level declarations: function clauses, type signatures, data,
+;; type, newtype, fixity. Driven by hk-parse-top which produces
+;; a (:program DECLS) node.
+
+(define
+  hk-prog
+  (fn
+    (&rest decls)
+    (list :program decls)))
+
+;; ── Function clauses & pattern bindings ──
+(hk-test
+  "simple fun-clause"
+  (hk-parse-top "f x = x + 1")
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list :op "+" (list :var "x") (list :int 1)))))
+
+(hk-test
+  "nullary decl"
+  (hk-parse-top "answer = 42")
+  (hk-prog
+    (list :fun-clause "answer" (list) (list :int 42))))
+
+(hk-test
+  "multi-clause fn (separate defs for each pattern)"
+  (hk-parse-top "fact 0 = 1\nfact n = n")
+  (hk-prog
+    (list :fun-clause "fact" (list (list :p-int 0)) (list :int 1))
+    (list
+      :fun-clause
+      "fact"
+      (list (list :p-var "n"))
+      (list :var "n"))))
+
+(hk-test
+  "constructor pattern in fn args"
+  (hk-parse-top "fromJust (Just x) = x")
+  (hk-prog
+    (list
+      :fun-clause
+      "fromJust"
+      (list (list :p-con "Just" (list (list :p-var "x"))))
+      (list :var "x"))))
+
+(hk-test
+  "pattern binding at top level"
+  (hk-parse-top "(a, b) = pair")
+  (hk-prog
+    (list
+      :pat-bind
+      (list
+        :p-tuple
+        (list (list :p-var "a") (list :p-var "b")))
+      (list :var "pair"))))
+
+;; ── Type signatures ──
+(hk-test
+  "single-name sig"
+  (hk-parse-top "f :: Int -> Int")
+  (hk-prog
+    (list
+      :type-sig
+      (list "f")
+      (list :t-fun (list :t-con "Int") (list :t-con "Int")))))
+
+(hk-test
+  "multi-name sig"
+  (hk-parse-top "f, g, h :: Int -> Bool")
+  (hk-prog
+    (list
+      :type-sig
+      (list "f" "g" "h")
+      (list :t-fun (list :t-con "Int") (list :t-con "Bool")))))
+
+(hk-test
+  "sig with type application"
+  (hk-parse-top "f :: Maybe a -> a")
+  (hk-prog
+    (list
+      :type-sig
+      (list "f")
+      (list
+        :t-fun
+        (list :t-app (list :t-con "Maybe") (list :t-var "a"))
+        (list :t-var "a")))))
+
+(hk-test
+  "sig with list type"
+  (hk-parse-top "len :: [a] -> Int")
+  (hk-prog
+    (list
+      :type-sig
+      (list "len")
+      (list
+        :t-fun
+        (list :t-list (list :t-var "a"))
+        (list :t-con "Int")))))
+
+(hk-test
+  "sig with tuple and right-assoc ->"
+  (hk-parse-top "pair :: a -> b -> (a, b)")
+  (hk-prog
+    (list
+      :type-sig
+      (list "pair")
+      (list
+        :t-fun
+        (list :t-var "a")
+        (list
+          :t-fun
+          (list :t-var "b")
+          (list
+            :t-tuple
+            (list (list :t-var "a") (list :t-var "b"))))))))
+
+(hk-test
+  "sig + implementation together"
+  (hk-parse-top "id :: a -> a\nid x = x")
+  (hk-prog
+    (list
+      :type-sig
+      (list "id")
+      (list :t-fun (list :t-var "a") (list :t-var "a")))
+    (list
+      :fun-clause
+      "id"
+      (list (list :p-var "x"))
+      (list :var "x"))))
+
+;; ── data declarations ──
+(hk-test
+  "data Maybe"
+  (hk-parse-top "data Maybe a = Nothing | Just a")
+  (hk-prog
+    (list
+      :data
+      "Maybe"
+      (list "a")
+      (list
+        (list :con-def "Nothing" (list))
+        (list :con-def "Just" (list (list :t-var "a")))))))
+
+(hk-test
+  "data Either"
+  (hk-parse-top "data Either a b = Left a | Right b")
+  (hk-prog
+    (list
+      :data
+      "Either"
+      (list "a" "b")
+      (list
+        (list :con-def "Left" (list (list :t-var "a")))
+        (list :con-def "Right" (list (list :t-var "b")))))))
+
+(hk-test
+  "data with no type parameters"
+  (hk-parse-top "data Bool = True | False")
+  (hk-prog
+    (list
+      :data
+      "Bool"
+      (list)
+      (list
+        (list :con-def "True" (list))
+        (list :con-def "False" (list))))))
+
+(hk-test
+  "recursive data type"
+  (hk-parse-top "data Tree a = Leaf | Node (Tree a) a (Tree a)")
+  (hk-prog
+    (list
+      :data
+      "Tree"
+      (list "a")
+      (list
+        (list :con-def "Leaf" (list))
+        (list
+          :con-def
+          "Node"
+          (list
+            (list :t-app (list :t-con "Tree") (list :t-var "a"))
+            (list :t-var "a")
+            (list :t-app (list :t-con "Tree") (list :t-var "a"))))))))
+
+;; ── type synonyms ──
+(hk-test
+  "simple type synonym"
+  (hk-parse-top "type Name = String")
+  (hk-prog
+    (list :type-syn "Name" (list) (list :t-con "String"))))
+
+(hk-test
+  "parameterised type synonym"
+  (hk-parse-top "type Pair a = (a, a)")
+  (hk-prog
+    (list
+      :type-syn
+      "Pair"
+      (list "a")
+      (list
+        :t-tuple
+        (list (list :t-var "a") (list :t-var "a"))))))
+
+;; ── newtype ──
+(hk-test
+  "newtype"
+  (hk-parse-top "newtype Age = Age Int")
+  (hk-prog (list :newtype "Age" (list) "Age" (list :t-con "Int"))))
+
+(hk-test
+  "parameterised newtype"
+  (hk-parse-top "newtype Wrap a = Wrap a")
+  (hk-prog
+    (list :newtype "Wrap" (list "a") "Wrap" (list :t-var "a"))))
+
+;; ── fixity declarations ──
+(hk-test
+  "infixl with precedence"
+  (hk-parse-top "infixl 5 +:, -:")
+  (hk-prog (list :fixity "l" 5 (list "+:" "-:"))))
+
+(hk-test
+  "infixr"
+  (hk-parse-top "infixr 9 .")
+  (hk-prog (list :fixity "r" 9 (list "."))))
+
+(hk-test
+  "infix (non-assoc) default prec"
+  (hk-parse-top "infix ==")
+  (hk-prog (list :fixity "n" 9 (list "=="))))
+
+(hk-test
+  "fixity with backtick operator name"
+  (hk-parse-top "infixl 7 `div`")
+  (hk-prog (list :fixity "l" 7 (list "div"))))
+
+;; ── Several decls combined ──
+(hk-test
+  "mixed: data + sig + fn + type"
+  (hk-parse-top "data Maybe a = Nothing | Just a\ntype Entry = Maybe Int\nf :: Entry -> Int\nf (Just x) = x\nf Nothing = 0")
+  (hk-prog
+    (list
+      :data
+      "Maybe"
+      (list "a")
+      (list
+        (list :con-def "Nothing" (list))
+        (list :con-def "Just" (list (list :t-var "a")))))
+    (list
+      :type-syn
+      "Entry"
+      (list)
+      (list :t-app (list :t-con "Maybe") (list :t-con "Int")))
+    (list
+      :type-sig
+      (list "f")
+      (list :t-fun (list :t-con "Entry") (list :t-con "Int")))
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-con "Just" (list (list :p-var "x"))))
+      (list :var "x"))
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-con "Nothing" (list)))
+      (list :int 0))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/parser-expr.sx

@@ -0,0 +1,258 @@
+;; Haskell expression parser tests.
+;; hk-parse tokenises, runs layout, then parses. Output is an AST
+;; whose head is a keyword tag (evaluates to its string name).
+
+;; ── 1. Literals ──
+(hk-test "integer" (hk-parse "42") (list :int 42))
+(hk-test "float" (hk-parse "3.14") (list :float 3.14))
+(hk-test "string" (hk-parse "\"hi\"") (list :string "hi"))
+(hk-test "char" (hk-parse "'a'") (list :char "a"))
+
+;; ── 2. Variables and constructors ──
+(hk-test "varid" (hk-parse "foo") (list :var "foo"))
+(hk-test "conid" (hk-parse "Nothing") (list :con "Nothing"))
+(hk-test "qvarid" (hk-parse "Data.Map.lookup") (list :var "Data.Map.lookup"))
+(hk-test "qconid" (hk-parse "Data.Map") (list :con "Data.Map"))
+
+;; ── 3. Parens / unit / tuple ──
+(hk-test "parens strip" (hk-parse "(42)") (list :int 42))
+(hk-test "unit" (hk-parse "()") (list :con "()"))
+(hk-test
+  "2-tuple"
+  (hk-parse "(1, 2)")
+  (list :tuple (list (list :int 1) (list :int 2))))
+(hk-test
+  "3-tuple"
+  (hk-parse "(x, y, z)")
+  (list
+    :tuple
+    (list (list :var "x") (list :var "y") (list :var "z"))))
+
+;; ── 4. Lists ──
+(hk-test "empty list" (hk-parse "[]") (list :list (list)))
+(hk-test
+  "singleton list"
+  (hk-parse "[1]")
+  (list :list (list (list :int 1))))
+(hk-test
+  "list of ints"
+  (hk-parse "[1, 2, 3]")
+  (list
+    :list
+    (list (list :int 1) (list :int 2) (list :int 3))))
+(hk-test
+  "range"
+  (hk-parse "[1..10]")
+  (list :range (list :int 1) (list :int 10)))
+(hk-test
+  "range with step"
+  (hk-parse "[1, 3..10]")
+  (list
+    :range-step
+    (list :int 1)
+    (list :int 3)
+    (list :int 10)))
+
+;; ── 5. Application ──
+(hk-test
+  "one-arg app"
+  (hk-parse "f x")
+  (list :app (list :var "f") (list :var "x")))
+(hk-test
+  "multi-arg app is left-assoc"
+  (hk-parse "f x y z")
+  (list
+    :app
+    (list
+      :app
+      (list :app (list :var "f") (list :var "x"))
+      (list :var "y"))
+    (list :var "z")))
+(hk-test
+  "app with con"
+  (hk-parse "Just 5")
+  (list :app (list :con "Just") (list :int 5)))
+
+;; ── 6. Infix operators ──
+(hk-test
+  "simple +"
+  (hk-parse "1 + 2")
+  (list :op "+" (list :int 1) (list :int 2)))
+(hk-test
+  "precedence: * binds tighter than +"
+  (hk-parse "1 + 2 * 3")
+  (list
+    :op
+    "+"
+    (list :int 1)
+    (list :op "*" (list :int 2) (list :int 3))))
+(hk-test
+  "- is left-assoc"
+  (hk-parse "10 - 3 - 2")
+  (list
+    :op
+    "-"
+    (list :op "-" (list :int 10) (list :int 3))
+    (list :int 2)))
+(hk-test
+  ": is right-assoc"
+  (hk-parse "a : b : c")
+  (list
+    :op
+    ":"
+    (list :var "a")
+    (list :op ":" (list :var "b") (list :var "c"))))
+(hk-test
+  "app binds tighter than op"
+  (hk-parse "f x + g y")
+  (list
+    :op
+    "+"
+    (list :app (list :var "f") (list :var "x"))
+    (list :app (list :var "g") (list :var "y"))))
+(hk-test
+  "$ is lowest precedence, right-assoc"
+  (hk-parse "f $ g x")
+  (list
+    :op
+    "$"
+    (list :var "f")
+    (list :app (list :var "g") (list :var "x"))))
+
+;; ── 7. Backticks (varid-as-operator) ──
+(hk-test
+  "backtick operator"
+  (hk-parse "x `mod` 3")
+  (list :op "mod" (list :var "x") (list :int 3)))
+
+;; ── 8. Unary negation ──
+(hk-test
+  "unary -"
+  (hk-parse "- 5")
+  (list :neg (list :int 5)))
+(hk-test
+  "unary - on application"
+  (hk-parse "- f x")
+  (list :neg (list :app (list :var "f") (list :var "x"))))
+(hk-test
+  "- n + m → (- n) + m"
+  (hk-parse "- 1 + 2")
+  (list
+    :op
+    "+"
+    (list :neg (list :int 1))
+    (list :int 2)))
+
+;; ── 9. Lambda ──
+(hk-test
+  "lambda single param"
+  (hk-parse "\\x -> x")
+  (list :lambda (list (list :p-var "x")) (list :var "x")))
+(hk-test
+  "lambda multi-param"
+  (hk-parse "\\x y -> x + y")
+  (list
+    :lambda
+    (list (list :p-var "x") (list :p-var "y"))
+    (list :op "+" (list :var "x") (list :var "y"))))
+(hk-test
+  "lambda body is full expression"
+  (hk-parse "\\f -> f 1 + f 2")
+  (list
+    :lambda
+    (list (list :p-var "f"))
+    (list
+      :op
+      "+"
+      (list :app (list :var "f") (list :int 1))
+      (list :app (list :var "f") (list :int 2)))))
+
+;; ── 10. if-then-else ──
+(hk-test
+  "if basic"
+  (hk-parse "if x then 1 else 2")
+  (list :if (list :var "x") (list :int 1) (list :int 2)))
+(hk-test
+  "if with infix cond"
+  (hk-parse "if x == 0 then y else z")
+  (list
+    :if
+    (list :op "==" (list :var "x") (list :int 0))
+    (list :var "y")
+    (list :var "z")))
+
+;; ── 11. let-in ──
+(hk-test
+  "let single binding"
+  (hk-parse "let x = 1 in x")
+  (list
+    :let
+    (list (list :bind (list :p-var "x") (list :int 1)))
+    (list :var "x")))
+(hk-test
+  "let two bindings (multi-line)"
+  (hk-parse "let x = 1\n    y = 2\nin x + y")
+  (list
+    :let
+    (list
+      (list :bind (list :p-var "x") (list :int 1))
+      (list :bind (list :p-var "y") (list :int 2)))
+    (list :op "+" (list :var "x") (list :var "y"))))
+(hk-test
+  "let with explicit braces"
+  (hk-parse "let { x = 1 ; y = 2 } in x + y")
+  (list
+    :let
+    (list
+      (list :bind (list :p-var "x") (list :int 1))
+      (list :bind (list :p-var "y") (list :int 2)))
+    (list :op "+" (list :var "x") (list :var "y"))))
+
+;; ── 12. Mixed / nesting ──
+(hk-test
+  "nested application"
+  (hk-parse "f (g x) y")
+  (list
+    :app
+    (list
+      :app
+      (list :var "f")
+      (list :app (list :var "g") (list :var "x")))
+    (list :var "y")))
+(hk-test
+  "lambda applied"
+  (hk-parse "(\\x -> x + 1) 5")
+  (list
+    :app
+    (list
+      :lambda
+      (list (list :p-var "x"))
+      (list :op "+" (list :var "x") (list :int 1)))
+    (list :int 5)))
+(hk-test
+  "lambda + if"
+  (hk-parse "\\n -> if n == 0 then 1 else n")
+  (list
+    :lambda
+    (list (list :p-var "n"))
+    (list
+      :if
+      (list :op "==" (list :var "n") (list :int 0))
+      (list :int 1)
+      (list :var "n"))))
+
+;; ── 13. Precedence corners ──
+(hk-test
+  ". is right-assoc (prec 9)"
+  (hk-parse "f . g . h")
+  (list
+    :op
+    "."
+    (list :var "f")
+    (list :op "." (list :var "g") (list :var "h"))))
+(hk-test
+  "== is non-associative (single use)"
+  (hk-parse "x == y")
+  (list :op "==" (list :var "x") (list :var "y")))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/parser-guards-where.sx

@@ -0,0 +1,261 @@
+;; Guards and where-clauses — on fun-clauses, case alts, and
+;; let-bindings (which now also accept funclause-style LHS like
+;; `let f x = e` or `let f x | g = e | g = e`).
+
+(define
+  hk-prog
+  (fn (&rest decls) (list :program decls)))
+
+;; ── Guarded fun-clauses ──
+(hk-test
+  "simple guards (two branches)"
+  (hk-parse-top "abs x | x < 0 = - x\n      | otherwise = x")
+  (hk-prog
+    (list
+      :fun-clause
+      "abs"
+      (list (list :p-var "x"))
+      (list
+        :guarded
+        (list
+          (list
+            :guard
+            (list :op "<" (list :var "x") (list :int 0))
+            (list :neg (list :var "x")))
+          (list :guard (list :var "otherwise") (list :var "x")))))))
+
+(hk-test
+  "three-way guard"
+  (hk-parse-top "sign n | n > 0 = 1\n       | n < 0 = -1\n       | otherwise = 0")
+  (hk-prog
+    (list
+      :fun-clause
+      "sign"
+      (list (list :p-var "n"))
+      (list
+        :guarded
+        (list
+          (list
+            :guard
+            (list :op ">" (list :var "n") (list :int 0))
+            (list :int 1))
+          (list
+            :guard
+            (list :op "<" (list :var "n") (list :int 0))
+            (list :neg (list :int 1)))
+          (list
+            :guard
+            (list :var "otherwise")
+            (list :int 0)))))))
+
+(hk-test
+  "mixed: one eq clause plus one guarded clause"
+  (hk-parse-top "sign 0 = 0\nsign n | n > 0 = 1\n       | otherwise = -1")
+  (hk-prog
+    (list
+      :fun-clause
+      "sign"
+      (list (list :p-int 0))
+      (list :int 0))
+    (list
+      :fun-clause
+      "sign"
+      (list (list :p-var "n"))
+      (list
+        :guarded
+        (list
+          (list
+            :guard
+            (list :op ">" (list :var "n") (list :int 0))
+            (list :int 1))
+          (list
+            :guard
+            (list :var "otherwise")
+            (list :neg (list :int 1))))))))
+
+;; ── where on fun-clauses ──
+(hk-test
+  "where with one binding"
+  (hk-parse-top "f x = y + y\n  where y = x + 1")
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :where
+        (list :op "+" (list :var "y") (list :var "y"))
+        (list
+          (list
+            :fun-clause
+            "y"
+            (list)
+            (list :op "+" (list :var "x") (list :int 1))))))))
+
+(hk-test
+  "where with multiple bindings"
+  (hk-parse-top "f x = y * z\n  where y = x + 1\n        z = x - 1")
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :where
+        (list :op "*" (list :var "y") (list :var "z"))
+        (list
+          (list
+            :fun-clause
+            "y"
+            (list)
+            (list :op "+" (list :var "x") (list :int 1)))
+          (list
+            :fun-clause
+            "z"
+            (list)
+            (list :op "-" (list :var "x") (list :int 1))))))))
+
+(hk-test
+  "guards + where"
+  (hk-parse-top "f x | x > 0 = y\n    | otherwise = 0\n  where y = 99")
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :where
+        (list
+          :guarded
+          (list
+            (list
+              :guard
+              (list :op ">" (list :var "x") (list :int 0))
+              (list :var "y"))
+            (list
+              :guard
+              (list :var "otherwise")
+              (list :int 0))))
+        (list
+          (list :fun-clause "y" (list) (list :int 99)))))))
+
+;; ── Guards in case alts ──
+(hk-test
+  "case alt with guards"
+  (hk-parse "case x of\n  Just y | y > 0 -> y\n         | otherwise -> 0\n  Nothing -> 0")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list
+          :guarded
+          (list
+            (list
+              :guard
+              (list :op ">" (list :var "y") (list :int 0))
+              (list :var "y"))
+            (list
+              :guard
+              (list :var "otherwise")
+              (list :int 0)))))
+      (list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
+
+(hk-test
+  "case alt with where"
+  (hk-parse "case x of\n  Just y -> y + z where z = 5\n  Nothing -> 0")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-con "Just" (list (list :p-var "y")))
+        (list
+          :where
+          (list :op "+" (list :var "y") (list :var "z"))
+          (list
+            (list :fun-clause "z" (list) (list :int 5)))))
+      (list :alt (list :p-con "Nothing" (list)) (list :int 0)))))
+
+;; ── let-bindings: funclause form, guards, where ──
+(hk-test
+  "let with funclause shorthand"
+  (hk-parse "let f x = x + 1 in f 5")
+  (list
+    :let
+    (list
+      (list
+        :fun-clause
+        "f"
+        (list (list :p-var "x"))
+        (list :op "+" (list :var "x") (list :int 1))))
+    (list :app (list :var "f") (list :int 5))))
+
+(hk-test
+  "let with guards"
+  (hk-parse "let f x | x > 0 = x\n        | otherwise = 0\nin f 3")
+  (list
+    :let
+    (list
+      (list
+        :fun-clause
+        "f"
+        (list (list :p-var "x"))
+        (list
+          :guarded
+          (list
+            (list
+              :guard
+              (list :op ">" (list :var "x") (list :int 0))
+              (list :var "x"))
+            (list
+              :guard
+              (list :var "otherwise")
+              (list :int 0))))))
+    (list :app (list :var "f") (list :int 3))))
+
+(hk-test
+  "let funclause + where"
+  (hk-parse "let f x = y where y = x + 1\nin f 7")
+  (list
+    :let
+    (list
+      (list
+        :fun-clause
+        "f"
+        (list (list :p-var "x"))
+        (list
+          :where
+          (list :var "y")
+          (list
+            (list
+              :fun-clause
+              "y"
+              (list)
+              (list :op "+" (list :var "x") (list :int 1)))))))
+    (list :app (list :var "f") (list :int 7))))
+
+;; ── Nested: where inside where (via recursive hk-parse-decl) ──
+(hk-test
+  "where block can contain a type signature"
+  (hk-parse-top "f x = y\n  where y :: Int\n        y = x")
+  (hk-prog
+    (list
+      :fun-clause
+      "f"
+      (list (list :p-var "x"))
+      (list
+        :where
+        (list :var "y")
+        (list
+          (list :type-sig (list "y") (list :t-con "Int"))
+          (list
+            :fun-clause
+            "y"
+            (list)
+            (list :var "x")))))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/parser-module.sx

@@ -0,0 +1,202 @@
+;; Module header + imports. The parser switches from (:program DECLS)
+;; to (:module NAME EXPORTS IMPORTS DECLS) as soon as a module header
+;; or any `import` decl appears.
+
+;; ── Module header ──
+(hk-test
+  "simple module, no exports"
+  (hk-parse-top "module M where\n  f = 1")
+  (list
+    :module
+    "M"
+    nil
+    (list)
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "module with dotted name"
+  (hk-parse-top "module Data.Map where\nf = 1")
+  (list
+    :module
+    "Data.Map"
+    nil
+    (list)
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "module with empty export list"
+  (hk-parse-top "module M () where\nf = 1")
+  (list
+    :module
+    "M"
+    (list)
+    (list)
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "module with exports (var, tycon-all, tycon-with)"
+  (hk-parse-top "module M (f, g, Maybe(..), List(Cons, Nil)) where\nf = 1\ng = 2")
+  (list
+    :module
+    "M"
+    (list
+      (list :ent-var "f")
+      (list :ent-var "g")
+      (list :ent-all "Maybe")
+      (list :ent-with "List" (list "Cons" "Nil")))
+    (list)
+    (list
+      (list :fun-clause "f" (list) (list :int 1))
+      (list :fun-clause "g" (list) (list :int 2)))))
+
+(hk-test
+  "module export list including another module"
+  (hk-parse-top "module M (module Foo, f) where\nf = 1")
+  (list
+    :module
+    "M"
+    (list (list :ent-module "Foo") (list :ent-var "f"))
+    (list)
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "module export with operator"
+  (hk-parse-top "module M ((+:), f) where\nf = 1")
+  (list
+    :module
+    "M"
+    (list (list :ent-var "+:") (list :ent-var "f"))
+    (list)
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "empty module body"
+  (hk-parse-top "module M where")
+  (list :module "M" nil (list) (list)))
+
+;; ── Imports ──
+(hk-test
+  "plain import"
+  (hk-parse-top "import Foo")
+  (list
+    :module
+    nil
+    nil
+    (list (list :import false "Foo" nil nil))
+    (list)))
+
+(hk-test
+  "qualified import"
+  (hk-parse-top "import qualified Data.Map")
+  (list
+    :module
+    nil
+    nil
+    (list (list :import true "Data.Map" nil nil))
+    (list)))
+
+(hk-test
+  "import with alias"
+  (hk-parse-top "import Data.Map as M")
+  (list
+    :module
+    nil
+    nil
+    (list (list :import false "Data.Map" "M" nil))
+    (list)))
+
+(hk-test
+  "import with explicit list"
+  (hk-parse-top "import Foo (bar, Baz(..), Quux(X, Y))")
+  (list
+    :module
+    nil
+    nil
+    (list
+      (list
+        :import
+        false
+        "Foo"
+        nil
+        (list
+          :spec-items
+          (list
+            (list :ent-var "bar")
+            (list :ent-all "Baz")
+            (list :ent-with "Quux" (list "X" "Y"))))))
+    (list)))
+
+(hk-test
+  "import hiding"
+  (hk-parse-top "import Foo hiding (x, y)")
+  (list
+    :module
+    nil
+    nil
+    (list
+      (list
+        :import
+        false
+        "Foo"
+        nil
+        (list
+          :spec-hiding
+          (list (list :ent-var "x") (list :ent-var "y")))))
+    (list)))
+
+(hk-test
+  "qualified + alias + hiding"
+  (hk-parse-top "import qualified Data.List as L hiding (sort)")
+  (list
+    :module
+    nil
+    nil
+    (list
+      (list
+        :import
+        true
+        "Data.List"
+        "L"
+        (list :spec-hiding (list (list :ent-var "sort")))))
+    (list)))
+
+;; ── Combinations ──
+(hk-test
+  "module with multiple imports and a decl"
+  (hk-parse-top "module M where\nimport Foo\nimport qualified Bar as B\nf = 1")
+  (list
+    :module
+    "M"
+    nil
+    (list
+      (list :import false "Foo" nil nil)
+      (list :import true "Bar" "B" nil))
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "headerless file with imports"
+  (hk-parse-top "import Foo\nimport Bar (baz)\nf = 1")
+  (list
+    :module
+    nil
+    nil
+    (list
+      (list :import false "Foo" nil nil)
+      (list
+        :import
+        false
+        "Bar"
+        nil
+        (list :spec-items (list (list :ent-var "baz")))))
+    (list (list :fun-clause "f" (list) (list :int 1)))))
+
+(hk-test
+  "plain program (no header, no imports) still uses :program"
+  (hk-parse-top "f = 1\ng = 2")
+  (list
+    :program
+    (list
+      (list :fun-clause "f" (list) (list :int 1))
+      (list :fun-clause "g" (list) (list :int 2)))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/parser-patterns.sx

@@ -0,0 +1,234 @@
+;; Full-pattern parser tests: as-patterns, lazy ~, negative literals,
+;; infix constructor patterns (`:`, any consym), lambda pattern args,
+;; and let pattern-bindings.
+
+;; ── as-patterns ──
+(hk-test
+  "as pattern, wraps constructor"
+  (hk-parse "case x of n@(Just y) -> n")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list
+          :p-as
+          "n"
+          (list :p-con "Just" (list (list :p-var "y"))))
+        (list :var "n")))))
+
+(hk-test
+  "as pattern, wraps wildcard"
+  (hk-parse "case x of all@_ -> all")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list
+        :alt
+        (list :p-as "all" (list :p-wild))
+        (list :var "all")))))
+
+(hk-test
+  "as in lambda"
+  (hk-parse "\\xs@(a : rest) -> xs")
+  (list
+    :lambda
+    (list
+      (list
+        :p-as
+        "xs"
+        (list
+          :p-con
+          ":"
+          (list (list :p-var "a") (list :p-var "rest")))))
+    (list :var "xs")))
+
+;; ── lazy patterns ──
+(hk-test
+  "lazy var"
+  (hk-parse "case x of ~y -> y")
+  (list
+    :case
+    (list :var "x")
+    (list
+      (list :alt (list :p-lazy (list :p-var "y")) (list :var "y")))))
+
+(hk-test
+  "lazy constructor"
+  (hk-parse "\\(~(Just x)) -> x")
+  (list
+    :lambda
+    (list
+      (list
+        :p-lazy
+        (list :p-con "Just" (list (list :p-var "x")))))
+    (list :var "x")))
+
+;; ── negative literal patterns ──
+(hk-test
+  "negative int pattern"
+  (hk-parse "case n of\n  -1 -> 0\n  _ -> n")
+  (list
+    :case
+    (list :var "n")
+    (list
+      (list :alt (list :p-int -1) (list :int 0))
+      (list :alt (list :p-wild) (list :var "n")))))
+
+(hk-test
+  "negative float pattern"
+  (hk-parse "case x of -0.5 -> 1")
+  (list
+    :case
+    (list :var "x")
+    (list (list :alt (list :p-float -0.5) (list :int 1)))))
+
+;; ── infix constructor patterns (`:` and any consym) ──
+(hk-test
+  "cons pattern"
+  (hk-parse "case xs of x : rest -> x")
+  (list
+    :case
+    (list :var "xs")
+    (list
+      (list
+        :alt
+        (list
+          :p-con
+          ":"
+          (list (list :p-var "x") (list :p-var "rest")))
+        (list :var "x")))))
+
+(hk-test
+  "cons is right-associative in pats"
+  (hk-parse "case xs of a : b : rest -> rest")
+  (list
+    :case
+    (list :var "xs")
+    (list
+      (list
+        :alt
+        (list
+          :p-con
+          ":"
+          (list
+            (list :p-var "a")
+            (list
+              :p-con
+              ":"
+              (list (list :p-var "b") (list :p-var "rest")))))
+        (list :var "rest")))))
+
+(hk-test
+  "consym pattern"
+  (hk-parse "case p of a :+: b -> a")
+  (list
+    :case
+    (list :var "p")
+    (list
+      (list
+        :alt
+        (list
+          :p-con
+          ":+:"
+          (list (list :p-var "a") (list :p-var "b")))
+        (list :var "a")))))
+
+;; ── lambda with pattern args ──
+(hk-test
+  "lambda with constructor pattern"
+  (hk-parse "\\(Just x) -> x")
+  (list
+    :lambda
+    (list (list :p-con "Just" (list (list :p-var "x"))))
+    (list :var "x")))
+
+(hk-test
+  "lambda with tuple pattern"
+  (hk-parse "\\(a, b) -> a + b")
+  (list
+    :lambda
+    (list
+      (list
+        :p-tuple
+        (list (list :p-var "a") (list :p-var "b"))))
+    (list :op "+" (list :var "a") (list :var "b"))))
+
+(hk-test
+  "lambda with wildcard"
+  (hk-parse "\\_ -> 42")
+  (list :lambda (list (list :p-wild)) (list :int 42)))
+
+(hk-test
+  "lambda with mixed apats"
+  (hk-parse "\\x _ (Just y) -> y")
+  (list
+    :lambda
+    (list
+      (list :p-var "x")
+      (list :p-wild)
+      (list :p-con "Just" (list (list :p-var "y"))))
+    (list :var "y")))
+
+;; ── let pattern-bindings ──
+(hk-test
+  "let tuple pattern-binding"
+  (hk-parse "let (x, y) = pair in x + y")
+  (list
+    :let
+    (list
+      (list
+        :bind
+        (list
+          :p-tuple
+          (list (list :p-var "x") (list :p-var "y")))
+        (list :var "pair")))
+    (list :op "+" (list :var "x") (list :var "y"))))
+
+(hk-test
+  "let constructor pattern-binding"
+  (hk-parse "let Just x = m in x")
+  (list
+    :let
+    (list
+      (list
+        :bind
+        (list :p-con "Just" (list (list :p-var "x")))
+        (list :var "m")))
+    (list :var "x")))
+
+(hk-test
+  "let cons pattern-binding"
+  (hk-parse "let (x : rest) = xs in x")
+  (list
+    :let
+    (list
+      (list
+        :bind
+        (list
+          :p-con
+          ":"
+          (list (list :p-var "x") (list :p-var "rest")))
+        (list :var "xs")))
+    (list :var "x")))
+
+;; ── do with constructor-pattern binds ──
+(hk-test
+  "do bind to tuple pattern"
+  (hk-parse "do\n  (a, b) <- pairs\n  return a")
+  (list
+    :do
+    (list
+      (list
+        :do-bind
+        (list
+          :p-tuple
+          (list (list :p-var "a") (list :p-var "b")))
+        (list :var "pairs"))
+      (list
+        :do-expr
+        (list :app (list :var "return") (list :var "a"))))))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}