coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: coop:322eb1d034ab20bf53e2fc9842f848fbc62ed1b2
Branches Tags
coop:main coop:loops/fed-sx-m1 coop:loops/go coop:loops/fed-prims coop:loops/erlang coop:architecture coop:lib/guest/quoting coop:loops/scheme coop:hs-f coop:lib/guest/method-chain coop:lib/guest/test-runner coop:lib/smalltalk/refl-env coop:lib/tcl/uplevel coop:loops/kernel coop:loops/apl coop:loops/datalog coop:loops/js coop:loops/ocaml coop:loops/haskell coop:loops/minikanren coop:loops/tcl coop:bugs/resume-letrec coop:bugs/jit-bytecode-loop coop:loops/prolog coop:loops/smalltalk coop:loops/ruby coop:loops/lua coop:loops/forth coop:loops/common-lisp coop:loops/hs coop:hs-e36-websocket coop:hs-e37-tokenizer coop:hs-e39-webworker coop:wasm coop:macros coop:sx coop:exorcism coop:cssx coop:decoupling coop:sexpression coop:relations
..
compare: coop:loops/common-lisp
Branches Tags
coop:loops/fed-sx-m1 coop:loops/go coop:loops/fed-prims coop:loops/erlang coop:architecture coop:lib/guest/quoting coop:loops/scheme coop:hs-f coop:lib/guest/method-chain coop:lib/guest/test-runner coop:lib/smalltalk/refl-env coop:lib/tcl/uplevel coop:loops/kernel coop:loops/apl coop:loops/datalog coop:loops/js coop:loops/ocaml coop:loops/haskell coop:loops/minikanren coop:loops/tcl coop:bugs/resume-letrec coop:bugs/jit-bytecode-loop coop:loops/prolog coop:loops/smalltalk coop:loops/ruby coop:loops/lua coop:loops/forth coop:loops/common-lisp coop:loops/hs coop:hs-e36-websocket coop:hs-e37-tokenizer coop:hs-e39-webworker coop:main coop:wasm coop:macros coop:sx coop:exorcism coop:cssx coop:decoupling coop:sexpression coop:relations

1 Commits
322eb1d034 ... loops/comm

Author SHA1 Message Date
giles
6d53d36495 briefing: push to origin/loops/common-lisp after each commit
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 40s
Details
2026-05-05 20:08:03 +00:00
232 changed files with 12864 additions and 57324 deletions
Expand all files Collapse all files

114
hosts/javascript/platform.py
View File

@@ -1129,7 +1129,6 @@ 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;
''',
@@ -1476,22 +1475,6 @@ 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": '''
@@ -1950,30 +1933,12 @@ 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); }
@@ -2140,13 +2105,6 @@ 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;
@@ -2168,16 +2126,7 @@ PLATFORM_JS_PRE = '''
}
function error(msg) { throw new Error(msg); }
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 inspect(x) { return JSON.stringify(x); }
function debugLog() { console.error.apply(console, ["[sx-debug]"].concat(Array.prototype.slice.call(arguments))); }
'''
@@ -2501,7 +2450,6 @@ 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;
@@ -2823,8 +2771,8 @@ PLATFORM_DOM_JS = """
// If lambda takes 0 params, call without event arg (convenience for on-click handlers)
var wrapped = isLambda(handler)
? (lambdaParams(handler).length === 0
? function(e) { try { 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); } })
? 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); } })
: 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 };
@@ -4033,11 +3981,6 @@ 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(), [], []));
@@ -4160,56 +4103,7 @@ 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;
// -----------------------------------------------------------------------
// 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;''']
PRIMITIVES["clear-stores"] = clearStores;''']
if has_deps:
lines.append('''
// Platform deps functions (native JS, not transpiled — need explicit registration)

73
hosts/ocaml/bin/bench_cek.ml
View File

@@ -1,73 +0,0 @@
(** 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%!"

46
hosts/ocaml/bin/bench_inspect.ml
View File

@@ -1,46 +0,0 @@
(* 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

155
hosts/ocaml/bin/bench_vm.ml
View File

@@ -1,155 +0,0 @@
(** 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%!"

2
hosts/ocaml/bin/dune
View File

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

29
hosts/ocaml/bin/mcp_tree.ml
View File

@@ -1892,34 +1892,8 @@ 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 ->
@@ -3044,8 +3018,7 @@ 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")]);
("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")])]
("setup", `Assoc [("type", `String "string"); ("description", `String "SX setup expression to run before main evaluation")])]
["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")]);

3
hosts/ocaml/bin/run_tests.ml
View File

@@ -2899,9 +2899,6 @@ 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 *)

32
hosts/ocaml/bin/sx_server.ml
View File

@@ -703,11 +703,6 @@ 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] ->
@@ -769,13 +764,7 @@ 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))));
(* 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)))
List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args))))
(* ---- Type predicates and introspection ---- *)
let setup_introspection env =
@@ -961,24 +950,7 @@ 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 :: 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-extend" (fun args -> match args with [e] -> Env (Sx_types.env_extend (uw e)) | _ -> raise (Eval_error "env-extend: expected env"));
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) ---- *)

3
hosts/ocaml/browser/bundle.sh
View File

@@ -75,9 +75,6 @@ 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)

9
hosts/ocaml/browser/compile-modules.js
View File

@@ -85,7 +85,6 @@ 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',
];
@@ -456,10 +455,8 @@ for (const file of FILES) {
'hs-parser': ['hs-tokenizer'],
'hs-compiler': ['hs-tokenizer', 'hs-parser'],
'hs-runtime': ['hs-tokenizer', 'hs-parser', 'hs-compiler'],
'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'],
'hs-integration': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime'],
'hs-htmx': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration'],
};
manifest[key] = {
file: sxbcFile,
@@ -480,7 +477,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-worker', 'hs-prolog', 'hs-integration', 'hs-htmx'];
const HS_LAZY = ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration', 'hs-htmx'];
for (const m of HS_LAZY) {
if (manifest[m] && !lazyDeps.includes(m)) lazyDeps.push(m);
}

2
hosts/ocaml/lib/dune
View File

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

25
hosts/ocaml/lib/sx_compiler.ml
View File

@@ -200,30 +200,7 @@ 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
(* 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))))))))))
(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))))))))))
(* compile *)
and compile expr =

207
hosts/ocaml/lib/sx_primitives.ml
View File

@@ -666,9 +666,7 @@ let () =
register "list?" (fun args ->
match args with [List _] | [ListRef _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "list?: 1 arg"));
register "dict?" (fun args ->
match args with [Dict _] -> Bool true | [AdtValue _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg"));
register "adt?" (fun args ->
match args with [AdtValue _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "adt?: 1 arg"));
match args with [Dict _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg"));
register "symbol?" (fun args ->
match args with [Symbol _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "symbol?: 1 arg"));
register "keyword?" (fun args ->
@@ -1281,11 +1279,6 @@ let () =
match args with [String msg] -> raise (Eval_error msg)
| [a] -> raise (Eval_error (to_string a))
| _ -> raise (Eval_error "host-error: 1 arg"));
register "host-warn" (fun args ->
match args with
| [String msg] -> prerr_endline msg; Nil
| [a] -> prerr_endline (to_string a); Nil
| _ -> raise (Eval_error "host-warn: 1 arg"));
register "try-catch" (fun args ->
match args with
| [try_fn; catch_fn] ->
@@ -1607,32 +1600,6 @@ let () =
match args with [StringBuffer buf] -> Integer (Buffer.length buf)
| _ -> raise (Eval_error "string-buffer-length: expected (buffer)"));
(* Short aliases — same StringBuffer value, terser names for hot paths.
Append accepts any value: strings pass through, others get inspected/coerced. *)
register "make-buffer" (fun _ -> StringBuffer (Buffer.create 64));
register "buffer?" (fun args ->
match args with [StringBuffer _] -> Bool true | [_] -> Bool false
| _ -> raise (Eval_error "buffer?: expected 1 arg"));
register "buffer-append!" (fun args ->
match args with
| [StringBuffer buf; String s] -> Buffer.add_string buf s; Nil
| [StringBuffer buf; Integer n] -> Buffer.add_string buf (string_of_int n); Nil
| [StringBuffer buf; Number n] -> Buffer.add_string buf (Sx_types.format_number n); Nil
| [StringBuffer buf; Symbol s] -> Buffer.add_string buf s; Nil
| [StringBuffer buf; Char n] ->
Buffer.add_utf_8_uchar buf (Uchar.of_int n); Nil
| [StringBuffer buf; Nil] -> Buffer.add_string buf ""; Nil
| [StringBuffer buf; Bool true] -> Buffer.add_string buf "true"; Nil
| [StringBuffer buf; Bool false] -> Buffer.add_string buf "false"; Nil
| [StringBuffer buf; v] -> Buffer.add_string buf (inspect v); Nil
| _ -> raise (Eval_error "buffer-append!: expected (buffer value)"));
register "buffer->string" (fun args ->
match args with [StringBuffer buf] -> String (Buffer.contents buf)
| _ -> raise (Eval_error "buffer->string: expected (buffer)"));
register "buffer-length" (fun args ->
match args with [StringBuffer buf] -> Integer (Buffer.length buf)
| _ -> raise (Eval_error "buffer-length: expected (buffer)"));
(* Capability-based sandboxing — gate IO operations *)
let cap_stack : string list ref = ref [] in
register "with-capabilities" (fun args ->
@@ -3033,174 +3000,4 @@ let () =
List.iteri (fun i c -> Bytes.set b i c) bytes_list;
SxBytevector b
| [Nil] -> SxBytevector (Bytes.create 0)
| _ -> raise (Eval_error "list->bytevector: expected list"));
(* === File I/O === *)
register "file-read" (fun args ->
match args with
| [String path] ->
(try
let ic = open_in path in
let n = in_channel_length ic in
let s = Bytes.create n in
really_input ic s 0 n;
close_in ic;
String (Bytes.to_string s)
with Sys_error msg -> raise (Eval_error ("file-read: " ^ msg)))
| _ -> raise (Eval_error "file-read: (path)"));
register "file-write" (fun args ->
match args with
| [String path; String content] ->
(try
let oc = open_out path in
output_string oc content;
close_out oc;
Nil
with Sys_error msg -> raise (Eval_error ("file-write: " ^ msg)))
| _ -> raise (Eval_error "file-write: (path content)"));
register "file-append" (fun args ->
match args with
| [String path; String content] ->
(try
let oc = open_out_gen [Open_append; Open_creat; Open_wronly; Open_text] 0o644 path in
output_string oc content;
close_out oc;
Nil
with Sys_error msg -> raise (Eval_error ("file-append: " ^ msg)))
| _ -> raise (Eval_error "file-append: (path content)"));
register "file-exists?" (fun args ->
match args with
| [String path] -> Bool (Sys.file_exists path)
| _ -> raise (Eval_error "file-exists?: (path)"));
register "file-glob" (fun args ->
let glob_match pat str =
let pn = String.length pat and sn = String.length str in
let rec go pi si =
if pi = pn then si = sn
else match pat.[pi] with
| '*' ->
let rec try_from i = i <= sn && (go (pi+1) i || try_from (i+1)) in
try_from si
| '?' -> si < sn && go (pi+1) (si+1)
| '[' ->
let pi' = ref (pi+1) in
let negate = !pi' < pn && pat.[!pi'] = '^' in
if negate then incr pi';
let matched = ref false in
while !pi' < pn && pat.[!pi'] <> ']' do
let c1 = pat.[!pi'] in
incr pi';
if !pi' + 1 < pn && pat.[!pi'] = '-' then begin
let c2 = pat.[!pi' + 1] in
pi' := !pi' + 2;
if si < sn && str.[si] >= c1 && str.[si] <= c2 then matched := true
end else if si < sn && str.[si] = c1 then matched := true
done;
if !pi' < pn then incr pi';
((!matched && not negate) || (not !matched && negate)) && go !pi' (si+1)
| c -> si < sn && str.[si] = c && go (pi+1) (si+1)
in go 0 0
in
let glob_paths pat =
let dir = Filename.dirname pat in
let base_pat = Filename.basename pat in
let dir' = if dir = "." && not (String.length pat > 1 && pat.[0] = '.') then "." else dir in
(try
let entries = Sys.readdir dir' in
Array.fold_left (fun acc entry ->
if glob_match base_pat entry then
let full = if dir' = "." then entry else Filename.concat dir' entry in
full :: acc
else acc
) [] entries
|> List.sort String.compare
with Sys_error _ -> [])
in
match args with
| [String pat] -> List (List.map (fun s -> String s) (glob_paths pat))
| _ -> raise (Eval_error "file-glob: (pattern)"));
(* === Clock === *)
register "clock-seconds" (fun args ->
match args with
| [] -> Integer (int_of_float (Unix.gettimeofday ()))
| _ -> raise (Eval_error "clock-seconds: no args"));
register "clock-milliseconds" (fun args ->
match args with
| [] -> Integer (int_of_float (Unix.gettimeofday () *. 1000.0))
| _ -> raise (Eval_error "clock-milliseconds: no args"));
register "clock-format" (fun args ->
match args with
| [Integer t] | [Integer t; String _] ->
let fmt = (match args with [_; String f] -> f | _ -> "%a %b %e %H:%M:%S %Z %Y") in
let tm = Unix.gmtime (float_of_int t) in
let buf = Buffer.create 32 in
let n = String.length fmt in
let i = ref 0 in
while !i < n do
if fmt.[!i] = '%' && !i + 1 < n then begin
(match fmt.[!i + 1] with
| 'Y' -> Buffer.add_string buf (Printf.sprintf "%04d" (1900 + tm.Unix.tm_year))
| 'm' -> Buffer.add_string buf (Printf.sprintf "%02d" (tm.Unix.tm_mon + 1))
| 'd' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_mday)
| 'e' -> Buffer.add_string buf (Printf.sprintf "%2d" tm.Unix.tm_mday)
| 'H' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_hour)
| 'M' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_min)
| 'S' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_sec)
| 'j' -> Buffer.add_string buf (Printf.sprintf "%03d" (tm.Unix.tm_yday + 1))
| 'Z' -> Buffer.add_string buf "UTC"
| 'a' -> let days = [|"Sun";"Mon";"Tue";"Wed";"Thu";"Fri";"Sat"|] in
Buffer.add_string buf days.(tm.Unix.tm_wday)
| 'A' -> let days = [|"Sunday";"Monday";"Tuesday";"Wednesday";"Thursday";"Friday";"Saturday"|] in
Buffer.add_string buf days.(tm.Unix.tm_wday)
| 'b' | 'h' -> let mons = [|"Jan";"Feb";"Mar";"Apr";"May";"Jun";"Jul";"Aug";"Sep";"Oct";"Nov";"Dec"|] in
Buffer.add_string buf mons.(tm.Unix.tm_mon)
| 'B' -> let mons = [|"January";"February";"March";"April";"May";"June";"July";"August";"September";"October";"November";"December"|] in
Buffer.add_string buf mons.(tm.Unix.tm_mon)
| c -> Buffer.add_char buf '%'; Buffer.add_char buf c);
i := !i + 2
end else begin
Buffer.add_char buf fmt.[!i];
incr i
end
done;
String (Buffer.contents buf)
| _ -> raise (Eval_error "clock-format: (seconds [format])"));
(* === Env-as-value (Phase 4) === *)
(* env-lookup: (env key) → value or nil. Works on Env, Dict, or Nil. *)
register "env-lookup" (fun args ->
let unwrap = function
| Env e -> e
| Nil -> make_env ()
| _ -> raise (Eval_error "env-lookup: first arg must be an environment") in
match args with
| [env_val; key] ->
let e = unwrap env_val in
let k = value_to_string key in
if env_has e k then env_get e k else Nil
| _ -> raise (Eval_error "env-lookup: (env key)"));
(* env-extend: (env [key val ...]) → new child env with optional bindings. *)
register "env-extend" (fun args ->
match args with
| [] -> raise (Eval_error "env-extend: requires at least one arg")
| env_val :: pairs ->
let parent_env = match env_val with
| Env e -> e
| Nil -> make_env ()
| _ -> raise (Eval_error "env-extend: first arg must be an environment") in
let child = env_extend parent_env in
let rec add_bindings = function
| [] -> ()
| k :: v :: rest -> ignore (env_bind child (value_to_string k) v); add_bindings rest
| [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in
add_bindings pairs;
Env child)
| _ -> raise (Eval_error "list->bytevector: expected list"))

100
hosts/ocaml/lib/sx_ref.ml
View File

@@ -759,78 +759,7 @@ 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 () = 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)
(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)))))
(* step-sf-handler-bind *)
and step_sf_handler_bind args env kont =
@@ -1125,7 +1054,8 @@ let sf_define_type args env_val =
(match pargs with
| [v] ->
(match v with
| AdtValue a -> Bool (a.av_type = type_name)
| Dict d -> Bool (Hashtbl.mem d "_adt" &&
(match Hashtbl.find_opt d "_type" with Some (String t) -> t = type_name | _ -> false))
| _ -> Bool false)
| _ -> Bool false)));
List.iter (fun spec ->
@@ -1139,18 +1069,21 @@ 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
AdtValue {
av_type = type_name;
av_ctor = cn;
av_fields = Array.of_list 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));
env_bind_v (cn ^ "?")
(NativeFn (cn ^ "?", fun pargs ->
(match pargs with
| [v] ->
(match v with
| AdtValue a -> Bool (a.av_ctor = cn)
| Dict d -> Bool (Hashtbl.mem d "_adt" &&
(match Hashtbl.find_opt d "_ctor" with Some (String c) -> c = cn | _ -> false))
| _ -> Bool false)
| _ -> Bool false)));
List.iteri (fun idx fname ->
@@ -1159,10 +1092,13 @@ let sf_define_type args env_val =
(match pargs with
| [v] ->
(match v with
| AdtValue a ->
if idx < Array.length a.av_fields then a.av_fields.(idx)
| 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")))
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": expected 1 arg")))))
) field_names
| _ -> ())

75
hosts/ocaml/lib/sx_runtime.ml
View File

@@ -6,69 +6,8 @@
open Sx_types
(** 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. *)
(** Call a registered primitive by name. *)
let prim_call name args =
(* 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))
@@ -270,13 +209,6 @@ 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 ->
@@ -472,10 +404,6 @@ 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
@@ -611,4 +539,3 @@ 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

191
hosts/ocaml/lib/sx_types.ml
View File

@@ -82,16 +82,6 @@ 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 =
@@ -530,7 +520,6 @@ 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
@@ -817,15 +806,14 @@ let dict_vals (d : dict) =
(** {1 Value display} *)
(* 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)
let rec inspect = function
| Nil -> "nil"
| Bool true -> "true"
| Bool false -> "false"
| Integer n -> string_of_int n
| Number n -> 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 "\\\""
@@ -834,129 +822,66 @@ let rec inspect_into buf = function
| '\r' -> Buffer.add_string buf "\\r"
| '\t' -> Buffer.add_string buf "\\t"
| c -> Buffer.add_char buf c) s;
Buffer.add_char buf '"'
| Symbol s -> Buffer.add_string buf s
| Keyword k -> Buffer.add_char buf ':'; Buffer.add_string buf k
Buffer.add_char buf '"';
Buffer.contents buf
| Symbol s -> s
| Keyword k -> ":" ^ k
| List items | ListRef { contents = 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 ')'
"(" ^ String.concat " " (List.map inspect items) ^ ")"
| Dict d ->
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 '}'
let pairs = Hashtbl.fold (fun k v acc ->
(Printf.sprintf ":%s %s" k (inspect v)) :: acc) d [] in
"{" ^ String.concat " " pairs ^ "}"
| Lambda l ->
let tag = match l.l_name with Some n -> n | None -> "lambda" in
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 ")>"
Printf.sprintf "<%s(%s)>" tag (String.concat ", " l.l_params)
| Component c ->
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 ")>"
Printf.sprintf "<Component ~%s(%s)>" c.c_name (String.concat ", " c.c_params)
| Island i ->
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 ")>"
Printf.sprintf "<Island ~%s(%s)>" i.i_name (String.concat ", " i.i_params)
| Macro m ->
let tag = match m.m_name with Some n -> n | None -> "macro" in
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 '>'
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")
| Record r ->
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 '>'
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
| Vector arr ->
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))
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)
| Char n ->
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 } ->
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;
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"
| 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)))))

48
hosts/ocaml/lib/sx_vm.ml
View File

@@ -327,18 +327,7 @@ and call_closure_reuse cl args =
vm.sp <- saved_sp;
raise e);
vm.frames <- saved_frames;
(* 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
pop vm
| None ->
call_closure cl args cl.vm_env_ref
@@ -742,57 +731,38 @@ 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 (Bool (Sx_runtime._fast_eq a b))
push vm ((Hashtbl.find Sx_primitives.primitives "=") [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)
| _ -> Sx_runtime.prim_call "<" [a; b])
| _ -> (Hashtbl.find Sx_primitives.primitives "<") [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)
| _ -> Sx_runtime.prim_call ">" [a; b])
| _ -> (Hashtbl.find Sx_primitives.primitives ">") [a; b])
| 167 (* OP_NOT *) ->
let v = pop vm in
push vm (Bool (not (sx_truthy v)))
@@ -915,17 +885,9 @@ 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;

2
lib/common-lisp/conformance.sh
View File

@@ -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(load "lib/guest/prefix.sx")\n'
printf '(epoch 1)\n(load "spec/stdlib.sx")\n'
local i=2
for f in $load_files; do
printf '(epoch %d)\n(load "%s")\n' "$i" "$f"

130
lib/common-lisp/runtime.sx
View File

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

2
lib/common-lisp/scoreboard.json
View File

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

2
lib/common-lisp/scoreboard.md
View File

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

207
lib/common-lisp/tests/runtime.sx
View File

@@ -1,207 +0,0 @@
;; lib/common-lisp/tests/runtime.sx — tests for CL runtime layer
(load "lib/common-lisp/runtime.sx")
(defsuite
"cl-types"
(deftest "cl-null? nil" (assert= true (cl-null? nil)))
(deftest "cl-null? false" (assert= false (cl-null? false)))
(deftest
"cl-consp? pair"
(assert= true (cl-consp? (list 1 2))))
(deftest "cl-consp? nil" (assert= false (cl-consp? nil)))
(deftest "cl-listp? nil" (assert= true (cl-listp? nil)))
(deftest
"cl-listp? list"
(assert= true (cl-listp? (list 1 2))))
(deftest "cl-atom? nil" (assert= true (cl-atom? nil)))
(deftest "cl-atom? pair" (assert= false (cl-atom? (list 1))))
(deftest "cl-integerp?" (assert= true (cl-integerp? 42)))
(deftest "cl-floatp?" (assert= true (cl-floatp? 3.14)))
(deftest
"cl-characterp?"
(assert= true (cl-characterp? (integer->char 65))))
(deftest "cl-stringp?" (assert= true (cl-stringp? "hello")))
(deftest "cl-symbolp?" (assert= true (cl-symbolp? (quote foo)))))
(defsuite
"cl-arithmetic"
(deftest "cl-mod" (assert= 1 (cl-mod 10 3)))
(deftest "cl-rem" (assert= 1 (cl-rem 10 3)))
(deftest
"cl-quotient"
(assert= 3 (cl-quotient 10 3)))
(deftest "cl-gcd" (assert= 4 (cl-gcd 12 8)))
(deftest "cl-lcm" (assert= 12 (cl-lcm 4 6)))
(deftest "cl-abs pos" (assert= 5 (cl-abs 5)))
(deftest "cl-abs neg" (assert= 5 (cl-abs -5)))
(deftest "cl-min" (assert= 2 (cl-min 2 7)))
(deftest "cl-max" (assert= 7 (cl-max 2 7)))
(deftest "cl-evenp? t" (assert= true (cl-evenp? 4)))
(deftest "cl-evenp? f" (assert= false (cl-evenp? 3)))
(deftest "cl-oddp? t" (assert= true (cl-oddp? 7)))
(deftest "cl-zerop?" (assert= true (cl-zerop? 0)))
(deftest "cl-plusp?" (assert= true (cl-plusp? 1)))
(deftest "cl-minusp?" (assert= true (cl-minusp? -1)))
(deftest "cl-signum pos" (assert= 1 (cl-signum 42)))
(deftest "cl-signum neg" (assert= -1 (cl-signum -7)))
(deftest "cl-signum zero" (assert= 0 (cl-signum 0))))
(defsuite
"cl-chars"
(deftest
"cl-char-code"
(assert= 65 (cl-char-code (integer->char 65))))
(deftest "cl-code-char" (assert= true (char? (cl-code-char 65))))
(deftest
"cl-char-upcase"
(assert=
(integer->char 65)
(cl-char-upcase (integer->char 97))))
(deftest
"cl-char-downcase"
(assert=
(integer->char 97)
(cl-char-downcase (integer->char 65))))
(deftest
"cl-alpha-char-p"
(assert= true (cl-alpha-char-p (integer->char 65))))
(deftest
"cl-digit-char-p"
(assert= true (cl-digit-char-p (integer->char 48))))
(deftest
"cl-char=?"
(assert=
true
(cl-char=? (integer->char 65) (integer->char 65))))
(deftest
"cl-char<?"
(assert=
true
(cl-char<? (integer->char 65) (integer->char 90))))
(deftest
"cl-char space"
(assert= (integer->char 32) cl-char-space))
(deftest
"cl-char newline"
(assert= (integer->char 10) cl-char-newline)))
(defsuite
"cl-format"
(deftest
"cl-format nil basic"
(assert= "hello" (cl-format nil "~a" "hello")))
(deftest
"cl-format nil number"
(assert= "42" (cl-format nil "~d" 42)))
(deftest
"cl-format nil hex"
(assert= "ff" (cl-format nil "~x" 255)))
(deftest
"cl-format nil template"
(assert= "x=3 y=4" (cl-format nil "x=~d y=~d" 3 4)))
(deftest "cl-format nil tilde" (assert= "a~b" (cl-format nil "a~~b"))))
(defsuite
"cl-gensym"
(deftest
"cl-gensym returns symbol"
(assert= "symbol" (type-of (cl-gensym))))
(deftest "cl-gensym unique" (assert= false (= (cl-gensym) (cl-gensym)))))
(defsuite
"cl-sets"
(deftest "cl-make-set empty" (assert= true (cl-set? (cl-make-set))))
(deftest
"cl-set-add/member"
(let
((s (cl-make-set)))
(do
(cl-set-add s 1)
(assert= true (cl-set-memberp s 1)))))
(deftest
"cl-set-memberp false"
(assert= false (cl-set-memberp (cl-make-set) 42)))
(deftest
"cl-list->set"
(let
((s (cl-list->set (list 1 2 3))))
(assert= true (cl-set-memberp s 2)))))
(defsuite
"cl-lists"
(deftest
"cl-nth 0"
(assert=
1
(cl-nth 0 (list 1 2 3))))
(deftest
"cl-nth 2"
(assert=
3
(cl-nth 2 (list 1 2 3))))
(deftest
"cl-last"
(assert=
(list 3)
(cl-last (list 1 2 3))))
(deftest
"cl-butlast"
(assert=
(list 1 2)
(cl-butlast (list 1 2 3))))
(deftest
"cl-nthcdr 1"
(assert=
(list 2 3)
(cl-nthcdr 1 (list 1 2 3))))
(deftest
"cl-assoc hit"
(assert=
(list "b" 2)
(cl-assoc "b" (list (list "a" 1) (list "b" 2)))))
(deftest
"cl-assoc miss"
(assert= nil (cl-assoc "z" (list (list "a" 1)))))
(deftest
"cl-getf hit"
(assert= 42 (cl-getf (list "x" 42 "y" 99) "x")))
(deftest "cl-getf miss" (assert= nil (cl-getf (list "x" 42) "z")))
(deftest
"cl-adjoin new"
(assert=
(list 0 1 2)
(cl-adjoin 0 (list 1 2))))
(deftest
"cl-adjoin dup"
(assert=
(list 1 2)
(cl-adjoin 1 (list 1 2))))
(deftest
"cl-flatten"
(assert=
(list 1 2 3 4)
(cl-flatten (list 1 (list 2 3) 4))))
(deftest
"cl-member hit"
(assert=
(list 2 3)
(cl-member 2 (list 1 2 3))))
(deftest
"cl-member miss"
(assert=
nil
(cl-member 9 (list 1 2 3)))))
(defsuite
"cl-radix"
(deftest "binary" (assert= "1010" (cl-format-binary 10)))
(deftest "octal" (assert= "17" (cl-format-octal 15)))
(deftest "hex" (assert= "ff" (cl-format-hex 255)))
(deftest "decimal" (assert= "42" (cl-format-decimal 42)))
(deftest
"n->s r16"
(assert= "1f" (cl-integer-to-string 31 16)))
(deftest
"s->n r16"
(assert= 31 (cl-string-to-integer "1f" 16))))

20
lib/compiler.sx
View File

@@ -1008,27 +1008,11 @@
(let
((name (symbol-name head))
(argc (len args))
(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)))
(name-idx (pool-add (get em "pool") name)))
(for-each (fn (a) (compile-expr em a scope false)) args)
(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))))
(emit-byte em argc))
(do
(compile-expr em head scope false)
(for-each (fn (a) (compile-expr em a scope false)) args)

22
lib/erlang/scoreboard.json
View File

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

20
lib/erlang/scoreboard.md
View File

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

44
lib/fiber.sx
View File

@@ -1,44 +0,0 @@
; 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?))))

18
lib/guest/baseline/apl.json
View File

@@ -1,18 +0,0 @@
{
"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
}
]
}

86
lib/guest/baseline/common-lisp.json
View File

@@ -1,86 +0,0 @@
{
"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."
}

67
lib/guest/baseline/erlang.json
View File

@@ -1,67 +0,0 @@
{
"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"
}

18
lib/guest/baseline/forth.json
View File

@@ -1,18 +0,0 @@
{
"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
}
]
}

122
lib/guest/baseline/haskell.json
View File

@@ -1,122 +0,0 @@
{
"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."
}

75
lib/guest/baseline/js.json
View File

@@ -1,75 +0,0 @@
{
"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"
}

18
lib/guest/baseline/lua.json
View File

@@ -1,18 +0,0 @@
{
"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
}
]
}

187
lib/guest/baseline/prolog.json
View File

@@ -1,187 +0,0 @@
{
"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"
}

18
lib/guest/baseline/ruby.json
View File

@@ -1,18 +0,0 @@
{
"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
}
]
}

25
lib/guest/baseline/smalltalk.json
View File

@@ -1,25 +0,0 @@
{
"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"
}

37
lib/guest/baseline/tcl.json
View File

@@ -1,37 +0,0 @@
{
"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"
}

221
lib/guest/conformance.sh
View File

@@ -1,221 +0,0 @@
#!/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."

40
lib/guest/conformance.sx
View File

@@ -1,40 +0,0 @@
;; 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)))))

67
lib/guest/lex.sx
View File

@@ -1,67 +0,0 @@
;; 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)))

46
lib/guest/prefix.sx
View File

@@ -1,46 +0,0 @@
;; 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))))

76
lib/haskell/conformance.conf
View File

@@ -1,76 +0,0 @@
# 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/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"
)
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"
}

3
lib/haskell/conformance.sh
View File

@@ -1,3 +0,0 @@
#!/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" "$@"

249
lib/haskell/desugar.sx
View File

@@ -1,249 +0,0 @@
;; 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
;; Transformations
((= 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)))
;; Expression nodes
((= tag "app")
(list
:app
(hk-desugar (nth node 1))
(hk-desugar (nth node 2))))
((= 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 (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))))
;; Top-level
((= tag "program")
(list :program (map hk-desugar (nth node 1))))
((= tag "module")
(list
:module
(nth node 1)
(nth node 2)
(nth node 3)
(map hk-desugar (nth node 4))))
;; Decls carrying a body
((= tag "fun-clause")
(list
:fun-clause
(nth node 1)
(nth node 2)
(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))))
;; Everything else: leaf literals, vars, cons, patterns,
;; types, imports, type-sigs, data / newtype / fixity, …
(:else node)))))))
;; Convenience — tokenize + layout + parse + desugar.
(define
hk-core
(fn (src) (hk-desugar (hk-parse-top src))))
(define
hk-core-expr
(fn (src) (hk-desugar (hk-parse src))))

1265
lib/haskell/eval.sx
View File

File diff suppressed because it is too large Load Diff

658
lib/haskell/infer.sx
View File

@@ -1,658 +0,0 @@
;; 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)))))))

329
lib/haskell/layout.sx
View File

@@ -1,329 +0,0 @@
;; 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))))

201
lib/haskell/match.sx
View File

@@ -1,201 +0,0 @@
;; 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
((not (hk-is-con-val? fv)) nil)
((not (= (hk-val-con-name fv) pat-name)) nil)
(:else
(let
((val-args (hk-val-con-args fv)))
(cond
((not (= (len pat-args) (len val-args)))
nil)
(:else
(hk-match-all
pat-args
val-args
env))))))))
((= 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
(and
(hk-is-con-val? fv)
(= (hk-val-con-name fv) "[]"))
env
nil))
(:else
(cond
((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))))

1658
lib/haskell/parser.sx
View File

File diff suppressed because it is too large Load Diff

607
lib/haskell/runtime.sx
View File

@@ -1,130 +1,507 @@
;; Haskell runtime: constructor registry.
;; lib/haskell/runtime.sx — Haskell-on-SX runtime layer
;;
;; 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.
;; 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
(define hk-constructors (dict))
;; ===========================================================================
;; 1. Numeric type class helpers
;; ===========================================================================
(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-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
(has-key? hk-constructors name)
(get (get hk-constructors name) "arity")
nil)))
(define
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)
(hk-div a b)
(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))))
((q (quotient a b)) (r (remainder a b)))
(if
(and
(not (= r 0))
(or
(and (< a 0) (> b 0))
(and (> a 0) (< b 0))))
(- q 1)
q)))
;; (:newtype NAME TVARS CNAME FIELD)
(define
hk-register-newtype!
(fn
(nt-node)
(hk-register-con!
(nth nt-node 3)
1
(nth nt-node 1))))
;; Haskell mod: result has same sign as divisor
(define hk-mod modulo)
;; Walk a decls list, registering every `data` / `newtype` decl.
;; 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-register-decls!
(fn
(decls)
(for-each
(fn
(d)
(hk-signum x)
(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)))
((> 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)
;; ===========================================================================
(define
hk-register-program!
(fn
(ast)
(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})))
(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)))
(cond
((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))))
((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))))))
;; Convenience: source → AST → desugar → register.
;; intToDigit: 0-15 → char
(define
hk-load-source!
(fn (src) (hk-register-program! (hk-core src))))
(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)))))
;; ── 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")
;; ===========================================================================
;; 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)
(define
(hk-take n lst)
(if
(or (= n 0) (= (len lst) 0))
(list)
(cons (first lst) (hk-take (- n 1) (rest lst)))))
(define
(hk-drop n lst)
(if
(or (= n 0) (= (len lst) 0))
lst
(hk-drop (- n 1) (rest lst))))
(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)))))
(define
(hk-drop-while pred lst)
(if
(or (= (len lst) 0) (not (pred (first lst))))
lst
(hk-drop-while pred (rest lst))))
(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)
""
(reduce
(fn (a b) (str a "," (hk-show b)))
(hk-show (first x))
(rest x)))
"]"))
(else (str x))))

25
lib/haskell/scoreboard.json
View File

@@ -1,25 +0,0 @@
{
"date": "2026-05-06",
"total_pass": 156,
"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": 8, "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": 7, "fail": 0},
"powers": {"pass": 14, "fail": 0}
}
}

25
lib/haskell/scoreboard.md
View File

@@ -1,25 +0,0 @@
# Haskell-on-SX Scoreboard
Updated 2026-05-06 · 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 | 8/8 | ✓ |
| 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 | 7/7 | ✓ |
| powers.hs | 14/14 | ✓ |
| **Total** | **156/156** | **18/18 programs** |

25
lib/haskell/test.sh
View File

@@ -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 | awk 'NR==1{print $1}')
MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
SX_SERVER="$MAIN_ROOT/$SX_SERVER"
else
@@ -42,35 +42,25 @@ 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")
$INFER_LOAD
(load "lib/haskell/testlib.sx")
(epoch 2)
(load "$FILE")
(epoch 3)
(eval "(list hk-test-pass hk-test-fail)")
EPOCHS
OUTPUT=$(timeout 360 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
OUTPUT=$(timeout 60 "$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]+\)\)' || true; } | tail -1 \
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 3 //; s/\)$//')
fi
if [ -z "$LINE" ]; then
@@ -92,20 +82,13 @@ 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")
$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 360 "$SX_SERVER" < "$TMPFILE2" 2>&1 | grep -E '^\(ok 3 ' || true)
FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>&1 | grep -E '^\(ok 3 ' || true)
rm -f "$TMPFILE2"
echo " $FAILS"
elif [ "$VERBOSE" = "1" ]; then

58
lib/haskell/testlib.sx
View File

@@ -1,58 +0,0 @@
;; 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})))))

60
lib/haskell/tests/class.sx
View File

@@ -1,60 +0,0 @@
;; 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}

84
lib/haskell/tests/deriving.sx
View File

@@ -1,84 +0,0 @@
;; 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 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")
;; ─── combined Eq + Show ───────────────────────────────────────────────────────
(hk-test
"deriving Eq Show: combined in parens"
(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}

305
lib/haskell/tests/desugar.sx
View File

@@ -1,305 +0,0 @@
;; 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}

117
lib/haskell/tests/do-io.sx
View File

@@ -1,117 +0,0 @@
;; 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}

278
lib/haskell/tests/eval.sx
View File

@@ -1,278 +0,0 @@
;; 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
"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"))
;; ── not / id built-ins ──
(hk-test "not True" (hk-eval-expr-source "not True") (list "False"))
(hk-test "not False" (hk-eval-expr-source "not False") (list "True"))
(hk-test "id" (hk-eval-expr-source "id 42") 42)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

181
lib/haskell/tests/infer.sx
View File

@@ -1,181 +0,0 @@
;; 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}

137
lib/haskell/tests/infinite.sx
View File

@@ -1,137 +0,0 @@
;; 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}

85
lib/haskell/tests/io-input.sx
View File

@@ -1,85 +0,0 @@
;; 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"
(guard
(e (true (>= (index-of e "file not found") 0)))
(begin
(set! hk-vfs (dict))
(hk-run-io "main = readFile \"no.txt\" >>= putStrLn")
false))
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}

245
lib/haskell/tests/layout.sx
View File

@@ -1,245 +0,0 @@
;; 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}

256
lib/haskell/tests/match.sx
View File

@@ -1,256 +0,0 @@
;; 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}

56
lib/haskell/tests/parse.sx
View File

@@ -3,8 +3,60 @@
;; 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.
;; The hk-test / hk-deep=? helpers live in lib/haskell/testlib.sx
;; and are preloaded by lib/haskell/test.sh.
(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})))))
;; Convenience: tokenize and drop newline + eof tokens so tests focus
;; on meaningful content. Returns list of {:type :value} pairs.

278
lib/haskell/tests/parser-case-do.sx
View File

@@ -1,278 +0,0 @@
;; 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}

273
lib/haskell/tests/parser-decls.sx
View File

@@ -1,273 +0,0 @@
;; 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}

258
lib/haskell/tests/parser-expr.sx
View File

@@ -1,258 +0,0 @@
;; 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}

261
lib/haskell/tests/parser-guards-where.sx
View File

@@ -1,261 +0,0 @@
;; 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}

202
lib/haskell/tests/parser-module.sx
View File

@@ -1,202 +0,0 @@
;; 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}

234
lib/haskell/tests/parser-patterns.sx
View File

@@ -1,234 +0,0 @@
;; 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}

191
lib/haskell/tests/parser-sect-comp.sx
View File

@@ -1,191 +0,0 @@
;; Operator sections and list comprehensions.
;; ── Operator references (unchanged expr shape) ──
(hk-test
"op as value (+)"
(hk-parse "(+)")
(list :var "+"))
(hk-test
"op as value (-)"
(hk-parse "(-)")
(list :var "-"))
(hk-test
"op as value (:)"
(hk-parse "(:)")
(list :var ":"))
(hk-test
"backtick op as value"
(hk-parse "(`div`)")
(list :var "div"))
;; ── Right sections (op expr) ──
(hk-test
"right section (+ 5)"
(hk-parse "(+ 5)")
(list :sect-right "+" (list :int 5)))
(hk-test
"right section (* x)"
(hk-parse "(* x)")
(list :sect-right "*" (list :var "x")))
(hk-test
"right section with backtick op"
(hk-parse "(`div` 2)")
(list :sect-right "div" (list :int 2)))
;; `-` is unary in expr position — (- 5) is negation, not a right section
(hk-test
"(- 5) is negation, not a section"
(hk-parse "(- 5)")
(list :neg (list :int 5)))
;; ── Left sections (expr op) ──
(hk-test
"left section (5 +)"
(hk-parse "(5 +)")
(list :sect-left "+" (list :int 5)))
(hk-test
"left section with backtick"
(hk-parse "(x `mod`)")
(list :sect-left "mod" (list :var "x")))
(hk-test
"left section with cons (x :)"
(hk-parse "(x :)")
(list :sect-left ":" (list :var "x")))
;; ── Mixed / nesting ──
(hk-test
"map (+ 1) xs"
(hk-parse "map (+ 1) xs")
(list
:app
(list
:app
(list :var "map")
(list :sect-right "+" (list :int 1)))
(list :var "xs")))
(hk-test
"filter (< 0) xs"
(hk-parse "filter (< 0) xs")
(list
:app
(list
:app
(list :var "filter")
(list :sect-right "<" (list :int 0)))
(list :var "xs")))
;; ── Plain parens and tuples still work ──
(hk-test
"plain parens unwrap"
(hk-parse "(1 + 2)")
(list :op "+" (list :int 1) (list :int 2)))
(hk-test
"tuple still parses"
(hk-parse "(a, b, c)")
(list
:tuple
(list (list :var "a") (list :var "b") (list :var "c"))))
;; ── List comprehensions ──
(hk-test
"simple list comprehension"
(hk-parse "[x | x <- xs]")
(list
:list-comp
(list :var "x")
(list
(list :q-gen (list :p-var "x") (list :var "xs")))))
(hk-test
"comprehension with filter"
(hk-parse "[x * 2 | x <- xs, x > 0]")
(list
:list-comp
(list :op "*" (list :var "x") (list :int 2))
(list
(list :q-gen (list :p-var "x") (list :var "xs"))
(list
:q-guard
(list :op ">" (list :var "x") (list :int 0))))))
(hk-test
"comprehension with let"
(hk-parse "[y | x <- xs, let y = x + 1]")
(list
:list-comp
(list :var "y")
(list
(list :q-gen (list :p-var "x") (list :var "xs"))
(list
:q-let
(list
(list
:bind
(list :p-var "y")
(list :op "+" (list :var "x") (list :int 1))))))))
(hk-test
"nested generators"
(hk-parse "[(x, y) | x <- xs, y <- ys]")
(list
:list-comp
(list :tuple (list (list :var "x") (list :var "y")))
(list
(list :q-gen (list :p-var "x") (list :var "xs"))
(list :q-gen (list :p-var "y") (list :var "ys")))))
(hk-test
"comprehension with constructor pattern"
(hk-parse "[v | Just v <- xs]")
(list
:list-comp
(list :var "v")
(list
(list
:q-gen
(list :p-con "Just" (list (list :p-var "v")))
(list :var "xs")))))
(hk-test
"comprehension with tuple pattern"
(hk-parse "[x + y | (x, y) <- pairs]")
(list
:list-comp
(list :op "+" (list :var "x") (list :var "y"))
(list
(list
:q-gen
(list
:p-tuple
(list (list :p-var "x") (list :p-var "y")))
(list :var "pairs")))))
(hk-test
"combination: generator, let, guard"
(hk-parse "[z | x <- xs, let z = x * 2, z > 10]")
(list
:list-comp
(list :var "z")
(list
(list :q-gen (list :p-var "x") (list :var "xs"))
(list
:q-let
(list
(list
:bind
(list :p-var "z")
(list :op "*" (list :var "x") (list :int 2)))))
(list
:q-guard
(list :op ">" (list :var "z") (list :int 10))))))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

234
lib/haskell/tests/prelude-extra.sx
View File

@@ -1,234 +0,0 @@
;; prelude-extra.sx — tests for Phase 6 prelude additions:
;; ord/isAlpha/isDigit/isSpace/isUpper/isLower/isAlphaNum/digitToInt
;; words/lines/unwords/unlines/sort/nub/splitAt/span/break
;; partition/intercalate/intersperse/isPrefixOf/isSuffixOf/isInfixOf
;; ── ord ──────────────────────────────────────────────────────
(hk-test "ord 'A'" (hk-eval-expr-source "ord 'A'") 65)
(hk-test "ord 'a'" (hk-eval-expr-source "ord 'a'") 97)
(hk-test "ord '0'" (hk-eval-expr-source "ord '0'") 48)
;; ── isAlpha / isDigit / isSpace / isUpper / isLower ──────────
(hk-test
"isAlpha 'a' True"
(hk-eval-expr-source "isAlpha 'a'")
(list "True"))
(hk-test
"isAlpha 'Z' True"
(hk-eval-expr-source "isAlpha 'Z'")
(list "True"))
(hk-test
"isAlpha '3' False"
(hk-eval-expr-source "isAlpha '3'")
(list "False"))
(hk-test
"isDigit '5' True"
(hk-eval-expr-source "isDigit '5'")
(list "True"))
(hk-test
"isDigit 'a' False"
(hk-eval-expr-source "isDigit 'a'")
(list "False"))
(hk-test
"isSpace ' ' True"
(hk-eval-expr-source "isSpace ' '")
(list "True"))
(hk-test
"isSpace 'x' False"
(hk-eval-expr-source "isSpace 'x'")
(list "False"))
(hk-test
"isUpper 'A' True"
(hk-eval-expr-source "isUpper 'A'")
(list "True"))
(hk-test
"isUpper 'a' False"
(hk-eval-expr-source "isUpper 'a'")
(list "False"))
(hk-test
"isLower 'z' True"
(hk-eval-expr-source "isLower 'z'")
(list "True"))
(hk-test
"isLower 'Z' False"
(hk-eval-expr-source "isLower 'Z'")
(list "False"))
(hk-test
"isAlphaNum '3' True"
(hk-eval-expr-source "isAlphaNum '3'")
(list "True"))
(hk-test
"isAlphaNum 'b' True"
(hk-eval-expr-source "isAlphaNum 'b'")
(list "True"))
(hk-test
"isAlphaNum '!' False"
(hk-eval-expr-source "isAlphaNum '!'")
(list "False"))
;; ── digitToInt ───────────────────────────────────────────────
(hk-test "digitToInt '0'" (hk-eval-expr-source "digitToInt '0'") 0)
(hk-test "digitToInt '7'" (hk-eval-expr-source "digitToInt '7'") 7)
(hk-test "digitToInt '9'" (hk-eval-expr-source "digitToInt '9'") 9)
;; ── words ────────────────────────────────────────────────────
(hk-test
"words single"
(hk-deep-force (hk-eval-expr-source "words \"hello\""))
(list ":" "hello" (list "[]")))
(hk-test
"words two"
(hk-deep-force (hk-eval-expr-source "words \"hello world\""))
(list ":" "hello" (list ":" "world" (list "[]"))))
(hk-test
"words leading/trailing spaces"
(hk-deep-force (hk-eval-expr-source "words \" foo bar \""))
(list ":" "foo" (list ":" "bar" (list "[]"))))
(hk-test
"words empty string"
(hk-deep-force (hk-eval-expr-source "words \"\""))
(list "[]"))
;; ── lines ────────────────────────────────────────────────────
(hk-test
"lines single no newline"
(hk-deep-force (hk-eval-expr-source "lines \"hello\""))
(list ":" "hello" (list "[]")))
(hk-test
"lines two lines"
(hk-deep-force (hk-eval-expr-source "lines \"a\\nb\""))
(list ":" "a" (list ":" "b" (list "[]"))))
(hk-test
"lines trailing newline"
(hk-deep-force (hk-eval-expr-source "lines \"a\\n\""))
(list ":" "a" (list "[]")))
(hk-test
"lines empty string"
(hk-deep-force (hk-eval-expr-source "lines \"\""))
(list "[]"))
;; ── unwords / unlines ────────────────────────────────────────
(hk-test
"unwords two"
(hk-eval-expr-source "unwords [\"hello\", \"world\"]")
"hello world")
(hk-test "unwords empty" (hk-eval-expr-source "unwords []") "")
(hk-test "unlines two" (hk-eval-expr-source "unlines [\"a\", \"b\"]") "a\nb\n")
;; ── sort / nub ───────────────────────────────────────────────
(hk-test
"sort ascending"
(hk-deep-force (hk-eval-expr-source "sort [3,1,2]"))
(list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))
(hk-test
"sort already sorted"
(hk-deep-force (hk-eval-expr-source "sort [1,2,3]"))
(list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))
(hk-test
"nub removes duplicates"
(hk-deep-force (hk-eval-expr-source "nub [1,2,1,3,2]"))
(list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))
(hk-test
"nub no duplicates unchanged"
(hk-deep-force (hk-eval-expr-source "nub [1,2,3]"))
(list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))
;; ── splitAt ──────────────────────────────────────────────────
(hk-test
"splitAt 2"
(hk-deep-force (hk-eval-expr-source "splitAt 2 [1,2,3,4]"))
(list
"Tuple"
(list ":" 1 (list ":" 2 (list "[]")))
(list ":" 3 (list ":" 4 (list "[]")))))
(hk-test
"splitAt 0"
(hk-deep-force (hk-eval-expr-source "splitAt 0 [1,2,3]"))
(list
"Tuple"
(list "[]")
(list ":" 1 (list ":" 2 (list ":" 3 (list "[]"))))))
;; ── span / break ─────────────────────────────────────────────
(hk-test
"span digits"
(hk-deep-force (hk-eval-expr-source "span (\\x -> x < 3) [1,2,3,4]"))
(list
"Tuple"
(list ":" 1 (list ":" 2 (list "[]")))
(list ":" 3 (list ":" 4 (list "[]")))))
(hk-test
"break digits"
(hk-deep-force (hk-eval-expr-source "break (\\x -> x >= 3) [1,2,3,4]"))
(list
"Tuple"
(list ":" 1 (list ":" 2 (list "[]")))
(list ":" 3 (list ":" 4 (list "[]")))))
;; ── partition ────────────────────────────────────────────────
(hk-test
"partition even/odd"
(hk-deep-force
(hk-eval-expr-source "partition (\\x -> x `mod` 2 == 0) [1,2,3,4,5]"))
(list
"Tuple"
(list ":" 2 (list ":" 4 (list "[]")))
(list ":" 1 (list ":" 3 (list ":" 5 (list "[]"))))))
;; ── intercalate / intersperse ────────────────────────────────
(hk-test
"intercalate"
(hk-eval-expr-source "intercalate \", \" [\"a\", \"b\", \"c\"]")
"a, b, c")
(hk-test
"intersperse"
(hk-deep-force (hk-eval-expr-source "intersperse 0 [1,2,3]"))
(list
":"
1
(list
":"
0
(list ":" 2 (list ":" 0 (list ":" 3 (list "[]")))))))
;; ── isPrefixOf / isSuffixOf / isInfixOf ──────────────────────
(hk-test
"isPrefixOf True"
(hk-deep-force (hk-eval-expr-source "isPrefixOf [1,2] [1,2,3]"))
(list "True"))
(hk-test
"isPrefixOf False"
(hk-deep-force (hk-eval-expr-source "isPrefixOf [2,3] [1,2,3]"))
(list "False"))
(hk-test
"isSuffixOf True"
(hk-deep-force (hk-eval-expr-source "isSuffixOf [2,3] [1,2,3]"))
(list "True"))
(hk-test
"isInfixOf True"
(hk-deep-force (hk-eval-expr-source "isInfixOf [2,3] [1,2,3,4]"))
(list "True"))
(hk-test
"isInfixOf False"
(hk-deep-force (hk-eval-expr-source "isInfixOf [5,6] [1,2,3,4]"))
(list "False"))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

70
lib/haskell/tests/program-anagram.sx
View File

@@ -1,70 +0,0 @@
;; anagram.hs — anagram detection using sort.
(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-ana-src
"isAnagram xs ys = sort xs == sort ys\n\nhasAnagram needle haystack = any (isAnagram needle) haystack\n")
(hk-test
"isAnagram [1,2,3] [3,2,1] True"
(hk-prog-val (str hk-ana-src "r = isAnagram [1,2,3] [3,2,1]\n") "r")
(list "True"))
(hk-test
"isAnagram [1,2,3] [1,2,4] False"
(hk-prog-val (str hk-ana-src "r = isAnagram [1,2,3] [1,2,4]\n") "r")
(list "False"))
(hk-test
"isAnagram [] [] True"
(hk-prog-val (str hk-ana-src "r = isAnagram [] []\n") "r")
(list "True"))
(hk-test
"isAnagram [1] [1] True"
(hk-prog-val (str hk-ana-src "r = isAnagram [1] [1]\n") "r")
(list "True"))
(hk-test
"isAnagram [1,2] [2,1] True"
(hk-prog-val (str hk-ana-src "r = isAnagram [1,2] [2,1]\n") "r")
(list "True"))
(hk-test
"isAnagram [1,1,2] [2,1,1] True"
(hk-prog-val (str hk-ana-src "r = isAnagram [1,1,2] [2,1,1]\n") "r")
(list "True"))
(hk-test
"isAnagram [1,2] [1,2,3] False"
(hk-prog-val (str hk-ana-src "r = isAnagram [1,2] [1,2,3]\n") "r")
(list "False"))
(hk-test
"hasAnagram [1,2] [[3,4],[2,1],[5,6]] True"
(hk-prog-val
(str hk-ana-src "r = hasAnagram [1,2] [[3,4],[2,1],[5,6]]\n")
"r")
(list "True"))
(hk-test
"hasAnagram [1,2] [[3,4],[5,6]] False"
(hk-prog-val (str hk-ana-src "r = hasAnagram [1,2] [[3,4],[5,6]]\n") "r")
(list "False"))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

83
lib/haskell/tests/program-binary.sx
View File

@@ -1,83 +0,0 @@
;; binary.hs — integer binary representation using explicit recursion.
(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-bin-src
"toBits 0 = []\ntoBits n = (n `mod` 2) : toBits (n `div` 2)\n\ntoBin 0 = [0]\ntoBin n = reverse (toBits n)\n\naddBit acc b = acc * 2 + b\nfromBin bits = foldl addBit 0 bits\n\nnumBits 0 = 1\nnumBits n = length (toBits n)\n")
(hk-test
"toBin 0 = [0]"
(hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 0\n") "r"))
(list 0))
(hk-test
"toBin 1 = [1]"
(hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 1\n") "r"))
(list 1))
(hk-test
"toBin 2 = [1,0]"
(hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 2\n") "r"))
(list 1 0))
(hk-test
"toBin 3 = [1,1]"
(hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 3\n") "r"))
(list 1 1))
(hk-test
"toBin 4 = [1,0,0]"
(hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 4\n") "r"))
(list 1 0 0))
(hk-test
"toBin 7 = [1,1,1]"
(hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 7\n") "r"))
(list 1 1 1))
(hk-test
"toBin 8 = [1,0,0,0]"
(hk-as-list (hk-prog-val (str hk-bin-src "r = toBin 8\n") "r"))
(list 1 0 0 0))
(hk-test
"fromBin [0] = 0"
(hk-prog-val (str hk-bin-src "r = fromBin [0]\n") "r")
0)
(hk-test
"fromBin [1] = 1"
(hk-prog-val (str hk-bin-src "r = fromBin [1]\n") "r")
1)
(hk-test
"fromBin [1,0,1] = 5"
(hk-prog-val (str hk-bin-src "r = fromBin [1,0,1]\n") "r")
5)
(hk-test
"fromBin [1,1,1] = 7"
(hk-prog-val (str hk-bin-src "r = fromBin [1,1,1]\n") "r")
7)
(hk-test
"roundtrip: fromBin (toBin 13) = 13"
(hk-prog-val (str hk-bin-src "r = fromBin (toBin 13)\n") "r")
13)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

55
lib/haskell/tests/program-calculator.sx
View File

@@ -1,55 +0,0 @@
;; calculator.hs — recursive descent expression evaluator.
;;
;; Exercises:
;; - ADTs with constructor fields: TNum Int, TOp String, R Int [Token]
;; - Nested constructor pattern matching: (R v (TOp "+":rest))
;; - let bindings in function bodies
;; - Integer arithmetic including `div` (backtick infix)
;; - Left-associative multi-level operator precedence
(define
hk-prog-val
(fn
(src name)
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
(define
hk-calc-src
"data Token = TNum Int | TOp String\ndata Result = R Int [Token]\ngetV (R v _) = v\ngetR (R _ r) = r\neval ts = getV (parseExpr ts)\nparseExpr ts = parseExprRest (parseTerm ts)\nparseExprRest (R v (TOp \"+\":rest)) =\n let t = parseTerm rest\n in parseExprRest (R (v + getV t) (getR t))\nparseExprRest (R v (TOp \"-\":rest)) =\n let t = parseTerm rest\n in parseExprRest (R (v - getV t) (getR t))\nparseExprRest r = r\nparseTerm ts = parseTermRest (parseFactor ts)\nparseTermRest (R v (TOp \"*\":rest)) =\n let t = parseFactor rest\n in parseTermRest (R (v * getV t) (getR t))\nparseTermRest (R v (TOp \"/\":rest)) =\n let t = parseFactor rest\n in parseTermRest (R (v `div` getV t) (getR t))\nparseTermRest r = r\nparseFactor (TNum n:rest) = R n rest\n")
(hk-test
"calculator: 2 + 3 = 5"
(hk-prog-val
(str hk-calc-src "result = eval [TNum 2, TOp \"+\", TNum 3]\n")
"result")
5)
(hk-test
"calculator: 2 + 3 * 4 = 14 (precedence)"
(hk-prog-val
(str hk-calc-src "result = eval [TNum 2, TOp \"+\", TNum 3, TOp \"*\", TNum 4]\n")
"result")
14)
(hk-test
"calculator: 10 - 3 - 2 = 5 (left-assoc)"
(hk-prog-val
(str hk-calc-src "result = eval [TNum 10, TOp \"-\", TNum 3, TOp \"-\", TNum 2]\n")
"result")
5)
(hk-test
"calculator: 6 / 2 * 3 = 9 (left-assoc)"
(hk-prog-val
(str hk-calc-src "result = eval [TNum 6, TOp \"/\", TNum 2, TOp \"*\", TNum 3]\n")
"result")
9)
(hk-test
"calculator: single number"
(hk-prog-val
(str hk-calc-src "result = eval [TNum 42]\n")
"result")
42)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

83
lib/haskell/tests/program-collatz.sx
View File

@@ -1,83 +0,0 @@
;; collatz.hs — Collatz (3n+1) sequences.
(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-prog-val
(fn
(src name)
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
(define
hk-col-src
"collatz 1 = [1]\ncollatz n = if n `mod` 2 == 0\n then n : collatz (n `div` 2)\n else n : collatz (3 * n + 1)\ncollatzLen n = length (collatz n)\n")
(hk-test
"collatz 1 = [1]"
(hk-as-list (hk-prog-val (str hk-col-src "r = collatz 1\n") "r"))
(list 1))
(hk-test
"collatz 2 = [2,1]"
(hk-as-list (hk-prog-val (str hk-col-src "r = collatz 2\n") "r"))
(list 2 1))
(hk-test
"collatz 4 = [4,2,1]"
(hk-as-list (hk-prog-val (str hk-col-src "r = collatz 4\n") "r"))
(list 4 2 1))
(hk-test
"collatz 6 starts 6,3,10"
(hk-as-list (hk-prog-val (str hk-col-src "r = take 3 (collatz 6)\n") "r"))
(list 6 3 10))
(hk-test
"collatz 8 = [8,4,2,1]"
(hk-as-list (hk-prog-val (str hk-col-src "r = collatz 8\n") "r"))
(list 8 4 2 1))
(hk-test
"collatzLen 1 = 1"
(hk-prog-val (str hk-col-src "r = collatzLen 1\n") "r")
1)
(hk-test
"collatzLen 2 = 2"
(hk-prog-val (str hk-col-src "r = collatzLen 2\n") "r")
2)
(hk-test
"collatzLen 4 = 3"
(hk-prog-val (str hk-col-src "r = collatzLen 4\n") "r")
3)
(hk-test
"collatzLen 8 = 4"
(hk-prog-val (str hk-col-src "r = collatzLen 8\n") "r")
4)
(hk-test
"collatzLen 16 = 5"
(hk-prog-val (str hk-col-src "r = collatzLen 16\n") "r")
5)
(hk-test
"collatz last is always 1"
(hk-prog-val (str hk-col-src "r = last (collatz 27)\n") "r")
1)
(hk-test
"collatz 3 = [3,10,5,16,8,4,2,1]"
(hk-as-list (hk-prog-val (str hk-col-src "r = collatz 3\n") "r"))
(list 3 10 5 16 8 4 2 1))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

83
lib/haskell/tests/program-either.sx
View File

@@ -1,83 +0,0 @@
;; either.hs — Either ADT operations via pattern matching.
(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-either-src
"safeDiv _ 0 = Left \"divide by zero\"\nsafeDiv x y = Right (x `div` y)\n\nfromRight _ (Right x) = x\nfromRight def (Left _) = def\n\nfromLeft (Left x) _ = x\nfromLeft _ def = def\n\nisRight (Right _) = True\nisRight (Left _) = False\n\nisLeft (Left _) = True\nisLeft (Right _) = False\n\nmapRight _ (Left e) = Left e\nmapRight f (Right x) = Right (f x)\n\ndouble x = x * 2\n")
(hk-test
"safeDiv 10 2 = Right 5"
(hk-prog-val (str hk-either-src "r = safeDiv 10 2\n") "r")
(list "Right" 5))
(hk-test
"safeDiv 7 0 = Left msg"
(hk-prog-val (str hk-either-src "r = safeDiv 7 0\n") "r")
(list "Left" "divide by zero"))
(hk-test
"fromRight 0 (Right 42) = 42"
(hk-prog-val (str hk-either-src "r = fromRight 0 (Right 42)\n") "r")
42)
(hk-test
"fromRight 0 (Left msg) = 0"
(hk-prog-val (str hk-either-src "r = fromRight 0 (Left \"err\")\n") "r")
0)
(hk-test
"isRight (Right 1) = True"
(hk-prog-val (str hk-either-src "r = isRight (Right 1)\n") "r")
(list "True"))
(hk-test
"isRight (Left x) = False"
(hk-prog-val (str hk-either-src "r = isRight (Left \"x\")\n") "r")
(list "False"))
(hk-test
"isLeft (Left x) = True"
(hk-prog-val (str hk-either-src "r = isLeft (Left \"x\")\n") "r")
(list "True"))
(hk-test
"isLeft (Right x) = False"
(hk-prog-val (str hk-either-src "r = isLeft (Right 1)\n") "r")
(list "False"))
(hk-test
"mapRight double (Right 5) = Right 10"
(hk-prog-val (str hk-either-src "r = mapRight double (Right 5)\n") "r")
(list "Right" 10))
(hk-test
"mapRight double (Left e) = Left e"
(hk-prog-val (str hk-either-src "r = mapRight double (Left \"err\")\n") "r")
(list "Left" "err"))
(hk-test
"chain safeDiv results"
(hk-prog-val (str hk-either-src "r = fromRight (-1) (safeDiv 20 4)\n") "r")
5)
(hk-test
"chain safeDiv error"
(hk-prog-val (str hk-either-src "r = fromRight (-1) (safeDiv 20 0)\n") "r")
-1)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

45
lib/haskell/tests/program-fib.sx
View File

@@ -1,45 +0,0 @@
;; fib.hs — infinite Fibonacci stream classic program.
;;
;; The canonical artefact lives at lib/haskell/tests/programs/fib.hs.
;; The source is mirrored here as an SX string because the evaluator
;; doesn't have read-file in the default env. If you change one, keep
;; the other in sync — there's a runner-level cross-check against the
;; expected first-15 list.
(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-fib-source
"zipPlus (x:xs) (y:ys) = x + y : zipPlus xs ys
zipPlus _ _ = []
myFibs = 0 : 1 : zipPlus myFibs (tail myFibs)
result = take 15 myFibs
")
(hk-test
"fib.hs — first 15 Fibonacci numbers"
(hk-as-list (hk-prog-val hk-fib-source "result"))
(list 0 1 1 2 3 5 8 13 21 34 55 89 144 233 377))
;; Spot-check that the user-defined zipPlus is also reachable
(hk-test
"fib.hs — zipPlus is a multi-clause user fn"
(hk-as-list
(hk-prog-val
(str hk-fib-source "extra = zipPlus [1, 2, 3] [10, 20, 30]\n")
"extra"))
(list 11 22 33))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

84
lib/haskell/tests/program-fizzbuzz.sx
View File

@@ -1,84 +0,0 @@
;; fizzbuzz.hs — classic FizzBuzz with guards.
(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-fb-src
"fizzbuzz n\n | n `mod` 15 == 0 = \"FizzBuzz\"\n | n `mod` 3 == 0 = \"Fizz\"\n | n `mod` 5 == 0 = \"Buzz\"\n | otherwise = \"Other\"\n")
(hk-test
"fizzbuzz 1 = Other"
(hk-prog-val (str hk-fb-src "r = fizzbuzz 1\n") "r")
"Other")
(hk-test
"fizzbuzz 3 = Fizz"
(hk-prog-val (str hk-fb-src "r = fizzbuzz 3\n") "r")
"Fizz")
(hk-test
"fizzbuzz 5 = Buzz"
(hk-prog-val (str hk-fb-src "r = fizzbuzz 5\n") "r")
"Buzz")
(hk-test
"fizzbuzz 15 = FizzBuzz"
(hk-prog-val (str hk-fb-src "r = fizzbuzz 15\n") "r")
"FizzBuzz")
(hk-test
"fizzbuzz 30 = FizzBuzz"
(hk-prog-val (str hk-fb-src "r = fizzbuzz 30\n") "r")
"FizzBuzz")
(hk-test
"fizzbuzz 6 = Fizz"
(hk-prog-val (str hk-fb-src "r = fizzbuzz 6\n") "r")
"Fizz")
(hk-test
"fizzbuzz 10 = Buzz"
(hk-prog-val (str hk-fb-src "r = fizzbuzz 10\n") "r")
"Buzz")
(hk-test
"fizzbuzz 7 = Other"
(hk-prog-val (str hk-fb-src "r = fizzbuzz 7\n") "r")
"Other")
(hk-test
"fizzbuzz 9 = Fizz"
(hk-prog-val (str hk-fb-src "r = fizzbuzz 9\n") "r")
"Fizz")
(hk-test
"fizzbuzz 25 = Buzz"
(hk-prog-val (str hk-fb-src "r = fizzbuzz 25\n") "r")
"Buzz")
(hk-test
"map fizzbuzz [1..5] starts Other"
(hk-as-list
(hk-prog-val (str hk-fb-src "r = map fizzbuzz [1,2,3,4,5]\n") "r"))
(list "Other" "Other" "Fizz" "Other" "Buzz"))
(hk-test
"fizzbuzz 45 = FizzBuzz"
(hk-prog-val (str hk-fb-src "r = fizzbuzz 45\n") "r")
"FizzBuzz")
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

49
lib/haskell/tests/program-io.sx
View File

@@ -1,49 +0,0 @@
;; program-io.sx — tests for real IO monad (putStrLn, print, putStr).
(hk-test
"putStrLn single line"
(hk-run-io "main = putStrLn \"hello\"")
(list "hello"))
(hk-test
"putStrLn two lines via do"
(hk-run-io "main = do { putStrLn \"a\"; putStrLn \"b\" }")
(list "a" "b"))
(hk-test "print Int" (hk-run-io "main = print 42") (list "42"))
(hk-test "print Bool True" (hk-run-io "main = print True") (list "True"))
(hk-test
"putStr collects string"
(hk-run-io "main = putStr \"hello\"")
(list "hello"))
(hk-test
"do with let then putStrLn"
(hk-run-io "main = do\n let s = \"world\"\n putStrLn s")
(list "world"))
(hk-test
"do sequence three lines"
(hk-run-io "main = do { putStrLn \"1\"; putStrLn \"2\"; putStrLn \"3\" }")
(list "1" "2" "3"))
(hk-test
"print computed value"
(hk-run-io "main = print (6 * 7)")
(list "42"))
(hk-test
"putStrLn returns IO unit"
(hk-deep-force (hk-run "main = putStrLn \"hi\""))
(list "IO" (list "Tuple")))
(hk-test
"hk-run-io resets between calls"
(begin
(hk-run-io "main = putStrLn \"first\"")
(hk-run-io "main = putStrLn \"second\""))
(list "second"))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

84
lib/haskell/tests/program-matrix.sx
View File

@@ -1,84 +0,0 @@
;; matrix.hs — transpose and 2D list operations.
(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-mat-src
"transpose [] = []\ntranspose ([] : _) = []\ntranspose xss = map head xss : transpose (map tail xss)\n\nmatAdd xss yss = zipWith (zipWith (+)) xss yss\n\ndiagonal [] = []\ndiagonal xss = head (head xss) : diagonal (map tail (tail xss))\n\nrowSum = map sum\ncolSum xss = map sum (transpose xss)\n")
(hk-test
"transpose 2x2"
(hk-deep-force
(hk-prog-val (str hk-mat-src "r = transpose [[1,2],[3,4]]\n") "r"))
(list
":"
(list ":" 1 (list ":" 3 (list "[]")))
(list ":" (list ":" 2 (list ":" 4 (list "[]"))) (list "[]"))))
(hk-test
"transpose 1x3"
(hk-deep-force
(hk-prog-val (str hk-mat-src "r = transpose [[1,2,3]]\n") "r"))
(list
":"
(list ":" 1 (list "[]"))
(list
":"
(list ":" 2 (list "[]"))
(list ":" (list ":" 3 (list "[]")) (list "[]")))))
(hk-test
"transpose empty = []"
(hk-as-list (hk-prog-val (str hk-mat-src "r = transpose []\n") "r"))
(list))
(hk-test
"rowSum [[1,2],[3,4]] = [3,7]"
(hk-as-list (hk-prog-val (str hk-mat-src "r = rowSum [[1,2],[3,4]]\n") "r"))
(list 3 7))
(hk-test
"colSum [[1,2],[3,4]] = [4,6]"
(hk-as-list (hk-prog-val (str hk-mat-src "r = colSum [[1,2],[3,4]]\n") "r"))
(list 4 6))
(hk-test
"matAdd [[1,2],[3,4]] [[5,6],[7,8]] = [[6,8],[10,12]]"
(hk-deep-force
(hk-prog-val
(str hk-mat-src "r = matAdd [[1,2],[3,4]] [[5,6],[7,8]]\n")
"r"))
(list
":"
(list ":" 6 (list ":" 8 (list "[]")))
(list ":" (list ":" 10 (list ":" 12 (list "[]"))) (list "[]"))))
(hk-test
"diagonal [[1,2],[3,4]] = [1,4]"
(hk-as-list
(hk-prog-val (str hk-mat-src "r = diagonal [[1,2],[3,4]]\n") "r"))
(list 1 4))
(hk-test
"diagonal 3x3"
(hk-as-list
(hk-prog-val
(str hk-mat-src "r = diagonal [[1,2,3],[4,5,6],[7,8,9]]\n")
"r"))
(list 1 5 9))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

83
lib/haskell/tests/program-maybe.sx
View File

@@ -1,83 +0,0 @@
;; maybe.hs — safe operations returning Maybe values.
(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-maybe-src
"safeDiv _ 0 = Nothing\nsafeDiv x y = Just (x `div` y)\n\nsafeHead [] = Nothing\nsafeHead (x:_) = Just x\n\nfromMaybeZero Nothing = 0\nfromMaybeZero (Just x) = x\n\nmapMaybe _ Nothing = Nothing\nmapMaybe f (Just x) = Just (f x)\n\ndouble x = x * 2\n")
(hk-test
"safeDiv 10 2 = Just 5"
(hk-prog-val (str hk-maybe-src "r = safeDiv 10 2\n") "r")
(list "Just" 5))
(hk-test
"safeDiv 7 0 = Nothing"
(hk-prog-val (str hk-maybe-src "r = safeDiv 7 0\n") "r")
(list "Nothing"))
(hk-test
"safeHead [1,2,3] = Just 1"
(hk-prog-val (str hk-maybe-src "r = safeHead [1,2,3]\n") "r")
(list "Just" 1))
(hk-test
"safeHead [] = Nothing"
(hk-prog-val (str hk-maybe-src "r = safeHead []\n") "r")
(list "Nothing"))
(hk-test
"fromMaybeZero Nothing = 0"
(hk-prog-val (str hk-maybe-src "r = fromMaybeZero Nothing\n") "r")
0)
(hk-test
"fromMaybeZero (Just 42) = 42"
(hk-prog-val (str hk-maybe-src "r = fromMaybeZero (Just 42)\n") "r")
42)
(hk-test
"mapMaybe double Nothing = Nothing"
(hk-prog-val (str hk-maybe-src "r = mapMaybe double Nothing\n") "r")
(list "Nothing"))
(hk-test
"mapMaybe double (Just 5) = Just 10"
(hk-prog-val (str hk-maybe-src "r = mapMaybe double (Just 5)\n") "r")
(list "Just" 10))
(hk-test
"chain: fromMaybeZero (safeDiv 10 2) = 5"
(hk-prog-val (str hk-maybe-src "r = fromMaybeZero (safeDiv 10 2)\n") "r")
5)
(hk-test
"chain: fromMaybeZero (safeDiv 10 0) = 0"
(hk-prog-val (str hk-maybe-src "r = fromMaybeZero (safeDiv 10 0)\n") "r")
0)
(hk-test
"safeDiv 100 5 = Just 20"
(hk-prog-val (str hk-maybe-src "r = safeDiv 100 5\n") "r")
(list "Just" 20))
(hk-test
"mapMaybe double (safeDiv 6 2) = Just 6"
(hk-prog-val (str hk-maybe-src "r = mapMaybe double (safeDiv 6 2)\n") "r")
(list "Just" 6))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

38
lib/haskell/tests/program-nqueens.sx
View File

@@ -1,38 +0,0 @@
;; nqueens.hs — n-queens solver via list comprehension + where.
;;
;; Also exercises:
;; - multi-clause let/where binding (go 0 = ...; go k = ...)
;; - list comprehensions (desugared to concatMap)
;; - abs (from Prelude)
;; - [1..n] finite range
;;
;; n=8 is too slow for a 60s timeout; n=4 and n=5 run in ~17s combined.
(define
hk-prog-val
(fn
(src name)
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
(define
hk-nq-base
"queens n = go n
where
go 0 = [[]]
go k = [q:qs | qs <- go (k - 1), q <- [1..n], safe q qs]
safe q qs = check q qs 1
check q [] _ = True
check q (c:cs) d = q /= c && abs (q - c) /= d && check q cs (d + 1)
")
(hk-test
"nqueens: queens 4 has 2 solutions"
(hk-prog-val (str hk-nq-base "result = length (queens 4)\n") "result")
2)
(hk-test
"nqueens: queens 5 has 10 solutions"
(hk-prog-val (str hk-nq-base "result = length (queens 5)\n") "result")
10)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

86
lib/haskell/tests/program-palindrome.sx
View File

@@ -1,86 +0,0 @@
;; palindrome.hs — palindrome check via reverse comparison.
(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-prog-val
(fn
(src name)
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
(define hk-pal-src "isPalindrome xs = xs == reverse xs\n")
(hk-test
"isPalindrome empty"
(hk-prog-val (str hk-pal-src "r = isPalindrome []\n") "r")
(list "True"))
(hk-test
"isPalindrome single"
(hk-prog-val (str hk-pal-src "r = isPalindrome [1]\n") "r")
(list "True"))
(hk-test
"isPalindrome [1,2,1] True"
(hk-prog-val (str hk-pal-src "r = isPalindrome [1,2,1]\n") "r")
(list "True"))
(hk-test
"isPalindrome [1,2,3] False"
(hk-prog-val (str hk-pal-src "r = isPalindrome [1,2,3]\n") "r")
(list "False"))
(hk-test
"isPalindrome [1,2,2,1] True"
(hk-prog-val (str hk-pal-src "r = isPalindrome [1,2,2,1]\n") "r")
(list "True"))
(hk-test
"isPalindrome [1,2,3,4] False"
(hk-prog-val (str hk-pal-src "r = isPalindrome [1,2,3,4]\n") "r")
(list "False"))
(hk-test
"isPalindrome five odd True"
(hk-prog-val (str hk-pal-src "r = isPalindrome [1,2,3,2,1]\n") "r")
(list "True"))
(hk-test
"isPalindrome racecar True"
(hk-prog-val (str hk-pal-src "r = isPalindrome \"racecar\"\n") "r")
(list "True"))
(hk-test
"isPalindrome hello False"
(hk-prog-val (str hk-pal-src "r = isPalindrome \"hello\"\n") "r")
(list "False"))
(hk-test
"isPalindrome a True"
(hk-prog-val (str hk-pal-src "r = isPalindrome \"a\"\n") "r")
(list "True"))
(hk-test
"isPalindrome madam True"
(hk-prog-val (str hk-pal-src "r = isPalindrome \"madam\"\n") "r")
(list "True"))
(hk-test
"not-palindrome via map"
(hk-as-list
(hk-prog-val
(str hk-pal-src "r = filter isPalindrome [[1],[1,2],[1,2,1],[2,3]]\n")
"r"))
(list
(list ":" 1 (list "[]"))
(list ":" 1 (list ":" 2 (list ":" 1 (list "[]"))))))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

78
lib/haskell/tests/program-powers.sx
View File

@@ -1,78 +0,0 @@
;; powers.hs — integer exponentiation and powers-of-2 checks.
(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-pow-src
"pow _ 0 = 1\npow base n = base * pow base (n - 1)\n\npowers base k = map (pow base) [0..k]\n\nisPowerOf2 n\n | n <= 0 = False\n | n == 1 = True\n | otherwise = n `mod` 2 == 0 && isPowerOf2 (n `div` 2)\n\nlog2 1 = 0\nlog2 n = 1 + log2 (n `div` 2)\n")
(hk-test "pow 2 0 = 1" (hk-prog-val (str hk-pow-src "r = pow 2 0\n") "r") 1)
(hk-test "pow 2 1 = 2" (hk-prog-val (str hk-pow-src "r = pow 2 1\n") "r") 2)
(hk-test
"pow 2 8 = 256"
(hk-prog-val (str hk-pow-src "r = pow 2 8\n") "r")
256)
(hk-test "pow 3 4 = 81" (hk-prog-val (str hk-pow-src "r = pow 3 4\n") "r") 81)
(hk-test
"pow 10 3 = 1000"
(hk-prog-val (str hk-pow-src "r = pow 10 3\n") "r")
1000)
(hk-test
"powers 2 4 = [1,2,4,8,16]"
(hk-as-list (hk-prog-val (str hk-pow-src "r = powers 2 4\n") "r"))
(list 1 2 4 8 16))
(hk-test
"powers 3 3 = [1,3,9,27]"
(hk-as-list (hk-prog-val (str hk-pow-src "r = powers 3 3\n") "r"))
(list 1 3 9 27))
(hk-test
"isPowerOf2 1 = True"
(hk-prog-val (str hk-pow-src "r = isPowerOf2 1\n") "r")
(list "True"))
(hk-test
"isPowerOf2 8 = True"
(hk-prog-val (str hk-pow-src "r = isPowerOf2 8\n") "r")
(list "True"))
(hk-test
"isPowerOf2 6 = False"
(hk-prog-val (str hk-pow-src "r = isPowerOf2 6\n") "r")
(list "False"))
(hk-test
"isPowerOf2 0 = False"
(hk-prog-val (str hk-pow-src "r = isPowerOf2 0\n") "r")
(list "False"))
(hk-test "log2 1 = 0" (hk-prog-val (str hk-pow-src "r = log2 1\n") "r") 0)
(hk-test "log2 8 = 3" (hk-prog-val (str hk-pow-src "r = log2 8\n") "r") 3)
(hk-test
"log2 1024 = 10"
(hk-prog-val (str hk-pow-src "r = log2 1024\n") "r")
10)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

83
lib/haskell/tests/program-primes.sx
View File

@@ -1,83 +0,0 @@
;; primes.hs — primality testing via trial division with where clauses.
(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-primes-src
"isPrime n\n | n < 2 = False\n | n == 2 = True\n | otherwise = all notDiv [2..n-1]\n where notDiv d = n `mod` d /= 0\n\nprimes20 = filter isPrime [2..20]\n\nnextPrime n = head (filter isPrime [n+1..])\n\ncountPrimes lo hi = length (filter isPrime [lo..hi])\n")
(hk-test
"isPrime 2 = True"
(hk-prog-val (str hk-primes-src "r = isPrime 2\n") "r")
(list "True"))
(hk-test
"isPrime 3 = True"
(hk-prog-val (str hk-primes-src "r = isPrime 3\n") "r")
(list "True"))
(hk-test
"isPrime 4 = False"
(hk-prog-val (str hk-primes-src "r = isPrime 4\n") "r")
(list "False"))
(hk-test
"isPrime 5 = True"
(hk-prog-val (str hk-primes-src "r = isPrime 5\n") "r")
(list "True"))
(hk-test
"isPrime 1 = False"
(hk-prog-val (str hk-primes-src "r = isPrime 1\n") "r")
(list "False"))
(hk-test
"isPrime 0 = False"
(hk-prog-val (str hk-primes-src "r = isPrime 0\n") "r")
(list "False"))
(hk-test
"isPrime 7 = True"
(hk-prog-val (str hk-primes-src "r = isPrime 7\n") "r")
(list "True"))
(hk-test
"isPrime 9 = False"
(hk-prog-val (str hk-primes-src "r = isPrime 9\n") "r")
(list "False"))
(hk-test
"isPrime 11 = True"
(hk-prog-val (str hk-primes-src "r = isPrime 11\n") "r")
(list "True"))
(hk-test
"primes20 = [2,3,5,7,11,13,17,19]"
(hk-as-list (hk-prog-val (str hk-primes-src "r = primes20\n") "r"))
(list 2 3 5 7 11 13 17 19))
(hk-test
"countPrimes 1 10 = 4"
(hk-prog-val (str hk-primes-src "r = countPrimes 1 10\n") "r")
4)
(hk-test
"nextPrime 10 = 11"
(hk-prog-val (str hk-primes-src "r = nextPrime 10\n") "r")
11)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

65
lib/haskell/tests/program-quicksort.sx
View File

@@ -1,65 +0,0 @@
;; quicksort.hs — naive functional quicksort.
(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-prog-val
(fn
(src name)
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
(define
hk-qs-source
"qsort [] = []
qsort (x:xs) = qsort smaller ++ [x] ++ qsort larger
where
smaller = filter (< x) xs
larger = filter (>= x) xs
result = qsort [3, 1, 4, 1, 5, 9, 2, 6, 5, 3, 5]
")
(hk-test
"quicksort.hs — sort a list of ints"
(hk-as-list (hk-prog-val hk-qs-source "result"))
(list 1 1 2 3 3 4 5 5 5 6 9))
(hk-test
"quicksort.hs — empty list"
(hk-as-list
(hk-prog-val
(str hk-qs-source "e = qsort []\n")
"e"))
(list))
(hk-test
"quicksort.hs — singleton"
(hk-as-list
(hk-prog-val
(str hk-qs-source "s = qsort [42]\n")
"s"))
(list 42))
(hk-test
"quicksort.hs — already sorted"
(hk-as-list
(hk-prog-val
(str hk-qs-source "asc = qsort [1, 2, 3, 4, 5]\n")
"asc"))
(list 1 2 3 4 5))
(hk-test
"quicksort.hs — reverse sorted"
(hk-as-list
(hk-prog-val
(str hk-qs-source "desc = qsort [5, 4, 3, 2, 1]\n")
"desc"))
(list 1 2 3 4 5))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

83
lib/haskell/tests/program-roman.sx
View File

@@ -1,83 +0,0 @@
;; roman.hs — convert integers to Roman numerals with guards + ++.
(define
hk-prog-val
(fn
(src name)
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
(define
hk-rom-src
"toRoman 0 = \"\"\ntoRoman n\n | n >= 1000 = \"M\" ++ toRoman (n - 1000)\n | n >= 900 = \"CM\" ++ toRoman (n - 900)\n | n >= 500 = \"D\" ++ toRoman (n - 500)\n | n >= 400 = \"CD\" ++ toRoman (n - 400)\n | n >= 100 = \"C\" ++ toRoman (n - 100)\n | n >= 90 = \"XC\" ++ toRoman (n - 90)\n | n >= 50 = \"L\" ++ toRoman (n - 50)\n | n >= 40 = \"XL\" ++ toRoman (n - 40)\n | n >= 10 = \"X\" ++ toRoman (n - 10)\n | n >= 9 = \"IX\" ++ toRoman (n - 9)\n | n >= 5 = \"V\" ++ toRoman (n - 5)\n | n >= 4 = \"IV\" ++ toRoman (n - 4)\n | otherwise = \"I\" ++ toRoman (n - 1)\n")
(hk-test
"toRoman 1 = I"
(hk-prog-val (str hk-rom-src "r = toRoman 1\n") "r")
"I")
(hk-test
"toRoman 4 = IV"
(hk-prog-val (str hk-rom-src "r = toRoman 4\n") "r")
"IV")
(hk-test
"toRoman 5 = V"
(hk-prog-val (str hk-rom-src "r = toRoman 5\n") "r")
"V")
(hk-test
"toRoman 9 = IX"
(hk-prog-val (str hk-rom-src "r = toRoman 9\n") "r")
"IX")
(hk-test
"toRoman 10 = X"
(hk-prog-val (str hk-rom-src "r = toRoman 10\n") "r")
"X")
(hk-test
"toRoman 14 = XIV"
(hk-prog-val (str hk-rom-src "r = toRoman 14\n") "r")
"XIV")
(hk-test
"toRoman 40 = XL"
(hk-prog-val (str hk-rom-src "r = toRoman 40\n") "r")
"XL")
(hk-test
"toRoman 50 = L"
(hk-prog-val (str hk-rom-src "r = toRoman 50\n") "r")
"L")
(hk-test
"toRoman 90 = XC"
(hk-prog-val (str hk-rom-src "r = toRoman 90\n") "r")
"XC")
(hk-test
"toRoman 100 = C"
(hk-prog-val (str hk-rom-src "r = toRoman 100\n") "r")
"C")
(hk-test
"toRoman 400 = CD"
(hk-prog-val (str hk-rom-src "r = toRoman 400\n") "r")
"CD")
(hk-test
"toRoman 1000 = M"
(hk-prog-val (str hk-rom-src "r = toRoman 1000\n") "r")
"M")
(hk-test
"toRoman 1994 = MCMXCIV"
(hk-prog-val (str hk-rom-src "r = toRoman 1994\n") "r")
"MCMXCIV")
(hk-test
"toRoman 58 = LVIII"
(hk-prog-val (str hk-rom-src "r = toRoman 58\n") "r")
"LVIII")
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

48
lib/haskell/tests/program-sieve.sx
View File

@@ -1,48 +0,0 @@
;; sieve.hs — lazy sieve of Eratosthenes.
;;
;; The canonical artefact lives at lib/haskell/tests/programs/sieve.hs.
;; Mirrored here as an SX string because the default eval env has no
;; read-file. Uses filter + backtick `mod` + lazy [2..] — all of which
;; are now wired in via Phase 3 + the mod/div additions to hk-binop.
(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-prog-val
(fn
(src name)
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
(define
hk-sieve-source
"sieve (p:xs) = p : sieve (filter (\\x -> x `mod` p /= 0) xs)
sieve [] = []
primes = sieve [2..]
result = take 10 primes
")
(hk-test
"sieve.hs — first 10 primes"
(hk-as-list (hk-prog-val hk-sieve-source "result"))
(list 2 3 5 7 11 13 17 19 23 29))
(hk-test
"sieve.hs — 20th prime is 71"
(nth
(hk-as-list
(hk-prog-val
(str
hk-sieve-source
"result20 = take 20 primes\n")
"result20"))
19)
71)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

74
lib/haskell/tests/program-wordcount.sx
View File

@@ -1,74 +0,0 @@
;; wordcount.hs — word and line counting via string splitting.
(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-wc-src
"wordCount s = length (words s)\nlineCount s = length (lines s)\ncharCount = length\n\nlongestWord s = foldl longer \"\" (words s)\n where longer a b = if length a >= length b then a else b\n\nshortestWord s = foldl shorter (head (words s)) (words s)\n where shorter a b = if length a <= length b then a else b\n\nuniqueWords s = nub (words s)\n")
(hk-test
"wordCount single word"
(hk-prog-val (str hk-wc-src "r = wordCount \"hello\"\n") "r")
1)
(hk-test
"wordCount two words"
(hk-prog-val (str hk-wc-src "r = wordCount \"hello world\"\n") "r")
2)
(hk-test
"wordCount with extra spaces"
(hk-prog-val (str hk-wc-src "r = wordCount \" foo bar \"\n") "r")
2)
(hk-test
"wordCount empty = 0"
(hk-prog-val (str hk-wc-src "r = wordCount \"\"\n") "r")
0)
(hk-test
"lineCount one line"
(hk-prog-val (str hk-wc-src "r = lineCount \"hello\"\n") "r")
1)
(hk-test
"lineCount two lines"
(hk-prog-val (str hk-wc-src "r = lineCount \"a\\nb\"\n") "r")
2)
(hk-test
"charCount \"hello\" = 5"
(hk-prog-val (str hk-wc-src "r = charCount \"hello\"\n") "r")
5)
(hk-test
"charCount empty = 0"
(hk-prog-val (str hk-wc-src "r = charCount \"\"\n") "r")
0)
(hk-test
"longestWord picks longest"
(hk-prog-val (str hk-wc-src "r = longestWord \"a bb ccc\"\n") "r")
"ccc")
(hk-test
"uniqueWords removes duplicates"
(hk-as-list
(hk-prog-val (str hk-wc-src "r = uniqueWords \"a b a c b\"\n") "r"))
(list "a" "b" "c"))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

74
lib/haskell/tests/program-zipwith.sx
View File

@@ -1,74 +0,0 @@
;; zipwith.hs — zip, zipWith, unzip operations.
(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-zip-src
"addPair (x, y) = x + y\npairSum xs ys = map addPair (zip xs ys)\n\nscaleBy k xs = map (\\x -> x * k) xs\n\ndotProduct xs ys = sum (zipWith (*) xs ys)\n\nzipIndex xs = zip [0..length xs - 1] xs\n")
(hk-test
"zip two lists"
(hk-as-list (hk-prog-val (str hk-zip-src "r = zip [1,2,3] [4,5,6]\n") "r"))
(list (list "Tuple" 1 4) (list "Tuple" 2 5) (list "Tuple" 3 6)))
(hk-test
"zip unequal lengths — shorter wins"
(hk-as-list (hk-prog-val (str hk-zip-src "r = zip [1,2] [10,20,30]\n") "r"))
(list (list "Tuple" 1 10) (list "Tuple" 2 20)))
(hk-test
"zipWith (+)"
(hk-as-list
(hk-prog-val (str hk-zip-src "r = zipWith (+) [1,2,3] [10,20,30]\n") "r"))
(list 11 22 33))
(hk-test
"zipWith (*)"
(hk-as-list
(hk-prog-val (str hk-zip-src "r = zipWith (*) [2,3,4] [10,10,10]\n") "r"))
(list 20 30 40))
(hk-test
"dotProduct [1,2,3] [4,5,6] = 32"
(hk-prog-val (str hk-zip-src "r = dotProduct [1,2,3] [4,5,6]\n") "r")
32)
(hk-test
"dotProduct unit vectors = 0"
(hk-prog-val (str hk-zip-src "r = dotProduct [1,0] [0,1]\n") "r")
0)
(hk-test
"pairSum adds element-wise"
(hk-as-list
(hk-prog-val (str hk-zip-src "r = pairSum [1,2,3] [4,5,6]\n") "r"))
(list 5 7 9))
(hk-test
"unzip separates pairs"
(hk-prog-val (str hk-zip-src "r = unzip [(1,2),(3,4),(5,6)]\n") "r")
(list
"Tuple"
(list ":" 1 (list ":" 3 (list ":" 5 (list "[]"))))
(list ":" 2 (list ":" 4 (list ":" 6 (list "[]"))))))
(hk-test
"zip empty = []"
(hk-as-list (hk-prog-val (str hk-zip-src "r = zip [] [1,2,3]\n") "r"))
(list))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

40
lib/haskell/tests/programs/calculator.hs
View File

@@ -1,40 +0,0 @@
-- calculator.hs — recursive descent expression evaluator.
--
-- Tokens are represented as an ADT; the parser threads a [Token] list
-- through a custom Result type so pattern matching can destructure the
-- pair (value, remaining-tokens) directly inside constructor patterns.
--
-- Operator precedence: * and / bind tighter than + and -.
-- All operators are left-associative.
data Token = TNum Int | TOp String
data Result = R Int [Token]
getV (R v _) = v
getR (R _ r) = r
eval ts = getV (parseExpr ts)
parseExpr ts = parseExprRest (parseTerm ts)
parseExprRest (R v (TOp "+":rest)) =
let t = parseTerm rest
in parseExprRest (R (v + getV t) (getR t))
parseExprRest (R v (TOp "-":rest)) =
let t = parseTerm rest
in parseExprRest (R (v - getV t) (getR t))
parseExprRest r = r
parseTerm ts = parseTermRest (parseFactor ts)
parseTermRest (R v (TOp "*":rest)) =
let t = parseFactor rest
in parseTermRest (R (v * getV t) (getR t))
parseTermRest (R v (TOp "/":rest)) =
let t = parseFactor rest
in parseTermRest (R (v `div` getV t) (getR t))
parseTermRest r = r
parseFactor (TNum n:rest) = R n rest
result = eval [TNum 2, TOp "+", TNum 3, TOp "*", TNum 4]

15
lib/haskell/tests/programs/fib.hs
View File

@@ -1,15 +0,0 @@
-- fib.hs — infinite Fibonacci stream.
--
-- The classic two-line definition: `fibs` is a self-referential
-- lazy list built by zipping itself with its own tail, summing the
-- pair at each step. Without lazy `:` (cons cell with thunked head
-- and tail) this would diverge before producing any output; with
-- it, `take 15 fibs` evaluates exactly as much of the spine as
-- demanded.
zipPlus (x:xs) (y:ys) = x + y : zipPlus xs ys
zipPlus _ _ = []
myFibs = 0 : 1 : zipPlus myFibs (tail myFibs)
result = take 15 myFibs

18
lib/haskell/tests/programs/nqueens.hs
View File

@@ -1,18 +0,0 @@
-- nqueens.hs — n-queens backtracking solver.
--
-- `queens n` returns all solutions as lists of column positions,
-- one per row. Each call to `go k` extends all partial `(k-1)`-row
-- solutions by one safe queen, using a list comprehension whose guard
-- checks the new queen against all already-placed queens.
queens n = go n
where
go 0 = [[]]
go k = [q:qs | qs <- go (k - 1), q <- [1..n], safe q qs]
safe q qs = check q qs 1
check q [] _ = True
check q (c:cs) d = q /= c && abs (q - c) /= d && check q cs (d + 1)
result = length (queens 8)

12
lib/haskell/tests/programs/quicksort.hs
View File

@@ -1,12 +0,0 @@
-- quicksort.hs — naive functional quicksort.
--
-- Partition by pivot, recurse on each half, concatenate.
-- Uses right sections `(< x)` and `(>= x)` with filter.
qsort [] = []
qsort (x:xs) = qsort smaller ++ [x] ++ qsort larger
where
smaller = filter (< x) xs
larger = filter (>= x) xs
result = qsort [3, 1, 4, 1, 5, 9, 2, 6, 5, 3, 5]

13
lib/haskell/tests/programs/sieve.hs
View File

@@ -1,13 +0,0 @@
-- sieve.hs — lazy sieve of Eratosthenes.
--
-- Each recursive call to `sieve` consumes one prime `p` off the front
-- of the input stream and produces an infinite stream of composites
-- filtered out via `filter`. Because cons is lazy, only as much of
-- the stream is forced as demanded by `take`.
sieve (p:xs) = p : sieve (filter (\x -> x `mod` p /= 0) xs)
sieve [] = []
primes = sieve [2..]
result = take 10 primes

548
lib/haskell/tests/runtime.sx
View File

@@ -1,127 +1,451 @@
;; Runtime constructor-registry tests. Built-ins are pre-registered
;; when lib/haskell/runtime.sx loads; user types are registered by
;; walking a parsed+desugared AST with hk-register-program! (or the
;; `hk-load-source!` convenience).
;; lib/haskell/tests/runtime.sx — smoke-tests for lib/haskell/runtime.sx
;;
;; Uses the same hk-test framework as tests/parse.sx.
;; Loaded by test.sh after: tokenizer.sx + runtime.sx are pre-loaded.
;; ── Pre-registered built-ins ──
(hk-test "True is a con" (hk-is-con? "True") true)
(hk-test "False is a con" (hk-is-con? "False") true)
(hk-test "[] is a con" (hk-is-con? "[]") true)
(hk-test ": (cons) is a con" (hk-is-con? ":") true)
(hk-test "() is a con" (hk-is-con? "()") true)
;; ---------------------------------------------------------------------------
;; Test framework boilerplate (mirrors parse.sx)
;; ---------------------------------------------------------------------------
(hk-test "True arity 0" (hk-con-arity "True") 0)
(hk-test ": arity 2" (hk-con-arity ":") 2)
(hk-test "[] arity 0" (hk-con-arity "[]") 0)
(hk-test "True type Bool" (hk-con-type "True") "Bool")
(hk-test "False type Bool" (hk-con-type "False") "Bool")
(hk-test ": type List" (hk-con-type ":") "List")
(hk-test "() type Unit" (hk-con-type "()") "Unit")
(define hk-test-pass 0)
(define hk-test-fail 0)
(define hk-test-fails (list))
;; ── Unknown names ──
(hk-test "is-con? false for varid" (hk-is-con? "foo") false)
(hk-test "arity nil for unknown" (hk-con-arity "NotACon") nil)
(hk-test "type nil for unknown" (hk-con-type "NotACon") nil)
;; ── data MyBool = Yes | No ──
(hk-test
"register simple data"
(define
(hk-test name actual expected)
(if
(= actual expected)
(set! hk-test-pass (+ hk-test-pass 1))
(do
(hk-load-source! "data MyBool = Yes | No")
(list
(hk-con-arity "Yes")
(hk-con-arity "No")
(hk-con-type "Yes")
(hk-con-type "No")))
(list 0 0 "MyBool" "MyBool"))
(set! hk-test-fail (+ hk-test-fail 1))
(append! hk-test-fails {:actual actual :expected expected :name name}))))
;; ── data Maybe a = Nothing | Just a ──
(hk-test
"register Maybe"
(do
(hk-load-source! "data Maybe a = Nothing | Just a")
(list
(hk-con-arity "Nothing")
(hk-con-arity "Just")
(hk-con-type "Nothing")
(hk-con-type "Just")))
(list 0 1 "Maybe" "Maybe"))
;; ---------------------------------------------------------------------------
;; 1. Numeric type class helpers
;; ---------------------------------------------------------------------------
;; ── data Either a b = Left a | Right b ──
(hk-test
"register Either"
(do
(hk-load-source! "data Either a b = Left a | Right b")
(list
(hk-con-arity "Left")
(hk-con-arity "Right")
(hk-con-type "Left")
(hk-con-type "Right")))
(list 1 1 "Either" "Either"))
(hk-test "is-integer? int" (hk-is-integer? 42) true)
(hk-test "is-integer? float" (hk-is-integer? 1.5) false)
(hk-test "is-float? float" (hk-is-float? 3.14) true)
(hk-test "is-float? int" (hk-is-float? 3) false)
(hk-test "is-num? int" (hk-is-num? 10) true)
(hk-test "is-num? float" (hk-is-num? 1) true)
;; ── Recursive data ──
(hk-test
"register recursive Tree"
(do
(hk-load-source!
"data Tree a = Leaf | Node (Tree a) a (Tree a)")
(list
(hk-con-arity "Leaf")
(hk-con-arity "Node")
(hk-con-type "Leaf")
(hk-con-type "Node")))
(list 0 3 "Tree" "Tree"))
(hk-test "to-float" (hk-to-float 5) 5)
(hk-test "to-integer trunc" (hk-to-integer 3.7) 3)
;; ── newtype ──
(hk-test
"register newtype"
(do
(hk-load-source! "newtype Age = MkAge Int")
(list
(hk-con-arity "MkAge")
(hk-con-type "MkAge")))
(list 1 "Age"))
(hk-test "div pos pos" (hk-div 7 2) 3)
(hk-test "div neg pos" (hk-div -7 2) -4)
(hk-test "div pos neg" (hk-div 7 -2) -4)
(hk-test "div neg neg" (hk-div -7 -2) 3)
(hk-test "div exact" (hk-div 6 2) 3)
;; ── Multiple data decls in one program ──
(hk-test
"multiple data decls"
(do
(hk-load-source!
"data Color = Red | Green | Blue\ndata Shape = Circle | Square\nf x = x")
(list
(hk-con-type "Red")
(hk-con-type "Green")
(hk-con-type "Blue")
(hk-con-type "Circle")
(hk-con-type "Square")))
(list "Color" "Color" "Color" "Shape" "Shape"))
(hk-test "mod pos pos" (hk-mod 10 3) 1)
(hk-test "mod neg pos" (hk-mod -7 3) 2)
(hk-test "rem pos pos" (hk-rem 10 3) 1)
(hk-test "rem neg pos" (hk-rem -7 3) -1)
;; ── Inside a module header ──
(hk-test
"register from module body"
(do
(hk-load-source!
"module M where\ndata Pair a = Pair a a")
(list
(hk-con-arity "Pair")
(hk-con-type "Pair")))
(list 2 "Pair"))
(hk-test "abs pos" (hk-abs 5) 5)
(hk-test "abs neg" (hk-abs -5) 5)
(hk-test "signum pos" (hk-signum 42) 1)
(hk-test "signum neg" (hk-signum -7) -1)
(hk-test "signum zero" (hk-signum 0) 0)
;; ── Non-data decls are ignored ──
(hk-test
"program with only fun-decl leaves registry unchanged for that name"
(do
(hk-load-source! "myFunctionNotACon x = x + 1")
(hk-is-con? "myFunctionNotACon"))
false)
(hk-test "gcd" (hk-gcd 12 8) 4)
(hk-test "lcm" (hk-lcm 4 6) 12)
(hk-test "even?" (hk-even? 4) true)
(hk-test "even? odd" (hk-even? 3) false)
(hk-test "odd?" (hk-odd? 7) true)
;; ── Re-registering overwrites (last wins) ──
(hk-test
"re-registration overwrites the entry"
;; ---------------------------------------------------------------------------
;; 2. Rational numbers
;; ---------------------------------------------------------------------------
(let
((r (hk-make-rational 1 2)))
(do
(hk-load-source! "data Foo = Bar Int")
(hk-load-source! "data Foo = Bar Int Int")
(hk-con-arity "Bar"))
(hk-test "rational?" (hk-rational? r) true)
(hk-test "numerator" (hk-numerator r) 1)
(hk-test "denominator" (hk-denominator r) 2)))
(let
((r (hk-make-rational 2 4)))
(do
(hk-test "rat normalise num" (hk-numerator r) 1)
(hk-test "rat normalise den" (hk-denominator r) 2)))
(let
((sum (hk-rational-add (hk-make-rational 1 2) (hk-make-rational 1 3))))
(do
(hk-test "rat-add num" (hk-numerator sum) 5)
(hk-test "rat-add den" (hk-denominator sum) 6)))
(hk-test
"rat-to-float"
(hk-rational-to-float (hk-make-rational 1 2))
0.5)
(hk-test "rational? int" (hk-rational? 42) false)
;; ---------------------------------------------------------------------------
;; 3. Lazy evaluation (promises via SX delay)
;; ---------------------------------------------------------------------------
(let
((p (delay 42)))
(hk-test "force promise" (hk-force p) 42))
(hk-test "force non-promise" (hk-force 99) 99)
;; ---------------------------------------------------------------------------
;; 4. Char utilities — compare via hk-ord to avoid = on char type
;; ---------------------------------------------------------------------------
(hk-test "ord A" (hk-ord (integer->char 65)) 65)
(hk-test "chr 65" (hk-ord (hk-chr 65)) 65)
(hk-test "is-alpha? A" (hk-is-alpha? (integer->char 65)) true)
(hk-test "is-alpha? 0" (hk-is-alpha? (integer->char 48)) false)
(hk-test "is-digit? 5" (hk-is-digit? (integer->char 53)) true)
(hk-test "is-digit? A" (hk-is-digit? (integer->char 65)) false)
(hk-test "is-upper? A" (hk-is-upper? (integer->char 65)) true)
(hk-test "is-upper? a" (hk-is-upper? (integer->char 97)) false)
(hk-test "is-lower? a" (hk-is-lower? (integer->char 97)) true)
(hk-test "is-space? spc" (hk-is-space? (integer->char 32)) true)
(hk-test "is-space? A" (hk-is-space? (integer->char 65)) false)
(hk-test
"to-upper a"
(hk-ord (hk-to-upper (integer->char 97)))
65)
(hk-test
"to-lower A"
(hk-ord (hk-to-lower (integer->char 65)))
97)
(hk-test
"digit-to-int 0"
(hk-digit-to-int (integer->char 48))
0)
(hk-test
"digit-to-int 9"
(hk-digit-to-int (integer->char 57))
9)
(hk-test
"digit-to-int a"
(hk-digit-to-int (integer->char 97))
10)
(hk-test
"digit-to-int F"
(hk-digit-to-int (integer->char 70))
15)
(hk-test "int-to-digit 0" (hk-ord (hk-int-to-digit 0)) 48)
(hk-test "int-to-digit 10" (hk-ord (hk-int-to-digit 10)) 97)
;; ---------------------------------------------------------------------------
;; 5. Data.Set
;; ---------------------------------------------------------------------------
(hk-test "set-empty is set?" (hk-set? (hk-set-empty)) true)
(hk-test "set-null? empty" (hk-set-null? (hk-set-empty)) true)
(let
((s (hk-set-singleton 42)))
(do
(hk-test "singleton member" (hk-set-member? 42 s) true)
(hk-test "singleton size" (hk-set-size s) 1)))
(let
((s (hk-set-from-list (list 1 2 3))))
(do
(hk-test "from-list member" (hk-set-member? 2 s) true)
(hk-test "from-list absent" (hk-set-member? 9 s) false)
(hk-test "from-list size" (hk-set-size s) 3)))
;; ---------------------------------------------------------------------------
;; 6. Data.List
;; ---------------------------------------------------------------------------
(hk-test "head" (hk-head (list 1 2 3)) 1)
(hk-test
"tail length"
(len (hk-tail (list 1 2 3)))
2)
(hk-test "null? empty" (hk-null? (list)) true)
(hk-test "null? non-empty" (hk-null? (list 1)) false)
(hk-test
"length"
(hk-length (list 1 2 3))
3)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
(hk-test
"take 2"
(hk-take 2 (list 1 2 3))
(list 1 2))
(hk-test "take 0" (hk-take 0 (list 1 2)) (list))
(hk-test
"take overflow"
(hk-take 5 (list 1 2))
(list 1 2))
(hk-test
"drop 1"
(hk-drop 1 (list 1 2 3))
(list 2 3))
(hk-test
"drop 0"
(hk-drop 0 (list 1 2))
(list 1 2))
(hk-test
"take-while"
(hk-take-while
(fn (x) (< x 3))
(list 1 2 3 4))
(list 1 2))
(hk-test
"drop-while"
(hk-drop-while
(fn (x) (< x 3))
(list 1 2 3 4))
(list 3 4))
(hk-test
"zip"
(hk-zip (list 1 2) (list 3 4))
(list (list 1 3) (list 2 4)))
(hk-test
"zip uneven"
(hk-zip
(list 1 2 3)
(list 4 5))
(list (list 1 4) (list 2 5)))
(hk-test
"zip-with +"
(hk-zip-with
+
(list 1 2 3)
(list 10 20 30))
(list 11 22 33))
(hk-test
"unzip fst"
(first
(hk-unzip
(list (list 1 3) (list 2 4))))
(list 1 2))
(hk-test
"unzip snd"
(nth
(hk-unzip
(list (list 1 3) (list 2 4)))
1)
(list 3 4))
(hk-test
"elem hit"
(hk-elem 2 (list 1 2 3))
true)
(hk-test
"elem miss"
(hk-elem 9 (list 1 2 3))
false)
(hk-test
"not-elem"
(hk-not-elem 9 (list 1 2 3))
true)
(hk-test
"nub"
(hk-nub (list 1 2 1 3 2))
(list 1 2 3))
(hk-test
"sum"
(hk-sum (list 1 2 3 4))
10)
(hk-test
"product"
(hk-product (list 1 2 3 4))
24)
(hk-test
"maximum"
(hk-maximum (list 3 1 4 1 5))
5)
(hk-test
"minimum"
(hk-minimum (list 3 1 4 1 5))
1)
(hk-test
"concat"
(hk-concat
(list (list 1 2) (list 3 4)))
(list 1 2 3 4))
(hk-test
"concat-map"
(hk-concat-map
(fn (x) (list x (* x x)))
(list 1 2 3))
(list 1 1 2 4 3 9))
(hk-test
"sort"
(hk-sort (list 3 1 4 1 5))
(list 1 1 3 4 5))
(hk-test
"replicate"
(hk-replicate 3 0)
(list 0 0 0))
(hk-test "replicate 0" (hk-replicate 0 99) (list))
(hk-test
"intersperse"
(hk-intersperse 0 (list 1 2 3))
(list 1 0 2 0 3))
(hk-test
"intersperse 1"
(hk-intersperse 0 (list 1))
(list 1))
(hk-test "intersperse empty" (hk-intersperse 0 (list)) (list))
(hk-test
"span"
(hk-span
(fn (x) (< x 3))
(list 1 2 3 4))
(list (list 1 2) (list 3 4)))
(hk-test
"break"
(hk-break
(fn (x) (>= x 3))
(list 1 2 3 4))
(list (list 1 2) (list 3 4)))
(hk-test
"foldl"
(hk-foldl
(fn (a b) (- a b))
10
(list 1 2 3))
4)
(hk-test
"foldr"
(hk-foldr cons (list) (list 1 2 3))
(list 1 2 3))
(hk-test
"scanl"
(hk-scanl + 0 (list 1 2 3))
(list 0 1 3 6))
;; ---------------------------------------------------------------------------
;; 7. Maybe / Either
;; ---------------------------------------------------------------------------
(hk-test "nothing is-nothing?" (hk-is-nothing? hk-nothing) true)
(hk-test "nothing is-just?" (hk-is-just? hk-nothing) false)
(hk-test "just is-just?" (hk-is-just? (hk-just 42)) true)
(hk-test "just is-nothing?" (hk-is-nothing? (hk-just 42)) false)
(hk-test "from-just" (hk-from-just (hk-just 99)) 99)
(hk-test
"from-maybe nothing"
(hk-from-maybe 0 hk-nothing)
0)
(hk-test
"from-maybe just"
(hk-from-maybe 0 (hk-just 42))
42)
(hk-test
"maybe nothing"
(hk-maybe 0 (fn (x) (* x 2)) hk-nothing)
0)
(hk-test
"maybe just"
(hk-maybe 0 (fn (x) (* x 2)) (hk-just 5))
10)
(hk-test "left is-left?" (hk-is-left? (hk-left "e")) true)
(hk-test "right is-right?" (hk-is-right? (hk-right 42)) true)
(hk-test "from-right" (hk-from-right (hk-right 7)) 7)
(hk-test
"either left"
(hk-either (fn (x) (str "L" x)) (fn (x) (str "R" x)) (hk-left "err"))
"Lerr")
(hk-test
"either right"
(hk-either
(fn (x) (str "L" x))
(fn (x) (str "R" x))
(hk-right 42))
"R42")
;; ---------------------------------------------------------------------------
;; 8. Tuples
;; ---------------------------------------------------------------------------
(hk-test "pair" (hk-pair 1 2) (list 1 2))
(hk-test "fst" (hk-fst (hk-pair 3 4)) 3)
(hk-test "snd" (hk-snd (hk-pair 3 4)) 4)
(hk-test
"triple"
(hk-triple 1 2 3)
(list 1 2 3))
(hk-test
"fst3"
(hk-fst3 (hk-triple 7 8 9))
7)
(hk-test
"thd3"
(hk-thd3 (hk-triple 7 8 9))
9)
(hk-test "curry" ((hk-curry +) 3 4) 7)
(hk-test
"uncurry"
((hk-uncurry (fn (a b) (* a b))) (list 3 4))
12)
;; ---------------------------------------------------------------------------
;; 9. String helpers
;; ---------------------------------------------------------------------------
(hk-test "words" (hk-words "hello world") (list "hello" "world"))
(hk-test "words leading ws" (hk-words " foo bar") (list "foo" "bar"))
(hk-test "words empty" (hk-words "") (list))
(hk-test "unwords" (hk-unwords (list "a" "b" "c")) "a b c")
(hk-test "unwords single" (hk-unwords (list "x")) "x")
(hk-test "lines" (hk-lines "a\nb\nc") (list "a" "b" "c"))
(hk-test "lines single" (hk-lines "hello") (list "hello"))
(hk-test "unlines" (hk-unlines (list "a" "b")) "a\nb\n")
(hk-test "is-prefix-of yes" (hk-is-prefix-of "he" "hello") true)
(hk-test "is-prefix-of no" (hk-is-prefix-of "wo" "hello") false)
(hk-test "is-prefix-of eq" (hk-is-prefix-of "hi" "hi") true)
(hk-test "is-prefix-of empty" (hk-is-prefix-of "" "hi") true)
(hk-test "is-suffix-of yes" (hk-is-suffix-of "lo" "hello") true)
(hk-test "is-suffix-of no" (hk-is-suffix-of "he" "hello") false)
(hk-test "is-suffix-of empty" (hk-is-suffix-of "" "hi") true)
(hk-test "is-infix-of yes" (hk-is-infix-of "ell" "hello") true)
(hk-test "is-infix-of no" (hk-is-infix-of "xyz" "hello") false)
(hk-test "is-infix-of empty" (hk-is-infix-of "" "hello") true)
;; ---------------------------------------------------------------------------
;; 10. Show
;; ---------------------------------------------------------------------------
(hk-test "show nil" (hk-show nil) "Nothing")
(hk-test "show true" (hk-show true) "True")
(hk-test "show false" (hk-show false) "False")
(hk-test "show int" (hk-show 42) "42")
(hk-test "show string" (hk-show "hi") "\"hi\"")
(hk-test
"show list"
(hk-show (list 1 2 3))
"[1,2,3]")
(hk-test "show empty list" (hk-show (list)) "[]")
;; ---------------------------------------------------------------------------
;; Summary (required by test.sh — last expression is the return value)
;; ---------------------------------------------------------------------------
(list hk-test-pass hk-test-fail)

85
lib/haskell/tests/seq.sx
View File

@@ -1,85 +0,0 @@
;; seq / deepseq tests. seq is strict in its first arg (forces to
;; WHNF) and returns the second arg unchanged. deepseq additionally
;; forces the first arg to normal form.
(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))))
;; ── seq returns its second arg ──
(hk-test
"seq with primitive first arg"
(hk-eval-expr-source "seq 1 99")
99)
(hk-test
"seq forces first arg via let"
(hk-eval-expr-source "let x = 1 + 2 in seq x x")
3)
(hk-test
"seq second arg is whatever shape"
(hk-eval-expr-source "seq 0 \"hello\"")
"hello")
;; ── seq enables previously-lazy bottom to be forced ──
;; Without seq the let-binding `x = error …` is never forced;
;; with seq it must be forced because seq is strict in its first
;; argument. We don't run that error case here (it would terminate
;; the test), but we do verify the negative — that without seq,
;; the bottom bound is never demanded.
(hk-test
"lazy let — bottom never forced when unused"
(hk-eval-expr-source "let x = error \"never\" in 42")
42)
;; ── deepseq forces nested structure ──
(hk-test
"deepseq with finite list"
(hk-eval-expr-source "deepseq [1, 2, 3] 7")
7)
(hk-test
"deepseq with constructor value"
(hk-eval-expr-source "deepseq (Just 5) 11")
11)
(hk-test
"deepseq with tuple"
(hk-eval-expr-source "deepseq (1, 2) 13")
13)
;; ── seq + arithmetic ──
(hk-test
"seq used inside arithmetic doesn't poison the result"
(hk-eval-expr-source "(seq 1 5) + (seq 2 7)")
12)
;; ── seq in user code ──
(hk-test
"seq via fun-clause"
(hk-prog-val
"f x = seq x (x + 1)\nresult = f 10"
"result")
11)
(hk-test
"seq sequences list construction"
(hk-eval-list "[seq 1 10, seq 2 20]")
(list 10 20))
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

151
lib/haskell/tests/stdlib.sx
View File

@@ -1,151 +0,0 @@
;; stdlib.sx — tests for standard-library functions added in Phase 5:
;; Eq/Ord, Show, Num, Functor, Monad, Applicative, plus common Prelude.
(define
hk-t
(fn
(lbl src expected)
(hk-test lbl (hk-deep-force (hk-run src)) expected)))
(define
hk-ts
(fn
(lbl src expected)
(hk-test
lbl
(hk-deep-force (hk-run (str "main = show (" src ")")))
expected)))
;; ── Ord ──────────────────────────────────────────────────────
(hk-test
"compare lt"
(hk-deep-force (hk-run "main = compare 1 2"))
(list "LT"))
(hk-test
"compare eq"
(hk-deep-force (hk-run "main = compare 3 3"))
(list "EQ"))
(hk-test
"compare gt"
(hk-deep-force (hk-run "main = compare 9 5"))
(list "GT"))
(hk-test "min" (hk-deep-force (hk-run "main = min 3 5")) 3)
(hk-test "max" (hk-deep-force (hk-run "main = max 3 5")) 5)
;; ── Show ─────────────────────────────────────────────────────
(hk-ts "show int" "42" "42")
(hk-ts "show neg" "negate 7" "-7")
(hk-ts "show bool T" "True" "True")
(hk-ts "show bool F" "False" "False")
(hk-ts "show list" "[1,2,3]" "[1, 2, 3]")
(hk-ts "show Just" "Just 5" "(Just 5)")
(hk-ts "show Nothing" "Nothing" "Nothing")
(hk-ts "show LT" "LT" "LT")
(hk-ts "show tuple" "(1, True)" "(1, True)")
;; ── Num extras ───────────────────────────────────────────────
(hk-test "signum pos" (hk-deep-force (hk-run "main = signum 5")) 1)
(hk-test
"signum neg"
(hk-deep-force (hk-run "main = signum (negate 3)"))
(- 0 1))
(hk-test "signum zero" (hk-deep-force (hk-run "main = signum 0")) 0)
(hk-test "fromIntegral" (hk-deep-force (hk-run "main = fromIntegral 7")) 7)
;; ── foldr / foldl ────────────────────────────────────────────
(hk-test "foldr sum" (hk-deep-force (hk-run "main = foldr (+) 0 [1,2,3]")) 6)
(hk-test "foldl sum" (hk-deep-force (hk-run "main = foldl (+) 0 [1,2,3]")) 6)
(hk-test "foldl1" (hk-deep-force (hk-run "main = foldl1 (+) [1,2,3,4]")) 10)
(hk-test
"foldr cons"
(hk-deep-force (hk-run "main = show (foldr (:) [] [1,2,3])"))
"[1, 2, 3]")
;; ── List ops ─────────────────────────────────────────────────
(hk-test
"reverse"
(hk-deep-force (hk-run "main = show (reverse [1,2,3])"))
"[3, 2, 1]")
(hk-test "null []" (hk-deep-force (hk-run "main = null []")) (list "True"))
(hk-test
"null xs"
(hk-deep-force (hk-run "main = null [1]"))
(list "False"))
(hk-test
"elem yes"
(hk-deep-force (hk-run "main = elem 2 [1,2,3]"))
(list "True"))
(hk-test
"elem no"
(hk-deep-force (hk-run "main = elem 9 [1,2,3]"))
(list "False"))
(hk-test
"zip"
(hk-deep-force (hk-run "main = show (zip [1,2] [3,4])"))
"[(1, 3), (2, 4)]")
(hk-test "sum" (hk-deep-force (hk-run "main = sum [1,2,3,4,5]")) 15)
(hk-test "product" (hk-deep-force (hk-run "main = product [1,2,3,4]")) 24)
(hk-test "maximum" (hk-deep-force (hk-run "main = maximum [3,1,9,2]")) 9)
(hk-test "minimum" (hk-deep-force (hk-run "main = minimum [3,1,9,2]")) 1)
(hk-test
"any yes"
(hk-deep-force (hk-run "main = any (\\x -> x > 3) [1,2,5]"))
(list "True"))
(hk-test
"any no"
(hk-deep-force (hk-run "main = any (\\x -> x > 9) [1,2,5]"))
(list "False"))
(hk-test
"all yes"
(hk-deep-force (hk-run "main = all (\\x -> x > 0) [1,2,5]"))
(list "True"))
(hk-test
"all no"
(hk-deep-force (hk-run "main = all (\\x -> x > 3) [1,2,5]"))
(list "False"))
;; ── Higher-order ─────────────────────────────────────────────
(hk-test "flip" (hk-deep-force (hk-run "main = flip (-) 3 10")) 7)
(hk-test "const" (hk-deep-force (hk-run "main = const 42 True")) 42)
;; ── Functor ──────────────────────────────────────────────────
(hk-test
"fmap list"
(hk-deep-force (hk-run "main = show (fmap (+1) [1,2,3])"))
"[2, 3, 4]")
;; ── Monad / Applicative ──────────────────────────────────────
(hk-test "return" (hk-deep-force (hk-run "main = return 7")) (list "IO" 7))
(hk-test "pure" (hk-deep-force (hk-run "main = pure 7")) (list "IO" 7))
(hk-test
"when T"
(hk-deep-force (hk-run "main = when True (return 1)"))
(list "IO" 1))
(hk-test
"when F"
(hk-deep-force (hk-run "main = when False (return 1)"))
(list "IO" (list "()")))
(hk-test
"unless F"
(hk-deep-force (hk-run "main = unless False (return 2)"))
(list "IO" 2))
;; ── lookup / maybe / either ─────────────────────────────────
(hk-test
"lookup hit"
(hk-deep-force (hk-run "main = show (lookup 2 [(1,10),(2,20)])"))
"(Just 20)")
(hk-test
"lookup miss"
(hk-deep-force (hk-run "main = show (lookup 9 [(1,10)])"))
"Nothing")
(hk-test
"maybe def"
(hk-deep-force (hk-run "main = maybe 0 (+1) Nothing"))
0)
(hk-test
"maybe just"
(hk-deep-force (hk-run "main = maybe 0 (+1) (Just 5)"))
6)
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

Some files were not shown because too many files have changed in this diff Show More