Compare commits
1 Commits
loops/sche
...
f13e03e625
| Author | SHA1 | Date | |
|---|---|---|---|
| f13e03e625 |
@@ -1279,7 +1279,7 @@ let run_foundation_tests () =
|
||||
assert_true "sx_truthy \"\"" (Bool (sx_truthy (String "")));
|
||||
assert_eq "not truthy nil" (Bool false) (Bool (sx_truthy Nil));
|
||||
assert_eq "not truthy false" (Bool false) (Bool (sx_truthy (Bool false)));
|
||||
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None; l_call_count = 0 } in
|
||||
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None } in
|
||||
assert_true "is_lambda" (Bool (Sx_types.is_lambda (Lambda l)));
|
||||
ignore (Sx_types.set_lambda_name (Lambda l) "my-fn");
|
||||
assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l))
|
||||
|
||||
@@ -528,183 +528,6 @@ let () =
|
||||
| [Rational (_, d)] -> Integer d
|
||||
| [Integer _] -> Integer 1
|
||||
| _ -> raise (Eval_error "denominator: expected rational or integer"));
|
||||
(* printf-spec: apply one Tcl/printf format spec to one arg.
|
||||
spec is like "%5.2f", "%-10s", "%x", "%c", "%d". Always starts with %
|
||||
and ends with the conversion char. Supports d i u x X o c s f e g.
|
||||
Coerces arg to the right type per conversion. *)
|
||||
register "printf-spec" (fun args ->
|
||||
let spec_str, arg = match args with
|
||||
| [String s; v] -> (s, v)
|
||||
| _ -> raise (Eval_error "printf-spec: (spec arg)")
|
||||
in
|
||||
let n = String.length spec_str in
|
||||
if n < 2 || spec_str.[0] <> '%' then
|
||||
raise (Eval_error ("printf-spec: invalid spec " ^ spec_str));
|
||||
let type_char = spec_str.[n - 1] in
|
||||
let to_int v = match v with
|
||||
| Integer i -> i
|
||||
| Number f -> int_of_float f
|
||||
| String s ->
|
||||
let s = String.trim s in
|
||||
(try int_of_string s
|
||||
with _ ->
|
||||
try int_of_float (float_of_string s)
|
||||
with _ -> 0)
|
||||
| Bool true -> 1 | Bool false -> 0
|
||||
| _ -> 0
|
||||
in
|
||||
let to_float v = match v with
|
||||
| Number f -> f
|
||||
| Integer i -> float_of_int i
|
||||
| String s ->
|
||||
let s = String.trim s in
|
||||
(try float_of_string s with _ -> 0.0)
|
||||
| _ -> 0.0
|
||||
in
|
||||
let to_string v = match v with
|
||||
| String s -> s
|
||||
| Integer i -> string_of_int i
|
||||
| Number f -> Sx_types.format_number f
|
||||
| Bool true -> "1" | Bool false -> "0"
|
||||
| Nil -> ""
|
||||
| _ -> Sx_types.inspect v
|
||||
in
|
||||
try
|
||||
match type_char with
|
||||
| 'd' | 'i' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%d" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'u' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%u" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'x' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%x" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'X' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%X" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'o' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%o" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'c' ->
|
||||
let n_val = to_int arg in
|
||||
let body = String.sub spec_str 0 (n - 1) in
|
||||
let fmt = Scanf.format_from_string (body ^ "s") "%s" in
|
||||
String (Printf.sprintf fmt (String.make 1 (Char.chr (n_val land 0xff))))
|
||||
| 's' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%s" in
|
||||
String (Printf.sprintf fmt (to_string arg))
|
||||
| 'f' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%f" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'e' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%e" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'E' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%E" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'g' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%g" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'G' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%G" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| _ -> raise (Eval_error ("printf-spec: unsupported conversion " ^ String.make 1 type_char))
|
||||
with
|
||||
| Eval_error _ as e -> raise e
|
||||
| _ -> raise (Eval_error ("printf-spec: invalid format " ^ spec_str)));
|
||||
|
||||
(* scan-spec: apply one Tcl/scanf format spec to a string.
|
||||
Returns (consumed-count . parsed-value), or nil on failure. *)
|
||||
register "scan-spec" (fun args ->
|
||||
let spec_str, str = match args with
|
||||
| [String s; String input] -> (s, input)
|
||||
| _ -> raise (Eval_error "scan-spec: (spec input)")
|
||||
in
|
||||
let n = String.length spec_str in
|
||||
if n < 2 || spec_str.[0] <> '%' then
|
||||
raise (Eval_error ("scan-spec: invalid spec " ^ spec_str));
|
||||
let type_char = spec_str.[n - 1] in
|
||||
let len = String.length str in
|
||||
(* skip leading whitespace for non-%c/%s conversions *)
|
||||
let i = ref 0 in
|
||||
if type_char <> 'c' then
|
||||
while !i < len && (str.[!i] = ' ' || str.[!i] = '\t' || str.[!i] = '\n') do incr i done;
|
||||
let start = !i in
|
||||
try
|
||||
match type_char with
|
||||
| 'd' | 'i' ->
|
||||
let j = ref !i in
|
||||
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
|
||||
while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done;
|
||||
if !j > start && (str.[start] >= '0' && str.[start] <= '9'
|
||||
|| (!j > start + 1 && (str.[start] = '-' || str.[start] = '+'))) then
|
||||
let n_val = int_of_string (String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer n_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'x' | 'X' ->
|
||||
let j = ref !i in
|
||||
while !j < len &&
|
||||
((str.[!j] >= '0' && str.[!j] <= '9') ||
|
||||
(str.[!j] >= 'a' && str.[!j] <= 'f') ||
|
||||
(str.[!j] >= 'A' && str.[!j] <= 'F')) do incr j done;
|
||||
if !j > start then
|
||||
let n_val = int_of_string ("0x" ^ String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer n_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'o' ->
|
||||
let j = ref !i in
|
||||
while !j < len && str.[!j] >= '0' && str.[!j] <= '7' do incr j done;
|
||||
if !j > start then
|
||||
let n_val = int_of_string ("0o" ^ String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer n_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'f' | 'e' | 'g' ->
|
||||
let j = ref !i in
|
||||
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
|
||||
while !j < len && ((str.[!j] >= '0' && str.[!j] <= '9') || str.[!j] = '.') do incr j done;
|
||||
if !j < len && (str.[!j] = 'e' || str.[!j] = 'E') then begin
|
||||
incr j;
|
||||
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
|
||||
while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done
|
||||
end;
|
||||
if !j > start then
|
||||
let f_val = float_of_string (String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Number f_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 's' ->
|
||||
let j = ref !i in
|
||||
while !j < len && str.[!j] <> ' ' && str.[!j] <> '\t' && str.[!j] <> '\n' do incr j done;
|
||||
if !j > start then
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (String (String.sub str start (!j - start)));
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'c' ->
|
||||
if !i < len then
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer (Char.code str.[!i]));
|
||||
Hashtbl.replace d "consumed" (Integer (!i + 1));
|
||||
Dict d
|
||||
else Nil
|
||||
| _ -> raise (Eval_error ("scan-spec: unsupported conversion " ^ String.make 1 type_char))
|
||||
with
|
||||
| Eval_error _ as e -> raise e
|
||||
| _ -> Nil);
|
||||
|
||||
register "parse-int" (fun args ->
|
||||
let parse_leading_int s =
|
||||
let len = String.length s in
|
||||
@@ -3576,204 +3399,6 @@ let () =
|
||||
Nil
|
||||
| _ -> raise (Eval_error "channel-set-blocking!: (channel bool)"));
|
||||
|
||||
(* === Exec === run an external process; capture stdout *)
|
||||
register "exec-process" (fun args ->
|
||||
let items = match args with
|
||||
| [List xs] | [ListRef { contents = xs }] -> xs
|
||||
| _ -> raise (Eval_error "exec-process: (cmd-list)")
|
||||
in
|
||||
let argv = Array.of_list (List.map (function
|
||||
| String s -> s
|
||||
| v -> Sx_types.inspect v
|
||||
) items) in
|
||||
if Array.length argv = 0 then raise (Eval_error "exec: empty command");
|
||||
let (out_r, out_w) = Unix.pipe () in
|
||||
let (err_r, err_w) = Unix.pipe () in
|
||||
let pid =
|
||||
try Unix.create_process argv.(0) argv Unix.stdin out_w err_w
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
Unix.close out_r; Unix.close out_w;
|
||||
Unix.close err_r; Unix.close err_w;
|
||||
raise (Eval_error ("exec: " ^ Unix.error_message e))
|
||||
in
|
||||
Unix.close out_w;
|
||||
Unix.close err_w;
|
||||
let buf = Buffer.create 256 in
|
||||
let errbuf = Buffer.create 64 in
|
||||
let chunk = Bytes.create 4096 in
|
||||
let read_all fd target =
|
||||
try
|
||||
let stop = ref false in
|
||||
while not !stop do
|
||||
let n = Unix.read fd chunk 0 (Bytes.length chunk) in
|
||||
if n = 0 then stop := true
|
||||
else Buffer.add_subbytes target chunk 0 n
|
||||
done
|
||||
with _ -> ()
|
||||
in
|
||||
read_all out_r buf;
|
||||
read_all err_r errbuf;
|
||||
Unix.close out_r;
|
||||
Unix.close err_r;
|
||||
let (_, status) = Unix.waitpid [] pid in
|
||||
let exit_code = match status with
|
||||
| Unix.WEXITED n -> n
|
||||
| Unix.WSIGNALED _ | Unix.WSTOPPED _ -> 1
|
||||
in
|
||||
let s = Buffer.contents buf in
|
||||
let trimmed =
|
||||
if String.length s > 0 && s.[String.length s - 1] = '\n'
|
||||
then String.sub s 0 (String.length s - 1) else s
|
||||
in
|
||||
if exit_code <> 0 then
|
||||
raise (Eval_error ("exec: child exited " ^ string_of_int exit_code
|
||||
^ (if Buffer.length errbuf > 0
|
||||
then ": " ^ Buffer.contents errbuf
|
||||
else "")))
|
||||
else String trimmed);
|
||||
|
||||
(* exec-pipeline: takes a list of words like Tcl `exec` would receive.
|
||||
Recognizes `|` as a stage separator and `> file`, `>> file`, `< file`,
|
||||
`2>@1` (stderr→stdout), `2> file`. Returns trimmed stdout of the last
|
||||
stage; raises Eval_error if the last stage exits non-zero. *)
|
||||
register "exec-pipeline" (fun args ->
|
||||
let items = match args with
|
||||
| [List xs] | [ListRef { contents = xs }] -> xs
|
||||
| _ -> raise (Eval_error "exec-pipeline: (word-list)")
|
||||
in
|
||||
let words = List.map (function
|
||||
| String s -> s
|
||||
| v -> Sx_types.inspect v
|
||||
) items in
|
||||
if words = [] then raise (Eval_error "exec: empty command");
|
||||
let split_stages ws =
|
||||
let rec loop acc cur = function
|
||||
| [] -> List.rev (List.rev cur :: acc)
|
||||
| "|" :: rest -> loop (List.rev cur :: acc) [] rest
|
||||
| w :: rest -> loop acc (w :: cur) rest
|
||||
in
|
||||
loop [] [] ws
|
||||
in
|
||||
let extract_redirs ws =
|
||||
let in_path = ref None in
|
||||
let out_path = ref None in
|
||||
let out_append = ref false in
|
||||
let err_path = ref None in
|
||||
let merge_err = ref false in
|
||||
let cleaned = ref [] in
|
||||
let rec loop = function
|
||||
| [] -> ()
|
||||
| "<" :: p :: rest -> in_path := Some p; loop rest
|
||||
| ">" :: p :: rest -> out_path := Some p; out_append := false; loop rest
|
||||
| ">>" :: p :: rest -> out_path := Some p; out_append := true; loop rest
|
||||
| "2>@1" :: rest -> merge_err := true; loop rest
|
||||
| "2>" :: p :: rest -> err_path := Some p; loop rest
|
||||
| w :: rest -> cleaned := w :: !cleaned; loop rest
|
||||
in
|
||||
loop ws;
|
||||
(List.rev !cleaned, !in_path, !out_path, !out_append, !err_path, !merge_err)
|
||||
in
|
||||
let stages = List.map extract_redirs (split_stages words) in
|
||||
if stages = [] then raise (Eval_error "exec: no stages");
|
||||
let n = List.length stages in
|
||||
let pipes = Array.init (max 0 (n - 1)) (fun _ -> Unix.pipe ()) in
|
||||
let (final_r, final_w) = Unix.pipe () in
|
||||
let (errstash_r, errstash_w) = Unix.pipe () in
|
||||
let pids = ref [] in
|
||||
let close_safe fd = try Unix.close fd with _ -> () in
|
||||
let open_in_redir = function
|
||||
| None -> Unix.stdin
|
||||
| Some path ->
|
||||
(try Unix.openfile path [Unix.O_RDONLY] 0o644
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("exec: open <" ^ path ^ ": " ^ Unix.error_message e)))
|
||||
in
|
||||
let open_out_redir path append =
|
||||
let flags = Unix.O_WRONLY :: Unix.O_CREAT :: (if append then [Unix.O_APPEND] else [Unix.O_TRUNC]) in
|
||||
try Unix.openfile path flags 0o644
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("exec: open >" ^ path ^ ": " ^ Unix.error_message e))
|
||||
in
|
||||
let stages_arr = Array.of_list stages in
|
||||
(try
|
||||
Array.iteri (fun i (cleaned, ip, op, app, ep, merge) ->
|
||||
if cleaned = [] then raise (Eval_error "exec: empty stage in pipeline");
|
||||
let argv = Array.of_list cleaned in
|
||||
let stdin_fd =
|
||||
if i = 0 then open_in_redir ip
|
||||
else fst pipes.(i - 1)
|
||||
in
|
||||
let stdout_fd =
|
||||
if i = n - 1 then
|
||||
(match op with
|
||||
| None -> final_w
|
||||
| Some path -> open_out_redir path app)
|
||||
else snd pipes.(i)
|
||||
in
|
||||
let stderr_fd =
|
||||
if merge then stdout_fd
|
||||
else (match ep with
|
||||
| None -> if i = n - 1 then errstash_w else Unix.stderr
|
||||
| Some path -> open_out_redir path false)
|
||||
in
|
||||
let pid =
|
||||
try Unix.create_process argv.(0) argv stdin_fd stdout_fd stderr_fd
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("exec: " ^ argv.(0) ^ ": " ^ Unix.error_message e))
|
||||
in
|
||||
pids := pid :: !pids;
|
||||
if i > 0 then close_safe (fst pipes.(i - 1));
|
||||
if i < n - 1 then close_safe (snd pipes.(i));
|
||||
if i = 0 && ip <> None then close_safe stdin_fd;
|
||||
if i = n - 1 && op <> None then close_safe stdout_fd;
|
||||
if not merge && ep <> None then close_safe stderr_fd
|
||||
) stages_arr
|
||||
with e ->
|
||||
close_safe final_r; close_safe final_w;
|
||||
close_safe errstash_r; close_safe errstash_w;
|
||||
Array.iter (fun (a,b) -> close_safe a; close_safe b) pipes;
|
||||
raise e);
|
||||
close_safe final_w;
|
||||
close_safe errstash_w;
|
||||
let buf = Buffer.create 256 in
|
||||
let errbuf = Buffer.create 64 in
|
||||
let chunk = Bytes.create 4096 in
|
||||
let read_all fd target =
|
||||
try
|
||||
let stop = ref false in
|
||||
while not !stop do
|
||||
let r = Unix.read fd chunk 0 (Bytes.length chunk) in
|
||||
if r = 0 then stop := true
|
||||
else Buffer.add_subbytes target chunk 0 r
|
||||
done
|
||||
with _ -> ()
|
||||
in
|
||||
read_all final_r buf;
|
||||
read_all errstash_r errbuf;
|
||||
close_safe final_r;
|
||||
close_safe errstash_r;
|
||||
let exit_codes = List.rev_map (fun pid ->
|
||||
let (_, st) = Unix.waitpid [] pid in
|
||||
match st with
|
||||
| Unix.WEXITED c -> c
|
||||
| _ -> 1
|
||||
) !pids in
|
||||
let final_code = match List.rev exit_codes with
|
||||
| [] -> 0
|
||||
| last :: _ -> last
|
||||
in
|
||||
let s = Buffer.contents buf in
|
||||
let trimmed =
|
||||
if String.length s > 0 && s.[String.length s - 1] = '\n'
|
||||
then String.sub s 0 (String.length s - 1) else s
|
||||
in
|
||||
if final_code <> 0 then
|
||||
raise (Eval_error ("exec: pipeline last stage exited " ^ string_of_int final_code
|
||||
^ (if Buffer.length errbuf > 0
|
||||
then ": " ^ Buffer.contents errbuf
|
||||
else "")))
|
||||
else String trimmed);
|
||||
|
||||
(* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *)
|
||||
let resolve_inet_addr host =
|
||||
if host = "" || host = "0.0.0.0" then Unix.inet_addr_any
|
||||
@@ -4109,25 +3734,4 @@ let () =
|
||||
| k :: v :: rest -> ignore (env_bind child (value_to_string k) v); add_bindings rest
|
||||
| [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in
|
||||
add_bindings pairs;
|
||||
Env child);
|
||||
|
||||
(* JIT cache control & observability — backed by refs in sx_types.ml to
|
||||
avoid creating a sx_primitives → sx_vm dependency cycle. sx_vm reads
|
||||
these refs to decide when to JIT. *)
|
||||
register "jit-stats" (fun _args ->
|
||||
let d = Hashtbl.create 8 in
|
||||
Hashtbl.replace d "threshold" (Number (float_of_int !Sx_types.jit_threshold));
|
||||
Hashtbl.replace d "compiled" (Number (float_of_int !Sx_types.jit_compiled_count));
|
||||
Hashtbl.replace d "compile-failed" (Number (float_of_int !Sx_types.jit_skipped_count));
|
||||
Hashtbl.replace d "below-threshold" (Number (float_of_int !Sx_types.jit_threshold_skipped_count));
|
||||
Dict d);
|
||||
register "jit-set-threshold!" (fun args ->
|
||||
match args with
|
||||
| [Number n] -> Sx_types.jit_threshold := int_of_float n; Nil
|
||||
| [Integer n] -> Sx_types.jit_threshold := n; Nil
|
||||
| _ -> raise (Eval_error "jit-set-threshold!: (n) where n is integer"));
|
||||
register "jit-reset-counters!" (fun _args ->
|
||||
Sx_types.jit_compiled_count := 0;
|
||||
Sx_types.jit_skipped_count := 0;
|
||||
Sx_types.jit_threshold_skipped_count := 0;
|
||||
Nil)
|
||||
Env child)
|
||||
|
||||
@@ -138,7 +138,6 @@ and lambda = {
|
||||
l_closure : env;
|
||||
mutable l_name : string option;
|
||||
mutable l_compiled : vm_closure option; (** Lazy JIT cache *)
|
||||
mutable l_call_count : int; (** Tiered-compilation counter — JIT after threshold calls *)
|
||||
}
|
||||
|
||||
and component = {
|
||||
@@ -450,20 +449,7 @@ let make_lambda params body closure =
|
||||
| List items -> List.map value_to_string items
|
||||
| _ -> value_to_string_list params
|
||||
in
|
||||
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None; l_call_count = 0 }
|
||||
|
||||
(** {1 JIT cache control}
|
||||
|
||||
Tiered compilation: only JIT a lambda after it's been called [jit_threshold]
|
||||
times. This filters out one-shot lambdas (test harness, dynamic eval, REPLs)
|
||||
so they never enter the JIT cache. Counters are exposed to SX as [(jit-stats)].
|
||||
|
||||
These live here (in sx_types) rather than sx_vm so [sx_primitives] can read
|
||||
them without creating a sx_primitives → sx_vm dependency cycle. *)
|
||||
let jit_threshold = ref 4
|
||||
let jit_compiled_count = ref 0
|
||||
let jit_skipped_count = ref 0
|
||||
let jit_threshold_skipped_count = ref 0
|
||||
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None }
|
||||
|
||||
let make_component name params has_children body closure affinity =
|
||||
let n = value_to_string name in
|
||||
|
||||
@@ -57,9 +57,6 @@ let () = Sx_types._convert_vm_suspension := (fun exn ->
|
||||
let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
|
||||
ref (fun _ _ -> None)
|
||||
|
||||
(* JIT threshold and counters live in Sx_types so primitives can read them
|
||||
without creating a sx_primitives → sx_vm dependency cycle. *)
|
||||
|
||||
(** Sentinel closure indicating JIT compilation was attempted and failed.
|
||||
Prevents retrying compilation on every call. *)
|
||||
let jit_failed_sentinel = {
|
||||
@@ -367,21 +364,13 @@ and vm_call vm f args =
|
||||
| None ->
|
||||
if l.l_name <> None
|
||||
then begin
|
||||
l.l_call_count <- l.l_call_count + 1;
|
||||
if l.l_call_count >= !Sx_types.jit_threshold then begin
|
||||
l.l_compiled <- Some jit_failed_sentinel;
|
||||
match !jit_compile_ref l vm.globals with
|
||||
| Some cl ->
|
||||
incr Sx_types.jit_compiled_count;
|
||||
l.l_compiled <- Some cl;
|
||||
push_closure_frame vm cl args
|
||||
| None ->
|
||||
incr Sx_types.jit_skipped_count;
|
||||
push vm (cek_call_or_suspend vm f (List args))
|
||||
end else begin
|
||||
incr Sx_types.jit_threshold_skipped_count;
|
||||
l.l_compiled <- Some jit_failed_sentinel;
|
||||
match !jit_compile_ref l vm.globals with
|
||||
| Some cl ->
|
||||
l.l_compiled <- Some cl;
|
||||
push_closure_frame vm cl args
|
||||
| None ->
|
||||
push vm (cek_call_or_suspend vm f (List args))
|
||||
end
|
||||
end
|
||||
else
|
||||
push vm (cek_call_or_suspend vm f (List args)))
|
||||
|
||||
@@ -25,9 +25,8 @@
|
||||
; Glyph classification sets
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
apl-parse-op-glyphs
|
||||
(list "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@"))
|
||||
(define apl-parse-op-glyphs
|
||||
(list "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@"))
|
||||
|
||||
(define
|
||||
apl-parse-fn-glyphs
|
||||
@@ -83,48 +82,22 @@
|
||||
"⍎"
|
||||
"⍕"))
|
||||
|
||||
(define apl-quad-fn-names (list "⎕FMT" "⎕←"))
|
||||
(define apl-quad-fn-names (list "⎕FMT"))
|
||||
|
||||
(define apl-known-fn-names (list))
|
||||
(define
|
||||
apl-parse-op-glyph?
|
||||
(fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs)))
|
||||
|
||||
; ============================================================
|
||||
; Token accessors
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
apl-collect-fn-bindings
|
||||
(fn
|
||||
(stmt-groups)
|
||||
(set! apl-known-fn-names (list))
|
||||
(for-each
|
||||
(fn
|
||||
(toks)
|
||||
(when
|
||||
(and
|
||||
(>= (len toks) 3)
|
||||
(= (tok-type (nth toks 0)) :name)
|
||||
(= (tok-type (nth toks 1)) :assign)
|
||||
(= (tok-type (nth toks 2)) :lbrace))
|
||||
(set!
|
||||
apl-known-fn-names
|
||||
(cons (tok-val (nth toks 0)) apl-known-fn-names))))
|
||||
stmt-groups)))
|
||||
|
||||
(define
|
||||
apl-parse-op-glyph?
|
||||
(fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs)))
|
||||
|
||||
(define
|
||||
apl-parse-fn-glyph?
|
||||
(fn (v) (some (fn (g) (= g v)) apl-parse-fn-glyphs)))
|
||||
|
||||
(define tok-type (fn (tok) (get tok :type)))
|
||||
|
||||
; ============================================================
|
||||
; Collect trailing operators starting at index i
|
||||
; Returns {:ops (op ...) :end new-i}
|
||||
; ============================================================
|
||||
|
||||
(define tok-val (fn (tok) (get tok :value)))
|
||||
|
||||
(define
|
||||
@@ -134,8 +107,8 @@
|
||||
(and (= (tok-type tok) :glyph) (apl-parse-op-glyph? (tok-val tok)))))
|
||||
|
||||
; ============================================================
|
||||
; Build a derived-fn node by chaining operators left-to-right
|
||||
; (+/¨ → (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+"))))
|
||||
; Collect trailing operators starting at index i
|
||||
; Returns {:ops (op ...) :end new-i}
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
@@ -146,17 +119,15 @@
|
||||
(and (= (tok-type tok) :glyph) (apl-parse-fn-glyph? (tok-val tok)))
|
||||
(and
|
||||
(= (tok-type tok) :name)
|
||||
(or
|
||||
(some (fn (q) (= q (tok-val tok))) apl-quad-fn-names)
|
||||
(some (fn (q) (= q (tok-val tok))) apl-known-fn-names))))))
|
||||
|
||||
; ============================================================
|
||||
; Find matching close bracket/paren/brace
|
||||
; Returns the index of the matching close token
|
||||
; ============================================================
|
||||
(some (fn (q) (= q (tok-val tok))) apl-quad-fn-names)))))
|
||||
|
||||
(define collect-ops (fn (tokens i) (collect-ops-loop tokens i (list))))
|
||||
|
||||
; ============================================================
|
||||
; Build a derived-fn node by chaining operators left-to-right
|
||||
; (+/¨ → (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+"))))
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
collect-ops-loop
|
||||
(fn
|
||||
@@ -172,10 +143,8 @@
|
||||
{:end i :ops acc})))))
|
||||
|
||||
; ============================================================
|
||||
; Segment collection: scan tokens left-to-right, building
|
||||
; a list of {:kind "val"/"fn" :node ast} segments.
|
||||
; Operators following function glyphs are merged into
|
||||
; derived-fn nodes during this pass.
|
||||
; Find matching close bracket/paren/brace
|
||||
; Returns the index of the matching close token
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
@@ -194,20 +163,12 @@
|
||||
(find-matching-close-loop tokens start open-type close-type 1)))
|
||||
|
||||
; ============================================================
|
||||
; Build tree from segment list
|
||||
;
|
||||
; The segments are in left-to-right order.
|
||||
; APL evaluates right-to-left, so the LEFTMOST function is
|
||||
; the outermost (last-evaluated) node.
|
||||
;
|
||||
; Patterns:
|
||||
; [val] → val node
|
||||
; [fn val ...] → (:monad fn (build-tree rest))
|
||||
; [val fn val ...] → (:dyad fn val (build-tree rest))
|
||||
; [val val ...] → (:vec val1 val2 ...) — strand
|
||||
; Segment collection: scan tokens left-to-right, building
|
||||
; a list of {:kind "val"/"fn" :node ast} segments.
|
||||
; Operators following function glyphs are merged into
|
||||
; derived-fn nodes during this pass.
|
||||
; ============================================================
|
||||
|
||||
; Find the index of the first function segment (returns -1 if none)
|
||||
(define
|
||||
find-matching-close-loop
|
||||
(fn
|
||||
@@ -247,9 +208,21 @@
|
||||
collect-segments
|
||||
(fn (tokens) (collect-segments-loop tokens 0 (list))))
|
||||
|
||||
; Build an array node from 0..n value segments
|
||||
; If n=1 → return that segment's node
|
||||
; If n>1 → return (:vec node1 node2 ...)
|
||||
; ============================================================
|
||||
; Build tree from segment list
|
||||
;
|
||||
; The segments are in left-to-right order.
|
||||
; APL evaluates right-to-left, so the LEFTMOST function is
|
||||
; the outermost (last-evaluated) node.
|
||||
;
|
||||
; Patterns:
|
||||
; [val] → val node
|
||||
; [fn val ...] → (:monad fn (build-tree rest))
|
||||
; [val fn val ...] → (:dyad fn val (build-tree rest))
|
||||
; [val val ...] → (:vec val1 val2 ...) — strand
|
||||
; ============================================================
|
||||
|
||||
; Find the index of the first function segment (returns -1 if none)
|
||||
(define
|
||||
collect-segments-loop
|
||||
(fn
|
||||
@@ -269,47 +242,24 @@
|
||||
((= tt :str)
|
||||
(collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)})))
|
||||
((= tt :name)
|
||||
(cond
|
||||
((and (< (+ i 1) (len tokens)) (= (tok-type (nth tokens (+ i 1))) :assign))
|
||||
(if
|
||||
(some (fn (q) (= q tv)) apl-quad-fn-names)
|
||||
(let
|
||||
((op-result (collect-ops tokens (+ i 1))))
|
||||
(let
|
||||
((rhs-tokens (slice tokens (+ i 2) (len tokens))))
|
||||
((ops (get op-result :ops)) (ni (get op-result :end)))
|
||||
(let
|
||||
((rhs-expr (parse-apl-expr rhs-tokens)))
|
||||
((fn-node (build-derived-fn (list :fn-glyph tv) ops)))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(len tokens)
|
||||
(append acc {:kind "val" :node (list :assign-expr tv rhs-expr)})))))
|
||||
((some (fn (q) (= q tv)) apl-quad-fn-names)
|
||||
(let
|
||||
((op-result (collect-ops tokens (+ i 1))))
|
||||
(let
|
||||
((ops (get op-result :ops))
|
||||
(ni (get op-result :end)))
|
||||
(let
|
||||
((fn-node (build-derived-fn (list :fn-glyph tv) ops)))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
ni
|
||||
(append acc {:kind "fn" :node fn-node}))))))
|
||||
((some (fn (q) (= q tv)) apl-known-fn-names)
|
||||
(let
|
||||
((op-result (collect-ops tokens (+ i 1))))
|
||||
(let
|
||||
((ops (get op-result :ops))
|
||||
(ni (get op-result :end)))
|
||||
(let
|
||||
((fn-node (build-derived-fn (list :fn-name tv) ops)))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
ni
|
||||
(append acc {:kind "fn" :node fn-node}))))))
|
||||
(else
|
||||
(let
|
||||
((br (maybe-bracket (list :name tv) tokens (+ i 1))))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(nth br 1)
|
||||
(append acc {:kind "val" :node (nth br 0)}))))))
|
||||
ni
|
||||
(append acc {:kind "fn" :node fn-node})))))
|
||||
(let
|
||||
((br (maybe-bracket (list :name tv) tokens (+ i 1))))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(nth br 1)
|
||||
(append acc {:kind "val" :node (nth br 0)})))))
|
||||
((= tt :lparen)
|
||||
(let
|
||||
((end (find-matching-close tokens (+ i 1) :lparen :rparen)))
|
||||
@@ -317,23 +267,11 @@
|
||||
((inner-tokens (slice tokens (+ i 1) end))
|
||||
(after (+ end 1)))
|
||||
(let
|
||||
((inner-segs (collect-segments inner-tokens)))
|
||||
(if
|
||||
(and
|
||||
(>= (len inner-segs) 2)
|
||||
(every? (fn (s) (= (get s :kind) "fn")) inner-segs))
|
||||
(let
|
||||
((train-node (cons :train (map (fn (s) (get s :node)) inner-segs))))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
after
|
||||
(append acc {:kind "fn" :node train-node})))
|
||||
(let
|
||||
((br (maybe-bracket (parse-apl-expr inner-tokens) tokens after)))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(nth br 1)
|
||||
(append acc {:kind "val" :node (nth br 0)}))))))))
|
||||
((br (maybe-bracket (parse-apl-expr inner-tokens) tokens after)))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(nth br 1)
|
||||
(append acc {:kind "val" :node (nth br 0)}))))))
|
||||
((= tt :lbrace)
|
||||
(let
|
||||
((end (find-matching-close tokens (+ i 1) :lbrace :rbrace)))
|
||||
@@ -344,22 +282,10 @@
|
||||
((= tt :glyph)
|
||||
(cond
|
||||
((or (= tv "⍺") (= tv "⍵"))
|
||||
(if
|
||||
(and
|
||||
(< (+ i 1) (len tokens))
|
||||
(= (tok-type (nth tokens (+ i 1))) :assign))
|
||||
(let
|
||||
((rhs-tokens (slice tokens (+ i 2) (len tokens))))
|
||||
(let
|
||||
((rhs-expr (parse-apl-expr rhs-tokens)))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(len tokens)
|
||||
(append acc {:kind "val" :node (list :assign-expr tv rhs-expr)}))))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(+ i 1)
|
||||
(append acc {:kind "val" :node (list :name tv)}))))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(+ i 1)
|
||||
(append acc {:kind "val" :node (list :name tv)})))
|
||||
((= tv "∇")
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
@@ -414,24 +340,15 @@
|
||||
ni
|
||||
(append acc {:kind "fn" :node fn-node})))))))
|
||||
((apl-parse-op-glyph? tv)
|
||||
(if
|
||||
(or (= tv "/") (= tv "⌿") (= tv "\\") (= tv "⍀"))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(+ i 1)
|
||||
(append acc {:kind "fn" :node (list :fn-glyph tv)}))
|
||||
(collect-segments-loop tokens (+ i 1) acc)))
|
||||
(collect-segments-loop tokens (+ i 1) acc))
|
||||
(true (collect-segments-loop tokens (+ i 1) acc))))
|
||||
(true (collect-segments-loop tokens (+ i 1) acc))))))))
|
||||
|
||||
(define find-first-fn (fn (segs) (find-first-fn-loop segs 0)))
|
||||
|
||||
|
||||
; ============================================================
|
||||
; Split token list on statement separators (diamond / newline)
|
||||
; Only splits at depth 0 (ignores separators inside { } or ( ) )
|
||||
; ============================================================
|
||||
|
||||
; Build an array node from 0..n value segments
|
||||
; If n=1 → return that segment's node
|
||||
; If n>1 → return (:vec node1 node2 ...)
|
||||
(define
|
||||
find-first-fn-loop
|
||||
(fn
|
||||
@@ -453,9 +370,10 @@
|
||||
(get (first segs) :node)
|
||||
(cons :vec (map (fn (s) (get s :node)) segs)))))
|
||||
|
||||
|
||||
; ============================================================
|
||||
; Parse a dfn body (tokens between { and })
|
||||
; Handles guard expressions: cond : expr
|
||||
; Split token list on statement separators (diamond / newline)
|
||||
; Only splits at depth 0 (ignores separators inside { } or ( ) )
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
@@ -490,6 +408,11 @@
|
||||
split-statements
|
||||
(fn (tokens) (split-statements-loop tokens (list) (list) 0)))
|
||||
|
||||
; ============================================================
|
||||
; Parse a dfn body (tokens between { and })
|
||||
; Handles guard expressions: cond : expr
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
split-statements-loop
|
||||
(fn
|
||||
@@ -544,10 +467,6 @@
|
||||
((stmt-groups (split-statements tokens)))
|
||||
(let ((stmts (map parse-dfn-stmt stmt-groups))) (cons :dfn stmts)))))
|
||||
|
||||
; ============================================================
|
||||
; Parse a single statement (assignment or expression)
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
parse-dfn-stmt
|
||||
(fn
|
||||
@@ -564,17 +483,12 @@
|
||||
(parse-apl-expr body-tokens)))
|
||||
(parse-stmt tokens)))))
|
||||
|
||||
; ============================================================
|
||||
; Parse an expression from a flat token list
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
find-top-level-colon
|
||||
(fn (tokens i) (find-top-level-colon-loop tokens i 0)))
|
||||
|
||||
; ============================================================
|
||||
; Main entry point
|
||||
; parse-apl: string → AST
|
||||
; Parse a single statement (assignment or expression)
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
@@ -594,6 +508,10 @@
|
||||
((and (= tt :colon) (= depth 0)) i)
|
||||
(true (find-top-level-colon-loop tokens (+ i 1) depth)))))))
|
||||
|
||||
; ============================================================
|
||||
; Parse an expression from a flat token list
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
parse-stmt
|
||||
(fn
|
||||
@@ -608,6 +526,11 @@
|
||||
(parse-apl-expr (slice tokens 2)))
|
||||
(parse-apl-expr tokens))))
|
||||
|
||||
; ============================================================
|
||||
; Main entry point
|
||||
; parse-apl: string → AST
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
parse-apl-expr
|
||||
(fn
|
||||
@@ -624,52 +547,13 @@
|
||||
((tokens (apl-tokenize src)))
|
||||
(let
|
||||
((stmt-groups (split-statements tokens)))
|
||||
(begin
|
||||
(apl-collect-fn-bindings stmt-groups)
|
||||
(if
|
||||
(= (len stmt-groups) 0)
|
||||
nil
|
||||
(if
|
||||
(= (len stmt-groups) 0)
|
||||
nil
|
||||
(if
|
||||
(= (len stmt-groups) 1)
|
||||
(parse-stmt (first stmt-groups))
|
||||
(cons :program (map parse-stmt stmt-groups)))))))))
|
||||
|
||||
(define
|
||||
split-bracket-loop
|
||||
(fn
|
||||
(tokens current acc depth)
|
||||
(if
|
||||
(= (len tokens) 0)
|
||||
(append acc (list current))
|
||||
(let
|
||||
((tok (first tokens)) (more (rest tokens)))
|
||||
(let
|
||||
((tt (tok-type tok)))
|
||||
(cond
|
||||
((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket))
|
||||
(split-bracket-loop
|
||||
more
|
||||
(append current (list tok))
|
||||
acc
|
||||
(+ depth 1)))
|
||||
((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket))
|
||||
(split-bracket-loop
|
||||
more
|
||||
(append current (list tok))
|
||||
acc
|
||||
(- depth 1)))
|
||||
((and (= tt :semi) (= depth 0))
|
||||
(split-bracket-loop
|
||||
more
|
||||
(list)
|
||||
(append acc (list current))
|
||||
depth))
|
||||
(else
|
||||
(split-bracket-loop more (append current (list tok)) acc depth))))))))
|
||||
|
||||
(define
|
||||
split-bracket-content
|
||||
(fn (tokens) (split-bracket-loop tokens (list) (list) 0)))
|
||||
(= (len stmt-groups) 1)
|
||||
(parse-stmt (first stmt-groups))
|
||||
(cons :program (map parse-stmt stmt-groups))))))))
|
||||
|
||||
(define
|
||||
maybe-bracket
|
||||
@@ -685,17 +569,8 @@
|
||||
((inner-tokens (slice tokens (+ after 1) end))
|
||||
(next-after (+ end 1)))
|
||||
(let
|
||||
((sections (split-bracket-content inner-tokens)))
|
||||
(if
|
||||
(= (len sections) 1)
|
||||
(let
|
||||
((idx-expr (parse-apl-expr inner-tokens)))
|
||||
(let
|
||||
((indexed (list :dyad (list :fn-glyph "⌷") idx-expr val-node)))
|
||||
(maybe-bracket indexed tokens next-after)))
|
||||
(let
|
||||
((axis-exprs (map (fn (toks) (if (= (len toks) 0) :all (parse-apl-expr toks))) sections)))
|
||||
(let
|
||||
((indexed (cons :bracket (cons val-node axis-exprs))))
|
||||
(maybe-bracket indexed tokens next-after)))))))
|
||||
((idx-expr (parse-apl-expr inner-tokens)))
|
||||
(let
|
||||
((indexed (list :dyad (list :fn-glyph "⌷") idx-expr val-node)))
|
||||
(maybe-bracket indexed tokens next-after)))))
|
||||
(list val-node after))))
|
||||
|
||||
@@ -808,25 +808,6 @@
|
||||
((picked (map (fn (i) (nth arr-ravel i)) kept)))
|
||||
(make-array (list (len picked)) picked))))))
|
||||
|
||||
(define
|
||||
apl-compress-first
|
||||
(fn
|
||||
(mask arr)
|
||||
(let
|
||||
((mask-ravel (get mask :ravel))
|
||||
(shape (get arr :shape))
|
||||
(ravel (get arr :ravel)))
|
||||
(if
|
||||
(< (len shape) 2)
|
||||
(apl-compress mask arr)
|
||||
(let
|
||||
((rows (first shape)) (cols (last shape)))
|
||||
(let
|
||||
((kept-rows (filter (fn (i) (not (= 0 (nth mask-ravel i)))) (range 0 rows))))
|
||||
(let
|
||||
((new-ravel (reduce (fn (acc r) (append acc (map (fn (j) (nth ravel (+ (* r cols) j))) (range 0 cols)))) (list) kept-rows)))
|
||||
(make-array (cons (len kept-rows) (rest shape)) new-ravel))))))))
|
||||
|
||||
(define
|
||||
apl-primes
|
||||
(fn
|
||||
@@ -902,7 +883,7 @@
|
||||
(let
|
||||
((sub (apl-permutations (- n 1))))
|
||||
(reduce
|
||||
(fn (acc p) (append (apl-insert-everywhere n p) acc))
|
||||
(fn (acc p) (append acc (apl-insert-everywhere n p)))
|
||||
(list)
|
||||
sub)))))
|
||||
|
||||
@@ -1004,60 +985,6 @@
|
||||
(some (fn (c) (= c 0)) codes)
|
||||
(some (fn (c) (= c (nth e 1))) codes)))))
|
||||
|
||||
(define apl-rng-state 12345)
|
||||
|
||||
(define apl-rng-seed! (fn (s) (set! apl-rng-state s)))
|
||||
|
||||
(define
|
||||
apl-rng-next!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(set!
|
||||
apl-rng-state
|
||||
(mod (+ (* apl-rng-state 1103515245) 12345) 2147483648))
|
||||
apl-rng-state)))
|
||||
|
||||
(define
|
||||
apl-roll
|
||||
(fn
|
||||
(arr)
|
||||
(let
|
||||
((n (if (scalar? arr) (first (get arr :ravel)) (first (get arr :ravel)))))
|
||||
(apl-scalar (+ apl-io (mod (apl-rng-next!) n))))))
|
||||
|
||||
(define
|
||||
apl-cartesian
|
||||
(fn
|
||||
(lists)
|
||||
(if
|
||||
(= (len lists) 0)
|
||||
(list (list))
|
||||
(let
|
||||
((rest-prods (apl-cartesian (rest lists))))
|
||||
(reduce
|
||||
(fn (acc x) (append acc (map (fn (p) (cons x p)) rest-prods)))
|
||||
(list)
|
||||
(first lists))))))
|
||||
|
||||
(define
|
||||
apl-bracket-multi
|
||||
(fn
|
||||
(axes arr)
|
||||
(let
|
||||
((shape (get arr :shape)) (ravel (get arr :ravel)))
|
||||
(let
|
||||
((rank (len shape)) (strides (apl-strides shape)))
|
||||
(let
|
||||
((axis-info (map (fn (i) (let ((a (nth axes i))) (cond ((= a nil) {:idxs (range 0 (nth shape i)) :scalar? false}) ((= (len (get a :shape)) 0) {:idxs (list (- (first (get a :ravel)) apl-io)) :scalar? true}) (else {:idxs (map (fn (x) (- x apl-io)) (get a :ravel)) :scalar? false})))) (range 0 rank))))
|
||||
(let
|
||||
((cells (apl-cartesian (map (fn (a) (get a :idxs)) axis-info))))
|
||||
(let
|
||||
((result-ravel (map (fn (cell) (let ((flat (reduce + 0 (map (fn (i) (* (nth cell i) (nth strides i))) (range 0 rank))))) (nth ravel flat))) cells)))
|
||||
(let
|
||||
((result-shape (filter (fn (x) (>= x 0)) (map (fn (i) (let ((a (nth axis-info i))) (if (get a :scalar?) -1 (len (get a :idxs))))) (range 0 rank)))))
|
||||
(make-array result-shape result-ravel)))))))))
|
||||
|
||||
(define
|
||||
apl-reduce
|
||||
(fn
|
||||
|
||||
@@ -39,7 +39,6 @@ cat > "$TMPFILE" << 'EPOCHS'
|
||||
(load "lib/apl/tests/idioms.sx")
|
||||
(load "lib/apl/tests/eval-ops.sx")
|
||||
(load "lib/apl/tests/pipeline.sx")
|
||||
(load "lib/apl/tests/programs-e2e.sx")
|
||||
(epoch 4)
|
||||
(eval "(list apl-test-pass apl-test-fail)")
|
||||
EPOCHS
|
||||
|
||||
@@ -178,280 +178,3 @@
|
||||
"apl-run \"(⍳5)[3] × 7\" → 21"
|
||||
(mkrv (apl-run "(⍳5)[3] × 7"))
|
||||
(list 21))
|
||||
|
||||
(apl-test "decimal: 3.7 → 3.7" (mkrv (apl-run "3.7")) (list 3.7))
|
||||
|
||||
(apl-test "decimal: ¯2.5 → -2.5" (mkrv (apl-run "¯2.5")) (list -2.5))
|
||||
|
||||
(apl-test "decimal: 1.5 + 2.5 → 4" (mkrv (apl-run "1.5 + 2.5")) (list 4))
|
||||
|
||||
(apl-test "decimal: ⌊3.7 → 3" (mkrv (apl-run "⌊ 3.7")) (list 3))
|
||||
|
||||
(apl-test "decimal: ⌈3.7 → 4" (mkrv (apl-run "⌈ 3.7")) (list 4))
|
||||
|
||||
(apl-test
|
||||
"⎕← scalar passthrough"
|
||||
(mkrv (apl-run "⎕← 42"))
|
||||
(list 42))
|
||||
|
||||
(apl-test
|
||||
"⎕← vector passthrough"
|
||||
(mkrv (apl-run "⎕← 1 2 3"))
|
||||
(list 1 2 3))
|
||||
|
||||
(apl-test
|
||||
"string: 'abc' → 3-char vector"
|
||||
(mkrv (apl-run "'abc'"))
|
||||
(list "a" "b" "c"))
|
||||
|
||||
(apl-test "string: 'a' is rank-0 scalar" (mksh (apl-run "'a'")) (list))
|
||||
|
||||
(apl-test "string: 'hello' shape (5)" (mksh (apl-run "'hello'")) (list 5))
|
||||
|
||||
(apl-test
|
||||
"named-fn: f ← {⍺+⍵} ⋄ 3 f 4 → 7"
|
||||
(mkrv (apl-run "f ← {⍺+⍵} ⋄ 3 f 4"))
|
||||
(list 7))
|
||||
|
||||
(apl-test
|
||||
"named-fn monadic: sq ← {⍵×⍵} ⋄ sq 7 → 49"
|
||||
(mkrv (apl-run "sq ← {⍵×⍵} ⋄ sq 7"))
|
||||
(list 49))
|
||||
|
||||
(apl-test
|
||||
"named-fn dyadic: hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4 → 25"
|
||||
(mkrv (apl-run "hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4"))
|
||||
(list 25))
|
||||
|
||||
(apl-test
|
||||
"named-fn: dbl ← {⍵+⍵} ⋄ dbl ⍳5"
|
||||
(mkrv (apl-run "dbl ← {⍵+⍵} ⋄ dbl ⍳5"))
|
||||
(list 2 4 6 8 10))
|
||||
|
||||
(apl-test
|
||||
"named-fn factorial via ∇ recursion"
|
||||
(mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5"))
|
||||
(list 120))
|
||||
|
||||
(apl-test
|
||||
"named-fn used twice in expr: dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4"
|
||||
(mkrv (apl-run "dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4"))
|
||||
(list 14))
|
||||
|
||||
(apl-test
|
||||
"named-fn with vector arg: neg ← {-⍵} ⋄ neg 1 2 3"
|
||||
(mkrv (apl-run "neg ← {-⍵} ⋄ neg 1 2 3"))
|
||||
(list -1 -2 -3))
|
||||
|
||||
(apl-test
|
||||
"multi-axis: M[2;2] → center"
|
||||
(mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[2;2]"))
|
||||
(list 5))
|
||||
|
||||
(apl-test
|
||||
"multi-axis: M[1;] → first row"
|
||||
(mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[1;]"))
|
||||
(list 1 2 3))
|
||||
|
||||
(apl-test
|
||||
"multi-axis: M[;2] → second column"
|
||||
(mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[;2]"))
|
||||
(list 2 5 8))
|
||||
|
||||
(apl-test
|
||||
"multi-axis: M[1 2;1 2] → 2x2 block"
|
||||
(mkrv (apl-run "M ← (2 3) ⍴ ⍳6 ⋄ M[1 2;1 2]"))
|
||||
(list 1 2 4 5))
|
||||
|
||||
(apl-test
|
||||
"multi-axis: M[1 2;1 2] shape (2 2)"
|
||||
(mksh (apl-run "M ← (2 3) ⍴ ⍳6 ⋄ M[1 2;1 2]"))
|
||||
(list 2 2))
|
||||
|
||||
(apl-test
|
||||
"multi-axis: M[;] full matrix"
|
||||
(mkrv (apl-run "M ← (2 2) ⍴ 10 20 30 40 ⋄ M[;]"))
|
||||
(list 10 20 30 40))
|
||||
|
||||
(apl-test
|
||||
"multi-axis: M[1;] shape collapsed"
|
||||
(mksh (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[1;]"))
|
||||
(list 3))
|
||||
|
||||
(apl-test
|
||||
"multi-axis: select all rows of column 3"
|
||||
(mkrv (apl-run "M ← (4 3) ⍴ 1 2 3 4 5 6 7 8 9 10 11 12 ⋄ M[;3]"))
|
||||
(list 3 6 9 12))
|
||||
|
||||
(apl-test
|
||||
"train: mean = (+/÷≢) on 1..5"
|
||||
(mkrv (apl-run "(+/÷≢) 1 2 3 4 5"))
|
||||
(list 3))
|
||||
|
||||
(apl-test
|
||||
"train: mean of 2 4 6 8 10"
|
||||
(mkrv (apl-run "(+/÷≢) 2 4 6 8 10"))
|
||||
(list 6))
|
||||
|
||||
(apl-test
|
||||
"train 2-atop: (- ⌊) 5 → -5"
|
||||
(mkrv (apl-run "(- ⌊) 5"))
|
||||
(list -5))
|
||||
|
||||
(apl-test
|
||||
"train 3-fork dyadic: 2(+×-)5 → -21"
|
||||
(mkrv (apl-run "2 (+ × -) 5"))
|
||||
(list -21))
|
||||
|
||||
(apl-test
|
||||
"train: range = (⌈/-⌊/) on vector"
|
||||
(mkrv (apl-run "(⌈/-⌊/) 3 1 4 1 5 9 2 6"))
|
||||
(list 8))
|
||||
|
||||
(apl-test
|
||||
"train: mean of ⍳10 has shape ()"
|
||||
(mksh (apl-run "(+/÷≢) ⍳10"))
|
||||
(list))
|
||||
|
||||
(apl-test
|
||||
"compress: 1 0 1 0 1 / 10 20 30 40 50"
|
||||
(mkrv (apl-run "1 0 1 0 1 / 10 20 30 40 50"))
|
||||
(list 10 30 50))
|
||||
|
||||
(apl-test
|
||||
"compress: empty mask → empty"
|
||||
(mkrv (apl-run "0 0 0 / 1 2 3"))
|
||||
(list))
|
||||
|
||||
(apl-test
|
||||
"primes via classic idiom (multi-stmt)"
|
||||
(mkrv (apl-run "P ← ⍳ 30 ⋄ (2 = +⌿ 0 = P ∘.| P) / P"))
|
||||
(list 2 3 5 7 11 13 17 19 23 29))
|
||||
|
||||
(apl-test
|
||||
"primes via classic idiom (n=20)"
|
||||
(mkrv (apl-run "P ← ⍳ 20 ⋄ (2 = +⌿ 0 = P ∘.| P) / P"))
|
||||
(list 2 3 5 7 11 13 17 19))
|
||||
|
||||
(apl-test
|
||||
"compress: filter even values"
|
||||
(mkrv (apl-run "(0 = 2 | 1 2 3 4 5 6) / 1 2 3 4 5 6"))
|
||||
(list 2 4 6))
|
||||
|
||||
(apl-test "inline-assign: x ← 5" (mkrv (apl-run "x ← 5")) (list 5))
|
||||
|
||||
(apl-test
|
||||
"inline-assign: (2×x) + x←10 → 30"
|
||||
(mkrv (apl-run "(2 × x) + x ← 10"))
|
||||
(list 30))
|
||||
|
||||
(apl-test
|
||||
"inline-assign primes one-liner: (2=+⌿0=a∘.|a)/a←⍳30"
|
||||
(mkrv (apl-run "(2 = +⌿ 0 = a ∘.| a) / a ← ⍳ 30"))
|
||||
(list 2 3 5 7 11 13 17 19 23 29))
|
||||
|
||||
(apl-test
|
||||
"inline-assign: x is reusable — x + x ← 7 → 14"
|
||||
(mkrv (apl-run "x + x ← 7"))
|
||||
(list 14))
|
||||
|
||||
(apl-test
|
||||
"inline-assign in dfn: f ← {x + x ← ⍵} ⋄ f 8 → 16"
|
||||
(mkrv (apl-run "f ← {x + x ← ⍵} ⋄ f 8"))
|
||||
(list 16))
|
||||
|
||||
(begin (apl-rng-seed! 42) nil)
|
||||
|
||||
(apl-test
|
||||
"?10 with seed 42 → 8 (deterministic)"
|
||||
(mkrv (apl-run "?10"))
|
||||
(list 8))
|
||||
|
||||
(apl-test "?10 next call → 5" (mkrv (apl-run "?10")) (list 5))
|
||||
|
||||
(apl-test
|
||||
"?100 stays in range"
|
||||
(let ((v (first (mkrv (apl-run "?100"))))) (and (>= v 1) (<= v 100)))
|
||||
true)
|
||||
|
||||
(begin (apl-rng-seed! 42) nil)
|
||||
|
||||
(apl-test
|
||||
"?10 with re-seed 42 → 8 (reproducible)"
|
||||
(mkrv (apl-run "?10"))
|
||||
(list 8))
|
||||
|
||||
(apl-test
|
||||
"apl-run-file: load primes.apl returns dfn AST"
|
||||
(first (apl-run-file "lib/apl/tests/programs/primes.apl"))
|
||||
:dfn)
|
||||
|
||||
(apl-test
|
||||
"apl-run-file: life.apl parses without error"
|
||||
(first (apl-run-file "lib/apl/tests/programs/life.apl"))
|
||||
:dfn)
|
||||
|
||||
(apl-test
|
||||
"apl-run-file: quicksort.apl parses without error"
|
||||
(first (apl-run-file "lib/apl/tests/programs/quicksort.apl"))
|
||||
:dfn)
|
||||
|
||||
(apl-test
|
||||
"apl-run-file: source-then-call returns primes count"
|
||||
(mksh
|
||||
(apl-run
|
||||
(str (file-read "lib/apl/tests/programs/primes.apl") " ⋄ primes 30")))
|
||||
(list 10))
|
||||
|
||||
(apl-test
|
||||
"primes one-liner with ⍵-rebind: primes 30"
|
||||
(mkrv
|
||||
(apl-run "primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} ⋄ primes 30"))
|
||||
(list 2 3 5 7 11 13 17 19 23 29))
|
||||
|
||||
(apl-test
|
||||
"primes one-liner: primes 50"
|
||||
(mkrv
|
||||
(apl-run "primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} ⋄ primes 50"))
|
||||
(list 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47))
|
||||
|
||||
(apl-test
|
||||
"primes.apl loaded + called via apl-run-file"
|
||||
(mkrv
|
||||
(apl-run
|
||||
(str (file-read "lib/apl/tests/programs/primes.apl") " ⋄ primes 20")))
|
||||
(list 2 3 5 7 11 13 17 19))
|
||||
|
||||
(apl-test
|
||||
"primes.apl loaded — count of primes ≤ 100"
|
||||
(first
|
||||
(mksh
|
||||
(apl-run
|
||||
(str
|
||||
(file-read "lib/apl/tests/programs/primes.apl")
|
||||
" ⋄ primes 100"))))
|
||||
25)
|
||||
|
||||
(apl-test
|
||||
"⍉ monadic transpose 2x3 → 3x2"
|
||||
(mkrv (apl-run "⍉ (2 3) ⍴ ⍳6"))
|
||||
(list 1 4 2 5 3 6))
|
||||
|
||||
(apl-test
|
||||
"⍉ transpose shape (3 2)"
|
||||
(mksh (apl-run "⍉ (2 3) ⍴ ⍳6"))
|
||||
(list 3 2))
|
||||
|
||||
(apl-test "⊢ monadic identity" (mkrv (apl-run "⊢ 1 2 3")) (list 1 2 3))
|
||||
|
||||
(apl-test
|
||||
"5 ⊣ 1 2 3 → 5 (left)"
|
||||
(mkrv (apl-run "5 ⊣ 1 2 3"))
|
||||
(list 5))
|
||||
|
||||
(apl-test
|
||||
"5 ⊢ 1 2 3 → 1 2 3 (right)"
|
||||
(mkrv (apl-run "5 ⊢ 1 2 3"))
|
||||
(list 1 2 3))
|
||||
|
||||
(apl-test "⍕ 42 → \"42\" (alias for ⎕FMT)" (apl-run "⍕ 42") "42")
|
||||
|
||||
@@ -1,96 +0,0 @@
|
||||
; End-to-end tests of the classic-program archetypes — running APL
|
||||
; source through the full pipeline (tokenize → parse → eval-ast → runtime).
|
||||
;
|
||||
; These mirror the algorithms documented in lib/apl/tests/programs/*.apl
|
||||
; but use forms our pipeline supports today (named functions instead of
|
||||
; the inline ⍵← rebinding idiom; multi-stmt over single one-liners).
|
||||
|
||||
(define mkrv (fn (arr) (get arr :ravel)))
|
||||
(define mksh (fn (arr) (get arr :shape)))
|
||||
|
||||
; ---------- factorial via ∇ recursion (cf. n-queens style) ----------
|
||||
|
||||
(apl-test
|
||||
"e2e: factorial 5! = 120"
|
||||
(mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5"))
|
||||
(list 120))
|
||||
|
||||
(apl-test
|
||||
"e2e: factorial 7! = 5040"
|
||||
(mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 7"))
|
||||
(list 5040))
|
||||
|
||||
(apl-test
|
||||
"e2e: factorial via ×/⍳N (no recursion)"
|
||||
(mkrv (apl-run "fact ← {×/⍳⍵} ⋄ fact 6"))
|
||||
(list 720))
|
||||
|
||||
; ---------- sum / triangular numbers (sum-1..N) ----------
|
||||
|
||||
(apl-test
|
||||
"e2e: triangular(10) = 55"
|
||||
(mkrv (apl-run "tri ← {+/⍳⍵} ⋄ tri 10"))
|
||||
(list 55))
|
||||
|
||||
(apl-test
|
||||
"e2e: triangular(100) = 5050"
|
||||
(mkrv (apl-run "tri ← {+/⍳⍵} ⋄ tri 100"))
|
||||
(list 5050))
|
||||
|
||||
; ---------- sum of squares ----------
|
||||
|
||||
(apl-test
|
||||
"e2e: sum-of-squares 1..5 = 55"
|
||||
(mkrv (apl-run "ss ← {+/⍵×⍵} ⋄ ss ⍳5"))
|
||||
(list 55))
|
||||
|
||||
(apl-test
|
||||
"e2e: sum-of-squares 1..10 = 385"
|
||||
(mkrv (apl-run "ss ← {+/⍵×⍵} ⋄ ss ⍳10"))
|
||||
(list 385))
|
||||
|
||||
; ---------- divisor-counting (prime-sieve building blocks) ----------
|
||||
|
||||
(apl-test
|
||||
"e2e: divisor counts 1..5 via outer mod"
|
||||
(mkrv (apl-run "P ← ⍳ 5 ⋄ +⌿ 0 = P ∘.| P"))
|
||||
(list 1 2 2 3 2))
|
||||
|
||||
(apl-test
|
||||
"e2e: divisor counts 1..10"
|
||||
(mkrv (apl-run "P ← ⍳ 10 ⋄ +⌿ 0 = P ∘.| P"))
|
||||
(list 1 2 2 3 2 4 2 4 3 4))
|
||||
|
||||
(apl-test
|
||||
"e2e: prime-mask 1..10 (count==2)"
|
||||
(mkrv (apl-run "P ← ⍳ 10 ⋄ 2 = +⌿ 0 = P ∘.| P"))
|
||||
(list 0 1 1 0 1 0 1 0 0 0))
|
||||
|
||||
; ---------- monadic primitives chained ----------
|
||||
|
||||
(apl-test
|
||||
"e2e: sum of |abs| = 15"
|
||||
(mkrv (apl-run "+/|¯1 ¯2 ¯3 ¯4 ¯5"))
|
||||
(list 15))
|
||||
|
||||
(apl-test
|
||||
"e2e: max of squares 1..6"
|
||||
(mkrv (apl-run "⌈/(⍳6)×⍳6"))
|
||||
(list 36))
|
||||
|
||||
; ---------- nested named functions ----------
|
||||
|
||||
(apl-test
|
||||
"e2e: compose dbl and sq via two named fns"
|
||||
(mkrv (apl-run "dbl ← {⍵+⍵} ⋄ sq ← {⍵×⍵} ⋄ sq dbl 3"))
|
||||
(list 36))
|
||||
|
||||
(apl-test
|
||||
"e2e: max-of-two as named dyadic fn"
|
||||
(mkrv (apl-run "mx ← {⍺⌈⍵} ⋄ 5 mx 3"))
|
||||
(list 5))
|
||||
|
||||
(apl-test
|
||||
"e2e: sqrt-via-newton 1 step from 1 → 2.5"
|
||||
(mkrv (apl-run "step ← {(⍵+⍺÷⍵)÷2} ⋄ 4 step 1"))
|
||||
(list 2.5))
|
||||
@@ -2,7 +2,7 @@
|
||||
(list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~" "<" "≤" "=" "≥" ">" "≠"
|
||||
"≢" "≡" "∊" "∧" "∨" "⍱" "⍲" "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆"
|
||||
"∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕"
|
||||
"⍺" "⍵" "∇" "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯"))
|
||||
"⍺" "⍵" "∇" "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯"))
|
||||
|
||||
(define apl-glyph?
|
||||
(fn (ch)
|
||||
@@ -138,22 +138,12 @@
|
||||
(begin
|
||||
(consume! "¯")
|
||||
(let ((digits (read-digits! "")))
|
||||
(if (and (< pos src-len) (= (cur-byte) ".")
|
||||
(< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1))))
|
||||
(begin (advance!)
|
||||
(let ((frac (read-digits! "")))
|
||||
(tok-push! :num (- 0 (string->number (str digits "." frac))))))
|
||||
(tok-push! :num (- 0 (parse-int digits 0)))))
|
||||
(tok-push! :num (- 0 (parse-int digits 0))))
|
||||
(scan!)))
|
||||
((apl-digit? ch)
|
||||
(begin
|
||||
(let ((digits (read-digits! "")))
|
||||
(if (and (< pos src-len) (= (cur-byte) ".")
|
||||
(< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1))))
|
||||
(begin (advance!)
|
||||
(let ((frac (read-digits! "")))
|
||||
(tok-push! :num (string->number (str digits "." frac)))))
|
||||
(tok-push! :num (parse-int digits 0))))
|
||||
(tok-push! :num (parse-int digits 0)))
|
||||
(scan!)))
|
||||
((= ch "'")
|
||||
(begin
|
||||
@@ -165,9 +155,7 @@
|
||||
(let ((start pos))
|
||||
(begin
|
||||
(if (cur-sw? "⎕") (consume! "⎕") (advance!))
|
||||
(if (and (< pos src-len) (cur-sw? "←"))
|
||||
(consume! "←")
|
||||
(read-ident-cont!))
|
||||
(read-ident-cont!)
|
||||
(tok-push! :name (slice source start pos))
|
||||
(scan!))))
|
||||
(true
|
||||
|
||||
@@ -39,13 +39,7 @@
|
||||
((= g "⊖") apl-reverse-first)
|
||||
((= g "⍋") apl-grade-up)
|
||||
((= g "⍒") apl-grade-down)
|
||||
((= g "?") apl-roll)
|
||||
((= g "⍉") apl-transpose)
|
||||
((= g "⊢") (fn (a) a))
|
||||
((= g "⊣") (fn (a) a))
|
||||
((= g "⍕") apl-quad-fmt)
|
||||
((= g "⎕FMT") apl-quad-fmt)
|
||||
((= g "⎕←") apl-quad-print)
|
||||
(else (error "no monadic fn for glyph")))))
|
||||
|
||||
(define
|
||||
@@ -85,11 +79,6 @@
|
||||
((= g "∊") apl-member)
|
||||
((= g "⍳") apl-index-of)
|
||||
((= g "~") apl-without)
|
||||
((= g "/") apl-compress)
|
||||
((= g "⌿") apl-compress-first)
|
||||
((= g "⍉") apl-transpose-dyadic)
|
||||
((= g "⊢") (fn (a b) b))
|
||||
((= g "⊣") (fn (a b) a))
|
||||
(else (error "no dyadic fn for glyph")))))
|
||||
|
||||
(define
|
||||
@@ -108,15 +97,6 @@
|
||||
((tag (first node)))
|
||||
(cond
|
||||
((= tag :num) (apl-scalar (nth node 1)))
|
||||
((= tag :str)
|
||||
(let
|
||||
((s (nth node 1)))
|
||||
(if
|
||||
(= (len s) 1)
|
||||
(apl-scalar s)
|
||||
(make-array
|
||||
(list (len s))
|
||||
(map (fn (i) (slice s i (+ i 1))) (range 0 (len s)))))))
|
||||
((= tag :vec)
|
||||
(let
|
||||
((items (rest node)))
|
||||
@@ -129,14 +109,8 @@
|
||||
(let
|
||||
((nm (nth node 1)))
|
||||
(cond
|
||||
((= nm "⍺")
|
||||
(let
|
||||
((v (get env "⍺")))
|
||||
(if (= v nil) (get env "alpha") v)))
|
||||
((= nm "⍵")
|
||||
(let
|
||||
((v (get env "⍵")))
|
||||
(if (= v nil) (get env "omega") v)))
|
||||
((= nm "⍺") (get env "alpha"))
|
||||
((= nm "⍵") (get env "omega"))
|
||||
((= nm "⎕IO") (apl-quad-io))
|
||||
((= nm "⎕ML") (apl-quad-ml))
|
||||
((= nm "⎕FR") (apl-quad-fr))
|
||||
@@ -148,11 +122,7 @@
|
||||
(if
|
||||
(and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇"))
|
||||
(apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env))
|
||||
(let
|
||||
((arg-val (apl-eval-ast arg env)))
|
||||
(let
|
||||
((new-env (if (and (list? arg) (> (len arg) 0) (= (first arg) :assign-expr)) (assoc env (nth arg 1) arg-val) env)))
|
||||
((apl-resolve-monadic fn-node new-env) arg-val))))))
|
||||
((apl-resolve-monadic fn-node env) (apl-eval-ast arg env)))))
|
||||
((= tag :dyad)
|
||||
(let
|
||||
((fn-node (nth node 1))
|
||||
@@ -164,27 +134,11 @@
|
||||
(get env "nabla")
|
||||
(apl-eval-ast lhs env)
|
||||
(apl-eval-ast rhs env))
|
||||
(let
|
||||
((rhs-val (apl-eval-ast rhs env)))
|
||||
(let
|
||||
((new-env (if (and (list? rhs) (> (len rhs) 0) (= (first rhs) :assign-expr)) (assoc env (nth rhs 1) rhs-val) env)))
|
||||
((apl-resolve-dyadic fn-node new-env)
|
||||
(apl-eval-ast lhs new-env)
|
||||
rhs-val))))))
|
||||
((apl-resolve-dyadic fn-node env)
|
||||
(apl-eval-ast lhs env)
|
||||
(apl-eval-ast rhs env)))))
|
||||
((= tag :program) (apl-eval-stmts (rest node) env))
|
||||
((= tag :dfn) node)
|
||||
((= tag :bracket)
|
||||
(let
|
||||
((arr-expr (nth node 1)) (axis-exprs (rest (rest node))))
|
||||
(let
|
||||
((arr (apl-eval-ast arr-expr env))
|
||||
(axes
|
||||
(map
|
||||
(fn (a) (if (= a :all) nil (apl-eval-ast a env)))
|
||||
axis-exprs)))
|
||||
(apl-bracket-multi axes arr))))
|
||||
((= tag :assign-expr) (apl-eval-ast (nth node 2) env))
|
||||
((= tag :assign) (apl-eval-ast (nth node 2) env))
|
||||
(else (error (list "apl-eval-ast: unknown node tag" tag node)))))))
|
||||
|
||||
(define
|
||||
@@ -465,36 +419,6 @@
|
||||
((f (apl-resolve-dyadic inner env)))
|
||||
(fn (arr) (apl-commute f arr))))
|
||||
(else (error "apl-resolve-monadic: unsupported op")))))
|
||||
((= tag :fn-name)
|
||||
(let
|
||||
((nm (nth fn-node 1)))
|
||||
(let
|
||||
((bound (get env nm)))
|
||||
(if
|
||||
(and
|
||||
(list? bound)
|
||||
(> (len bound) 0)
|
||||
(= (first bound) :dfn))
|
||||
(fn (arg) (apl-call-dfn-m bound arg))
|
||||
(error "apl-resolve-monadic: name not bound to dfn")))))
|
||||
((= tag :train)
|
||||
(let
|
||||
((fns (rest fn-node)))
|
||||
(let
|
||||
((n (len fns)))
|
||||
(cond
|
||||
((= n 2)
|
||||
(let
|
||||
((g (apl-resolve-monadic (nth fns 0) env))
|
||||
(h (apl-resolve-monadic (nth fns 1) env)))
|
||||
(fn (arg) (g (h arg)))))
|
||||
((= n 3)
|
||||
(let
|
||||
((f (apl-resolve-monadic (nth fns 0) env))
|
||||
(g (apl-resolve-dyadic (nth fns 1) env))
|
||||
(h (apl-resolve-monadic (nth fns 2) env)))
|
||||
(fn (arg) (g (f arg) (h arg)))))
|
||||
(else (error "monadic train arity not 2 or 3"))))))
|
||||
(else (error "apl-resolve-monadic: unknown fn-node tag"))))))
|
||||
|
||||
(define
|
||||
@@ -518,18 +442,6 @@
|
||||
((f (apl-resolve-dyadic inner env)))
|
||||
(fn (a b) (apl-commute-dyadic f a b))))
|
||||
(else (error "apl-resolve-dyadic: unsupported op")))))
|
||||
((= tag :fn-name)
|
||||
(let
|
||||
((nm (nth fn-node 1)))
|
||||
(let
|
||||
((bound (get env nm)))
|
||||
(if
|
||||
(and
|
||||
(list? bound)
|
||||
(> (len bound) 0)
|
||||
(= (first bound) :dfn))
|
||||
(fn (a b) (apl-call-dfn bound a b))
|
||||
(error "apl-resolve-dyadic: name not bound to dfn")))))
|
||||
((= tag :outer)
|
||||
(let
|
||||
((inner (nth fn-node 2)))
|
||||
@@ -543,26 +455,6 @@
|
||||
((f (apl-resolve-dyadic f-node env))
|
||||
(g (apl-resolve-dyadic g-node env)))
|
||||
(fn (a b) (apl-inner f g a b)))))
|
||||
((= tag :train)
|
||||
(let
|
||||
((fns (rest fn-node)))
|
||||
(let
|
||||
((n (len fns)))
|
||||
(cond
|
||||
((= n 2)
|
||||
(let
|
||||
((g (apl-resolve-monadic (nth fns 0) env))
|
||||
(h (apl-resolve-dyadic (nth fns 1) env)))
|
||||
(fn (a b) (g (h a b)))))
|
||||
((= n 3)
|
||||
(let
|
||||
((f (apl-resolve-dyadic (nth fns 0) env))
|
||||
(g (apl-resolve-dyadic (nth fns 1) env))
|
||||
(h (apl-resolve-dyadic (nth fns 2) env)))
|
||||
(fn (a b) (g (f a b) (h a b)))))
|
||||
(else (error "dyadic train arity not 2 or 3"))))))
|
||||
(else (error "apl-resolve-dyadic: unknown fn-node tag"))))))
|
||||
|
||||
(define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
|
||||
|
||||
(define apl-run-file (fn (path) (apl-run (file-read path))))
|
||||
|
||||
@@ -76,7 +76,7 @@ cat > "$TMPFILE" << 'EPOCHS'
|
||||
(eval "(list er-fib-test-pass er-fib-test-count)")
|
||||
EPOCHS
|
||||
|
||||
timeout 600 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
|
||||
timeout 120 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
|
||||
|
||||
# Parse "(N M)" from the line after each "(ok-len <epoch> ...)" marker.
|
||||
parse_pair() {
|
||||
|
||||
@@ -1,16 +1,16 @@
|
||||
{
|
||||
"language": "erlang",
|
||||
"total_pass": 530,
|
||||
"total": 530,
|
||||
"total_pass": 0,
|
||||
"total": 0,
|
||||
"suites": [
|
||||
{"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"}
|
||||
{"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"}
|
||||
]
|
||||
}
|
||||
|
||||
@@ -1,18 +1,18 @@
|
||||
# Erlang-on-SX Scoreboard
|
||||
|
||||
**Total: 530 / 530 tests passing**
|
||||
**Total: 0 / 0 tests passing**
|
||||
|
||||
| | Suite | Pass | Total |
|
||||
|---|---|---|---|
|
||||
| ✅ | 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 |
|
||||
| ✅ | 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 |
|
||||
|
||||
|
||||
Generated by `lib/erlang/conformance.sh`.
|
||||
|
||||
180
lib/guest/hm.sx
180
lib/guest/hm.sx
@@ -1,180 +0,0 @@
|
||||
;; lib/guest/hm.sx — Hindley-Milner type-inference foundations.
|
||||
;;
|
||||
;; Builds on lib/guest/match.sx (terms + unify) and ast.sx (canonical
|
||||
;; AST shapes). This file ships the ALGEBRA — types, schemes, free
|
||||
;; type-vars, generalize / instantiate, substitution composition — so a
|
||||
;; full Algorithm W (or J) can be assembled on top either inside this
|
||||
;; file or in a host-specific consumer (haskell/infer.sx,
|
||||
;; lib/ocaml/types.sx, …).
|
||||
;;
|
||||
;; Per the brief the second consumer for this step is OCaml-on-SX
|
||||
;; Phase 5 (paired sequencing). Until that lands, the algebra is the
|
||||
;; deliverable; the host-flavoured assembly (lambda / app / let
|
||||
;; inference rules with substitution threading) lives in the host.
|
||||
;;
|
||||
;; Types
|
||||
;; -----
|
||||
;; A type is a canonical match.sx term — type variables use mk-var,
|
||||
;; type constructors use mk-ctor:
|
||||
;; (hm-tv NAME) type variable
|
||||
;; (hm-arrow A B) A -> B
|
||||
;; (hm-con NAME ARGS) named n-ary constructor
|
||||
;; (hm-int) / (hm-bool) / (hm-string) primitive constructors
|
||||
;;
|
||||
;; Schemes
|
||||
;; -------
|
||||
;; (hm-scheme VARS TYPE) ∀ VARS . TYPE
|
||||
;; (hm-monotype TYPE) empty quantifier
|
||||
;; (hm-scheme? S) (hm-scheme-vars S) (hm-scheme-type S)
|
||||
;;
|
||||
;; Free type variables
|
||||
;; -------------------
|
||||
;; (hm-ftv TYPE) names occurring in TYPE
|
||||
;; (hm-ftv-scheme S) free names (minus quantifiers)
|
||||
;; (hm-ftv-env ENV) free across an env (name -> scheme)
|
||||
;;
|
||||
;; Substitution
|
||||
;; ------------
|
||||
;; (hm-apply SUBST TYPE) substitute through a type
|
||||
;; (hm-apply-scheme SUBST S) leaves bound vars alone
|
||||
;; (hm-apply-env SUBST ENV)
|
||||
;; (hm-compose S2 S1) apply S1 then S2
|
||||
;;
|
||||
;; Generalize / Instantiate
|
||||
;; ------------------------
|
||||
;; (hm-generalize TYPE ENV) → scheme over ftv(t) - ftv(env)
|
||||
;; (hm-instantiate SCHEME COUNTER) → fresh-var instance
|
||||
;; (hm-fresh-tv COUNTER) → (:var "tN"), bumps COUNTER
|
||||
;;
|
||||
;; Inference (literal only — the rest of Algorithm W lives in the host)
|
||||
;; --------------------------------------------------------------------
|
||||
;; (hm-infer-literal EXPR) → {:subst {} :type T}
|
||||
;;
|
||||
;; A complete Algorithm W consumes this kit by assembling lambda / app
|
||||
;; / let rules in the host language file.
|
||||
|
||||
(define hm-tv (fn (name) (list :var name)))
|
||||
(define hm-con (fn (name args) (list :ctor name args)))
|
||||
(define hm-arrow (fn (a b) (hm-con "->" (list a b))))
|
||||
(define hm-int (fn () (hm-con "Int" (list))))
|
||||
(define hm-bool (fn () (hm-con "Bool" (list))))
|
||||
(define hm-string (fn () (hm-con "String" (list))))
|
||||
|
||||
(define hm-scheme (fn (vars t) (list :scheme vars t)))
|
||||
(define hm-monotype (fn (t) (hm-scheme (list) t)))
|
||||
(define hm-scheme? (fn (s) (and (list? s) (not (empty? s)) (= (first s) :scheme))))
|
||||
(define hm-scheme-vars (fn (s) (nth s 1)))
|
||||
(define hm-scheme-type (fn (s) (nth s 2)))
|
||||
|
||||
(define
|
||||
hm-fresh-tv
|
||||
(fn (counter)
|
||||
(let ((n (first counter)))
|
||||
(begin
|
||||
(set-nth! counter 0 (+ n 1))
|
||||
(hm-tv (str "t" (+ n 1)))))))
|
||||
|
||||
(define
|
||||
hm-ftv-acc
|
||||
(fn (t acc)
|
||||
(cond
|
||||
((is-var? t)
|
||||
(if (some (fn (n) (= n (var-name t))) acc) acc (cons (var-name t) acc)))
|
||||
((is-ctor? t)
|
||||
(let ((a acc))
|
||||
(begin
|
||||
(for-each (fn (x) (set! a (hm-ftv-acc x a))) (ctor-args t))
|
||||
a)))
|
||||
(:else acc))))
|
||||
|
||||
(define hm-ftv (fn (t) (hm-ftv-acc t (list))))
|
||||
|
||||
(define
|
||||
hm-ftv-scheme
|
||||
(fn (s)
|
||||
(let ((qs (hm-scheme-vars s))
|
||||
(all (hm-ftv (hm-scheme-type s))))
|
||||
(filter (fn (n) (not (some (fn (q) (= q n)) qs))) all))))
|
||||
|
||||
(define
|
||||
hm-ftv-env
|
||||
(fn (env)
|
||||
(let ((acc (list)))
|
||||
(begin
|
||||
(for-each
|
||||
(fn (k)
|
||||
(for-each
|
||||
(fn (n)
|
||||
(when (not (some (fn (m) (= m n)) acc))
|
||||
(set! acc (cons n acc))))
|
||||
(hm-ftv-scheme (get env k))))
|
||||
(keys env))
|
||||
acc))))
|
||||
|
||||
(define hm-apply (fn (subst t) (walk* t subst)))
|
||||
|
||||
(define
|
||||
hm-apply-scheme
|
||||
(fn (subst s)
|
||||
(let ((qs (hm-scheme-vars s))
|
||||
(d {}))
|
||||
(begin
|
||||
(for-each
|
||||
(fn (k)
|
||||
(when (not (some (fn (q) (= q k)) qs))
|
||||
(dict-set! d k (get subst k))))
|
||||
(keys subst))
|
||||
(hm-scheme qs (walk* (hm-scheme-type s) d))))))
|
||||
|
||||
(define
|
||||
hm-apply-env
|
||||
(fn (subst env)
|
||||
(let ((d {}))
|
||||
(begin
|
||||
(for-each
|
||||
(fn (k) (dict-set! d k (hm-apply-scheme subst (get env k))))
|
||||
(keys env))
|
||||
d))))
|
||||
|
||||
(define
|
||||
hm-compose
|
||||
(fn (s2 s1)
|
||||
(let ((d {}))
|
||||
(begin
|
||||
(for-each (fn (k) (dict-set! d k (walk* (get s1 k) s2))) (keys s1))
|
||||
(for-each
|
||||
(fn (k) (when (not (has-key? d k)) (dict-set! d k (get s2 k))))
|
||||
(keys s2))
|
||||
d))))
|
||||
|
||||
(define
|
||||
hm-generalize
|
||||
(fn (t env)
|
||||
(let ((tvars (hm-ftv t))
|
||||
(evars (hm-ftv-env env)))
|
||||
(let ((qs (filter (fn (n) (not (some (fn (m) (= m n)) evars))) tvars)))
|
||||
(hm-scheme qs t)))))
|
||||
|
||||
(define
|
||||
hm-instantiate
|
||||
(fn (s counter)
|
||||
(let ((qs (hm-scheme-vars s))
|
||||
(subst {}))
|
||||
(begin
|
||||
(for-each
|
||||
(fn (q) (set! subst (assoc subst q (hm-fresh-tv counter))))
|
||||
qs)
|
||||
(walk* (hm-scheme-type s) subst)))))
|
||||
|
||||
;; Literal inference — the only AST kind whose typing rule is closed
|
||||
;; in the kit. Lambda / app / let live in host code so the host's own
|
||||
;; AST conventions stay untouched.
|
||||
(define
|
||||
hm-infer-literal
|
||||
(fn (expr)
|
||||
(let ((v (ast-literal-value expr)))
|
||||
(cond
|
||||
((number? v) {:subst {} :type (hm-int)})
|
||||
((string? v) {:subst {} :type (hm-string)})
|
||||
((boolean? v) {:subst {} :type (hm-bool)})
|
||||
(:else (error (str "hm-infer-literal: unknown kind: " v)))))))
|
||||
@@ -1,145 +0,0 @@
|
||||
;; lib/guest/layout.sx — configurable off-side / layout-sensitive lexer.
|
||||
;;
|
||||
;; Inserts virtual open / close / separator tokens based on indentation.
|
||||
;; Configurable enough to encode either the Haskell 98 layout rule (let /
|
||||
;; where / do / of opens a virtual brace at the next token's column) or
|
||||
;; a Python-ish indent / dedent rule (a colon at the end of a line opens
|
||||
;; a block at the next non-blank line's column).
|
||||
;;
|
||||
;; Token shape (input + output)
|
||||
;; ----------------------------
|
||||
;; Each token is a dict {:type :value :line :col …}. The kit reads
|
||||
;; only :type / :value / :line / :col and passes everything else
|
||||
;; through. The input stream MUST be free of newline filler tokens
|
||||
;; (preprocess them away with your tokenizer) — line breaks are detected
|
||||
;; by comparing :line of consecutive tokens.
|
||||
;;
|
||||
;; Config
|
||||
;; ------
|
||||
;; :open-keywords list of strings; a token whose :value matches
|
||||
;; opens a new layout block at the next token's
|
||||
;; column (Haskell: let/where/do/of).
|
||||
;; :open-trailing-fn (fn (tok) -> bool) — alternative trigger that
|
||||
;; fires AFTER the token is emitted. Use for
|
||||
;; Python-style trailing `:`.
|
||||
;; :open-token / :close-token / :sep-token
|
||||
;; templates {:type :value} merged with :line and
|
||||
;; :col when virtual tokens are emitted.
|
||||
;; :explicit-open? (fn (tok) -> bool) — if the next token after a
|
||||
;; trigger satisfies this, suppress virtual layout
|
||||
;; for that block (Haskell: `{`).
|
||||
;; :module-prelude? if true, wrap whole input in an implicit block
|
||||
;; at the first token's column (Haskell yes,
|
||||
;; Python no).
|
||||
;;
|
||||
;; Public entry
|
||||
;; ------------
|
||||
;; (layout-pass cfg tokens) -> tokens with virtual layout inserted.
|
||||
|
||||
(define
|
||||
layout-mk-virtual
|
||||
(fn (template line col)
|
||||
(assoc (assoc template :line line) :col col)))
|
||||
|
||||
(define
|
||||
layout-is-open-kw?
|
||||
(fn (tok open-kws)
|
||||
(and (= (get tok :type) "reserved")
|
||||
(some (fn (k) (= k (get tok :value))) open-kws))))
|
||||
|
||||
(define
|
||||
layout-pass
|
||||
(fn (cfg tokens)
|
||||
(let ((open-kws (get cfg :open-keywords))
|
||||
(trailing-fn (get cfg :open-trailing-fn))
|
||||
(open-tmpl (get cfg :open-token))
|
||||
(close-tmpl (get cfg :close-token))
|
||||
(sep-tmpl (get cfg :sep-token))
|
||||
(mod-prelude? (get cfg :module-prelude?))
|
||||
(expl?-fn (get cfg :explicit-open?))
|
||||
(out (list))
|
||||
(stack (list))
|
||||
(n (len tokens))
|
||||
(i 0)
|
||||
(prev-line -1)
|
||||
(pending-open false)
|
||||
(just-opened false))
|
||||
(define
|
||||
emit-closes-while-greater
|
||||
(fn (col line)
|
||||
(when (and (not (empty? stack)) (> (first stack) col))
|
||||
(do
|
||||
(append! out (layout-mk-virtual close-tmpl line col))
|
||||
(set! stack (rest stack))
|
||||
(emit-closes-while-greater col line)))))
|
||||
(define
|
||||
emit-pending-open
|
||||
(fn (line col)
|
||||
(do
|
||||
(append! out (layout-mk-virtual open-tmpl line col))
|
||||
(set! stack (cons col stack))
|
||||
(set! pending-open false)
|
||||
(set! just-opened true))))
|
||||
(define
|
||||
layout-step
|
||||
(fn ()
|
||||
(when (< i n)
|
||||
(let ((tok (nth tokens i)))
|
||||
(let ((line (get tok :line)) (col (get tok :col)))
|
||||
(cond
|
||||
(pending-open
|
||||
(cond
|
||||
((and (not (= expl?-fn nil)) (expl?-fn tok))
|
||||
(do
|
||||
(set! pending-open false)
|
||||
(append! out tok)
|
||||
(set! prev-line line)
|
||||
(set! i (+ i 1))
|
||||
(layout-step)))
|
||||
(:else
|
||||
(do
|
||||
(emit-pending-open line col)
|
||||
(layout-step)))))
|
||||
(:else
|
||||
(let ((on-fresh-line? (and (> prev-line 0) (> line prev-line))))
|
||||
(do
|
||||
(when on-fresh-line?
|
||||
(let ((stack-before stack))
|
||||
(begin
|
||||
(emit-closes-while-greater col line)
|
||||
(when (and (not (empty? stack))
|
||||
(= (first stack) col)
|
||||
(not just-opened)
|
||||
;; suppress separator if a dedent fired
|
||||
;; — the dedent is itself the separator
|
||||
(= (len stack) (len stack-before)))
|
||||
(append! out (layout-mk-virtual sep-tmpl line col))))))
|
||||
(set! just-opened false)
|
||||
(append! out tok)
|
||||
(set! prev-line line)
|
||||
(set! i (+ i 1))
|
||||
(cond
|
||||
((layout-is-open-kw? tok open-kws)
|
||||
(set! pending-open true))
|
||||
((and (not (= trailing-fn nil)) (trailing-fn tok))
|
||||
(set! pending-open true)))
|
||||
(layout-step))))))))))
|
||||
(begin
|
||||
;; Module prelude: implicit layout block at the first token's column.
|
||||
(when (and mod-prelude? (> n 0))
|
||||
(let ((tok (nth tokens 0)))
|
||||
(do
|
||||
(append! out (layout-mk-virtual open-tmpl (get tok :line) (get tok :col)))
|
||||
(set! stack (cons (get tok :col) stack))
|
||||
(set! just-opened true))))
|
||||
(layout-step)
|
||||
;; EOF: close every remaining block.
|
||||
(define close-rest
|
||||
(fn ()
|
||||
(when (not (empty? stack))
|
||||
(do
|
||||
(append! out (layout-mk-virtual close-tmpl 0 0))
|
||||
(set! stack (rest stack))
|
||||
(close-rest)))))
|
||||
(close-rest)
|
||||
out))))
|
||||
@@ -1,159 +0,0 @@
|
||||
;; lib/guest/reflective/env.sx — first-class environment kit.
|
||||
;;
|
||||
;; Extracted from Kernel-on-SX (lib/kernel/eval.sx) when Tcl's
|
||||
;; uplevel/upvar machinery (lib/tcl/runtime.sx) materialised as a
|
||||
;; second consumer needing the same scope-chain semantics.
|
||||
;;
|
||||
;; Canonical wire shape
|
||||
;; --------------------
|
||||
;; {:refl-tag :env :bindings DICT :parent ENV-OR-NIL}
|
||||
;;
|
||||
;; - :bindings is a mutable SX dict keyed by symbol name.
|
||||
;; - :parent is either another env or nil (root).
|
||||
;; - Lookup walks the parent chain until a hit or nil.
|
||||
;; - Default cfg uses dict-set! to mutate bindings in place.
|
||||
;;
|
||||
;; Consumers with their own shape (e.g., Tcl's {:level :locals :parent})
|
||||
;; pass an adapter cfg dict — same trick as lib/guest/match.sx's cfg
|
||||
;; for unification over guest-specific term shapes.
|
||||
;;
|
||||
;; Adapter cfg keys
|
||||
;; ----------------
|
||||
;; :bindings-of — fn (scope) → DICT
|
||||
;; :parent-of — fn (scope) → SCOPE-OR-NIL
|
||||
;; :extend — fn (scope) → SCOPE (push a fresh child)
|
||||
;; :bind! — fn (scope name val) → scope (functional or mutable)
|
||||
;; :env? — fn (v) → bool (predicate; cheap shape check)
|
||||
;;
|
||||
;; Public API — canonical shape, mutable, raises on miss
|
||||
;;
|
||||
;; (refl-make-env)
|
||||
;; (refl-extend-env PARENT)
|
||||
;; (refl-env? V)
|
||||
;; (refl-env-bind! ENV NAME VAL)
|
||||
;; (refl-env-has? ENV NAME)
|
||||
;; (refl-env-lookup ENV NAME)
|
||||
;; (refl-env-lookup-or-nil ENV NAME)
|
||||
;;
|
||||
;; Public API — adapter-cfg, any shape
|
||||
;;
|
||||
;; (refl-env-extend-with CFG SCOPE)
|
||||
;; (refl-env-bind!-with CFG SCOPE NAME VAL)
|
||||
;; (refl-env-has?-with CFG SCOPE NAME)
|
||||
;; (refl-env-lookup-with CFG SCOPE NAME)
|
||||
;; (refl-env-lookup-or-nil-with CFG SCOPE NAME)
|
||||
;; (refl-env-find-frame-with CFG SCOPE NAME)
|
||||
;; — returns the scope in the chain that contains NAME (or nil).
|
||||
;; Consumers needing source-frame mutation use this.
|
||||
;;
|
||||
;; (refl-canonical-cfg) — the default cfg, exposed so consumers
|
||||
;; can compare or extend it.
|
||||
|
||||
;; ── Canonical-shape predicates and constructors ─────────────────
|
||||
|
||||
(define refl-env? (fn (v) (and (dict? v) (= (get v :refl-tag) :env))))
|
||||
|
||||
(define refl-make-env (fn () {:parent nil :refl-tag :env :bindings {}}))
|
||||
|
||||
(define refl-extend-env (fn (parent) {:parent parent :refl-tag :env :bindings {}}))
|
||||
|
||||
(define
|
||||
refl-env-bind!
|
||||
(fn (env name val) (dict-set! (get env :bindings) name val) env))
|
||||
|
||||
(define
|
||||
refl-env-has?
|
||||
(fn
|
||||
(env name)
|
||||
(cond
|
||||
((nil? env) false)
|
||||
((not (refl-env? env)) false)
|
||||
((dict-has? (get env :bindings) name) true)
|
||||
(:else (refl-env-has? (get env :parent) name)))))
|
||||
|
||||
(define
|
||||
refl-env-lookup
|
||||
(fn
|
||||
(env name)
|
||||
(cond
|
||||
((nil? env) (error (str "refl-env-lookup: unbound symbol: " name)))
|
||||
((not (refl-env? env))
|
||||
(error (str "refl-env-lookup: corrupt env: " env)))
|
||||
((dict-has? (get env :bindings) name) (get (get env :bindings) name))
|
||||
(:else (refl-env-lookup (get env :parent) name)))))
|
||||
|
||||
(define
|
||||
refl-env-lookup-or-nil
|
||||
(fn
|
||||
(env name)
|
||||
(cond
|
||||
((nil? env) nil)
|
||||
((not (refl-env? env)) nil)
|
||||
((dict-has? (get env :bindings) name) (get (get env :bindings) name))
|
||||
(:else (refl-env-lookup-or-nil (get env :parent) name)))))
|
||||
|
||||
;; ── Adapter-cfg variants — any wire shape ───────────────────────
|
||||
|
||||
(define refl-env-extend-with (fn (cfg scope) ((get cfg :extend) scope)))
|
||||
|
||||
(define
|
||||
refl-env-bind!-with
|
||||
(fn (cfg scope name val) ((get cfg :bind!) scope name val)))
|
||||
|
||||
(define
|
||||
refl-env-has?-with
|
||||
(fn
|
||||
(cfg scope name)
|
||||
(cond
|
||||
((nil? scope) false)
|
||||
((not ((get cfg :env?) scope)) false)
|
||||
((dict-has? ((get cfg :bindings-of) scope) name) true)
|
||||
(:else (refl-env-has?-with cfg ((get cfg :parent-of) scope) name)))))
|
||||
|
||||
(define
|
||||
refl-env-lookup-with
|
||||
(fn
|
||||
(cfg scope name)
|
||||
(cond
|
||||
((nil? scope) (error (str "refl-env-lookup: unbound symbol: " name)))
|
||||
((not ((get cfg :env?) scope))
|
||||
(error (str "refl-env-lookup: corrupt scope: " scope)))
|
||||
((dict-has? ((get cfg :bindings-of) scope) name)
|
||||
(get ((get cfg :bindings-of) scope) name))
|
||||
(:else (refl-env-lookup-with cfg ((get cfg :parent-of) scope) name)))))
|
||||
|
||||
(define
|
||||
refl-env-lookup-or-nil-with
|
||||
(fn
|
||||
(cfg scope name)
|
||||
(cond
|
||||
((nil? scope) nil)
|
||||
((not ((get cfg :env?) scope)) nil)
|
||||
((dict-has? ((get cfg :bindings-of) scope) name)
|
||||
(get ((get cfg :bindings-of) scope) name))
|
||||
(:else
|
||||
(refl-env-lookup-or-nil-with cfg ((get cfg :parent-of) scope) name)))))
|
||||
|
||||
;; Returns the SCOPE in the chain that contains NAME, or nil if no
|
||||
;; scope binds it. Consumers (e.g. Smalltalk) use this to mutate the
|
||||
;; binding at its source frame rather than introducing a new shadow
|
||||
;; binding at the current frame. Pairs with `refl-env-lookup-with`
|
||||
;; for callers that need both the value and the defining scope.
|
||||
|
||||
(define refl-env-find-frame-with
|
||||
(fn (cfg scope name)
|
||||
(cond
|
||||
((nil? scope) nil)
|
||||
((not ((get cfg :env?) scope)) nil)
|
||||
((dict-has? ((get cfg :bindings-of) scope) name) scope)
|
||||
(:else
|
||||
(refl-env-find-frame-with cfg ((get cfg :parent-of) scope) name)))))
|
||||
|
||||
(define refl-env-find-frame
|
||||
(fn (env name) (refl-env-find-frame-with refl-canonical-cfg env name)))
|
||||
|
||||
;; ── Default canonical cfg ───────────────────────────────────────
|
||||
;; Exposed so consumers can use it explicitly, compose with it, or
|
||||
;; check adapter-correctness against the canonical implementation.
|
||||
|
||||
(define refl-canonical-cfg {:bind! (fn (e n v) (refl-env-bind! e n v)) :parent-of (fn (e) (get e :parent)) :env? (fn (v) (refl-env? v)) :bindings-of (fn (e) (get e :bindings)) :extend (fn (e) (refl-extend-env e))})
|
||||
@@ -1,89 +0,0 @@
|
||||
;; lib/guest/tests/hm.sx — exercises lib/guest/hm.sx algebra.
|
||||
|
||||
(define ghm-test-pass 0)
|
||||
(define ghm-test-fail 0)
|
||||
(define ghm-test-fails (list))
|
||||
|
||||
(define
|
||||
ghm-test
|
||||
(fn (name actual expected)
|
||||
(if (= actual expected)
|
||||
(set! ghm-test-pass (+ ghm-test-pass 1))
|
||||
(begin
|
||||
(set! ghm-test-fail (+ ghm-test-fail 1))
|
||||
(append! ghm-test-fails {:name name :expected expected :actual actual})))))
|
||||
|
||||
;; ── Type constructors ─────────────────────────────────────────────
|
||||
(ghm-test "tv" (hm-tv "a") (list :var "a"))
|
||||
(ghm-test "int" (hm-int) (list :ctor "Int" (list)))
|
||||
(ghm-test "arrow" (ctor-head (hm-arrow (hm-int) (hm-bool))) "->")
|
||||
(ghm-test "arrow-args-len" (len (ctor-args (hm-arrow (hm-int) (hm-bool)))) 2)
|
||||
|
||||
;; ── Schemes ───────────────────────────────────────────────────────
|
||||
(ghm-test "scheme-vars" (hm-scheme-vars (hm-scheme (list "a") (hm-tv "a"))) (list "a"))
|
||||
(ghm-test "monotype-vars" (hm-scheme-vars (hm-monotype (hm-int))) (list))
|
||||
(ghm-test "scheme?-yes" (hm-scheme? (hm-monotype (hm-int))) true)
|
||||
(ghm-test "scheme?-no" (hm-scheme? (hm-int)) false)
|
||||
|
||||
;; ── Fresh tyvars ──────────────────────────────────────────────────
|
||||
(ghm-test "fresh-1"
|
||||
(let ((c (list 0))) (var-name (hm-fresh-tv c))) "t1")
|
||||
(ghm-test "fresh-bumps"
|
||||
(let ((c (list 5))) (begin (hm-fresh-tv c) (first c))) 6)
|
||||
|
||||
;; ── Free type variables ──────────────────────────────────────────
|
||||
(ghm-test "ftv-int" (hm-ftv (hm-int)) (list))
|
||||
(ghm-test "ftv-tv" (hm-ftv (hm-tv "a")) (list "a"))
|
||||
(ghm-test "ftv-arrow"
|
||||
(len (hm-ftv (hm-arrow (hm-tv "a") (hm-arrow (hm-tv "b") (hm-tv "a"))))) 2)
|
||||
(ghm-test "ftv-scheme-quantified"
|
||||
(hm-ftv-scheme (hm-scheme (list "a") (hm-arrow (hm-tv "a") (hm-tv "b")))) (list "b"))
|
||||
(ghm-test "ftv-env"
|
||||
(let ((env (assoc {} "f" (hm-monotype (hm-arrow (hm-tv "x") (hm-tv "y"))))))
|
||||
(len (hm-ftv-env env))) 2)
|
||||
|
||||
;; ── Substitution / apply / compose ───────────────────────────────
|
||||
(ghm-test "apply-tv"
|
||||
(hm-apply (assoc {} "a" (hm-int)) (hm-tv "a")) (hm-int))
|
||||
(ghm-test "apply-arrow"
|
||||
(ctor-head
|
||||
(hm-apply (assoc {} "a" (hm-int))
|
||||
(hm-arrow (hm-tv "a") (hm-tv "b")))) "->")
|
||||
(ghm-test "compose-1-then-2"
|
||||
(var-name
|
||||
(hm-apply
|
||||
(hm-compose (assoc {} "b" (hm-tv "c")) (assoc {} "a" (hm-tv "b")))
|
||||
(hm-tv "a"))) "c")
|
||||
|
||||
;; ── Generalize / Instantiate ─────────────────────────────────────
|
||||
;; forall a. a -> a instantiated twice yields fresh vars each time
|
||||
(ghm-test "generalize-id"
|
||||
(len (hm-scheme-vars (hm-generalize (hm-arrow (hm-tv "a") (hm-tv "a")) {}))) 1)
|
||||
|
||||
(ghm-test "generalize-skips-env"
|
||||
;; ftv(t)={a,b}, ftv(env)={a}, qs={b}
|
||||
(let ((env (assoc {} "x" (hm-monotype (hm-tv "a")))))
|
||||
(len (hm-scheme-vars
|
||||
(hm-generalize (hm-arrow (hm-tv "a") (hm-tv "b")) env)))) 1)
|
||||
|
||||
(ghm-test "instantiate-fresh"
|
||||
(let ((s (hm-scheme (list "a") (hm-arrow (hm-tv "a") (hm-tv "a"))))
|
||||
(c (list 0)))
|
||||
(let ((t1 (hm-instantiate s c)) (t2 (hm-instantiate s c)))
|
||||
(not (= (var-name (first (ctor-args t1)))
|
||||
(var-name (first (ctor-args t2)))))))
|
||||
true)
|
||||
|
||||
;; ── Inference (literal only) ─────────────────────────────────────
|
||||
(ghm-test "infer-int"
|
||||
(ctor-head (get (hm-infer-literal (ast-literal 42)) :type)) "Int")
|
||||
(ghm-test "infer-string"
|
||||
(ctor-head (get (hm-infer-literal (ast-literal "hi")) :type)) "String")
|
||||
(ghm-test "infer-bool"
|
||||
(ctor-head (get (hm-infer-literal (ast-literal true)) :type)) "Bool")
|
||||
|
||||
(define ghm-tests-run!
|
||||
(fn ()
|
||||
{:passed ghm-test-pass
|
||||
:failed ghm-test-fail
|
||||
:total (+ ghm-test-pass ghm-test-fail)}))
|
||||
@@ -1,180 +0,0 @@
|
||||
;; lib/guest/tests/layout.sx — synthetic Python-ish off-side fixture.
|
||||
;;
|
||||
;; Exercises lib/guest/layout.sx with a config different from Haskell's
|
||||
;; (no module-prelude, layout opens via trailing `:` not via reserved
|
||||
;; keyword) to prove the kit isn't Haskell-shaped.
|
||||
|
||||
(define glayout-test-pass 0)
|
||||
(define glayout-test-fail 0)
|
||||
(define glayout-test-fails (list))
|
||||
|
||||
(define
|
||||
glayout-test
|
||||
(fn (name actual expected)
|
||||
(if (= actual expected)
|
||||
(set! glayout-test-pass (+ glayout-test-pass 1))
|
||||
(begin
|
||||
(set! glayout-test-fail (+ glayout-test-fail 1))
|
||||
(append! glayout-test-fails {:name name :expected expected :actual actual})))))
|
||||
|
||||
;; Convenience: build a token from {type value line col}.
|
||||
(define
|
||||
glayout-tok
|
||||
(fn (ty val line col)
|
||||
{:type ty :value val :line line :col col}))
|
||||
|
||||
;; Project a token list to ((type value) ...) for compact comparison.
|
||||
(define
|
||||
glayout-shape
|
||||
(fn (toks)
|
||||
(map (fn (t) (list (get t :type) (get t :value))) toks)))
|
||||
|
||||
;; ── Haskell-flavour: keyword opens block ─────────────────────────
|
||||
(define
|
||||
glayout-haskell-cfg
|
||||
{:open-keywords (list "let" "where" "do" "of")
|
||||
:open-trailing-fn nil
|
||||
:open-token {:type "vlbrace" :value "{"}
|
||||
:close-token {:type "vrbrace" :value "}"}
|
||||
:sep-token {:type "vsemi" :value ";"}
|
||||
:module-prelude? false
|
||||
:explicit-open? (fn (tok) (= (get tok :type) "lbrace"))})
|
||||
|
||||
;; do
|
||||
;; a
|
||||
;; b
|
||||
;; c ← outside the do-block
|
||||
(glayout-test "haskell-do-block"
|
||||
(glayout-shape
|
||||
(layout-pass
|
||||
glayout-haskell-cfg
|
||||
(list (glayout-tok "reserved" "do" 1 1)
|
||||
(glayout-tok "ident" "a" 2 3)
|
||||
(glayout-tok "ident" "b" 3 3)
|
||||
(glayout-tok "ident" "c" 4 1))))
|
||||
(list (list "reserved" "do")
|
||||
(list "vlbrace" "{")
|
||||
(list "ident" "a")
|
||||
(list "vsemi" ";")
|
||||
(list "ident" "b")
|
||||
(list "vrbrace" "}")
|
||||
(list "ident" "c")))
|
||||
|
||||
;; Explicit `{` after `do` suppresses virtual layout.
|
||||
(glayout-test "haskell-explicit-brace"
|
||||
(glayout-shape
|
||||
(layout-pass
|
||||
glayout-haskell-cfg
|
||||
(list (glayout-tok "reserved" "do" 1 1)
|
||||
(glayout-tok "lbrace" "{" 1 4)
|
||||
(glayout-tok "ident" "a" 1 6)
|
||||
(glayout-tok "rbrace" "}" 1 8))))
|
||||
(list (list "reserved" "do")
|
||||
(list "lbrace" "{")
|
||||
(list "ident" "a")
|
||||
(list "rbrace" "}")))
|
||||
|
||||
;; Single-statement do-block on the same line.
|
||||
(glayout-test "haskell-do-inline"
|
||||
(glayout-shape
|
||||
(layout-pass
|
||||
glayout-haskell-cfg
|
||||
(list (glayout-tok "reserved" "do" 1 1)
|
||||
(glayout-tok "ident" "a" 1 4))))
|
||||
(list (list "reserved" "do")
|
||||
(list "vlbrace" "{")
|
||||
(list "ident" "a")
|
||||
(list "vrbrace" "}")))
|
||||
|
||||
;; Module-prelude: wrap whole input in implicit layout block at first
|
||||
;; tok's column.
|
||||
(glayout-test "haskell-module-prelude"
|
||||
(glayout-shape
|
||||
(layout-pass
|
||||
(assoc glayout-haskell-cfg :module-prelude? true)
|
||||
(list (glayout-tok "ident" "x" 1 1)
|
||||
(glayout-tok "ident" "y" 2 1)
|
||||
(glayout-tok "ident" "z" 3 1))))
|
||||
(list (list "vlbrace" "{")
|
||||
(list "ident" "x")
|
||||
(list "vsemi" ";")
|
||||
(list "ident" "y")
|
||||
(list "vsemi" ";")
|
||||
(list "ident" "z")
|
||||
(list "vrbrace" "}")))
|
||||
|
||||
;; ── Python-flavour: trailing `:` opens block ─────────────────────
|
||||
(define
|
||||
glayout-python-cfg
|
||||
{:open-keywords (list)
|
||||
:open-trailing-fn (fn (tok) (and (= (get tok :type) "punct")
|
||||
(= (get tok :value) ":")))
|
||||
:open-token {:type "indent" :value "INDENT"}
|
||||
:close-token {:type "dedent" :value "DEDENT"}
|
||||
:sep-token {:type "newline" :value "NEWLINE"}
|
||||
:module-prelude? false
|
||||
:explicit-open? nil})
|
||||
|
||||
;; if x:
|
||||
;; a
|
||||
;; b
|
||||
;; c
|
||||
(glayout-test "python-if-block"
|
||||
(glayout-shape
|
||||
(layout-pass
|
||||
glayout-python-cfg
|
||||
(list (glayout-tok "reserved" "if" 1 1)
|
||||
(glayout-tok "ident" "x" 1 4)
|
||||
(glayout-tok "punct" ":" 1 5)
|
||||
(glayout-tok "ident" "a" 2 5)
|
||||
(glayout-tok "ident" "b" 3 5)
|
||||
(glayout-tok "ident" "c" 4 1))))
|
||||
(list (list "reserved" "if")
|
||||
(list "ident" "x")
|
||||
(list "punct" ":")
|
||||
(list "indent" "INDENT")
|
||||
(list "ident" "a")
|
||||
(list "newline" "NEWLINE")
|
||||
(list "ident" "b")
|
||||
(list "dedent" "DEDENT")
|
||||
(list "ident" "c")))
|
||||
|
||||
;; Nested Python-style blocks.
|
||||
;; def f():
|
||||
;; if x:
|
||||
;; a
|
||||
;; b
|
||||
(glayout-test "python-nested"
|
||||
(glayout-shape
|
||||
(layout-pass
|
||||
glayout-python-cfg
|
||||
(list (glayout-tok "reserved" "def" 1 1)
|
||||
(glayout-tok "ident" "f" 1 5)
|
||||
(glayout-tok "punct" "(" 1 6)
|
||||
(glayout-tok "punct" ")" 1 7)
|
||||
(glayout-tok "punct" ":" 1 8)
|
||||
(glayout-tok "reserved" "if" 2 5)
|
||||
(glayout-tok "ident" "x" 2 8)
|
||||
(glayout-tok "punct" ":" 2 9)
|
||||
(glayout-tok "ident" "a" 3 9)
|
||||
(glayout-tok "ident" "b" 4 5))))
|
||||
(list (list "reserved" "def")
|
||||
(list "ident" "f")
|
||||
(list "punct" "(")
|
||||
(list "punct" ")")
|
||||
(list "punct" ":")
|
||||
(list "indent" "INDENT")
|
||||
(list "reserved" "if")
|
||||
(list "ident" "x")
|
||||
(list "punct" ":")
|
||||
(list "indent" "INDENT")
|
||||
(list "ident" "a")
|
||||
(list "dedent" "DEDENT")
|
||||
(list "ident" "b")
|
||||
(list "dedent" "DEDENT")))
|
||||
|
||||
(define glayout-tests-run!
|
||||
(fn ()
|
||||
{:passed glayout-test-pass
|
||||
:failed glayout-test-fail
|
||||
:total (+ glayout-test-pass glayout-test-fail)}))
|
||||
@@ -14,8 +14,6 @@ PRELOADS=(
|
||||
lib/haskell/runtime.sx
|
||||
lib/haskell/match.sx
|
||||
lib/haskell/eval.sx
|
||||
lib/haskell/map.sx
|
||||
lib/haskell/set.sx
|
||||
lib/haskell/testlib.sx
|
||||
)
|
||||
|
||||
@@ -38,24 +36,6 @@ SUITES=(
|
||||
"matrix:lib/haskell/tests/program-matrix.sx"
|
||||
"wordcount:lib/haskell/tests/program-wordcount.sx"
|
||||
"powers:lib/haskell/tests/program-powers.sx"
|
||||
"caesar:lib/haskell/tests/program-caesar.sx"
|
||||
"runlength-str:lib/haskell/tests/program-runlength-str.sx"
|
||||
"showadt:lib/haskell/tests/program-showadt.sx"
|
||||
"showio:lib/haskell/tests/program-showio.sx"
|
||||
"partial:lib/haskell/tests/program-partial.sx"
|
||||
"statistics:lib/haskell/tests/program-statistics.sx"
|
||||
"newton:lib/haskell/tests/program-newton.sx"
|
||||
"wordfreq:lib/haskell/tests/program-wordfreq.sx"
|
||||
"mapgraph:lib/haskell/tests/program-mapgraph.sx"
|
||||
"uniquewords:lib/haskell/tests/program-uniquewords.sx"
|
||||
"setops:lib/haskell/tests/program-setops.sx"
|
||||
"shapes:lib/haskell/tests/program-shapes.sx"
|
||||
"person:lib/haskell/tests/program-person.sx"
|
||||
"config:lib/haskell/tests/program-config.sx"
|
||||
"counter:lib/haskell/tests/program-counter.sx"
|
||||
"accumulate:lib/haskell/tests/program-accumulate.sx"
|
||||
"safediv:lib/haskell/tests/program-safediv.sx"
|
||||
"trycatch:lib/haskell/tests/program-trycatch.sx"
|
||||
)
|
||||
|
||||
emit_scoreboard_json() {
|
||||
|
||||
@@ -131,280 +131,119 @@
|
||||
(let
|
||||
((tag (first node)))
|
||||
(cond
|
||||
;; Transformations
|
||||
((= tag "where")
|
||||
(list
|
||||
:let (map hk-desugar (nth node 2))
|
||||
:let
|
||||
(map hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 1))))
|
||||
((= tag "guarded") (hk-guards-to-if (nth node 1)))
|
||||
((= tag "list-comp")
|
||||
(hk-lc-desugar (hk-desugar (nth node 1)) (nth node 2)))
|
||||
(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 "p-rec")
|
||||
(let
|
||||
((cname (nth node 1))
|
||||
(field-pats (nth node 2))
|
||||
(field-order (hk-record-field-names cname)))
|
||||
(cond
|
||||
((nil? field-order)
|
||||
(raise (str "p-rec: no record info for " cname)))
|
||||
(:else
|
||||
(list
|
||||
:p-con
|
||||
cname
|
||||
(map
|
||||
(fn
|
||||
(fname)
|
||||
(let
|
||||
((p (hk-find-rec-pair field-pats fname)))
|
||||
(cond
|
||||
((nil? p) (list :p-wild))
|
||||
(:else (hk-desugar (nth p 1))))))
|
||||
field-order))))))
|
||||
((= tag "rec-update")
|
||||
(list
|
||||
:rec-update
|
||||
:app
|
||||
(hk-desugar (nth node 1))
|
||||
(map
|
||||
(fn (p) (list (first p) (hk-desugar (nth p 1))))
|
||||
(nth node 2))))
|
||||
((= tag "rec-create")
|
||||
(let
|
||||
((cname (nth node 1))
|
||||
(field-pairs (nth node 2))
|
||||
(field-order (hk-record-field-names cname)))
|
||||
(cond
|
||||
((nil? field-order)
|
||||
(raise (str "rec-create: no record info for " cname)))
|
||||
(:else
|
||||
(let
|
||||
((acc (list :con cname)))
|
||||
(begin
|
||||
(for-each
|
||||
(fn
|
||||
(fname)
|
||||
(let
|
||||
((pair
|
||||
(hk-find-rec-pair field-pairs fname)))
|
||||
(cond
|
||||
((nil? pair)
|
||||
(raise
|
||||
(str
|
||||
"rec-create: missing field "
|
||||
fname
|
||||
" for "
|
||||
cname)))
|
||||
(:else
|
||||
(set!
|
||||
acc
|
||||
(list
|
||||
:app
|
||||
acc
|
||||
(hk-desugar (nth pair 1))))))))
|
||||
field-order)
|
||||
acc))))))
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "op")
|
||||
(list
|
||||
:op (nth node 1)
|
||||
:op
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "neg") (list :neg (hk-desugar (nth node 1))))
|
||||
((= tag "if")
|
||||
(list
|
||||
:if (hk-desugar (nth node 1))
|
||||
:if
|
||||
(hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "tuple") (list :tuple (map hk-desugar (nth node 1))))
|
||||
((= tag "list") (list :list (map hk-desugar (nth node 1))))
|
||||
((= tag "tuple")
|
||||
(list :tuple (map hk-desugar (nth node 1))))
|
||||
((= tag "list")
|
||||
(list :list (map hk-desugar (nth node 1))))
|
||||
((= tag "range")
|
||||
(list
|
||||
:range (hk-desugar (nth node 1))
|
||||
:range
|
||||
(hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "range-step")
|
||||
(list
|
||||
:range-step (hk-desugar (nth node 1))
|
||||
:range-step
|
||||
(hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "lambda")
|
||||
(list :lambda (nth node 1) (hk-desugar (nth node 2))))
|
||||
(list
|
||||
:lambda
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "let")
|
||||
(list
|
||||
:let (map hk-desugar (nth node 1))
|
||||
:let
|
||||
(map hk-desugar (nth node 1))
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "case")
|
||||
(list
|
||||
:case (hk-desugar (nth node 1))
|
||||
:case
|
||||
(hk-desugar (nth node 1))
|
||||
(map hk-desugar (nth node 2))))
|
||||
((= tag "alt")
|
||||
(list :alt (hk-desugar (nth node 1)) (hk-desugar (nth node 2))))
|
||||
(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))))
|
||||
(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))))
|
||||
(list
|
||||
:sect-right
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
|
||||
;; Top-level
|
||||
((= tag "program")
|
||||
(list :program (map hk-desugar (hk-expand-records (nth node 1)))))
|
||||
(list :program (map hk-desugar (nth node 1))))
|
||||
((= tag "module")
|
||||
(list
|
||||
:module (nth node 1)
|
||||
:module
|
||||
(nth node 1)
|
||||
(nth node 2)
|
||||
(nth node 3)
|
||||
(map hk-desugar (hk-expand-records (nth node 4)))))
|
||||
(map hk-desugar (nth node 4))))
|
||||
|
||||
;; Decls carrying a body
|
||||
((= tag "fun-clause")
|
||||
(list
|
||||
:fun-clause (nth node 1)
|
||||
(map hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "instance-decl")
|
||||
(list
|
||||
:instance-decl (nth node 1)
|
||||
:fun-clause
|
||||
(nth node 1)
|
||||
(nth node 2)
|
||||
(map hk-desugar (nth node 3))))
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "pat-bind")
|
||||
(list :pat-bind (nth node 1) (hk-desugar (nth node 2))))
|
||||
(list
|
||||
:pat-bind
|
||||
(nth node 1)
|
||||
(hk-desugar (nth node 2))))
|
||||
((= tag "bind")
|
||||
(list :bind (nth node 1) (hk-desugar (nth node 2))))
|
||||
(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-record-fields (dict))
|
||||
(define
|
||||
hk-core
|
||||
(fn (src) (hk-desugar (hk-parse-top src))))
|
||||
|
||||
(define
|
||||
hk-register-record-fields!
|
||||
(fn (cname fields) (dict-set! hk-record-fields cname fields)))
|
||||
|
||||
(define
|
||||
hk-record-field-names
|
||||
(fn
|
||||
(cname)
|
||||
(if (has-key? hk-record-fields cname) (get hk-record-fields cname) nil)))
|
||||
|
||||
(define
|
||||
hk-record-field-index
|
||||
(fn
|
||||
(cname fname)
|
||||
(let
|
||||
((fields (hk-record-field-names cname)))
|
||||
(cond
|
||||
((nil? fields) -1)
|
||||
(:else
|
||||
(let
|
||||
((i 0) (idx -1))
|
||||
(begin
|
||||
(for-each
|
||||
(fn
|
||||
(f)
|
||||
(begin (when (= f fname) (set! idx i)) (set! i (+ i 1))))
|
||||
fields)
|
||||
idx)))))))
|
||||
|
||||
(define
|
||||
hk-find-rec-pair
|
||||
(fn
|
||||
(pairs name)
|
||||
(cond
|
||||
((empty? pairs) nil)
|
||||
((= (first (first pairs)) name) (first pairs))
|
||||
(:else (hk-find-rec-pair (rest pairs) name)))))
|
||||
|
||||
(define
|
||||
hk-record-accessors
|
||||
(fn
|
||||
(cname rec-fields)
|
||||
(let
|
||||
((n (len rec-fields)) (i 0) (out (list)))
|
||||
(define
|
||||
hk-ra-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i n)
|
||||
(let
|
||||
((field (nth rec-fields i)))
|
||||
(let
|
||||
((fname (first field)) (j 0) (pats (list)))
|
||||
(define
|
||||
hk-pat-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< j n)
|
||||
(begin
|
||||
(append!
|
||||
pats
|
||||
(if
|
||||
(= j i)
|
||||
(list "p-var" "__rec_field")
|
||||
(list "p-wild")))
|
||||
(set! j (+ j 1))
|
||||
(hk-pat-loop)))))
|
||||
(hk-pat-loop)
|
||||
(append!
|
||||
out
|
||||
(list
|
||||
"fun-clause"
|
||||
fname
|
||||
(list (list "p-con" cname pats))
|
||||
(list "var" "__rec_field")))
|
||||
(set! i (+ i 1))
|
||||
(hk-ra-loop))))))
|
||||
(hk-ra-loop)
|
||||
out)))
|
||||
|
||||
(define
|
||||
hk-expand-records
|
||||
(fn
|
||||
(decls)
|
||||
(let
|
||||
((out (list)))
|
||||
(for-each
|
||||
(fn
|
||||
(d)
|
||||
(cond
|
||||
((and (list? d) (= (first d) "data"))
|
||||
(let
|
||||
((dname (nth d 1))
|
||||
(tvars (nth d 2))
|
||||
(cons-list (nth d 3))
|
||||
(deriving (if (> (len d) 4) (nth d 4) (list)))
|
||||
(new-cons (list))
|
||||
(accessors (list)))
|
||||
(begin
|
||||
(for-each
|
||||
(fn
|
||||
(c)
|
||||
(cond
|
||||
((= (first c) "con-rec")
|
||||
(let
|
||||
((cname (nth c 1)) (rec-fields (nth c 2)))
|
||||
(begin
|
||||
(hk-register-record-fields!
|
||||
cname
|
||||
(map (fn (f) (first f)) rec-fields))
|
||||
(append!
|
||||
new-cons
|
||||
(list
|
||||
"con-def"
|
||||
cname
|
||||
(map (fn (f) (nth f 1)) rec-fields)))
|
||||
(for-each
|
||||
(fn (a) (append! accessors a))
|
||||
(hk-record-accessors cname rec-fields)))))
|
||||
(:else (append! new-cons c))))
|
||||
cons-list)
|
||||
(append!
|
||||
out
|
||||
(if
|
||||
(empty? deriving)
|
||||
(list "data" dname tvars new-cons)
|
||||
(list "data" dname tvars new-cons deriving)))
|
||||
(for-each (fn (a) (append! out a)) accessors))))
|
||||
(:else (append! out d))))
|
||||
decls)
|
||||
out)))
|
||||
|
||||
(define hk-core (fn (src) (hk-desugar (hk-parse-top src))))
|
||||
|
||||
(define hk-core-expr (fn (src) (hk-desugar (hk-parse src))))
|
||||
hk-core-expr
|
||||
(fn (src) (hk-desugar (hk-parse src))))
|
||||
|
||||
1023
lib/haskell/eval.sx
1023
lib/haskell/eval.sx
File diff suppressed because one or more lines are too long
@@ -1,520 +0,0 @@
|
||||
;; map.sx — Phase 11 Data.Map: weight-balanced BST in pure SX.
|
||||
;;
|
||||
;; Algorithm: Adams's weight-balanced tree (the same family as Haskell's
|
||||
;; Data.Map). Each node tracks its size; rotations maintain the invariant
|
||||
;;
|
||||
;; size(small-side) * delta >= size(large-side) (delta = 3)
|
||||
;;
|
||||
;; with single or double rotations chosen by the gamma ratio (gamma = 2).
|
||||
;; The size field is an Int and is included so `size`, `lookup`, etc. are
|
||||
;; O(log n) on both extremes of the tree.
|
||||
;;
|
||||
;; Representation:
|
||||
;; Empty → ("Map-Empty")
|
||||
;; Node → ("Map-Node" key val left right size)
|
||||
;;
|
||||
;; All operations are pure SX — no mutation of nodes once constructed.
|
||||
;; The user-facing Haskell layer (Phase 11 next iteration) wraps these
|
||||
;; for `import Data.Map as Map`.
|
||||
|
||||
;; ── Constructors ────────────────────────────────────────────
|
||||
(define hk-map-empty (list "Map-Empty"))
|
||||
|
||||
(define
|
||||
hk-map-node
|
||||
(fn
|
||||
(k v l r)
|
||||
(list "Map-Node" k v l r (+ 1 (+ (hk-map-size l) (hk-map-size r))))))
|
||||
|
||||
;; ── Predicates and accessors ────────────────────────────────
|
||||
(define hk-map-empty? (fn (m) (and (list? m) (= (first m) "Map-Empty"))))
|
||||
|
||||
(define hk-map-node? (fn (m) (and (list? m) (= (first m) "Map-Node"))))
|
||||
|
||||
(define
|
||||
hk-map-size
|
||||
(fn (m) (cond ((hk-map-empty? m) 0) (:else (nth m 5)))))
|
||||
|
||||
(define hk-map-key (fn (m) (nth m 1)))
|
||||
(define hk-map-val (fn (m) (nth m 2)))
|
||||
(define hk-map-left (fn (m) (nth m 3)))
|
||||
(define hk-map-right (fn (m) (nth m 4)))
|
||||
|
||||
;; ── Weight-balanced rotations ───────────────────────────────
|
||||
;; delta and gamma per Adams 1992 / Haskell Data.Map.
|
||||
|
||||
(define hk-map-delta 3)
|
||||
(define hk-map-gamma 2)
|
||||
|
||||
(define
|
||||
hk-map-single-l
|
||||
(fn
|
||||
(k v l r)
|
||||
(let
|
||||
((rk (hk-map-key r))
|
||||
(rv (hk-map-val r))
|
||||
(rl (hk-map-left r))
|
||||
(rr (hk-map-right r)))
|
||||
(hk-map-node rk rv (hk-map-node k v l rl) rr))))
|
||||
|
||||
(define
|
||||
hk-map-single-r
|
||||
(fn
|
||||
(k v l r)
|
||||
(let
|
||||
((lk (hk-map-key l))
|
||||
(lv (hk-map-val l))
|
||||
(ll (hk-map-left l))
|
||||
(lr (hk-map-right l)))
|
||||
(hk-map-node lk lv ll (hk-map-node k v lr r)))))
|
||||
|
||||
(define
|
||||
hk-map-double-l
|
||||
(fn
|
||||
(k v l r)
|
||||
(let
|
||||
((rk (hk-map-key r))
|
||||
(rv (hk-map-val r))
|
||||
(rl (hk-map-left r))
|
||||
(rr (hk-map-right r))
|
||||
(rlk (hk-map-key (hk-map-left r)))
|
||||
(rlv (hk-map-val (hk-map-left r)))
|
||||
(rll (hk-map-left (hk-map-left r)))
|
||||
(rlr (hk-map-right (hk-map-left r))))
|
||||
(hk-map-node
|
||||
rlk
|
||||
rlv
|
||||
(hk-map-node k v l rll)
|
||||
(hk-map-node rk rv rlr rr)))))
|
||||
|
||||
(define
|
||||
hk-map-double-r
|
||||
(fn
|
||||
(k v l r)
|
||||
(let
|
||||
((lk (hk-map-key l))
|
||||
(lv (hk-map-val l))
|
||||
(ll (hk-map-left l))
|
||||
(lr (hk-map-right l))
|
||||
(lrk (hk-map-key (hk-map-right l)))
|
||||
(lrv (hk-map-val (hk-map-right l)))
|
||||
(lrl (hk-map-left (hk-map-right l)))
|
||||
(lrr (hk-map-right (hk-map-right l))))
|
||||
(hk-map-node
|
||||
lrk
|
||||
lrv
|
||||
(hk-map-node lk lv ll lrl)
|
||||
(hk-map-node k v lrr r)))))
|
||||
|
||||
;; ── Balanced node constructor ──────────────────────────────
|
||||
;; Use this in place of hk-map-node when one side may have grown
|
||||
;; or shrunk by one and we need to restore the weight invariant.
|
||||
(define
|
||||
hk-map-balance
|
||||
(fn
|
||||
(k v l r)
|
||||
(let
|
||||
((sl (hk-map-size l)) (sr (hk-map-size r)))
|
||||
(cond
|
||||
((<= (+ sl sr) 1) (hk-map-node k v l r))
|
||||
((> sr (* hk-map-delta sl))
|
||||
(let
|
||||
((rl (hk-map-left r)) (rr (hk-map-right r)))
|
||||
(cond
|
||||
((< (hk-map-size rl) (* hk-map-gamma (hk-map-size rr)))
|
||||
(hk-map-single-l k v l r))
|
||||
(:else (hk-map-double-l k v l r)))))
|
||||
((> sl (* hk-map-delta sr))
|
||||
(let
|
||||
((ll (hk-map-left l)) (lr (hk-map-right l)))
|
||||
(cond
|
||||
((< (hk-map-size lr) (* hk-map-gamma (hk-map-size ll)))
|
||||
(hk-map-single-r k v l r))
|
||||
(:else (hk-map-double-r k v l r)))))
|
||||
(:else (hk-map-node k v l r))))))
|
||||
|
||||
(define
|
||||
hk-map-singleton
|
||||
(fn (k v) (hk-map-node k v hk-map-empty hk-map-empty)))
|
||||
|
||||
(define
|
||||
hk-map-insert
|
||||
(fn
|
||||
(k v m)
|
||||
(cond
|
||||
((hk-map-empty? m) (hk-map-singleton k v))
|
||||
(:else
|
||||
(let
|
||||
((mk (hk-map-key m)))
|
||||
(cond
|
||||
((< k mk)
|
||||
(hk-map-balance
|
||||
mk
|
||||
(hk-map-val m)
|
||||
(hk-map-insert k v (hk-map-left m))
|
||||
(hk-map-right m)))
|
||||
((> k mk)
|
||||
(hk-map-balance
|
||||
mk
|
||||
(hk-map-val m)
|
||||
(hk-map-left m)
|
||||
(hk-map-insert k v (hk-map-right m))))
|
||||
(:else (hk-map-node k v (hk-map-left m) (hk-map-right m)))))))))
|
||||
|
||||
(define
|
||||
hk-map-lookup
|
||||
(fn
|
||||
(k m)
|
||||
(cond
|
||||
((hk-map-empty? m) (list "Nothing"))
|
||||
(:else
|
||||
(let
|
||||
((mk (hk-map-key m)))
|
||||
(cond
|
||||
((< k mk) (hk-map-lookup k (hk-map-left m)))
|
||||
((> k mk) (hk-map-lookup k (hk-map-right m)))
|
||||
(:else (list "Just" (hk-map-val m)))))))))
|
||||
|
||||
(define
|
||||
hk-map-member
|
||||
(fn
|
||||
(k m)
|
||||
(cond
|
||||
((hk-map-empty? m) false)
|
||||
(:else
|
||||
(let
|
||||
((mk (hk-map-key m)))
|
||||
(cond
|
||||
((< k mk) (hk-map-member k (hk-map-left m)))
|
||||
((> k mk) (hk-map-member k (hk-map-right m)))
|
||||
(:else true)))))))
|
||||
|
||||
(define hk-map-null hk-map-empty?)
|
||||
|
||||
(define
|
||||
hk-map-find-min
|
||||
(fn
|
||||
(m)
|
||||
(cond
|
||||
((hk-map-empty? (hk-map-left m))
|
||||
(list (hk-map-key m) (hk-map-val m)))
|
||||
(:else (hk-map-find-min (hk-map-left m))))))
|
||||
|
||||
(define
|
||||
hk-map-delete-min
|
||||
(fn
|
||||
(m)
|
||||
(cond
|
||||
((hk-map-empty? (hk-map-left m)) (hk-map-right m))
|
||||
(:else
|
||||
(hk-map-balance
|
||||
(hk-map-key m)
|
||||
(hk-map-val m)
|
||||
(hk-map-delete-min (hk-map-left m))
|
||||
(hk-map-right m))))))
|
||||
|
||||
(define
|
||||
hk-map-find-max
|
||||
(fn
|
||||
(m)
|
||||
(cond
|
||||
((hk-map-empty? (hk-map-right m))
|
||||
(list (hk-map-key m) (hk-map-val m)))
|
||||
(:else (hk-map-find-max (hk-map-right m))))))
|
||||
|
||||
(define
|
||||
hk-map-delete-max
|
||||
(fn
|
||||
(m)
|
||||
(cond
|
||||
((hk-map-empty? (hk-map-right m)) (hk-map-left m))
|
||||
(:else
|
||||
(hk-map-balance
|
||||
(hk-map-key m)
|
||||
(hk-map-val m)
|
||||
(hk-map-left m)
|
||||
(hk-map-delete-max (hk-map-right m)))))))
|
||||
|
||||
(define
|
||||
hk-map-glue
|
||||
(fn
|
||||
(l r)
|
||||
(cond
|
||||
((hk-map-empty? l) r)
|
||||
((hk-map-empty? r) l)
|
||||
((> (hk-map-size l) (hk-map-size r))
|
||||
(let
|
||||
((mp (hk-map-find-max l)))
|
||||
(hk-map-balance (first mp) (nth mp 1) (hk-map-delete-max l) r)))
|
||||
(:else
|
||||
(let
|
||||
((mp (hk-map-find-min r)))
|
||||
(hk-map-balance (first mp) (nth mp 1) l (hk-map-delete-min r)))))))
|
||||
|
||||
(define
|
||||
hk-map-delete
|
||||
(fn
|
||||
(k m)
|
||||
(cond
|
||||
((hk-map-empty? m) m)
|
||||
(:else
|
||||
(let
|
||||
((mk (hk-map-key m)))
|
||||
(cond
|
||||
((< k mk)
|
||||
(hk-map-balance
|
||||
mk
|
||||
(hk-map-val m)
|
||||
(hk-map-delete k (hk-map-left m))
|
||||
(hk-map-right m)))
|
||||
((> k mk)
|
||||
(hk-map-balance
|
||||
mk
|
||||
(hk-map-val m)
|
||||
(hk-map-left m)
|
||||
(hk-map-delete k (hk-map-right m))))
|
||||
(:else (hk-map-glue (hk-map-left m) (hk-map-right m)))))))))
|
||||
|
||||
(define
|
||||
hk-map-from-list
|
||||
(fn
|
||||
(pairs)
|
||||
(reduce
|
||||
(fn (acc p) (hk-map-insert (first p) (nth p 1) acc))
|
||||
hk-map-empty
|
||||
pairs)))
|
||||
|
||||
(define
|
||||
hk-map-to-asc-list
|
||||
(fn
|
||||
(m)
|
||||
(cond
|
||||
((hk-map-empty? m) (list))
|
||||
(:else
|
||||
(append
|
||||
(hk-map-to-asc-list (hk-map-left m))
|
||||
(cons
|
||||
(list (hk-map-key m) (hk-map-val m))
|
||||
(hk-map-to-asc-list (hk-map-right m))))))))
|
||||
|
||||
(define hk-map-to-list hk-map-to-asc-list)
|
||||
|
||||
(define
|
||||
hk-map-keys
|
||||
(fn
|
||||
(m)
|
||||
(cond
|
||||
((hk-map-empty? m) (list))
|
||||
(:else
|
||||
(append
|
||||
(hk-map-keys (hk-map-left m))
|
||||
(cons (hk-map-key m) (hk-map-keys (hk-map-right m))))))))
|
||||
|
||||
(define
|
||||
hk-map-elems
|
||||
(fn
|
||||
(m)
|
||||
(cond
|
||||
((hk-map-empty? m) (list))
|
||||
(:else
|
||||
(append
|
||||
(hk-map-elems (hk-map-left m))
|
||||
(cons (hk-map-val m) (hk-map-elems (hk-map-right m))))))))
|
||||
|
||||
(define
|
||||
hk-map-union-with
|
||||
(fn
|
||||
(f m1 m2)
|
||||
(reduce
|
||||
(fn
|
||||
(acc p)
|
||||
(let
|
||||
((k (first p)) (v (nth p 1)))
|
||||
(let
|
||||
((look (hk-map-lookup k acc)))
|
||||
(cond
|
||||
((= (first look) "Just")
|
||||
(hk-map-insert k (f (nth look 1) v) acc))
|
||||
(:else (hk-map-insert k v acc))))))
|
||||
m1
|
||||
(hk-map-to-asc-list m2))))
|
||||
|
||||
(define
|
||||
hk-map-intersection-with
|
||||
(fn
|
||||
(f m1 m2)
|
||||
(reduce
|
||||
(fn
|
||||
(acc p)
|
||||
(let
|
||||
((k (first p)) (v1 (nth p 1)))
|
||||
(let
|
||||
((look (hk-map-lookup k m2)))
|
||||
(cond
|
||||
((= (first look) "Just")
|
||||
(hk-map-insert k (f v1 (nth look 1)) acc))
|
||||
(:else acc)))))
|
||||
hk-map-empty
|
||||
(hk-map-to-asc-list m1))))
|
||||
|
||||
(define
|
||||
hk-map-difference
|
||||
(fn
|
||||
(m1 m2)
|
||||
(reduce
|
||||
(fn
|
||||
(acc p)
|
||||
(let
|
||||
((k (first p)) (v (nth p 1)))
|
||||
(cond ((hk-map-member k m2) acc) (:else (hk-map-insert k v acc)))))
|
||||
hk-map-empty
|
||||
(hk-map-to-asc-list m1))))
|
||||
|
||||
(define
|
||||
hk-map-foldl-with-key
|
||||
(fn
|
||||
(f acc m)
|
||||
(cond
|
||||
((hk-map-empty? m) acc)
|
||||
(:else
|
||||
(let
|
||||
((acc1 (hk-map-foldl-with-key f acc (hk-map-left m))))
|
||||
(let
|
||||
((acc2 (f acc1 (hk-map-key m) (hk-map-val m))))
|
||||
(hk-map-foldl-with-key f acc2 (hk-map-right m))))))))
|
||||
|
||||
(define
|
||||
hk-map-foldr-with-key
|
||||
(fn
|
||||
(f acc m)
|
||||
(cond
|
||||
((hk-map-empty? m) acc)
|
||||
(:else
|
||||
(let
|
||||
((acc1 (hk-map-foldr-with-key f acc (hk-map-right m))))
|
||||
(let
|
||||
((acc2 (f (hk-map-key m) (hk-map-val m) acc1)))
|
||||
(hk-map-foldr-with-key f acc2 (hk-map-left m))))))))
|
||||
|
||||
(define
|
||||
hk-map-map-with-key
|
||||
(fn
|
||||
(f m)
|
||||
(cond
|
||||
((hk-map-empty? m) m)
|
||||
(:else
|
||||
(list
|
||||
"Map-Node"
|
||||
(hk-map-key m)
|
||||
(f (hk-map-key m) (hk-map-val m))
|
||||
(hk-map-map-with-key f (hk-map-left m))
|
||||
(hk-map-map-with-key f (hk-map-right m))
|
||||
(hk-map-size m))))))
|
||||
|
||||
(define
|
||||
hk-map-filter-with-key
|
||||
(fn
|
||||
(p m)
|
||||
(hk-map-foldr-with-key
|
||||
(fn (k v acc) (cond ((p k v) (hk-map-insert k v acc)) (:else acc)))
|
||||
hk-map-empty
|
||||
m)))
|
||||
|
||||
(define
|
||||
hk-map-adjust
|
||||
(fn
|
||||
(f k m)
|
||||
(cond
|
||||
((hk-map-empty? m) m)
|
||||
(:else
|
||||
(let
|
||||
((mk (hk-map-key m)))
|
||||
(cond
|
||||
((< k mk)
|
||||
(hk-map-node
|
||||
mk
|
||||
(hk-map-val m)
|
||||
(hk-map-adjust f k (hk-map-left m))
|
||||
(hk-map-right m)))
|
||||
((> k mk)
|
||||
(hk-map-node
|
||||
mk
|
||||
(hk-map-val m)
|
||||
(hk-map-left m)
|
||||
(hk-map-adjust f k (hk-map-right m))))
|
||||
(:else
|
||||
(hk-map-node
|
||||
mk
|
||||
(f (hk-map-val m))
|
||||
(hk-map-left m)
|
||||
(hk-map-right m)))))))))
|
||||
|
||||
(define
|
||||
hk-map-insert-with
|
||||
(fn
|
||||
(f k v m)
|
||||
(cond
|
||||
((hk-map-empty? m) (hk-map-singleton k v))
|
||||
(:else
|
||||
(let
|
||||
((mk (hk-map-key m)))
|
||||
(cond
|
||||
((< k mk)
|
||||
(hk-map-balance
|
||||
mk
|
||||
(hk-map-val m)
|
||||
(hk-map-insert-with f k v (hk-map-left m))
|
||||
(hk-map-right m)))
|
||||
((> k mk)
|
||||
(hk-map-balance
|
||||
mk
|
||||
(hk-map-val m)
|
||||
(hk-map-left m)
|
||||
(hk-map-insert-with f k v (hk-map-right m))))
|
||||
(:else
|
||||
(hk-map-node
|
||||
mk
|
||||
(f v (hk-map-val m))
|
||||
(hk-map-left m)
|
||||
(hk-map-right m)))))))))
|
||||
|
||||
(define
|
||||
hk-map-insert-with-key
|
||||
(fn
|
||||
(f k v m)
|
||||
(cond
|
||||
((hk-map-empty? m) (hk-map-singleton k v))
|
||||
(:else
|
||||
(let
|
||||
((mk (hk-map-key m)))
|
||||
(cond
|
||||
((< k mk)
|
||||
(hk-map-balance
|
||||
mk
|
||||
(hk-map-val m)
|
||||
(hk-map-insert-with-key f k v (hk-map-left m))
|
||||
(hk-map-right m)))
|
||||
((> k mk)
|
||||
(hk-map-balance
|
||||
mk
|
||||
(hk-map-val m)
|
||||
(hk-map-left m)
|
||||
(hk-map-insert-with-key f k v (hk-map-right m))))
|
||||
(:else
|
||||
(hk-map-node
|
||||
mk
|
||||
(f k v (hk-map-val m))
|
||||
(hk-map-left m)
|
||||
(hk-map-right m)))))))))
|
||||
|
||||
(define
|
||||
hk-map-alter
|
||||
(fn
|
||||
(f k m)
|
||||
(let
|
||||
((look (hk-map-lookup k m)))
|
||||
(let
|
||||
((res (f look)))
|
||||
(cond
|
||||
((= (first res) "Nothing") (hk-map-delete k m))
|
||||
(:else (hk-map-insert k (nth res 1) m)))))))
|
||||
@@ -87,41 +87,45 @@
|
||||
((nil? res) nil)
|
||||
(:else (assoc res (nth pat 1) val)))))
|
||||
(:else
|
||||
(let
|
||||
((fv (hk-force val)))
|
||||
(let ((fv (hk-force val)))
|
||||
(cond
|
||||
((= tag "p-int")
|
||||
(if (and (number? fv) (= fv (nth pat 1))) env nil))
|
||||
(if
|
||||
(and (number? fv) (= fv (nth pat 1)))
|
||||
env
|
||||
nil))
|
||||
((= tag "p-float")
|
||||
(if (and (number? fv) (= fv (nth pat 1))) env nil))
|
||||
(if
|
||||
(and (number? fv) (= fv (nth pat 1)))
|
||||
env
|
||||
nil))
|
||||
((= tag "p-string")
|
||||
(if (and (string? fv) (= fv (nth pat 1))) env nil))
|
||||
(if
|
||||
(and (string? fv) (= fv (nth pat 1)))
|
||||
env
|
||||
nil))
|
||||
((= tag "p-char")
|
||||
(if (and (string? fv) (= fv (nth pat 1))) env nil))
|
||||
(if
|
||||
(and (string? fv) (= fv (nth pat 1)))
|
||||
env
|
||||
nil))
|
||||
((= tag "p-con")
|
||||
(let
|
||||
((pat-name (nth pat 1)) (pat-args (nth pat 2)))
|
||||
(cond
|
||||
((and (= pat-name ":") (hk-str? fv) (not (hk-str-null? fv)))
|
||||
(let
|
||||
((str-head (hk-str-head fv))
|
||||
(str-tail (hk-str-tail fv)))
|
||||
(let
|
||||
((head-pat (nth pat-args 0))
|
||||
(tail-pat (nth pat-args 1)))
|
||||
(let
|
||||
((res (hk-match head-pat str-head env)))
|
||||
(cond
|
||||
((nil? res) nil)
|
||||
(:else (hk-match tail-pat str-tail res)))))))
|
||||
((not (hk-is-con-val? fv)) nil)
|
||||
((not (= (hk-val-con-name fv) pat-name)) nil)
|
||||
(:else
|
||||
(let
|
||||
((val-args (hk-val-con-args fv)))
|
||||
(cond
|
||||
((not (= (len val-args) (len pat-args))) nil)
|
||||
(:else (hk-match-all pat-args val-args env))))))))
|
||||
((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)))
|
||||
@@ -130,8 +134,13 @@
|
||||
((not (= (hk-val-con-name fv) "Tuple")) nil)
|
||||
((not (= (len (hk-val-con-args fv)) (len items)))
|
||||
nil)
|
||||
(:else (hk-match-all items (hk-val-con-args fv) env)))))
|
||||
((= tag "p-list") (hk-match-list-pat (nth pat 1) fv env))
|
||||
(:else
|
||||
(hk-match-all
|
||||
items
|
||||
(hk-val-con-args fv)
|
||||
env)))))
|
||||
((= tag "p-list")
|
||||
(hk-match-list-pat (nth pat 1) fv env))
|
||||
(:else nil))))))))))
|
||||
|
||||
(define
|
||||
@@ -152,26 +161,17 @@
|
||||
hk-match-list-pat
|
||||
(fn
|
||||
(items val env)
|
||||
(let
|
||||
((fv (hk-force val)))
|
||||
(let ((fv (hk-force val)))
|
||||
(cond
|
||||
((empty? items)
|
||||
(if
|
||||
(or
|
||||
(and (hk-is-con-val? fv) (= (hk-val-con-name fv) "[]"))
|
||||
(and (hk-str? fv) (hk-str-null? fv)))
|
||||
(and
|
||||
(hk-is-con-val? fv)
|
||||
(= (hk-val-con-name fv) "[]"))
|
||||
env
|
||||
nil))
|
||||
(:else
|
||||
(cond
|
||||
((and (hk-str? fv) (not (hk-str-null? fv)))
|
||||
(let
|
||||
((h (hk-str-head fv)) (t (hk-str-tail fv)))
|
||||
(let
|
||||
((res (hk-match (first items) h env)))
|
||||
(cond
|
||||
((nil? res) nil)
|
||||
(:else (hk-match-list-pat (rest items) t res))))))
|
||||
((not (hk-is-con-val? fv)) nil)
|
||||
((not (= (hk-val-con-name fv) ":")) nil)
|
||||
(:else
|
||||
@@ -183,7 +183,11 @@
|
||||
((res (hk-match (first items) h env)))
|
||||
(cond
|
||||
((nil? res) nil)
|
||||
(:else (hk-match-list-pat (rest items) t res)))))))))))))
|
||||
(:else
|
||||
(hk-match-list-pat
|
||||
(rest items)
|
||||
t
|
||||
res)))))))))))))
|
||||
|
||||
;; ── Convenience: parse a pattern from source for tests ─────
|
||||
;; (Uses the parser's case-alt entry — `case _ of pat -> 0` —
|
||||
|
||||
@@ -208,19 +208,9 @@
|
||||
((= (get t "type") "char")
|
||||
(do (hk-advance!) (list :char (get t "value"))))
|
||||
((= (get t "type") "varid")
|
||||
(do
|
||||
(hk-advance!)
|
||||
(cond
|
||||
((hk-match? "lbrace" nil)
|
||||
(hk-parse-rec-update (list :var (get t "value"))))
|
||||
(:else (list :var (get t "value"))))))
|
||||
(do (hk-advance!) (list :var (get t "value"))))
|
||||
((= (get t "type") "conid")
|
||||
(do
|
||||
(hk-advance!)
|
||||
(cond
|
||||
((hk-match? "lbrace" nil)
|
||||
(hk-parse-rec-create (get t "value")))
|
||||
(:else (list :con (get t "value"))))))
|
||||
(do (hk-advance!) (list :con (get t "value"))))
|
||||
((= (get t "type") "qvarid")
|
||||
(do (hk-advance!) (list :var (get t "value"))))
|
||||
((= (get t "type") "qconid")
|
||||
@@ -466,90 +456,6 @@
|
||||
(do
|
||||
(hk-expect! "rbracket" nil)
|
||||
(list :list (list first-e))))))))))
|
||||
(define
|
||||
hk-parse-rec-create
|
||||
(fn
|
||||
(cname)
|
||||
(begin
|
||||
(hk-expect! "lbrace" nil)
|
||||
(let
|
||||
((fields (list)))
|
||||
(define
|
||||
hk-rc-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "varid" nil)
|
||||
(let
|
||||
((fname (get (hk-advance!) "value")))
|
||||
(begin
|
||||
(hk-expect! "reservedop" "=")
|
||||
(let
|
||||
((fexpr (hk-parse-expr-inner)))
|
||||
(begin
|
||||
(append! fields (list fname fexpr))
|
||||
(when
|
||||
(hk-match? "comma" nil)
|
||||
(begin (hk-advance!) (hk-rc-loop))))))))))
|
||||
(hk-rc-loop)
|
||||
(hk-expect! "rbrace" nil)
|
||||
(list :rec-create cname fields)))))
|
||||
(define
|
||||
hk-parse-rec-update
|
||||
(fn
|
||||
(rec-expr)
|
||||
(begin
|
||||
(hk-expect! "lbrace" nil)
|
||||
(let
|
||||
((fields (list)))
|
||||
(define
|
||||
hk-ru-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "varid" nil)
|
||||
(let
|
||||
((fname (get (hk-advance!) "value")))
|
||||
(begin
|
||||
(hk-expect! "reservedop" "=")
|
||||
(let
|
||||
((fexpr (hk-parse-expr-inner)))
|
||||
(begin
|
||||
(append! fields (list fname fexpr))
|
||||
(when
|
||||
(hk-match? "comma" nil)
|
||||
(begin (hk-advance!) (hk-ru-loop))))))))))
|
||||
(hk-ru-loop)
|
||||
(hk-expect! "rbrace" nil)
|
||||
(list :rec-update rec-expr fields)))))
|
||||
(define
|
||||
hk-parse-rec-pat
|
||||
(fn
|
||||
(cname)
|
||||
(begin
|
||||
(hk-expect! "lbrace" nil)
|
||||
(let
|
||||
((field-pats (list)))
|
||||
(define
|
||||
hk-rp-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "varid" nil)
|
||||
(let
|
||||
((fname (get (hk-advance!) "value")))
|
||||
(begin
|
||||
(hk-expect! "reservedop" "=")
|
||||
(let
|
||||
((fpat (hk-parse-pat)))
|
||||
(begin
|
||||
(append! field-pats (list fname fpat))
|
||||
(when
|
||||
(hk-match? "comma" nil)
|
||||
(begin (hk-advance!) (hk-rp-loop))))))))))
|
||||
(hk-rp-loop)
|
||||
(hk-expect! "rbrace" nil)
|
||||
(list :p-rec cname field-pats)))))
|
||||
(define
|
||||
hk-parse-fexp
|
||||
(fn
|
||||
@@ -790,12 +696,7 @@
|
||||
(:else
|
||||
(do (hk-advance!) (list :p-var (get t "value")))))))
|
||||
((= (get t "type") "conid")
|
||||
(do
|
||||
(hk-advance!)
|
||||
(cond
|
||||
((hk-match? "lbrace" nil)
|
||||
(hk-parse-rec-pat (get t "value")))
|
||||
(:else (list :p-con (get t "value") (list))))))
|
||||
(do (hk-advance!) (list :p-con (get t "value") (list))))
|
||||
((= (get t "type") "qconid")
|
||||
(do (hk-advance!) (list :p-con (get t "value") (list))))
|
||||
((= (get t "type") "lparen") (hk-parse-paren-pat))
|
||||
@@ -861,24 +762,16 @@
|
||||
(cond
|
||||
((and (not (nil? t)) (or (= (get t "type") "conid") (= (get t "type") "qconid")))
|
||||
(let
|
||||
((name (get (hk-advance!) "value")))
|
||||
(cond
|
||||
((hk-match? "lbrace" nil)
|
||||
(hk-parse-rec-pat name))
|
||||
(:else
|
||||
(let
|
||||
((args (list)))
|
||||
(define
|
||||
hk-pca-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-apat-start? (hk-peek))
|
||||
(do
|
||||
(append! args (hk-parse-apat))
|
||||
(hk-pca-loop)))))
|
||||
(hk-pca-loop)
|
||||
(list :p-con name args))))))
|
||||
((name (get (hk-advance!) "value")) (args (list)))
|
||||
(define
|
||||
hk-pca-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-apat-start? (hk-peek))
|
||||
(do (append! args (hk-parse-apat)) (hk-pca-loop)))))
|
||||
(hk-pca-loop)
|
||||
(list :p-con name args)))
|
||||
(:else (hk-parse-apat))))))
|
||||
(define
|
||||
hk-parse-pat
|
||||
@@ -1319,47 +1212,16 @@
|
||||
(not (hk-match? "conid" nil))
|
||||
(hk-err "expected constructor name"))
|
||||
(let
|
||||
((name (get (hk-advance!) "value")))
|
||||
(cond
|
||||
((hk-match? "lbrace" nil)
|
||||
(begin
|
||||
(hk-advance!)
|
||||
(let
|
||||
((rec-fields (list)))
|
||||
(define
|
||||
hk-rec-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "varid" nil)
|
||||
(let
|
||||
((fname (get (hk-advance!) "value")))
|
||||
(begin
|
||||
(hk-expect! "reservedop" "::")
|
||||
(let
|
||||
((ftype (hk-parse-type)))
|
||||
(begin
|
||||
(append! rec-fields (list fname ftype))
|
||||
(when
|
||||
(hk-match? "comma" nil)
|
||||
(begin (hk-advance!) (hk-rec-loop))))))))))
|
||||
(hk-rec-loop)
|
||||
(hk-expect! "rbrace" nil)
|
||||
(list :con-rec name rec-fields))))
|
||||
(:else
|
||||
(let
|
||||
((fields (list)))
|
||||
(define
|
||||
hk-cd-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-atype-start? (hk-peek))
|
||||
(begin
|
||||
(append! fields (hk-parse-atype))
|
||||
(hk-cd-loop)))))
|
||||
(hk-cd-loop)
|
||||
(list :con-def name fields)))))))
|
||||
((name (get (hk-advance!) "value")) (fields (list)))
|
||||
(define
|
||||
hk-cd-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-atype-start? (hk-peek))
|
||||
(do (append! fields (hk-parse-atype)) (hk-cd-loop)))))
|
||||
(hk-cd-loop)
|
||||
(list :con-def name fields))))
|
||||
(define
|
||||
hk-parse-tvars
|
||||
(fn
|
||||
|
||||
@@ -12,7 +12,12 @@
|
||||
|
||||
(define
|
||||
hk-register-con!
|
||||
(fn (cname arity type-name) (dict-set! hk-constructors cname {:arity arity :type type-name})))
|
||||
(fn
|
||||
(cname arity type-name)
|
||||
(dict-set!
|
||||
hk-constructors
|
||||
cname
|
||||
{:arity arity :type type-name})))
|
||||
|
||||
(define hk-is-con? (fn (name) (has-key? hk-constructors name)))
|
||||
|
||||
@@ -43,15 +48,26 @@
|
||||
(fn
|
||||
(data-node)
|
||||
(let
|
||||
((type-name (nth data-node 1)) (cons-list (nth data-node 3)))
|
||||
((type-name (nth data-node 1))
|
||||
(cons-list (nth data-node 3)))
|
||||
(for-each
|
||||
(fn (cd) (hk-register-con! (nth cd 1) (len (nth cd 2)) type-name))
|
||||
(fn
|
||||
(cd)
|
||||
(hk-register-con!
|
||||
(nth cd 1)
|
||||
(len (nth cd 2))
|
||||
type-name))
|
||||
cons-list))))
|
||||
|
||||
;; (:newtype NAME TVARS CNAME FIELD)
|
||||
(define
|
||||
hk-register-newtype!
|
||||
(fn (nt-node) (hk-register-con! (nth nt-node 3) 1 (nth nt-node 1))))
|
||||
(fn
|
||||
(nt-node)
|
||||
(hk-register-con!
|
||||
(nth nt-node 3)
|
||||
1
|
||||
(nth nt-node 1))))
|
||||
|
||||
;; Walk a decls list, registering every `data` / `newtype` decl.
|
||||
(define
|
||||
@@ -62,9 +78,15 @@
|
||||
(fn
|
||||
(d)
|
||||
(cond
|
||||
((and (list? d) (not (empty? d)) (= (first d) "data"))
|
||||
((and
|
||||
(list? d)
|
||||
(not (empty? d))
|
||||
(= (first d) "data"))
|
||||
(hk-register-data! d))
|
||||
((and (list? d) (not (empty? d)) (= (first d) "newtype"))
|
||||
((and
|
||||
(list? d)
|
||||
(not (empty? d))
|
||||
(= (first d) "newtype"))
|
||||
(hk-register-newtype! d))
|
||||
(:else nil)))
|
||||
decls)))
|
||||
@@ -77,12 +99,16 @@
|
||||
((nil? ast) nil)
|
||||
((not (list? ast)) nil)
|
||||
((empty? ast) nil)
|
||||
((= (first ast) "program") (hk-register-decls! (nth ast 1)))
|
||||
((= (first ast) "module") (hk-register-decls! (nth ast 4)))
|
||||
((= (first ast) "program")
|
||||
(hk-register-decls! (nth ast 1)))
|
||||
((= (first ast) "module")
|
||||
(hk-register-decls! (nth ast 4)))
|
||||
(:else nil))))
|
||||
|
||||
;; Convenience: source → AST → desugar → register.
|
||||
(define hk-load-source! (fn (src) (hk-register-program! (hk-core src))))
|
||||
(define
|
||||
hk-load-source!
|
||||
(fn (src) (hk-register-program! (hk-core src))))
|
||||
|
||||
;; ── Built-in constructors pre-registered ─────────────────────
|
||||
;; Bool — used implicitly by `if`, comparison operators.
|
||||
@@ -96,55 +122,9 @@
|
||||
;; Standard Prelude types — pre-registered so expression-level
|
||||
;; programs can use them without a `data` decl.
|
||||
(hk-register-con! "Nothing" 0 "Maybe")
|
||||
(hk-register-con! "Just" 1 "Maybe")
|
||||
(hk-register-con! "Left" 1 "Either")
|
||||
(hk-register-con! "Right" 1 "Either")
|
||||
(hk-register-con! "Just" 1 "Maybe")
|
||||
(hk-register-con! "Left" 1 "Either")
|
||||
(hk-register-con! "Right" 1 "Either")
|
||||
(hk-register-con! "LT" 0 "Ordering")
|
||||
(hk-register-con! "EQ" 0 "Ordering")
|
||||
(hk-register-con! "GT" 0 "Ordering")
|
||||
(hk-register-con! "SomeException" 1 "SomeException")
|
||||
|
||||
(define
|
||||
hk-str?
|
||||
(fn (v) (or (string? v) (and (dict? v) (has-key? v "hk-str")))))
|
||||
|
||||
(define
|
||||
hk-str-head
|
||||
(fn
|
||||
(v)
|
||||
(if
|
||||
(string? v)
|
||||
(char-code (char-at v 0))
|
||||
(char-code (char-at (get v "hk-str") (get v "hk-off"))))))
|
||||
|
||||
(define
|
||||
hk-str-tail
|
||||
(fn
|
||||
(v)
|
||||
(let
|
||||
((buf (if (string? v) v (get v "hk-str")))
|
||||
(off (if (string? v) 1 (+ (get v "hk-off") 1))))
|
||||
(if (>= off (string-length buf)) (list "[]") {:hk-off off :hk-str buf}))))
|
||||
|
||||
(define
|
||||
hk-str-null?
|
||||
(fn
|
||||
(v)
|
||||
(if
|
||||
(string? v)
|
||||
(= (string-length v) 0)
|
||||
(>= (get v "hk-off") (string-length (get v "hk-str"))))))
|
||||
|
||||
(define
|
||||
hk-str-to-native
|
||||
(fn
|
||||
(v)
|
||||
(if
|
||||
(string? v)
|
||||
v
|
||||
(let
|
||||
((buf (get v "hk-str")) (off (get v "hk-off")))
|
||||
(reduce
|
||||
(fn (acc i) (str acc (char-at buf i)))
|
||||
""
|
||||
(range off (string-length buf)))))))
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
{
|
||||
"date": "2026-05-08",
|
||||
"total_pass": 285,
|
||||
"date": "2026-05-06",
|
||||
"total_pass": 156,
|
||||
"total_fail": 0,
|
||||
"programs": {
|
||||
"fib": {"pass": 2, "fail": 0},
|
||||
@@ -9,7 +9,7 @@
|
||||
"nqueens": {"pass": 2, "fail": 0},
|
||||
"calculator": {"pass": 5, "fail": 0},
|
||||
"collatz": {"pass": 11, "fail": 0},
|
||||
"palindrome": {"pass": 12, "fail": 0},
|
||||
"palindrome": {"pass": 8, "fail": 0},
|
||||
"maybe": {"pass": 12, "fail": 0},
|
||||
"fizzbuzz": {"pass": 12, "fail": 0},
|
||||
"anagram": {"pass": 9, "fail": 0},
|
||||
@@ -19,25 +19,7 @@
|
||||
"primes": {"pass": 12, "fail": 0},
|
||||
"zipwith": {"pass": 9, "fail": 0},
|
||||
"matrix": {"pass": 8, "fail": 0},
|
||||
"wordcount": {"pass": 10, "fail": 0},
|
||||
"powers": {"pass": 14, "fail": 0},
|
||||
"caesar": {"pass": 8, "fail": 0},
|
||||
"runlength-str": {"pass": 9, "fail": 0},
|
||||
"showadt": {"pass": 5, "fail": 0},
|
||||
"showio": {"pass": 5, "fail": 0},
|
||||
"partial": {"pass": 7, "fail": 0},
|
||||
"statistics": {"pass": 5, "fail": 0},
|
||||
"newton": {"pass": 5, "fail": 0},
|
||||
"wordfreq": {"pass": 7, "fail": 0},
|
||||
"mapgraph": {"pass": 6, "fail": 0},
|
||||
"uniquewords": {"pass": 4, "fail": 0},
|
||||
"setops": {"pass": 8, "fail": 0},
|
||||
"shapes": {"pass": 5, "fail": 0},
|
||||
"person": {"pass": 7, "fail": 0},
|
||||
"config": {"pass": 10, "fail": 0},
|
||||
"counter": {"pass": 7, "fail": 0},
|
||||
"accumulate": {"pass": 8, "fail": 0},
|
||||
"safediv": {"pass": 8, "fail": 0},
|
||||
"trycatch": {"pass": 8, "fail": 0}
|
||||
"wordcount": {"pass": 7, "fail": 0},
|
||||
"powers": {"pass": 14, "fail": 0}
|
||||
}
|
||||
}
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
# Haskell-on-SX Scoreboard
|
||||
|
||||
Updated 2026-05-08 · Phase 6 (prelude extras + 18 programs)
|
||||
Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
|
||||
|
||||
| Program | Tests | Status |
|
||||
|---------|-------|--------|
|
||||
@@ -10,7 +10,7 @@ Updated 2026-05-08 · Phase 6 (prelude extras + 18 programs)
|
||||
| nqueens.hs | 2/2 | ✓ |
|
||||
| calculator.hs | 5/5 | ✓ |
|
||||
| collatz.hs | 11/11 | ✓ |
|
||||
| palindrome.hs | 12/12 | ✓ |
|
||||
| palindrome.hs | 8/8 | ✓ |
|
||||
| maybe.hs | 12/12 | ✓ |
|
||||
| fizzbuzz.hs | 12/12 | ✓ |
|
||||
| anagram.hs | 9/9 | ✓ |
|
||||
@@ -20,24 +20,6 @@ Updated 2026-05-08 · Phase 6 (prelude extras + 18 programs)
|
||||
| primes.hs | 12/12 | ✓ |
|
||||
| zipwith.hs | 9/9 | ✓ |
|
||||
| matrix.hs | 8/8 | ✓ |
|
||||
| wordcount.hs | 10/10 | ✓ |
|
||||
| wordcount.hs | 7/7 | ✓ |
|
||||
| powers.hs | 14/14 | ✓ |
|
||||
| caesar.hs | 8/8 | ✓ |
|
||||
| runlength-str.hs | 9/9 | ✓ |
|
||||
| showadt.hs | 5/5 | ✓ |
|
||||
| showio.hs | 5/5 | ✓ |
|
||||
| partial.hs | 7/7 | ✓ |
|
||||
| statistics.hs | 5/5 | ✓ |
|
||||
| newton.hs | 5/5 | ✓ |
|
||||
| wordfreq.hs | 7/7 | ✓ |
|
||||
| mapgraph.hs | 6/6 | ✓ |
|
||||
| uniquewords.hs | 4/4 | ✓ |
|
||||
| setops.hs | 8/8 | ✓ |
|
||||
| shapes.hs | 5/5 | ✓ |
|
||||
| person.hs | 7/7 | ✓ |
|
||||
| config.hs | 10/10 | ✓ |
|
||||
| counter.hs | 7/7 | ✓ |
|
||||
| accumulate.hs | 8/8 | ✓ |
|
||||
| safediv.hs | 8/8 | ✓ |
|
||||
| trycatch.hs | 8/8 | ✓ |
|
||||
| **Total** | **285/285** | **36/36 programs** |
|
||||
| **Total** | **156/156** | **18/18 programs** |
|
||||
|
||||
@@ -1,62 +0,0 @@
|
||||
;; set.sx — Phase 12 Data.Set: wraps Data.Map with unit values.
|
||||
;;
|
||||
;; A Set is a Map from key to (). All set operations delegate to the map
|
||||
;; ops, ignoring the value side. Storage representation matches Data.Map:
|
||||
;;
|
||||
;; Empty → ("Map-Empty")
|
||||
;; Node → ("Map-Node" key () left right size)
|
||||
;;
|
||||
;; Tradeoff: trivial maintenance burden, slight overhead per node from
|
||||
;; the unused value slot. Faster path forward than re-implementing the
|
||||
;; weight-balanced BST.
|
||||
;;
|
||||
;; Functions live in this file; the Haskell-level `import Data.Set` /
|
||||
;; `import qualified Data.Set as Set` wiring (next Phase 12 box) binds
|
||||
;; them under the chosen alias.
|
||||
|
||||
(define hk-set-unit (list "Tuple"))
|
||||
|
||||
(define hk-set-empty hk-map-empty)
|
||||
|
||||
(define hk-set-singleton (fn (k) (hk-map-singleton k hk-set-unit)))
|
||||
|
||||
(define hk-set-insert (fn (k s) (hk-map-insert k hk-set-unit s)))
|
||||
|
||||
(define hk-set-delete hk-map-delete)
|
||||
(define hk-set-member hk-map-member)
|
||||
(define hk-set-size hk-map-size)
|
||||
(define hk-set-null hk-map-null)
|
||||
(define hk-set-to-asc-list hk-map-keys)
|
||||
(define hk-set-to-list hk-map-keys)
|
||||
|
||||
(define
|
||||
hk-set-from-list
|
||||
(fn (xs) (reduce (fn (acc k) (hk-set-insert k acc)) hk-set-empty xs)))
|
||||
|
||||
(define
|
||||
hk-set-union
|
||||
(fn (a b) (hk-map-union-with (fn (x y) hk-set-unit) a b)))
|
||||
|
||||
(define
|
||||
hk-set-intersection
|
||||
(fn (a b) (hk-map-intersection-with (fn (x y) hk-set-unit) a b)))
|
||||
|
||||
(define hk-set-difference hk-map-difference)
|
||||
|
||||
(define
|
||||
hk-set-is-subset-of
|
||||
(fn (a b) (= (hk-map-size (hk-map-difference a b)) 0)))
|
||||
|
||||
(define
|
||||
hk-set-filter
|
||||
(fn (p s) (hk-map-filter-with-key (fn (k v) (p k)) s)))
|
||||
|
||||
(define hk-set-map (fn (f s) (hk-set-from-list (map f (hk-map-keys s)))))
|
||||
|
||||
(define
|
||||
hk-set-foldr
|
||||
(fn (f z s) (hk-map-foldr-with-key (fn (k v acc) (f k acc)) z s)))
|
||||
|
||||
(define
|
||||
hk-set-foldl
|
||||
(fn (f z s) (hk-map-foldl-with-key (fn (acc k v) (f acc k)) z s)))
|
||||
@@ -55,8 +55,6 @@ for FILE in "${FILES[@]}"; do
|
||||
(load "lib/haskell/runtime.sx")
|
||||
(load "lib/haskell/match.sx")
|
||||
(load "lib/haskell/eval.sx")
|
||||
(load "lib/haskell/map.sx")
|
||||
(load "lib/haskell/set.sx")
|
||||
$INFER_LOAD
|
||||
(load "lib/haskell/testlib.sx")
|
||||
(epoch 2)
|
||||
@@ -100,8 +98,6 @@ EPOCHS
|
||||
(load "lib/haskell/runtime.sx")
|
||||
(load "lib/haskell/match.sx")
|
||||
(load "lib/haskell/eval.sx")
|
||||
(load "lib/haskell/map.sx")
|
||||
(load "lib/haskell/set.sx")
|
||||
$INFER_LOAD
|
||||
(load "lib/haskell/testlib.sx")
|
||||
(epoch 2)
|
||||
|
||||
@@ -56,21 +56,3 @@
|
||||
(append!
|
||||
hk-test-fails
|
||||
{:actual actual :expected expected :name name})))))
|
||||
|
||||
(define
|
||||
hk-test-error
|
||||
(fn
|
||||
(name thunk expected-substring)
|
||||
(let
|
||||
((caught (guard (e (true (if (string? e) e (str e)))) (begin (thunk) nil))))
|
||||
(cond
|
||||
((nil? caught)
|
||||
(do
|
||||
(set! hk-test-fail (+ hk-test-fail 1))
|
||||
(append! hk-test-fails {:actual "no error raised" :expected (str "error containing: " expected-substring) :name name})))
|
||||
((>= (index-of caught expected-substring) 0)
|
||||
(set! hk-test-pass (+ hk-test-pass 1)))
|
||||
(:else
|
||||
(do
|
||||
(set! hk-test-fail (+ hk-test-fail 1))
|
||||
(append! hk-test-fails {:actual caught :expected (str "error containing: " expected-substring) :name name})))))))
|
||||
|
||||
@@ -1,86 +0,0 @@
|
||||
;; class-defaults.sx — Phase 13: class default method implementations.
|
||||
|
||||
;; ── Eq default: myNeq derived from myEq via `not (myEq x y)` ──
|
||||
(define
|
||||
hk-myeq-source
|
||||
"class MyEq a where\n myEq :: a -> a -> Bool\n myNeq :: a -> a -> Bool\n myNeq x y = not (myEq x y)\ninstance MyEq Int where\n myEq x y = x == y\n")
|
||||
|
||||
(hk-test
|
||||
"Eq default: myNeq 3 5 = True (no explicit myNeq in instance)"
|
||||
(hk-deep-force (hk-run (str hk-myeq-source "main = myNeq 3 5\n")))
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"Eq default: myNeq 3 3 = False"
|
||||
(hk-deep-force (hk-run (str hk-myeq-source "main = myNeq 3 3\n")))
|
||||
(list "False"))
|
||||
|
||||
(hk-test
|
||||
"Eq default: myEq still works in same instance"
|
||||
(hk-deep-force (hk-run (str hk-myeq-source "main = myEq 7 7\n")))
|
||||
(list "True"))
|
||||
|
||||
;; ── Override path: instance can still provide the method explicitly. ──
|
||||
(hk-test
|
||||
"Default override: instance-provided beats class default"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"class Hi a where\n greet :: a -> String\n greet x = \"default\"\ninstance Hi Bool where\n greet x = \"override\"\nmain = greet True"))
|
||||
"override")
|
||||
|
||||
(hk-test
|
||||
"Default fallback: empty instance picks default"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"class Hi a where\n greet :: a -> String\n greet x = \"default\"\ninstance Hi Bool where\nmain = greet True"))
|
||||
"default")
|
||||
|
||||
(define
|
||||
hk-myord-source
|
||||
"class MyOrd a where\n myCmp :: a -> a -> Bool\n myMax :: a -> a -> a\n myMin :: a -> a -> a\n myMax a b = if myCmp a b then a else b\n myMin a b = if myCmp a b then b else a\ninstance MyOrd Int where\n myCmp x y = x >= y\n")
|
||||
|
||||
(hk-test
|
||||
"Ord default: myMax 3 5 = 5"
|
||||
(hk-deep-force (hk-run (str hk-myord-source "main = myMax 3 5\n")))
|
||||
5)
|
||||
|
||||
(hk-test
|
||||
"Ord default: myMax 8 2 = 8"
|
||||
(hk-deep-force (hk-run (str hk-myord-source "main = myMax 8 2\n")))
|
||||
8)
|
||||
|
||||
(hk-test
|
||||
"Ord default: myMin 3 5 = 3"
|
||||
(hk-deep-force (hk-run (str hk-myord-source "main = myMin 3 5\n")))
|
||||
3)
|
||||
|
||||
(hk-test
|
||||
"Ord default: myMin 8 2 = 2"
|
||||
(hk-deep-force (hk-run (str hk-myord-source "main = myMin 8 2\n")))
|
||||
2)
|
||||
|
||||
(hk-test
|
||||
"Ord default: myMax of equals returns first"
|
||||
(hk-deep-force (hk-run (str hk-myord-source "main = myMax 4 4\n")))
|
||||
4)
|
||||
|
||||
(define
|
||||
hk-mynum-source
|
||||
"class MyNum a where\n mySub :: a -> a -> a\n myLt :: a -> a -> Bool\n myNegate :: a -> a\n myAbs :: a -> a\n myNegate x = mySub (mySub x x) x\n myAbs x = if myLt x (mySub x x) then myNegate x else x\ninstance MyNum Int where\n mySub x y = x - y\n myLt x y = x < y\n")
|
||||
|
||||
(hk-test
|
||||
"Num default: myNegate 5 = -5"
|
||||
(hk-deep-force (hk-run (str hk-mynum-source "main = myNegate 5\n")))
|
||||
-5)
|
||||
|
||||
(hk-test
|
||||
"Num default: myAbs (myNegate 7) = 7"
|
||||
(hk-deep-force (hk-run (str hk-mynum-source "main = myAbs (myNegate 7)\n")))
|
||||
7)
|
||||
|
||||
(hk-test
|
||||
"Num default: myAbs 9 = 9"
|
||||
(hk-deep-force (hk-run (str hk-mynum-source "main = myAbs 9\n")))
|
||||
9)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -12,14 +12,14 @@
|
||||
"deriving Show: constructor with arg"
|
||||
(hk-deep-force
|
||||
(hk-run "data Wrapper = Wrap Int deriving (Show)\nmain = show (Wrap 42)"))
|
||||
"Wrap 42")
|
||||
"(Wrap 42)")
|
||||
|
||||
(hk-test
|
||||
"deriving Show: nested constructors"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf Leaf)"))
|
||||
"Node 1 Leaf Leaf")
|
||||
"(Node 1 Leaf Leaf)")
|
||||
|
||||
(hk-test
|
||||
"deriving Show: second constructor"
|
||||
@@ -30,31 +30,6 @@
|
||||
|
||||
;; ─── Eq ──────────────────────────────────────────────────────────────────────
|
||||
|
||||
(hk-test
|
||||
"deriving Show: nested ADT wraps inner constructor in parens"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf (Node 2 Leaf Leaf))"))
|
||||
"Node 1 Leaf (Node 2 Leaf Leaf)")
|
||||
|
||||
(hk-test
|
||||
"deriving Show: Maybe Maybe wraps inner Just"
|
||||
(hk-deep-force (hk-run "main = show (Just (Just 3))"))
|
||||
"Just (Just 3)")
|
||||
|
||||
(hk-test
|
||||
"deriving Show: negative argument wrapped in parens"
|
||||
(hk-deep-force (hk-run "main = show (Just (negate 3))"))
|
||||
"Just (-3)")
|
||||
|
||||
(hk-test
|
||||
"deriving Show: list element does not need parens"
|
||||
(hk-deep-force
|
||||
(hk-run "data Box = Box [Int] deriving (Show)\nmain = show (Box [1,2,3])"))
|
||||
"Box [1,2,3]")
|
||||
|
||||
;; ─── combined Eq + Show ───────────────────────────────────────────────────────
|
||||
|
||||
(hk-test
|
||||
"deriving Eq: same constructor"
|
||||
(hk-deep-force
|
||||
@@ -83,12 +58,14 @@
|
||||
"data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Blue)"))
|
||||
"True")
|
||||
|
||||
;; ─── combined Eq + Show ───────────────────────────────────────────────────────
|
||||
|
||||
(hk-test
|
||||
"deriving Eq Show: combined"
|
||||
"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")
|
||||
"(Circle 5)")
|
||||
|
||||
(hk-test
|
||||
"deriving Eq Show: eq on constructor with arg"
|
||||
|
||||
@@ -1,99 +0,0 @@
|
||||
;; errors.sx — Phase 9 error / undefined / partial-fn coverage via hk-test-error.
|
||||
|
||||
;; ── error builtin ────────────────────────────────────────────
|
||||
(define
|
||||
hk-as-list
|
||||
(fn
|
||||
(xs)
|
||||
(cond
|
||||
((and (list? xs) (= (first xs) "[]")) (list))
|
||||
((and (list? xs) (= (first xs) ":"))
|
||||
(cons (nth xs 1) (hk-as-list (nth xs 2))))
|
||||
(:else xs))))
|
||||
|
||||
(hk-test-error
|
||||
"error: raises with literal message"
|
||||
(fn () (hk-deep-force (hk-run "main = error \"boom\"")))
|
||||
"hk-error: boom")
|
||||
|
||||
(hk-test-error
|
||||
"error: raises with computed message"
|
||||
(fn () (hk-deep-force (hk-run "main = error (\"oops: \" ++ show 42)")))
|
||||
"hk-error: oops: 42")
|
||||
|
||||
;; ── undefined ────────────────────────────────────────────────
|
||||
(hk-test-error
|
||||
"error: nested in if branch (only fires when forced)"
|
||||
(fn
|
||||
()
|
||||
(hk-deep-force (hk-run "main = if 1 == 1 then error \"taken\" else 0")))
|
||||
"taken")
|
||||
|
||||
(hk-test-error
|
||||
"undefined: raises Prelude.undefined"
|
||||
(fn () (hk-deep-force (hk-run "main = undefined")))
|
||||
"Prelude.undefined")
|
||||
|
||||
;; The non-strict path: undefined doesn't fire when not forced.
|
||||
(hk-test-error
|
||||
"undefined: forced via arithmetic"
|
||||
(fn () (hk-deep-force (hk-run "main = undefined + 1")))
|
||||
"Prelude.undefined")
|
||||
|
||||
;; ── partial functions ───────────────────────────────────────
|
||||
(hk-test
|
||||
"undefined: lazy, not forced when discarded"
|
||||
(hk-deep-force (hk-run "main = let _ = undefined in 5"))
|
||||
5)
|
||||
|
||||
(hk-test-error
|
||||
"head []: raises Prelude.head: empty list"
|
||||
(fn () (hk-deep-force (hk-run "main = head []")))
|
||||
"Prelude.head: empty list")
|
||||
|
||||
(hk-test-error
|
||||
"tail []: raises Prelude.tail: empty list"
|
||||
(fn () (hk-deep-force (hk-run "main = tail []")))
|
||||
"Prelude.tail: empty list")
|
||||
|
||||
;; head and tail still work on non-empty lists.
|
||||
(hk-test-error
|
||||
"fromJust Nothing: raises Maybe.fromJust: Nothing"
|
||||
(fn () (hk-deep-force (hk-run "main = fromJust Nothing")))
|
||||
"Maybe.fromJust: Nothing")
|
||||
|
||||
(hk-test
|
||||
"head [42]: still works"
|
||||
(hk-deep-force (hk-run "main = head [42]"))
|
||||
42)
|
||||
|
||||
;; ── error in IO context ─────────────────────────────────────
|
||||
(hk-test
|
||||
"tail [1,2,3]: still works"
|
||||
(hk-as-list (hk-deep-force (hk-run "main = tail [1,2,3]")))
|
||||
(list 2 3))
|
||||
|
||||
(hk-test
|
||||
"hk-run-io: error in main lands in io-lines"
|
||||
(let
|
||||
((lines (hk-run-io "main = error \"caught here\"")))
|
||||
(>= (index-of (str lines) "caught here") 0))
|
||||
true)
|
||||
|
||||
;; ── hk-test-error helper itself ─────────────────────────────
|
||||
(hk-test
|
||||
"hk-run-io: putStrLn before error preserves earlier output"
|
||||
(let
|
||||
((lines (hk-run-io "main = do { putStrLn \"first\"; error \"died\"; putStrLn \"never\" }")))
|
||||
(and
|
||||
(>= (index-of (str lines) "first") 0)
|
||||
(>= (index-of (str lines) "died") 0)))
|
||||
true)
|
||||
|
||||
;; hk-as-list helper for converting a forced Haskell cons into an SX list.
|
||||
(hk-test-error
|
||||
"hk-test-error: matches partial substring inside wrapped exception"
|
||||
(fn () (hk-deep-force (hk-run "main = error \"unique-marker-xyz\"")))
|
||||
"unique-marker-xyz")
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -231,82 +231,16 @@
|
||||
1)
|
||||
|
||||
;; ── Laziness: app args evaluate only when forced ──
|
||||
(hk-test
|
||||
"error builtin: raises with hk-error prefix"
|
||||
(guard
|
||||
(e (true (>= (index-of e "hk-error: boom") 0)))
|
||||
(begin (hk-deep-force (hk-run "main = error \"boom\"")) false))
|
||||
true)
|
||||
|
||||
(hk-test
|
||||
"error builtin: raises with computed message"
|
||||
(guard
|
||||
(e (true (>= (index-of e "hk-error: oops: 42") 0)))
|
||||
(begin
|
||||
(hk-deep-force (hk-run "main = error (\"oops: \" ++ show 42)"))
|
||||
false))
|
||||
true)
|
||||
|
||||
(hk-test
|
||||
"undefined: raises hk-error with Prelude.undefined message"
|
||||
(guard
|
||||
(e (true (>= (index-of e "hk-error: Prelude.undefined") 0)))
|
||||
(begin (hk-deep-force (hk-run "main = undefined")) false))
|
||||
true)
|
||||
|
||||
(hk-test
|
||||
"undefined: lazy — only fires when forced"
|
||||
(hk-deep-force (hk-run "main = if True then 42 else undefined"))
|
||||
42)
|
||||
|
||||
(hk-test
|
||||
"head []: raises Prelude.head: empty list"
|
||||
(guard
|
||||
(e (true (>= (index-of e "Prelude.head: empty list") 0)))
|
||||
(begin (hk-deep-force (hk-run "main = head []")) false))
|
||||
true)
|
||||
|
||||
(hk-test
|
||||
"tail []: raises Prelude.tail: empty list"
|
||||
(guard
|
||||
(e (true (>= (index-of e "Prelude.tail: empty list") 0)))
|
||||
(begin (hk-deep-force (hk-run "main = tail []")) false))
|
||||
true)
|
||||
|
||||
;; ── not / id built-ins ──
|
||||
(hk-test
|
||||
"fromJust Nothing: raises Maybe.fromJust: Nothing"
|
||||
(guard
|
||||
(e (true (>= (index-of e "Maybe.fromJust: Nothing") 0)))
|
||||
(begin (hk-deep-force (hk-run "main = fromJust Nothing")) false))
|
||||
true)
|
||||
(hk-test
|
||||
"fromJust (Just 5) = 5"
|
||||
(hk-deep-force (hk-run "main = fromJust (Just 5)"))
|
||||
5)
|
||||
(hk-test
|
||||
"head [42] = 42 (still works for non-empty)"
|
||||
(hk-deep-force (hk-run "main = head [42]"))
|
||||
42)
|
||||
|
||||
(hk-test-error
|
||||
"hk-test-error helper: catches matching error"
|
||||
(fn () (hk-deep-force (hk-run "main = error \"boom\"")))
|
||||
"hk-error: boom")
|
||||
|
||||
(hk-test-error
|
||||
"hk-test-error helper: catches head [] error"
|
||||
(fn () (hk-deep-force (hk-run "main = head []")))
|
||||
"Prelude.head: empty list")
|
||||
|
||||
(hk-test
|
||||
"second arg never forced"
|
||||
(hk-eval-expr-source "(\\x y -> x) 1 (error \"never\")")
|
||||
(hk-eval-expr-source
|
||||
"(\\x y -> x) 1 (error \"never\")")
|
||||
1)
|
||||
|
||||
(hk-test
|
||||
"first arg never forced"
|
||||
(hk-eval-expr-source "(\\x y -> y) (error \"never\") 99")
|
||||
(hk-eval-expr-source
|
||||
"(\\x y -> y) (error \"never\") 99")
|
||||
99)
|
||||
|
||||
(hk-test
|
||||
@@ -317,7 +251,9 @@
|
||||
|
||||
(hk-test
|
||||
"lazy: const drops its second argument"
|
||||
(hk-prog-val "const x y = x\nresult = const 5 (error \"boom\")" "result")
|
||||
(hk-prog-val
|
||||
"const x y = x\nresult = const 5 (error \"boom\")"
|
||||
"result")
|
||||
5)
|
||||
|
||||
(hk-test
|
||||
@@ -334,10 +270,9 @@
|
||||
"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}
|
||||
|
||||
@@ -1,105 +0,0 @@
|
||||
;; Phase 16 — Exception handling unit tests.
|
||||
|
||||
(hk-test
|
||||
"catch — success path returns the action result"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"main = catch (return 42) (\\(SomeException m) -> return 0)"))
|
||||
(list "IO" 42))
|
||||
|
||||
(hk-test
|
||||
"catch — error caught, handler receives message"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"main = catch (error \"boom\") (\\(SomeException m) -> return m)"))
|
||||
(list "IO" "boom"))
|
||||
|
||||
(hk-test
|
||||
"try — success returns Right v"
|
||||
(hk-deep-force
|
||||
(hk-run "main = try (return 42)"))
|
||||
(list "IO" (list "Right" 42)))
|
||||
|
||||
(hk-test
|
||||
"try — error returns Left (SomeException msg)"
|
||||
(hk-deep-force
|
||||
(hk-run "main = try (error \"oops\")"))
|
||||
(list "IO" (list "Left" (list "SomeException" "oops"))))
|
||||
|
||||
(hk-test
|
||||
"handle — flip catch — caught error message"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"main = handle (\\(SomeException m) -> return m) (error \"hot\")"))
|
||||
(list "IO" "hot"))
|
||||
|
||||
(hk-test
|
||||
"throwIO + catch — handler sees the SomeException"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"main = catch (throwIO (SomeException \"bang\")) (\\(SomeException m) -> return m)"))
|
||||
(list "IO" "bang"))
|
||||
|
||||
(hk-test
|
||||
"throwIO + try — Left side"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"main = try (throwIO (SomeException \"x\"))"))
|
||||
(list "IO" (list "Left" (list "SomeException" "x"))))
|
||||
|
||||
(hk-test
|
||||
"evaluate — pure value returns IO v"
|
||||
(hk-deep-force
|
||||
(hk-run "main = evaluate (1 + 2 + 3)"))
|
||||
(list "IO" 6))
|
||||
|
||||
(hk-test
|
||||
"evaluate — error surfaces as catchable exception"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"main = catch (evaluate (error \"deep\")) (\\(SomeException m) -> return m)"))
|
||||
(list "IO" "deep"))
|
||||
|
||||
(hk-test
|
||||
"nested catch — inner handler runs first"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"main = catch (catch (error \"inner\") (\\(SomeException m) -> error (m ++ \"-rethrown\"))) (\\(SomeException m) -> return m)"))
|
||||
(list "IO" "inner-rethrown"))
|
||||
|
||||
(hk-test
|
||||
"catch chain — handler can succeed inside IO"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"main = do { x <- catch (error \"e1\") (\\(SomeException m) -> return 100); return (x + 1) }"))
|
||||
(list "IO" 101))
|
||||
|
||||
(hk-test
|
||||
"try then bind on Right"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"branch (Right v) = return (v * 2)
|
||||
branch (Left _) = return 0
|
||||
main = do { r <- try (return 21); branch r }"))
|
||||
(list "IO" 42))
|
||||
|
||||
(hk-test
|
||||
"try then bind on Left"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"branch (Right _) = return \"ok\"
|
||||
branch (Left (SomeException m)) = return m
|
||||
main = do { r <- try (error \"failed\"); branch r }"))
|
||||
(list "IO" "failed"))
|
||||
|
||||
(hk-test
|
||||
"catch — handler can use closed-over IORef"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef
|
||||
main = do
|
||||
r <- IORef.newIORef 0
|
||||
catch (error \"x\") (\\(SomeException m) -> IORef.writeIORef r 7)
|
||||
v <- IORef.readIORef r
|
||||
return v"))
|
||||
(list "IO" 7))
|
||||
@@ -1,31 +0,0 @@
|
||||
;; instance-where.sx — Phase 13: where-clauses inside instance bodies.
|
||||
|
||||
(hk-test
|
||||
"instance method body with where-helper (Bool)"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"class Greet a where\n greet :: a -> String\ninstance Greet Bool where\n greet x = mkMsg x\n where mkMsg True = \"yes\"\n mkMsg False = \"no\"\nmain = greet True"))
|
||||
"yes")
|
||||
|
||||
(hk-test
|
||||
"instance method body with where-helper (False branch)"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"class Greet a where\n greet :: a -> String\ninstance Greet Bool where\n greet x = mkMsg x\n where mkMsg True = \"yes\"\n mkMsg False = \"no\"\nmain = greet False"))
|
||||
"no")
|
||||
|
||||
(hk-test
|
||||
"instance method body with where-binding referenced multiple times"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"class Twice a where\n twice :: a -> Int\ninstance Twice Int where\n twice x = h + h\n where h = x + 1\nmain = twice 5"))
|
||||
12)
|
||||
|
||||
(hk-test
|
||||
"instance method body with multi-binding where"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"class Calc a where\n calc :: a -> Int\ninstance Calc Int where\n calc x = a + b\n where a = x * 2\n b = x + 1\nmain = calc 3"))
|
||||
10)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -64,11 +64,12 @@
|
||||
|
||||
(hk-test
|
||||
"readFile error on missing file"
|
||||
(begin
|
||||
(set! hk-vfs (dict))
|
||||
(let
|
||||
((lines (hk-run-io "main = readFile \"no.txt\" >>= putStrLn")))
|
||||
(>= (index-of (str lines) "file not found") 0)))
|
||||
(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
|
||||
|
||||
@@ -1,94 +0,0 @@
|
||||
;; Phase 15 — IORef unit tests.
|
||||
|
||||
(hk-test
|
||||
"newIORef + readIORef returns initial value"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 42; v <- IORef.readIORef r; return v }"))
|
||||
(list "IO" 42))
|
||||
|
||||
(hk-test
|
||||
"writeIORef updates the cell"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 0; IORef.writeIORef r 99; v <- IORef.readIORef r; return v }"))
|
||||
(list "IO" 99))
|
||||
|
||||
(hk-test
|
||||
"writeIORef returns IO ()"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 0; IORef.writeIORef r 1 }"))
|
||||
(list "IO" (list "Tuple")))
|
||||
|
||||
(hk-test
|
||||
"modifyIORef applies a function"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 5; IORef.modifyIORef r (\\x -> x * 2); v <- IORef.readIORef r; return v }"))
|
||||
(list "IO" 10))
|
||||
|
||||
(hk-test
|
||||
"modifyIORef' (strict) applies a function"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 7; IORef.modifyIORef' r (\\x -> x + 3); v <- IORef.readIORef r; return v }"))
|
||||
(list "IO" 10))
|
||||
|
||||
(hk-test
|
||||
"two reads return the same value"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 11; a <- IORef.readIORef r; b <- IORef.readIORef r; return (a + b) }"))
|
||||
(list "IO" 22))
|
||||
|
||||
(hk-test
|
||||
"shared ref across do-steps: write then read"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 1; IORef.writeIORef r 2; IORef.writeIORef r 3; v <- IORef.readIORef r; return v }"))
|
||||
(list "IO" 3))
|
||||
|
||||
(hk-test
|
||||
"two refs are independent"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\nmain = do { r1 <- IORef.newIORef 1; r2 <- IORef.newIORef 2; IORef.writeIORef r1 10; a <- IORef.readIORef r1; b <- IORef.readIORef r2; return (a + b) }"))
|
||||
(list "IO" 12))
|
||||
|
||||
(hk-test
|
||||
"string-valued IORef"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef \"hi\"; IORef.writeIORef r \"bye\"; v <- IORef.readIORef r; return v }"))
|
||||
(list "IO" "bye"))
|
||||
|
||||
(hk-test
|
||||
"list-valued IORef + cons"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef [1,2,3]; IORef.modifyIORef r (\\xs -> 0 : xs); v <- IORef.readIORef r; return v }"))
|
||||
(list
|
||||
"IO"
|
||||
(list ":" 0 (list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))))
|
||||
|
||||
(hk-test
|
||||
"counter loop: increment N times"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\nloop r 0 = return ()\nloop r n = do { IORef.modifyIORef r (\\x -> x + 1); loop r (n - 1) }\nmain = do { r <- IORef.newIORef 0; loop r 10; v <- IORef.readIORef r; return v }"))
|
||||
(list "IO" 10))
|
||||
|
||||
(hk-test
|
||||
"modifyIORef' inside a loop"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\ngo r 0 = return ()\ngo r n = do { IORef.modifyIORef' r (\\x -> x + n); go r (n - 1) }\nmain = do { r <- IORef.newIORef 0; go r 5; v <- IORef.readIORef r; return v }"))
|
||||
(list "IO" 15))
|
||||
|
||||
(hk-test
|
||||
"newIORef inside a function passed via parameter"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.IORef as IORef\nbump r = IORef.modifyIORef r (\\x -> x + 100)\nmain = do { r <- IORef.newIORef 1; bump r; v <- IORef.readIORef r; return v }"))
|
||||
(list "IO" 101))
|
||||
@@ -1,196 +0,0 @@
|
||||
;; map.sx — Phase 11 Data.Map unit tests.
|
||||
;;
|
||||
;; Tests both the SX-level `hk-map-*` helpers and the Haskell-level
|
||||
;; `Map.*` aliases bound by the import handler.
|
||||
|
||||
(define
|
||||
hk-as-list
|
||||
(fn
|
||||
(xs)
|
||||
(cond
|
||||
((and (list? xs) (= (first xs) "[]")) (list))
|
||||
((and (list? xs) (= (first xs) ":"))
|
||||
(cons (nth xs 1) (hk-as-list (nth xs 2))))
|
||||
(:else xs))))
|
||||
|
||||
;; ── SX-level (direct hk-map-*) ───────────────────────────────
|
||||
(hk-test
|
||||
"hk-map-empty: size 0, null true"
|
||||
(list (hk-map-size hk-map-empty) (hk-map-null hk-map-empty))
|
||||
(list 0 true))
|
||||
|
||||
(hk-test
|
||||
"hk-map-singleton: lookup hit"
|
||||
(let
|
||||
((m (hk-map-singleton 5 "five")))
|
||||
(list (hk-map-size m) (hk-map-lookup 5 m)))
|
||||
(list 1 (list "Just" "five")))
|
||||
|
||||
(hk-test
|
||||
"hk-map-insert: lookup hit on inserted"
|
||||
(let ((m (hk-map-insert 1 "a" hk-map-empty))) (hk-map-lookup 1 m))
|
||||
(list "Just" "a"))
|
||||
|
||||
(hk-test
|
||||
"hk-map-lookup: miss returns Nothing"
|
||||
(hk-map-lookup 99 (hk-map-singleton 1 "a"))
|
||||
(list "Nothing"))
|
||||
|
||||
(hk-test
|
||||
"hk-map-insert: overwrites existing key"
|
||||
(let
|
||||
((m (hk-map-insert 1 "second" (hk-map-insert 1 "first" hk-map-empty))))
|
||||
(hk-map-lookup 1 m))
|
||||
(list "Just" "second"))
|
||||
|
||||
(hk-test
|
||||
"hk-map-delete: removes key"
|
||||
(let
|
||||
((m (hk-map-insert 2 "b" (hk-map-insert 1 "a" hk-map-empty))))
|
||||
(let
|
||||
((m2 (hk-map-delete 1 m)))
|
||||
(list (hk-map-size m2) (hk-map-lookup 1 m2) (hk-map-lookup 2 m2))))
|
||||
(list 1 (list "Nothing") (list "Just" "b")))
|
||||
|
||||
(hk-test
|
||||
"hk-map-delete: missing key is no-op"
|
||||
(let ((m (hk-map-singleton 1 "a"))) (hk-map-size (hk-map-delete 99 m)))
|
||||
1)
|
||||
|
||||
(hk-test
|
||||
"hk-map-member: true on existing"
|
||||
(hk-map-member 1 (hk-map-singleton 1 "a"))
|
||||
true)
|
||||
|
||||
(hk-test
|
||||
"hk-map-member: false on missing"
|
||||
(hk-map-member 99 (hk-map-singleton 1 "a"))
|
||||
false)
|
||||
|
||||
(hk-test
|
||||
"hk-map-from-list: builds map; keys sorted"
|
||||
(hk-map-keys
|
||||
(hk-map-from-list
|
||||
(list (list 3 "c") (list 1 "a") (list 5 "e") (list 2 "b"))))
|
||||
(list 1 2 3 5))
|
||||
|
||||
(hk-test
|
||||
"hk-map-from-list: duplicates — last wins"
|
||||
(hk-map-lookup
|
||||
1
|
||||
(hk-map-from-list (list (list 1 "first") (list 1 "second"))))
|
||||
(list "Just" "second"))
|
||||
|
||||
(hk-test
|
||||
"hk-map-to-asc-list: ordered traversal"
|
||||
(hk-map-to-asc-list
|
||||
(hk-map-from-list (list (list 3 "c") (list 1 "a") (list 2 "b"))))
|
||||
(list (list 1 "a") (list 2 "b") (list 3 "c")))
|
||||
|
||||
(hk-test
|
||||
"hk-map-elems: in key order"
|
||||
(hk-map-elems
|
||||
(hk-map-from-list (list (list 3 30) (list 1 10) (list 2 20))))
|
||||
(list 10 20 30))
|
||||
|
||||
(hk-test
|
||||
"hk-map-union-with: combines duplicates"
|
||||
(hk-map-to-asc-list
|
||||
(hk-map-union-with
|
||||
(fn (a b) (str a "+" b))
|
||||
(hk-map-from-list (list (list 1 "a") (list 2 "b")))
|
||||
(hk-map-from-list (list (list 2 "B") (list 3 "c")))))
|
||||
(list (list 1 "a") (list 2 "b+B") (list 3 "c")))
|
||||
|
||||
(hk-test
|
||||
"hk-map-intersection-with: keeps shared keys"
|
||||
(hk-map-to-asc-list
|
||||
(hk-map-intersection-with
|
||||
+
|
||||
(hk-map-from-list (list (list 1 10) (list 2 20)))
|
||||
(hk-map-from-list (list (list 2 200) (list 3 30)))))
|
||||
(list (list 2 220)))
|
||||
|
||||
(hk-test
|
||||
"hk-map-difference: drops m2 keys"
|
||||
(hk-map-keys
|
||||
(hk-map-difference
|
||||
(hk-map-from-list (list (list 1 "a") (list 2 "b") (list 3 "c")))
|
||||
(hk-map-from-list (list (list 2 "x")))))
|
||||
(list 1 3))
|
||||
|
||||
(hk-test
|
||||
"hk-map-foldl-with-key: in-order accumulate"
|
||||
(hk-map-foldl-with-key
|
||||
(fn (acc k v) (str acc k v))
|
||||
""
|
||||
(hk-map-from-list (list (list 3 "c") (list 1 "a") (list 2 "b"))))
|
||||
"1a2b3c")
|
||||
|
||||
(hk-test
|
||||
"hk-map-map-with-key: transforms values"
|
||||
(hk-map-to-asc-list
|
||||
(hk-map-map-with-key
|
||||
(fn (k v) (* k v))
|
||||
(hk-map-from-list (list (list 2 10) (list 3 100)))))
|
||||
(list (list 2 20) (list 3 300)))
|
||||
|
||||
(hk-test
|
||||
"hk-map-filter-with-key: keeps matches"
|
||||
(hk-map-keys
|
||||
(hk-map-filter-with-key
|
||||
(fn (k v) (> k 1))
|
||||
(hk-map-from-list (list (list 1 "a") (list 2 "b") (list 3 "c")))))
|
||||
(list 2 3))
|
||||
|
||||
(hk-test
|
||||
"hk-map-adjust: applies f to existing"
|
||||
(hk-map-lookup
|
||||
1
|
||||
(hk-map-adjust (fn (v) (* v 10)) 1 (hk-map-singleton 1 5)))
|
||||
(list "Just" 50))
|
||||
|
||||
(hk-test
|
||||
"hk-map-insert-with: combines on existing"
|
||||
(hk-map-lookup 1 (hk-map-insert-with + 1 5 (hk-map-singleton 1 10)))
|
||||
(list "Just" 15))
|
||||
|
||||
(hk-test
|
||||
"hk-map-alter: Nothing → delete"
|
||||
(hk-map-size
|
||||
(hk-map-alter
|
||||
(fn (mv) (list "Nothing"))
|
||||
1
|
||||
(hk-map-from-list (list (list 1 "a") (list 2 "b")))))
|
||||
1)
|
||||
|
||||
;; ── Haskell-level (Map.*) via import wiring ─────────────────
|
||||
(hk-test
|
||||
"Map.size after Map.insert chain"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.Map as Map\nmain = Map.size (Map.insert 2 \"b\" (Map.insert 1 \"a\" Map.empty))"))
|
||||
2)
|
||||
|
||||
(hk-test
|
||||
"Map.lookup hit"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.Map as Map\nmain = Map.lookup 1 (Map.insert 1 \"a\" Map.empty)"))
|
||||
(list "Just" "a"))
|
||||
|
||||
(hk-test
|
||||
"Map.lookup miss"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.Map as Map\nmain = Map.lookup 99 (Map.insert 1 \"a\" Map.empty)"))
|
||||
(list "Nothing"))
|
||||
|
||||
(hk-test
|
||||
"Map.member true"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.Map as Map\nmain = Map.member 5 (Map.insert 5 \"x\" Map.empty)"))
|
||||
(list "True"))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,180 +0,0 @@
|
||||
;; numerics.sx — Phase 10 numeric tower verification.
|
||||
;;
|
||||
;; Practical integer-precision limit in Haskell-on-SX:
|
||||
;; • Raw SX `(* a b)` stays exact up to ±2^62 (≈ 4.6e18, OCaml int63).
|
||||
;; • BUT the Haskell tokenizer/parser parses an integer literal as a float
|
||||
;; once it exceeds 2^53 (≈ 9.007e15). Once any operand is a float, the
|
||||
;; binop result is a float (and decimal-precision is lost past 2^53).
|
||||
;; • Therefore: programs that stay below ~9e15 are exact; larger literals
|
||||
;; or accumulated products silently become floats. `factorial 18` is the
|
||||
;; last factorial that stays exact (6.4e15); `factorial 19` already floats.
|
||||
;;
|
||||
;; In Haskell terms, `Int` and `Integer` both currently map to SX number, so
|
||||
;; we don't yet support arbitrary-precision Integer. Documented; unbounded
|
||||
;; Integer is out of scope for Phase 10 — see Phase 11+ if it becomes needed.
|
||||
|
||||
(define
|
||||
hk-as-list
|
||||
(fn
|
||||
(xs)
|
||||
(cond
|
||||
((and (list? xs) (= (first xs) "[]")) (list))
|
||||
((and (list? xs) (= (first xs) ":"))
|
||||
(cons (nth xs 1) (hk-as-list (nth xs 2))))
|
||||
(:else xs))))
|
||||
|
||||
(hk-test
|
||||
"factorial 10 = 3628800 (small, exact)"
|
||||
(hk-deep-force
|
||||
(hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 10"))
|
||||
3628800)
|
||||
|
||||
(hk-test
|
||||
"factorial 15 = 1307674368000 (mid-range, exact)"
|
||||
(hk-deep-force
|
||||
(hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 15"))
|
||||
1307674368000)
|
||||
|
||||
(hk-test
|
||||
"factorial 18 = 6402373705728000 (last exact factorial)"
|
||||
(hk-deep-force
|
||||
(hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 18"))
|
||||
6402373705728000)
|
||||
|
||||
(hk-test
|
||||
"1000000 * 1000000 = 10^12 (exact)"
|
||||
(hk-deep-force (hk-run "main = 1000000 * 1000000"))
|
||||
1000000000000)
|
||||
|
||||
(hk-test
|
||||
"1000000000 * 1000000000 = 10^18 (exact, at boundary)"
|
||||
(hk-deep-force (hk-run "main = 1000000000 * 1000000000"))
|
||||
1e+18)
|
||||
|
||||
(hk-test
|
||||
"2^62 boundary: pow accumulates exactly"
|
||||
(hk-deep-force
|
||||
(hk-run "pow b 0 = 1\npow b n = b * pow b (n - 1)\nmain = pow 2 62"))
|
||||
4.6116860184273879e+18)
|
||||
|
||||
(hk-test
|
||||
"show factorial 12 = 479001600 (whole, fits in 32-bit)"
|
||||
(hk-deep-force
|
||||
(hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = show (fact 12)"))
|
||||
"479001600")
|
||||
|
||||
(hk-test
|
||||
"negate large positive — preserves magnitude"
|
||||
(hk-deep-force (hk-run "main = negate 1000000000000000000"))
|
||||
-1e+18)
|
||||
|
||||
(hk-test
|
||||
"abs negative large — preserves magnitude"
|
||||
(hk-deep-force (hk-run "main = abs (negate 1000000000000000000)"))
|
||||
1e+18)
|
||||
|
||||
(hk-test
|
||||
"div on large ints"
|
||||
(hk-deep-force (hk-run "main = div 1000000000000000000 1000000000"))
|
||||
1000000000)
|
||||
|
||||
(hk-test
|
||||
"fromIntegral 42 = 42 (identity in our runtime)"
|
||||
(hk-deep-force (hk-run "main = fromIntegral 42"))
|
||||
42)
|
||||
|
||||
(hk-test
|
||||
"fromIntegral preserves negative"
|
||||
(hk-deep-force (hk-run "main = fromIntegral (negate 7)"))
|
||||
-7)
|
||||
|
||||
(hk-test
|
||||
"fromIntegral round-trips through arithmetic"
|
||||
(hk-deep-force (hk-run "main = fromIntegral 5 + fromIntegral 3"))
|
||||
8)
|
||||
|
||||
(hk-test
|
||||
"fromIntegral in a program (mixing with map)"
|
||||
(hk-as-list (hk-deep-force (hk-run "main = map fromIntegral [1,2,3]")))
|
||||
(list 1 2 3))
|
||||
|
||||
(hk-test
|
||||
"toInteger 100 = 100 (identity)"
|
||||
(hk-deep-force (hk-run "main = toInteger 100"))
|
||||
100)
|
||||
|
||||
(hk-test
|
||||
"fromInteger 7 = 7 (identity)"
|
||||
(hk-deep-force (hk-run "main = fromInteger 7"))
|
||||
7)
|
||||
|
||||
(hk-test
|
||||
"toInteger / fromInteger round-trip"
|
||||
(hk-deep-force (hk-run "main = fromInteger (toInteger 42)"))
|
||||
42)
|
||||
|
||||
(hk-test
|
||||
"toInteger preserves negative"
|
||||
(hk-deep-force (hk-run "main = toInteger (negate 13)"))
|
||||
-13)
|
||||
|
||||
(hk-test
|
||||
"show 3.14 = 3.14"
|
||||
(hk-deep-force (hk-run "main = show 3.14"))
|
||||
"3.14")
|
||||
|
||||
(hk-test
|
||||
"show 1.0e10 — whole-valued float renders as decimal (int/float ambiguity)"
|
||||
(hk-deep-force (hk-run "main = show 1.0e10"))
|
||||
"10000000000")
|
||||
|
||||
(hk-test
|
||||
"show 0.001 uses scientific form (sub-0.1)"
|
||||
(hk-deep-force (hk-run "main = show 0.001"))
|
||||
"1.0e-3")
|
||||
|
||||
(hk-test
|
||||
"show negative float"
|
||||
(hk-deep-force (hk-run "main = show (negate 3.14)"))
|
||||
"-3.14")
|
||||
|
||||
(hk-test "sqrt 16 = 4" (hk-deep-force (hk-run "main = sqrt 16")) 4)
|
||||
|
||||
(hk-test "floor 3.7 = 3" (hk-deep-force (hk-run "main = floor 3.7")) 3)
|
||||
|
||||
(hk-test "ceiling 3.2 = 4" (hk-deep-force (hk-run "main = ceiling 3.2")) 4)
|
||||
|
||||
(hk-test
|
||||
"ceiling on whole = self"
|
||||
(hk-deep-force (hk-run "main = ceiling 4"))
|
||||
4)
|
||||
|
||||
(hk-test "round 2.6 = 3" (hk-deep-force (hk-run "main = round 2.6")) 3)
|
||||
|
||||
(hk-test
|
||||
"truncate -3.7 = -3"
|
||||
(hk-deep-force (hk-run "main = truncate (negate 3.7)"))
|
||||
-3)
|
||||
|
||||
(hk-test "recip 4.0 = 0.25" (hk-deep-force (hk-run "main = recip 4.0")) 0.25)
|
||||
|
||||
(hk-test "1.0 / 4.0 = 0.25" (hk-deep-force (hk-run "main = 1.0 / 4.0")) 0.25)
|
||||
|
||||
(hk-test
|
||||
"fromRational 0.5 = 0.5 (identity)"
|
||||
(hk-deep-force (hk-run "main = fromRational 0.5"))
|
||||
0.5)
|
||||
|
||||
(hk-test "pi ≈ 3.14159" (hk-deep-force (hk-run "main = pi")) 3.14159)
|
||||
|
||||
(hk-test "exp 0 = 1" (hk-deep-force (hk-run "main = exp 0")) 1)
|
||||
|
||||
(hk-test "sin 0 = 0" (hk-deep-force (hk-run "main = sin 0")) 0)
|
||||
|
||||
(hk-test "cos 0 = 1" (hk-deep-force (hk-run "main = cos 0")) 1)
|
||||
|
||||
(hk-test "2 ** 10 = 1024" (hk-deep-force (hk-run "main = 2 ** 10")) 1024)
|
||||
|
||||
(hk-test "log (exp 5) ≈ 5" (hk-deep-force (hk-run "main = log (exp 5)")) 5)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,81 +0,0 @@
|
||||
;; accumulate.hs — accumulate results into an IORef [Int] (Phase 15 conformance).
|
||||
|
||||
(define
|
||||
hk-accumulate-source
|
||||
"import qualified Data.IORef as IORef\n\npush :: IORef [Int] -> Int -> IO ()\npush r x = IORef.modifyIORef r (\\xs -> x : xs)\n\npushAll :: IORef [Int] -> [Int] -> IO ()\npushAll r [] = return ()\npushAll r (x:xs) = do\n push r x\n pushAll r xs\n\nreadReversed :: IORef [Int] -> IO [Int]\nreadReversed r = do\n xs <- IORef.readIORef r\n return (reverse xs)\n\ndoubleEach :: IORef [Int] -> [Int] -> IO ()\ndoubleEach r [] = return ()\ndoubleEach r (x:xs) = do\n push r (x * 2)\n doubleEach r xs\n\nsumIntoRef :: IORef Int -> [Int] -> IO ()\nsumIntoRef r [] = return ()\nsumIntoRef r (x:xs) = do\n IORef.modifyIORef r (\\acc -> acc + x)\n sumIntoRef r xs\n\n")
|
||||
|
||||
(hk-test
|
||||
"accumulate.hs — push three then read length"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-accumulate-source
|
||||
"main = do { r <- IORef.newIORef []; push r 1; push r 2; push r 3; xs <- IORef.readIORef r; return (length xs) }")))
|
||||
(list "IO" 3))
|
||||
|
||||
(hk-test
|
||||
"accumulate.hs — pushAll preserves reverse order"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-accumulate-source
|
||||
"main = do { r <- IORef.newIORef []; pushAll r [1,2,3,4]; xs <- IORef.readIORef r; return xs }")))
|
||||
(list
|
||||
"IO"
|
||||
(list ":" 4 (list ":" 3 (list ":" 2 (list ":" 1 (list "[]")))))))
|
||||
|
||||
(hk-test
|
||||
"accumulate.hs — readReversed gives original order"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-accumulate-source
|
||||
"main = do { r <- IORef.newIORef []; pushAll r [10,20,30]; readReversed r }")))
|
||||
(list "IO" (list ":" 10 (list ":" 20 (list ":" 30 (list "[]"))))))
|
||||
|
||||
(hk-test
|
||||
"accumulate.hs — doubleEach maps then accumulates"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-accumulate-source
|
||||
"main = do { r <- IORef.newIORef []; doubleEach r [1,2,3]; readReversed r }")))
|
||||
(list "IO" (list ":" 2 (list ":" 4 (list ":" 6 (list "[]"))))))
|
||||
|
||||
(hk-test
|
||||
"accumulate.hs — sum into Int IORef"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-accumulate-source
|
||||
"main = do { r <- IORef.newIORef 0; sumIntoRef r [1,2,3,4,5]; v <- IORef.readIORef r; return v }")))
|
||||
(list "IO" 15))
|
||||
|
||||
(hk-test
|
||||
"accumulate.hs — empty list leaves ref untouched"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-accumulate-source
|
||||
"main = do { r <- IORef.newIORef [99]; pushAll r []; xs <- IORef.readIORef r; return xs }")))
|
||||
(list "IO" (list ":" 99 (list "[]"))))
|
||||
|
||||
(hk-test
|
||||
"accumulate.hs — pushAll then sumIntoRef on the same input"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-accumulate-source
|
||||
"main = do { r <- IORef.newIORef 0; sumIntoRef r [10,20,30,40]; v <- IORef.readIORef r; return v }")))
|
||||
(list "IO" 100))
|
||||
|
||||
(hk-test
|
||||
"accumulate.hs — accumulate results from a recursive helper"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-accumulate-source
|
||||
"squaresUpTo r 0 = return ()\nsquaresUpTo r n = do { push r (n * n); squaresUpTo r (n - 1) }\nmain = do { r <- IORef.newIORef []; squaresUpTo r 4; readReversed r }")))
|
||||
(list
|
||||
"IO"
|
||||
(list ":" 16 (list ":" 9 (list ":" 4 (list ":" 1 (list "[]")))))))
|
||||
@@ -1,80 +0,0 @@
|
||||
;; caesar.hs — Caesar cipher.
|
||||
;; Source: https://rosettacode.org/wiki/Caesar_cipher#Haskell (adapted).
|
||||
;;
|
||||
;; Exercises chr, ord, isUpper, isLower, mod, string pattern matching
|
||||
;; (x:xs) over a String (which is now a [Char] string view), and map
|
||||
;; from the Phase 7 string=[Char] foundation.
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
(define
|
||||
hk-as-list
|
||||
(fn
|
||||
(xs)
|
||||
(cond
|
||||
((and (list? xs) (= (first xs) "[]")) (list))
|
||||
((and (list? xs) (= (first xs) ":"))
|
||||
(cons (nth xs 1) (hk-as-list (nth xs 2))))
|
||||
(:else xs))))
|
||||
|
||||
(define
|
||||
hk-caesar-source
|
||||
"shift n c = if isUpper c\n then chr (mod ((ord c) - 65 + n) 26 + 65)\n else if isLower c\n then chr (mod ((ord c) - 97 + n) 26 + 97)\n else chr c\n\ncaesarRec n [] = []\ncaesarRec n (x:xs) = shift n x : caesarRec n xs\n\ncaesarMap n s = map (shift n) s\n")
|
||||
|
||||
(hk-test
|
||||
"caesar.hs — caesarRec 3 \"ABC\" = DEF"
|
||||
(hk-as-list
|
||||
(hk-prog-val (str hk-caesar-source "r = caesarRec 3 \"ABC\"\n") "r"))
|
||||
(list "D" "E" "F"))
|
||||
|
||||
(hk-test
|
||||
"caesar.hs — caesarRec 13 \"Hello\" = Uryyb"
|
||||
(hk-as-list
|
||||
(hk-prog-val (str hk-caesar-source "r = caesarRec 13 \"Hello\"\n") "r"))
|
||||
(list "U" "r" "y" "y" "b"))
|
||||
|
||||
(hk-test
|
||||
"caesar.hs — caesarRec 1 \"AZ\" wraps to BA"
|
||||
(hk-as-list
|
||||
(hk-prog-val (str hk-caesar-source "r = caesarRec 1 \"AZ\"\n") "r"))
|
||||
(list "B" "A"))
|
||||
|
||||
(hk-test
|
||||
"caesar.hs — caesarRec 0 \"World\" identity"
|
||||
(hk-as-list
|
||||
(hk-prog-val (str hk-caesar-source "r = caesarRec 0 \"World\"\n") "r"))
|
||||
(list "W" "o" "r" "l" "d"))
|
||||
|
||||
(hk-test
|
||||
"caesar.hs — caesarRec preserves punctuation"
|
||||
(hk-as-list
|
||||
(hk-prog-val (str hk-caesar-source "r = caesarRec 3 \"Hi!\"\n") "r"))
|
||||
(list "K" "l" "!"))
|
||||
|
||||
(hk-test
|
||||
"caesar.hs — caesarMap 3 \"abc\" via map"
|
||||
(hk-as-list
|
||||
(hk-prog-val (str hk-caesar-source "r = caesarMap 3 \"abc\"\n") "r"))
|
||||
(list "d" "e" "f"))
|
||||
|
||||
(hk-test
|
||||
"caesar.hs — caesarMap 13 round-trips with caesarMap 13"
|
||||
(hk-as-list
|
||||
(hk-prog-val
|
||||
(str
|
||||
hk-caesar-source
|
||||
"r = caesarMap 13 (foldr (\\c acc -> c : acc) [] (caesarMap 13 \"Hello\"))\n")
|
||||
"r"))
|
||||
(list "H" "e" "l" "l" "o"))
|
||||
|
||||
(hk-test
|
||||
"caesar.hs — caesarRec 25 \"AB\" = ZA"
|
||||
(hk-as-list
|
||||
(hk-prog-val (str hk-caesar-source "r = caesarRec 25 \"AB\"\n") "r"))
|
||||
(list "Z" "A"))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,63 +0,0 @@
|
||||
;; config.hs — multi-field config record; partial update; defaultConfig
|
||||
;; constant.
|
||||
;;
|
||||
;; Exercises Phase 14: 4-field record, defaultConfig as a CAF, partial
|
||||
;; updates that change one or two fields, accessors over derived configs.
|
||||
|
||||
(define
|
||||
hk-config-source
|
||||
"data Config = Config { host :: String, port :: Int, retries :: Int, debug :: Bool } deriving (Show)\n\ndefaultConfig = Config { host = \"localhost\", port = 8080, retries = 3, debug = False }\n\ndevConfig = defaultConfig { debug = True }\nremoteConfig = defaultConfig { host = \"api.example.com\", port = 443 }\n")
|
||||
|
||||
(hk-test
|
||||
"config.hs — defaultConfig host"
|
||||
(hk-deep-force (hk-run (str hk-config-source "main = host defaultConfig")))
|
||||
"localhost")
|
||||
|
||||
(hk-test
|
||||
"config.hs — defaultConfig port"
|
||||
(hk-deep-force (hk-run (str hk-config-source "main = port defaultConfig")))
|
||||
8080)
|
||||
|
||||
(hk-test
|
||||
"config.hs — defaultConfig retries"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-config-source "main = retries defaultConfig")))
|
||||
3)
|
||||
|
||||
(hk-test
|
||||
"config.hs — devConfig flips debug"
|
||||
(hk-deep-force (hk-run (str hk-config-source "main = debug devConfig")))
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"config.hs — devConfig preserves host"
|
||||
(hk-deep-force (hk-run (str hk-config-source "main = host devConfig")))
|
||||
"localhost")
|
||||
|
||||
(hk-test
|
||||
"config.hs — devConfig preserves port"
|
||||
(hk-deep-force (hk-run (str hk-config-source "main = port devConfig")))
|
||||
8080)
|
||||
|
||||
(hk-test
|
||||
"config.hs — remoteConfig new host"
|
||||
(hk-deep-force (hk-run (str hk-config-source "main = host remoteConfig")))
|
||||
"api.example.com")
|
||||
|
||||
(hk-test
|
||||
"config.hs — remoteConfig new port"
|
||||
(hk-deep-force (hk-run (str hk-config-source "main = port remoteConfig")))
|
||||
443)
|
||||
|
||||
(hk-test
|
||||
"config.hs — remoteConfig preserves retries"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-config-source "main = retries remoteConfig")))
|
||||
3)
|
||||
|
||||
(hk-test
|
||||
"config.hs — remoteConfig preserves debug"
|
||||
(hk-deep-force (hk-run (str hk-config-source "main = debug remoteConfig")))
|
||||
(list "False"))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,66 +0,0 @@
|
||||
;; counter.hs — IORef-backed mutable counter (Phase 15 conformance).
|
||||
|
||||
(define
|
||||
hk-counter-source
|
||||
"import qualified Data.IORef as IORef\n\ncount :: IORef Int -> Int -> IO ()\ncount r 0 = return ()\ncount r n = do\n IORef.modifyIORef r (\\x -> x + 1)\n count r (n - 1)\n\ncountBy :: IORef Int -> Int -> Int -> IO ()\ncountBy r step 0 = return ()\ncountBy r step n = do\n IORef.modifyIORef r (\\x -> x + step)\n countBy r step (n - 1)\n\nnewCounter :: Int -> IO (IORef Int)\nnewCounter v = IORef.newIORef v\n\nbumpAndRead :: IORef Int -> IO Int\nbumpAndRead r = do\n IORef.modifyIORef r (\\x -> x + 1)\n IORef.readIORef r\n\n")
|
||||
|
||||
(hk-test
|
||||
"counter.hs — start at 0, count 5 ⇒ 5"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-counter-source
|
||||
"main = do { r <- newCounter 0; count r 5; v <- IORef.readIORef r; return v }")))
|
||||
(list "IO" 5))
|
||||
|
||||
(hk-test
|
||||
"counter.hs — start at 100, count 10 ⇒ 110"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-counter-source
|
||||
"main = do { r <- newCounter 100; count r 10; v <- IORef.readIORef r; return v }")))
|
||||
(list "IO" 110))
|
||||
|
||||
(hk-test
|
||||
"counter.hs — countBy step 5, n 4 ⇒ 20"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-counter-source
|
||||
"main = do { r <- newCounter 0; countBy r 5 4; v <- IORef.readIORef r; return v }")))
|
||||
(list "IO" 20))
|
||||
|
||||
(hk-test
|
||||
"counter.hs — bumpAndRead returns updated value"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-counter-source "main = do { r <- newCounter 41; bumpAndRead r }")))
|
||||
(list "IO" 42))
|
||||
|
||||
(hk-test
|
||||
"counter.hs — count then countBy compose"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-counter-source
|
||||
"main = do { r <- newCounter 0; count r 3; countBy r 10 2; v <- IORef.readIORef r; return v }")))
|
||||
(list "IO" 23))
|
||||
|
||||
(hk-test
|
||||
"counter.hs — two independent counters"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-counter-source
|
||||
"main = do { a <- newCounter 0; b <- newCounter 0; count a 7; countBy b 100 2; va <- IORef.readIORef a; vb <- IORef.readIORef b; return (va + vb) }")))
|
||||
(list "IO" 207))
|
||||
|
||||
(hk-test
|
||||
"counter.hs — modifyIORef' (strict) variant"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-counter-source
|
||||
"tick r 0 = return ()\ntick r n = do { IORef.modifyIORef' r (\\x -> x + 1); tick r (n - 1) }\nmain = do { r <- newCounter 0; tick r 50; v <- IORef.readIORef r; return v }")))
|
||||
(list "IO" 50))
|
||||
@@ -1,46 +0,0 @@
|
||||
;; mapgraph.hs — adjacency-list using Data.Map (BFS-style traversal).
|
||||
;;
|
||||
;; Exercises Phase 11: `import qualified Data.Map as Map`, `Map.empty`,
|
||||
;; `Map.insert`, `Map.lookup`, `Map.findWithDefault`. Adjacency lists are
|
||||
;; stored as `Map Int [Int]`; `neighbors` does a default-empty lookup.
|
||||
|
||||
(define
|
||||
hk-mapgraph-source
|
||||
"import qualified Data.Map as Map\n\nemptyG = Map.empty\n\naddEdge u v g = Map.insertWith add u [v] g\n where add new old = new ++ old\n\nbuild = addEdge 1 2 (addEdge 1 3 (addEdge 2 4 (addEdge 3 4 (addEdge 4 5 emptyG))))\n\nneighbors n g = Map.findWithDefault [] n g\n")
|
||||
|
||||
(hk-test
|
||||
"mapgraph.hs — neighbors of 1"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-mapgraph-source "main = neighbors 1 build\n")))
|
||||
(list ":" 2 (list ":" 3 (list "[]"))))
|
||||
|
||||
(hk-test
|
||||
"mapgraph.hs — neighbors of 4"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-mapgraph-source "main = neighbors 4 build\n")))
|
||||
(list ":" 5 (list "[]")))
|
||||
|
||||
(hk-test
|
||||
"mapgraph.hs — neighbors of 5 (leaf, no entry) defaults to []"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-mapgraph-source "main = neighbors 5 build\n")))
|
||||
(list "[]"))
|
||||
|
||||
(hk-test
|
||||
"mapgraph.hs — neighbors of 99 (absent) defaults to []"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-mapgraph-source "main = neighbors 99 build\n")))
|
||||
(list "[]"))
|
||||
|
||||
(hk-test
|
||||
"mapgraph.hs — Map.member 1"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-mapgraph-source "main = Map.member 1 build\n")))
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"mapgraph.hs — Map.size = 4 source nodes"
|
||||
(hk-deep-force (hk-run (str hk-mapgraph-source "main = Map.size build\n")))
|
||||
4)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,49 +0,0 @@
|
||||
;; newton.hs — Newton's method for square root.
|
||||
;; Source: classic numerical analysis exercise.
|
||||
;;
|
||||
;; Exercises Phase 10: `Float`, `abs`, `/`, iteration via `until`.
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
(define
|
||||
hk-newton-source
|
||||
"improve x guess = (guess + x / guess) / 2\n\ngoodEnough x guess = abs (guess * guess - x) < 0.0001\n\nnewtonSqrt x = newtonHelp x 1.0\n\nnewtonHelp x guess = if goodEnough x guess\n then guess\n else newtonHelp x (improve x guess)\n")
|
||||
|
||||
(hk-test
|
||||
"newton.hs — newtonSqrt 4 ≈ 2"
|
||||
(hk-prog-val
|
||||
(str hk-newton-source "r = abs (newtonSqrt 4.0 - 2.0) < 0.001\n")
|
||||
"r")
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"newton.hs — newtonSqrt 9 ≈ 3"
|
||||
(hk-prog-val
|
||||
(str hk-newton-source "r = abs (newtonSqrt 9.0 - 3.0) < 0.001\n")
|
||||
"r")
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"newton.hs — newtonSqrt 2 ≈ 1.41421"
|
||||
(hk-prog-val
|
||||
(str hk-newton-source "r = abs (newtonSqrt 2.0 - 1.41421) < 0.001\n")
|
||||
"r")
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"newton.hs — improve converges (one step)"
|
||||
(hk-prog-val (str hk-newton-source "r = improve 4.0 1.0\n") "r")
|
||||
2.5)
|
||||
|
||||
(hk-test
|
||||
"newton.hs — newtonSqrt 100 ≈ 10"
|
||||
(hk-prog-val
|
||||
(str hk-newton-source "r = abs (newtonSqrt 100.0 - 10.0) < 0.001\n")
|
||||
"r")
|
||||
(list "True"))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,58 +0,0 @@
|
||||
;; partial.hs — exercises Phase 9 partial functions caught at the top level.
|
||||
;;
|
||||
;; Each program calls a partial function on bad input; hk-run-io catches the
|
||||
;; raise and appends the error message to io-lines so tests can inspect.
|
||||
|
||||
(hk-test
|
||||
"partial.hs — main = print (head [])"
|
||||
(let
|
||||
((lines (hk-run-io "main = print (head [])")))
|
||||
(>= (index-of (str lines) "Prelude.head: empty list") 0))
|
||||
true)
|
||||
|
||||
(hk-test
|
||||
"partial.hs — main = print (tail [])"
|
||||
(let
|
||||
((lines (hk-run-io "main = print (tail [])")))
|
||||
(>= (index-of (str lines) "Prelude.tail: empty list") 0))
|
||||
true)
|
||||
|
||||
(hk-test
|
||||
"partial.hs — main = print (fromJust Nothing)"
|
||||
(let
|
||||
((lines (hk-run-io "main = print (fromJust Nothing)")))
|
||||
(>= (index-of (str lines) "Maybe.fromJust: Nothing") 0))
|
||||
true)
|
||||
|
||||
(hk-test
|
||||
"partial.hs — putStrLn before error preserves prior output"
|
||||
(let
|
||||
((lines (hk-run-io "main = do { putStrLn \"step 1\"; putStrLn (show (head [])); putStrLn \"never\" }")))
|
||||
(and
|
||||
(>= (index-of (str lines) "step 1") 0)
|
||||
(>= (index-of (str lines) "Prelude.head: empty list") 0)
|
||||
(= (index-of (str lines) "never") -1)))
|
||||
true)
|
||||
|
||||
(hk-test
|
||||
"partial.hs — undefined as IO action"
|
||||
(let
|
||||
((lines (hk-run-io "main = print undefined")))
|
||||
(>= (index-of (str lines) "Prelude.undefined") 0))
|
||||
true)
|
||||
|
||||
(hk-test
|
||||
"partial.hs — catches error from a user-thrown error"
|
||||
(let
|
||||
((lines (hk-run-io "main = error \"boom from main\"")))
|
||||
(>= (index-of (str lines) "boom from main") 0))
|
||||
true)
|
||||
|
||||
;; Negative case: when no error is raised, io-lines doesn't contain
|
||||
;; "Prelude" prefixes from our error path.
|
||||
(hk-test
|
||||
"partial.hs — happy path: head [42] succeeds, no error in output"
|
||||
(hk-run-io "main = print (head [42])")
|
||||
(list "42"))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,51 +0,0 @@
|
||||
;; person.hs — record type with accessors, update, deriving Show.
|
||||
;;
|
||||
;; Exercises Phase 14: data with record syntax, accessor functions,
|
||||
;; record creation, record update, deriving Show on a record.
|
||||
|
||||
(define
|
||||
hk-person-source
|
||||
"data Person = Person { name :: String, age :: Int } deriving (Show)\n\nalice = Person { name = \"alice\", age = 30 }\nbob = Person { name = \"bob\", age = 25 }\n\nbirthday p = p { age = age p + 1 }\n")
|
||||
|
||||
(hk-test
|
||||
"person.hs — alice's name"
|
||||
(hk-deep-force (hk-run (str hk-person-source "main = name alice")))
|
||||
"alice")
|
||||
|
||||
(hk-test
|
||||
"person.hs — alice's age"
|
||||
(hk-deep-force (hk-run (str hk-person-source "main = age alice")))
|
||||
30)
|
||||
|
||||
(hk-test
|
||||
"person.hs — birthday adds one year"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-person-source "main = age (birthday alice)")))
|
||||
31)
|
||||
|
||||
(hk-test
|
||||
"person.hs — birthday preserves name"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-person-source "main = name (birthday alice)")))
|
||||
"alice")
|
||||
|
||||
(hk-test
|
||||
"person.hs — show alice"
|
||||
(hk-deep-force (hk-run (str hk-person-source "main = show alice")))
|
||||
"Person \"alice\" 30")
|
||||
|
||||
(hk-test
|
||||
"person.hs — bob has different name"
|
||||
(hk-deep-force (hk-run (str hk-person-source "main = name bob")))
|
||||
"bob")
|
||||
|
||||
(hk-test
|
||||
"person.hs — pattern match in function"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-person-source
|
||||
"greet (Person { name = n }) = \"Hi, \" ++ n\nmain = greet alice")))
|
||||
"Hi, alice")
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,83 +0,0 @@
|
||||
;; runlength-str.hs — run-length encoding on a String.
|
||||
;; Source: https://rosettacode.org/wiki/Run-length_encoding#Haskell (adapted).
|
||||
;;
|
||||
;; Exercises String pattern matching `(x:xs)`, `span` over a string view,
|
||||
;; tuple construction `(Int, Char)`, character equality, and tuple-in-cons
|
||||
;; patterns `((n, c) : rest)` — all enabled by Phase 7 string=[Char].
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
(define
|
||||
hk-as-list
|
||||
(fn
|
||||
(xs)
|
||||
(cond
|
||||
((and (list? xs) (= (first xs) "[]")) (list))
|
||||
((and (list? xs) (= (first xs) ":"))
|
||||
(cons (nth xs 1) (hk-as-list (nth xs 2))))
|
||||
(:else xs))))
|
||||
|
||||
(define
|
||||
hk-rle-source
|
||||
"encodeRL [] = []\nencodeRL (x:xs) = let (same, rest) = span eqX xs\n eqX y = y == x\n in (1 + length same, x) : encodeRL rest\n\nreplicateRL 0 _ = []\nreplicateRL n c = c : replicateRL (n - 1) c\n\ndecodeRL [] = []\ndecodeRL ((n, c) : rest) = replicateRL n c ++ decodeRL rest\n")
|
||||
|
||||
(hk-test
|
||||
"rle.hs — encodeRL [] = []"
|
||||
(hk-as-list (hk-prog-val (str hk-rle-source "r = encodeRL \"\"\n") "r"))
|
||||
(list))
|
||||
|
||||
(hk-test
|
||||
"rle.hs — length (encodeRL \"aabbbcc\") = 3"
|
||||
(hk-prog-val (str hk-rle-source "r = length (encodeRL \"aabbbcc\")\n") "r")
|
||||
3)
|
||||
|
||||
(hk-test
|
||||
"rle.hs — map fst (encodeRL \"aabbbcc\") = [2,3,2]"
|
||||
(hk-as-list
|
||||
(hk-prog-val (str hk-rle-source "r = map fst (encodeRL \"aabbbcc\")\n") "r"))
|
||||
(list 2 3 2))
|
||||
|
||||
(hk-test
|
||||
"rle.hs — map snd (encodeRL \"aabbbcc\") = [97,98,99]"
|
||||
(hk-as-list
|
||||
(hk-prog-val (str hk-rle-source "r = map snd (encodeRL \"aabbbcc\")\n") "r"))
|
||||
(list 97 98 99))
|
||||
|
||||
(hk-test
|
||||
"rle.hs — counts of encodeRL \"aabbbccddddee\" = [2,3,2,4,2]"
|
||||
(hk-as-list
|
||||
(hk-prog-val
|
||||
(str hk-rle-source "r = map fst (encodeRL \"aabbbccddddee\")\n")
|
||||
"r"))
|
||||
(list 2 3 2 4 2))
|
||||
|
||||
(hk-test
|
||||
"rle.hs — chars of encodeRL \"aabbbccddddee\" = [97,98,99,100,101]"
|
||||
(hk-as-list
|
||||
(hk-prog-val
|
||||
(str hk-rle-source "r = map snd (encodeRL \"aabbbccddddee\")\n")
|
||||
"r"))
|
||||
(list 97 98 99 100 101))
|
||||
|
||||
(hk-test
|
||||
"rle.hs — singleton encodeRL \"x\""
|
||||
(hk-as-list
|
||||
(hk-prog-val (str hk-rle-source "r = map fst (encodeRL \"x\")\n") "r"))
|
||||
(list 1))
|
||||
|
||||
(hk-test
|
||||
"rle.hs — decodeRL round-trip preserves \"aabbbcc\""
|
||||
(hk-as-list
|
||||
(hk-prog-val (str hk-rle-source "r = decodeRL (encodeRL \"aabbbcc\")\n") "r"))
|
||||
(list 97 97 98 98 98 99 99))
|
||||
|
||||
(hk-test
|
||||
"rle.hs — replicateRL 4 65 = [65,65,65,65]"
|
||||
(hk-as-list (hk-prog-val (str hk-rle-source "r = replicateRL 4 65\n") "r"))
|
||||
(list 65 65 65 65))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,80 +0,0 @@
|
||||
;; safediv.hs — safe division using catch (Phase 16 conformance).
|
||||
|
||||
(define
|
||||
hk-safediv-source
|
||||
"safeDiv :: Int -> Int -> IO Int
|
||||
safeDiv _ 0 = throwIO (SomeException \"division by zero\")
|
||||
safeDiv x y = return (x `div` y)
|
||||
|
||||
guarded :: Int -> Int -> IO Int
|
||||
guarded x y = catch (safeDiv x y) (\\(SomeException _) -> return 0)
|
||||
|
||||
reason :: Int -> Int -> IO String
|
||||
reason x y = catch (safeDiv x y `seq` return \"ok\")
|
||||
(\\(SomeException m) -> return m)
|
||||
|
||||
bothBranches :: Int -> Int -> IO Int
|
||||
bothBranches x y = do
|
||||
v <- catch (safeDiv x y) (\\(SomeException _) -> return (-1))
|
||||
return (v + 100)
|
||||
|
||||
")
|
||||
|
||||
(hk-test
|
||||
"safediv.hs — divide by non-zero"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-safediv-source "main = guarded 10 2")))
|
||||
(list "IO" 5))
|
||||
|
||||
(hk-test
|
||||
"safediv.hs — divide by zero returns 0"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-safediv-source "main = guarded 10 0")))
|
||||
(list "IO" 0))
|
||||
|
||||
(hk-test
|
||||
"safediv.hs — divide by zero — reason captured"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-safediv-source "main = catch (safeDiv 1 0) (\\(SomeException m) -> return 0) >> reason 1 0")))
|
||||
(list "IO" "division by zero"))
|
||||
|
||||
(hk-test
|
||||
"safediv.hs — bothBranches success path"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-safediv-source "main = bothBranches 8 2")))
|
||||
(list "IO" 104))
|
||||
|
||||
(hk-test
|
||||
"safediv.hs — bothBranches failure path"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-safediv-source "main = bothBranches 8 0")))
|
||||
(list "IO" 99))
|
||||
|
||||
(hk-test
|
||||
"safediv.hs — chained safeDiv with catch"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-safediv-source
|
||||
"main = do { a <- guarded 20 4; b <- guarded 7 0; return (a + b) }")))
|
||||
(list "IO" 5))
|
||||
|
||||
(hk-test
|
||||
"safediv.hs — try then bind through Either"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-safediv-source
|
||||
"main = do { r <- try (safeDiv 1 0); case r of { Right v -> return v; Left (SomeException m) -> return 999 } }")))
|
||||
(list "IO" 999))
|
||||
|
||||
(hk-test
|
||||
"safediv.hs — handle (flip catch)"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-safediv-source
|
||||
"main = handle (\\(SomeException _) -> return 0) (safeDiv 5 0)")))
|
||||
(list "IO" 0))
|
||||
@@ -1,61 +0,0 @@
|
||||
;; setops.hs — set union/intersection/difference on integer sets.
|
||||
;;
|
||||
;; Exercises Phase 12: `import qualified Data.Set as Set`, all three
|
||||
;; combining operations + isSubsetOf.
|
||||
|
||||
(define
|
||||
hk-setops-source
|
||||
"import qualified Data.Set as Set\n\ns1 = Set.insert 1 (Set.insert 2 (Set.insert 3 Set.empty))\ns2 = Set.insert 3 (Set.insert 4 (Set.insert 5 Set.empty))\ns3 = Set.insert 1 (Set.insert 2 Set.empty)\n")
|
||||
|
||||
(hk-test
|
||||
"setops.hs — union size = 5"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-setops-source "main = Set.size (Set.union s1 s2)\n")))
|
||||
5)
|
||||
|
||||
(hk-test
|
||||
"setops.hs — intersection size = 1"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-setops-source "main = Set.size (Set.intersection s1 s2)\n")))
|
||||
1)
|
||||
|
||||
(hk-test
|
||||
"setops.hs — intersection contains 3"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-setops-source "main = Set.member 3 (Set.intersection s1 s2)\n")))
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"setops.hs — difference s1 s2 size = 2"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-setops-source "main = Set.size (Set.difference s1 s2)\n")))
|
||||
2)
|
||||
|
||||
(hk-test
|
||||
"setops.hs — difference doesn't contain shared key"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-setops-source "main = Set.member 3 (Set.difference s1 s2)\n")))
|
||||
(list "False"))
|
||||
|
||||
(hk-test
|
||||
"setops.hs — s3 is subset of s1"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-setops-source "main = Set.isSubsetOf s3 s1\n")))
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"setops.hs — s1 not subset of s3"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-setops-source "main = Set.isSubsetOf s1 s3\n")))
|
||||
(list "False"))
|
||||
|
||||
(hk-test
|
||||
"setops.hs — empty set is subset of anything"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-setops-source "main = Set.isSubsetOf Set.empty s1\n")))
|
||||
(list "True"))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,40 +0,0 @@
|
||||
;; shapes.hs — class Area with a default perimeter, two instances
|
||||
;; using where-local helpers.
|
||||
;;
|
||||
;; Exercises Phase 13: class default method (perimeter), instance
|
||||
;; methods that use `where`-bindings.
|
||||
|
||||
(define
|
||||
hk-shapes-source
|
||||
"class Shape a where\n area :: a -> Int\n perimeter :: a -> Int\n perimeter x = quadrilateral x\n where quadrilateral y = 2 * (sideA y + sideB y)\n sideA z = 1\n sideB z = 1\n\ndata Square = Square Int\ndata Rect = Rect Int Int\n\ninstance Shape Square where\n area (Square s) = s * s\n perimeter (Square s) = 4 * s\n\ninstance Shape Rect where\n area (Rect w h) = w * h\n perimeter (Rect w h) = peri\n where peri = 2 * (w + h)\n")
|
||||
|
||||
(hk-test
|
||||
"shapes.hs — area of Square 5 = 25"
|
||||
(hk-deep-force (hk-run (str hk-shapes-source "main = area (Square 5)\n")))
|
||||
25)
|
||||
|
||||
(hk-test
|
||||
"shapes.hs — perimeter of Square 5 = 20"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-shapes-source "main = perimeter (Square 5)\n")))
|
||||
20)
|
||||
|
||||
(hk-test
|
||||
"shapes.hs — area of Rect 3 4 = 12"
|
||||
(hk-deep-force (hk-run (str hk-shapes-source "main = area (Rect 3 4)\n")))
|
||||
12)
|
||||
|
||||
(hk-test
|
||||
"shapes.hs — perimeter of Rect 3 4 = 14 (via where-bound)"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-shapes-source "main = perimeter (Rect 3 4)\n")))
|
||||
14)
|
||||
|
||||
(hk-test
|
||||
"shapes.hs — Square sums area + perimeter"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-shapes-source "main = area (Square 4) + perimeter (Square 4)\n")))
|
||||
32)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,45 +0,0 @@
|
||||
;; showadt.hs — `deriving (Show)` on a multi-constructor recursive ADT.
|
||||
;; Source: classic exposition example, e.g. Real World Haskell ch.6.
|
||||
;;
|
||||
;; Exercises Phase 8: `deriving (Show)` on an ADT whose constructors recurse
|
||||
;; into themselves; precedence-based paren wrapping for nested arguments;
|
||||
;; `print` from the prelude (which is `putStrLn (show x)`).
|
||||
|
||||
(define
|
||||
hk-showadt-source
|
||||
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\n\nmain = do\n print (Lit 3)\n print (Add (Lit 1) (Lit 2))\n print (Mul (Lit 3) (Add (Lit 4) (Lit 5)))\n")
|
||||
|
||||
(hk-test
|
||||
"showadt.hs — main prints three lines"
|
||||
(hk-run-io hk-showadt-source)
|
||||
(list "Lit 3" "Add (Lit 1) (Lit 2)" "Mul (Lit 3) (Add (Lit 4) (Lit 5))"))
|
||||
|
||||
(hk-test
|
||||
"showadt.hs — show Lit 3"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Lit 3)"))
|
||||
"Lit 3")
|
||||
|
||||
(hk-test
|
||||
"showadt.hs — show Add wraps both args"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Add (Lit 1) (Lit 2))"))
|
||||
"Add (Lit 1) (Lit 2)")
|
||||
|
||||
(hk-test
|
||||
"showadt.hs — fully nested Mul of Adds"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Mul (Add (Lit 1) (Lit 2)) (Add (Lit 3) (Lit 4)))"))
|
||||
"Mul (Add (Lit 1) (Lit 2)) (Add (Lit 3) (Lit 4))")
|
||||
|
||||
(hk-test
|
||||
"showadt.hs — Lit with negative literal wraps int in parens"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Lit (negate 7))"))
|
||||
"Lit (-7)")
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,36 +0,0 @@
|
||||
;; showio.hs — `print` on various types inside a `do` block.
|
||||
;;
|
||||
;; Exercises Phase 8 `print x = putStrLn (show x)` and the IO monad's
|
||||
;; statement sequencing. Each `print` produces one io-line.
|
||||
|
||||
(define
|
||||
hk-showio-source
|
||||
"main = do\n print 42\n print True\n print False\n print [1,2,3]\n print (1, 2)\n print (Just 5)\n print Nothing\n print \"hello\"\n")
|
||||
|
||||
(hk-test
|
||||
"showio.hs — main produces 8 lines, all show-formatted"
|
||||
(hk-run-io hk-showio-source)
|
||||
(list "42" "True" "False" "[1,2,3]" "(1,2)" "Just 5" "Nothing" "\"hello\""))
|
||||
|
||||
(hk-test
|
||||
"showio.hs — print Int alone"
|
||||
(hk-run-io "main = print 42")
|
||||
(list "42"))
|
||||
|
||||
(hk-test
|
||||
"showio.hs — print list of Maybe"
|
||||
(hk-run-io "main = print [Just 1, Nothing, Just 3]")
|
||||
(list "[Just 1,Nothing,Just 3]"))
|
||||
|
||||
(hk-test
|
||||
"showio.hs — print nested tuple"
|
||||
(hk-run-io "main = print ((1, 2), (3, 4))")
|
||||
(list "((1,2),(3,4))"))
|
||||
|
||||
(hk-test
|
||||
"showio.hs — print derived ADT inside do"
|
||||
(hk-run-io
|
||||
"data Color = Red | Green | Blue deriving (Show)\nmain = do { print Red; print Green; print Blue }")
|
||||
(list "Red" "Green" "Blue"))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,45 +0,0 @@
|
||||
;; statistics.hs — mean, variance, std-dev on a [Double].
|
||||
;; Source: classic textbook example.
|
||||
;;
|
||||
;; Exercises Phase 10: `fromIntegral`, `/`, `sqrt`, list ops on `[Double]`.
|
||||
|
||||
(define
|
||||
hk-prog-val
|
||||
(fn
|
||||
(src name)
|
||||
(hk-deep-force (get (hk-eval-program (hk-core src)) name))))
|
||||
|
||||
(define
|
||||
hk-stats-source
|
||||
"mean xs = sum xs / fromIntegral (length xs)\n\nvariance xs = let m = mean xs\n sqDiff x = (x - m) * (x - m)\n in sum (map sqDiff xs) / fromIntegral (length xs)\n\nstdDev xs = sqrt (variance xs)\n")
|
||||
|
||||
(hk-test
|
||||
"statistics.hs — mean [1,2,3,4,5] = 3"
|
||||
(hk-prog-val (str hk-stats-source "r = mean [1.0,2.0,3.0,4.0,5.0]\n") "r")
|
||||
3)
|
||||
|
||||
(hk-test
|
||||
"statistics.hs — mean [10,20,30] = 20"
|
||||
(hk-prog-val (str hk-stats-source "r = mean [10.0,20.0,30.0]\n") "r")
|
||||
20)
|
||||
|
||||
(hk-test
|
||||
"statistics.hs — variance [2,4,4,4,5,5,7,9] = 4"
|
||||
(hk-prog-val
|
||||
(str hk-stats-source "r = variance [2.0,4.0,4.0,4.0,5.0,5.0,7.0,9.0]\n")
|
||||
"r")
|
||||
4)
|
||||
|
||||
(hk-test
|
||||
"statistics.hs — stdDev [2,4,4,4,5,5,7,9] = 2"
|
||||
(hk-prog-val
|
||||
(str hk-stats-source "r = stdDev [2.0,4.0,4.0,4.0,5.0,5.0,7.0,9.0]\n")
|
||||
"r")
|
||||
2)
|
||||
|
||||
(hk-test
|
||||
"statistics.hs — variance of constant list = 0"
|
||||
(hk-prog-val (str hk-stats-source "r = variance [5.0,5.0,5.0,5.0]\n") "r")
|
||||
0)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,95 +0,0 @@
|
||||
;; trycatch.hs — try pattern: branch on Left/Right (Phase 16 conformance).
|
||||
|
||||
(define
|
||||
hk-trycatch-source
|
||||
"parseInt :: String -> IO Int
|
||||
parseInt \"zero\" = return 0
|
||||
parseInt \"one\" = return 1
|
||||
parseInt \"two\" = return 2
|
||||
parseInt s = throwIO (SomeException (\"unknown: \" ++ s))
|
||||
|
||||
describe :: Either SomeException Int -> String
|
||||
describe (Right v) = \"got \" ++ show v
|
||||
describe (Left (SomeException m)) = \"err: \" ++ m
|
||||
|
||||
trial :: String -> IO String
|
||||
trial s = do
|
||||
r <- try (parseInt s)
|
||||
return (describe r)
|
||||
|
||||
run3 :: String -> String -> String -> IO [String]
|
||||
run3 a b c = do
|
||||
ra <- trial a
|
||||
rb <- trial b
|
||||
rc <- trial c
|
||||
return [ra, rb, rc]
|
||||
|
||||
")
|
||||
|
||||
(hk-test
|
||||
"trycatch.hs — Right branch"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-trycatch-source "main = trial \"one\"")))
|
||||
(list "IO" "got 1"))
|
||||
|
||||
(hk-test
|
||||
"trycatch.hs — Left branch with message"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-trycatch-source "main = trial \"banana\"")))
|
||||
(list "IO" "err: unknown: banana"))
|
||||
|
||||
(hk-test
|
||||
"trycatch.hs — chain over three inputs, all good"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-trycatch-source "main = run3 \"zero\" \"one\" \"two\"")))
|
||||
(list "IO"
|
||||
(list ":" "got 0"
|
||||
(list ":" "got 1"
|
||||
(list ":" "got 2"
|
||||
(list "[]"))))))
|
||||
|
||||
(hk-test
|
||||
"trycatch.hs — chain over three inputs, mixed"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-trycatch-source "main = run3 \"zero\" \"qux\" \"two\"")))
|
||||
(list "IO"
|
||||
(list ":" "got 0"
|
||||
(list ":" "err: unknown: qux"
|
||||
(list ":" "got 2"
|
||||
(list "[]"))))))
|
||||
|
||||
(hk-test
|
||||
"trycatch.hs — Left from throwIO carries message"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-trycatch-source
|
||||
"main = do { r <- try (throwIO (SomeException \"explicit\")); return (describe r) }")))
|
||||
(list "IO" "err: explicit"))
|
||||
|
||||
(hk-test
|
||||
"trycatch.hs — Right preserves the int"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-trycatch-source
|
||||
"main = do { r <- try (return 42); return (describe r) }")))
|
||||
(list "IO" "got 42"))
|
||||
|
||||
(hk-test
|
||||
"trycatch.hs — pattern-bind on Right inside do"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-trycatch-source
|
||||
"main = do { Right v <- try (parseInt \"two\"); return (v + 100) }")))
|
||||
(list "IO" 102))
|
||||
|
||||
(hk-test
|
||||
"trycatch.hs — handle alias on parseInt failure"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-trycatch-source
|
||||
"main = handle (\\(SomeException m) -> return (\"caught: \" ++ m)) (parseInt \"nope\" >>= (\\v -> return (show v)))")))
|
||||
(list "IO" "caught: unknown: nope"))
|
||||
@@ -1,35 +0,0 @@
|
||||
;; uniquewords.hs — count unique words using Data.Set.
|
||||
;;
|
||||
;; Exercises Phase 12: `import qualified Data.Set as Set`, `Set.empty`,
|
||||
;; `Set.insert`, `Set.size`, `foldl`.
|
||||
|
||||
(define
|
||||
hk-uniquewords-source
|
||||
"import qualified Data.Set as Set\n\naddWord s w = Set.insert w s\n\nuniqueWords ws = foldl addWord Set.empty ws\n\nresult = uniqueWords [\"the\", \"cat\", \"the\", \"dog\", \"the\", \"cat\"]\n")
|
||||
|
||||
(hk-test
|
||||
"uniquewords.hs — unique count = 3"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-uniquewords-source "main = Set.size result\n")))
|
||||
3)
|
||||
|
||||
(hk-test
|
||||
"uniquewords.hs — \"the\" present"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-uniquewords-source "main = Set.member \"the\" result\n")))
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"uniquewords.hs — \"missing\" absent"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-uniquewords-source "main = Set.member \"missing\" result\n")))
|
||||
(list "False"))
|
||||
|
||||
(hk-test
|
||||
"uniquewords.hs — empty list yields empty set"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.Set as Set\nmain = Set.size (foldl (\\s w -> Set.insert w s) Set.empty [])"))
|
||||
0)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,54 +0,0 @@
|
||||
;; wordfreq.hs — word-frequency histogram using Data.Map.
|
||||
;; Source: Rosetta Code "Word frequency" (Haskell entry, simplified).
|
||||
;;
|
||||
;; Exercises Phase 11: `import qualified Data.Map as Map`, `Map.empty`,
|
||||
;; `Map.insertWith`, `Map.lookup`, `Map.findWithDefault`, `foldl`.
|
||||
|
||||
(define
|
||||
hk-wordfreq-source
|
||||
"import qualified Data.Map as Map\n\ncountWord m w = Map.insertWith (+) w 1 m\n\nwordFreq xs = foldl countWord Map.empty xs\n\nresult = wordFreq [\"the\", \"cat\", \"the\", \"dog\", \"the\", \"cat\"]\n")
|
||||
|
||||
(hk-test
|
||||
"wordfreq.hs — \"the\" counted 3 times"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-wordfreq-source "main = Map.lookup \"the\" result\n")))
|
||||
(list "Just" 3))
|
||||
|
||||
(hk-test
|
||||
"wordfreq.hs — \"cat\" counted 2 times"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-wordfreq-source "main = Map.lookup \"cat\" result\n")))
|
||||
(list "Just" 2))
|
||||
|
||||
(hk-test
|
||||
"wordfreq.hs — \"dog\" counted 1 time"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-wordfreq-source "main = Map.lookup \"dog\" result\n")))
|
||||
(list "Just" 1))
|
||||
|
||||
(hk-test
|
||||
"wordfreq.hs — \"missing\" not present"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-wordfreq-source "main = Map.lookup \"missing\" result\n")))
|
||||
(list "Nothing"))
|
||||
|
||||
(hk-test
|
||||
"wordfreq.hs — Map.size = 3 unique words"
|
||||
(hk-deep-force (hk-run (str hk-wordfreq-source "main = Map.size result\n")))
|
||||
3)
|
||||
|
||||
(hk-test
|
||||
"wordfreq.hs — findWithDefault for missing returns 0"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-wordfreq-source "main = Map.findWithDefault 0 \"absent\" result\n")))
|
||||
0)
|
||||
|
||||
(hk-test
|
||||
"wordfreq.hs — findWithDefault for present returns count"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-wordfreq-source "main = Map.findWithDefault 0 \"the\" result\n")))
|
||||
3)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,127 +0,0 @@
|
||||
;; records.sx — Phase 14 record syntax tests.
|
||||
|
||||
(define
|
||||
hk-person-source
|
||||
"data Person = Person { name :: String, age :: Int }\n")
|
||||
|
||||
(define hk-pt-source "data Pt = Pt { x :: Int, y :: Int }\n")
|
||||
|
||||
;; ── Creation ────────────────────────────────────────────────
|
||||
(hk-test
|
||||
"creation: Person { name = \"a\", age = 1 } via accessor name"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-person-source
|
||||
"main = name (Person { name = \"alice\", age = 30 })")))
|
||||
"alice")
|
||||
|
||||
(hk-test
|
||||
"creation: source order doesn't matter (age first)"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-person-source "main = name (Person { age = 99, name = \"bob\" })")))
|
||||
"bob")
|
||||
|
||||
(hk-test
|
||||
"creation: age accessor returns the right field"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str hk-person-source "main = age (Person { age = 99, name = \"bob\" })")))
|
||||
99)
|
||||
|
||||
;; ── Accessors ──────────────────────────────────────────────
|
||||
(hk-test
|
||||
"accessor: x of Pt"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-pt-source "main = x (Pt { x = 7, y = 99 })")))
|
||||
7)
|
||||
|
||||
(hk-test
|
||||
"accessor: y of Pt"
|
||||
(hk-deep-force
|
||||
(hk-run (str hk-pt-source "main = y (Pt { x = 7, y = 99 })")))
|
||||
99)
|
||||
|
||||
;; ── Update — single field ──────────────────────────────────
|
||||
(hk-test
|
||||
"update one field: age changes"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-person-source
|
||||
"alice = Person { name = \"alice\", age = 30 }\nmain = age (alice { age = 31 })")))
|
||||
31)
|
||||
|
||||
(hk-test
|
||||
"update one field: name preserved"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-person-source
|
||||
"alice = Person { name = \"alice\", age = 30 }\nmain = name (alice { age = 31 })")))
|
||||
"alice")
|
||||
|
||||
;; ── Update — two fields ────────────────────────────────────
|
||||
(hk-test
|
||||
"update two fields: both changed"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-person-source
|
||||
"alice = Person { name = \"alice\", age = 30 }\nbob = alice { name = \"bob\", age = 50 }\nmain = age bob")))
|
||||
50)
|
||||
|
||||
(hk-test
|
||||
"update two fields: name takes new value"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-person-source
|
||||
"alice = Person { name = \"alice\", age = 30 }\nbob = alice { name = \"bob\", age = 50 }\nmain = name bob")))
|
||||
"bob")
|
||||
|
||||
;; ── Record patterns ────────────────────────────────────────
|
||||
(hk-test
|
||||
"case-alt record pattern: Pt { x = a }"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-pt-source
|
||||
"getX p = case p of Pt { x = a } -> a\nmain = getX (Pt { x = 7, y = 99 })")))
|
||||
7)
|
||||
|
||||
(hk-test
|
||||
"case-alt record pattern: multi-field bind"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-pt-source
|
||||
"sumPt p = case p of Pt { x = a, y = b } -> a + b\nmain = sumPt (Pt { x = 3, y = 4 })")))
|
||||
7)
|
||||
|
||||
(hk-test
|
||||
"fun-LHS record pattern"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
(str
|
||||
hk-person-source
|
||||
"getName (Person { name = n }) = n\nmain = getName (Person { name = \"alice\", age = 30 })")))
|
||||
"alice")
|
||||
|
||||
;; ── deriving Show on a record ───────────────────────────────
|
||||
(hk-test
|
||||
"deriving Show on a record produces positional output"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"data Person = Person { name :: String, age :: Int } deriving (Show)\nmain = show (Person { name = \"alice\", age = 30 })"))
|
||||
"Person \"alice\" 30")
|
||||
|
||||
(hk-test
|
||||
"deriving Show on Pt"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"data Pt = Pt { x :: Int, y :: Int } deriving (Show)\nmain = show (Pt { x = 3, y = 4 })"))
|
||||
"Pt 3 4")
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,119 +0,0 @@
|
||||
;; set.sx — Phase 12 Data.Set unit tests.
|
||||
|
||||
;; ── SX-level (direct hk-set-*) ───────────────────────────────
|
||||
(hk-test
|
||||
"hk-set-empty: size 0 + null"
|
||||
(list (hk-set-size hk-set-empty) (hk-set-null hk-set-empty))
|
||||
(list 0 true))
|
||||
|
||||
(hk-test
|
||||
"hk-set-singleton: member yes"
|
||||
(let
|
||||
((s (hk-set-singleton 5)))
|
||||
(list (hk-set-size s) (hk-set-member 5 s) (hk-set-member 99 s)))
|
||||
(list 1 true false))
|
||||
|
||||
(hk-test
|
||||
"hk-set-insert: idempotent"
|
||||
(let
|
||||
((s (hk-set-insert 1 (hk-set-insert 1 hk-set-empty))))
|
||||
(hk-set-size s))
|
||||
1)
|
||||
|
||||
(hk-test
|
||||
"hk-set-from-list: dedupes"
|
||||
(hk-set-to-asc-list (hk-set-from-list (list 3 1 4 1 5 9 2 6)))
|
||||
(list 1 2 3 4 5 6 9))
|
||||
|
||||
(hk-test
|
||||
"hk-set-delete: removes"
|
||||
(let
|
||||
((s (hk-set-from-list (list 1 2 3))))
|
||||
(hk-set-to-asc-list (hk-set-delete 2 s)))
|
||||
(list 1 3))
|
||||
|
||||
(hk-test
|
||||
"hk-set-union"
|
||||
(hk-set-to-asc-list
|
||||
(hk-set-union
|
||||
(hk-set-from-list (list 1 2 3))
|
||||
(hk-set-from-list (list 3 4 5))))
|
||||
(list 1 2 3 4 5))
|
||||
|
||||
(hk-test
|
||||
"hk-set-intersection"
|
||||
(hk-set-to-asc-list
|
||||
(hk-set-intersection
|
||||
(hk-set-from-list (list 1 2 3 4))
|
||||
(hk-set-from-list (list 3 4 5 6))))
|
||||
(list 3 4))
|
||||
|
||||
(hk-test
|
||||
"hk-set-difference"
|
||||
(hk-set-to-asc-list
|
||||
(hk-set-difference
|
||||
(hk-set-from-list (list 1 2 3 4))
|
||||
(hk-set-from-list (list 3 4 5))))
|
||||
(list 1 2))
|
||||
|
||||
(hk-test
|
||||
"hk-set-is-subset-of: yes"
|
||||
(hk-set-is-subset-of
|
||||
(hk-set-from-list (list 2 3))
|
||||
(hk-set-from-list (list 1 2 3 4)))
|
||||
true)
|
||||
|
||||
(hk-test
|
||||
"hk-set-is-subset-of: no"
|
||||
(hk-set-is-subset-of
|
||||
(hk-set-from-list (list 5 6))
|
||||
(hk-set-from-list (list 1 2 3 4)))
|
||||
false)
|
||||
|
||||
(hk-test
|
||||
"hk-set-filter"
|
||||
(hk-set-to-asc-list
|
||||
(hk-set-filter (fn (k) (> k 2)) (hk-set-from-list (list 1 2 3 4 5))))
|
||||
(list 3 4 5))
|
||||
|
||||
(hk-test
|
||||
"hk-set-map"
|
||||
(hk-set-to-asc-list
|
||||
(hk-set-map (fn (k) (* k 10)) (hk-set-from-list (list 1 2 3))))
|
||||
(list 10 20 30))
|
||||
|
||||
(hk-test
|
||||
"hk-set-foldr: sum"
|
||||
(hk-set-foldr + 0 (hk-set-from-list (list 1 2 3 4 5)))
|
||||
15)
|
||||
|
||||
;; ── Haskell-level (Set.* via import wiring) ──────────────────
|
||||
(hk-test
|
||||
"Set.size after Set.insert chain"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.Set as Set\nmain = Set.size (Set.insert 3 (Set.insert 1 (Set.insert 2 Set.empty)))"))
|
||||
3)
|
||||
|
||||
(hk-test
|
||||
"Set.member true"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.Set as Set\nmain = Set.member 5 (Set.insert 5 Set.empty)"))
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"Set.union via Haskell"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import Data.Set\nmain = Set.size (Set.union (Set.insert 1 Set.empty) (Set.insert 2 Set.empty))"))
|
||||
2)
|
||||
|
||||
(hk-test
|
||||
"Set.isSubsetOf via Haskell"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"import qualified Data.Set as S\nmain = S.isSubsetOf (S.insert 1 S.empty) (S.insert 2 (S.insert 1 S.empty))"))
|
||||
(list "True"))
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -1,140 +0,0 @@
|
||||
;; show.sx — tests for the Show / Read class plumbing.
|
||||
;;
|
||||
;; Covers Phase 8:
|
||||
;; - showsPrec / showParen / shows / showString stubs
|
||||
;; - Read class stubs (reads / readsPrec / read)
|
||||
;; - direct show coverage (Int, Bool, String, list, tuple, Maybe, ADT, ...)
|
||||
|
||||
;; ── ShowS / showsPrec / showParen stubs ──────────────────────
|
||||
(hk-test
|
||||
"shows: prepends show output"
|
||||
(hk-deep-force (hk-run "main = shows 5 \"abc\""))
|
||||
"5abc")
|
||||
|
||||
(hk-test
|
||||
"shows: works on True"
|
||||
(hk-deep-force (hk-run "main = shows True \"x\""))
|
||||
"Truex")
|
||||
|
||||
(hk-test
|
||||
"showString: prepends literal"
|
||||
(hk-deep-force (hk-run "main = showString \"hello\" \" world\""))
|
||||
"hello world")
|
||||
|
||||
(hk-test
|
||||
"showParen True: wraps inner output in parens"
|
||||
(hk-deep-force (hk-run "main = showParen True (showString \"inside\") \"\""))
|
||||
"(inside)")
|
||||
|
||||
(hk-test
|
||||
"showParen False: passes through unchanged"
|
||||
(hk-deep-force (hk-run "main = showParen False (showString \"inside\") \"\""))
|
||||
"inside")
|
||||
|
||||
(hk-test
|
||||
"showsPrec: prepends show output regardless of prec"
|
||||
(hk-deep-force (hk-run "main = showsPrec 11 42 \"end\""))
|
||||
"42end")
|
||||
|
||||
(hk-test
|
||||
"showParen + manual composition: build (Just 3)"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"buildJust3 s = showString \"Just \" (shows 3 s)\nmain = showParen True buildJust3 \"\""))
|
||||
"(Just 3)")
|
||||
|
||||
;; ── Read stubs ───────────────────────────────────────────────
|
||||
(hk-test
|
||||
"reads: stub returns empty list (null-check)"
|
||||
(hk-deep-force (hk-run "main = show (null (reads \"42\"))"))
|
||||
"True")
|
||||
|
||||
(hk-test
|
||||
"readsPrec: stub returns empty list"
|
||||
(hk-deep-force (hk-run "main = show (null (readsPrec 0 \"True\"))"))
|
||||
"True")
|
||||
|
||||
(hk-test
|
||||
"reads: type-checks in expression context (length)"
|
||||
(hk-deep-force (hk-run "main = show (length (reads \"abc\"))"))
|
||||
"0")
|
||||
|
||||
;; ── Direct `show` audit coverage ─────────────────────────────
|
||||
(hk-test "show Int" (hk-deep-force (hk-run "main = show 42")) "42")
|
||||
|
||||
(hk-test
|
||||
"show negative Int"
|
||||
(hk-deep-force (hk-run "main = show (negate 5)"))
|
||||
"-5")
|
||||
|
||||
(hk-test "show Bool True" (hk-deep-force (hk-run "main = show True")) "True")
|
||||
|
||||
(hk-test
|
||||
"show Bool False"
|
||||
(hk-deep-force (hk-run "main = show False"))
|
||||
"False")
|
||||
|
||||
(hk-test
|
||||
"show String quotes the value"
|
||||
(hk-deep-force (hk-run "main = show \"hello\""))
|
||||
"\"hello\"")
|
||||
|
||||
(hk-test
|
||||
"show list of Int"
|
||||
(hk-deep-force (hk-run "main = show [1,2,3]"))
|
||||
"[1,2,3]")
|
||||
|
||||
(hk-test
|
||||
"show empty list"
|
||||
(hk-deep-force (hk-run "main = show (drop 5 [1,2,3])"))
|
||||
"[]")
|
||||
|
||||
(hk-test
|
||||
"show pair tuple"
|
||||
(hk-deep-force (hk-run "main = show (1, True)"))
|
||||
"(1,True)")
|
||||
|
||||
(hk-test
|
||||
"show triple tuple"
|
||||
(hk-deep-force (hk-run "main = show (1, 2, 3)"))
|
||||
"(1,2,3)")
|
||||
|
||||
(hk-test
|
||||
"show Maybe Nothing"
|
||||
(hk-deep-force (hk-run "main = show Nothing"))
|
||||
"Nothing")
|
||||
|
||||
(hk-test
|
||||
"show Maybe Just"
|
||||
(hk-deep-force (hk-run "main = show (Just 3)"))
|
||||
"Just 3")
|
||||
|
||||
(hk-test
|
||||
"show nested Just wraps inner in parens"
|
||||
(hk-deep-force (hk-run "main = show (Just (Just 3))"))
|
||||
"Just (Just 3)")
|
||||
|
||||
(hk-test
|
||||
"show Just (negate 3) wraps negative in parens"
|
||||
(hk-deep-force (hk-run "main = show (Just (negate 3))"))
|
||||
"Just (-3)")
|
||||
|
||||
(hk-test
|
||||
"show custom nullary ADT"
|
||||
(hk-deep-force
|
||||
(hk-run "data Day = Mon | Tue | Wed deriving (Show)\nmain = show Tue"))
|
||||
"Tue")
|
||||
|
||||
(hk-test
|
||||
"show custom multi-constructor ADT"
|
||||
(hk-deep-force
|
||||
(hk-run
|
||||
"data Shape = Pt | Sq Int | Rect Int Int deriving (Show)\nmain = show (Rect 3 4)"))
|
||||
"Rect 3 4")
|
||||
|
||||
(hk-test
|
||||
"show list of Maybe wraps each element"
|
||||
(hk-deep-force (hk-run "main = show [Just 1, Nothing, Just 2]"))
|
||||
"[Just 1,Nothing,Just 2]")
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -37,11 +37,11 @@
|
||||
(hk-ts "show neg" "negate 7" "-7")
|
||||
(hk-ts "show bool T" "True" "True")
|
||||
(hk-ts "show bool F" "False" "False")
|
||||
(hk-ts "show list" "[1,2,3]" "[1,2,3]")
|
||||
(hk-ts "show Just" "Just 5" "Just 5")
|
||||
(hk-ts "show list" "[1,2,3]" "[1, 2, 3]")
|
||||
(hk-ts "show Just" "Just 5" "(Just 5)")
|
||||
(hk-ts "show Nothing" "Nothing" "Nothing")
|
||||
(hk-ts "show LT" "LT" "LT")
|
||||
(hk-ts "show tuple" "(1, True)" "(1,True)")
|
||||
(hk-ts "show tuple" "(1, True)" "(1, True)")
|
||||
|
||||
;; ── Num extras ───────────────────────────────────────────────
|
||||
(hk-test "signum pos" (hk-deep-force (hk-run "main = signum 5")) 1)
|
||||
@@ -59,13 +59,13 @@
|
||||
(hk-test
|
||||
"foldr cons"
|
||||
(hk-deep-force (hk-run "main = show (foldr (:) [] [1,2,3])"))
|
||||
"[1,2,3]")
|
||||
"[1, 2, 3]")
|
||||
|
||||
;; ── List ops ─────────────────────────────────────────────────
|
||||
(hk-test
|
||||
"reverse"
|
||||
(hk-deep-force (hk-run "main = show (reverse [1,2,3])"))
|
||||
"[3,2,1]")
|
||||
"[3, 2, 1]")
|
||||
(hk-test "null []" (hk-deep-force (hk-run "main = null []")) (list "True"))
|
||||
(hk-test
|
||||
"null xs"
|
||||
@@ -82,7 +82,7 @@
|
||||
(hk-test
|
||||
"zip"
|
||||
(hk-deep-force (hk-run "main = show (zip [1,2] [3,4])"))
|
||||
"[(1,3),(2,4)]")
|
||||
"[(1, 3), (2, 4)]")
|
||||
(hk-test "sum" (hk-deep-force (hk-run "main = sum [1,2,3,4,5]")) 15)
|
||||
(hk-test "product" (hk-deep-force (hk-run "main = product [1,2,3,4]")) 24)
|
||||
(hk-test "maximum" (hk-deep-force (hk-run "main = maximum [3,1,9,2]")) 9)
|
||||
@@ -112,7 +112,7 @@
|
||||
(hk-test
|
||||
"fmap list"
|
||||
(hk-deep-force (hk-run "main = show (fmap (+1) [1,2,3])"))
|
||||
"[2,3,4]")
|
||||
"[2, 3, 4]")
|
||||
|
||||
;; ── Monad / Applicative ──────────────────────────────────────
|
||||
(hk-test "return" (hk-deep-force (hk-run "main = return 7")) (list "IO" 7))
|
||||
@@ -134,7 +134,7 @@
|
||||
(hk-test
|
||||
"lookup hit"
|
||||
(hk-deep-force (hk-run "main = show (lookup 2 [(1,10),(2,20)])"))
|
||||
"Just 20")
|
||||
"(Just 20)")
|
||||
(hk-test
|
||||
"lookup miss"
|
||||
(hk-deep-force (hk-run "main = show (lookup 9 [(1,10)])"))
|
||||
|
||||
@@ -1,139 +0,0 @@
|
||||
;; String / Char tests — Phase 7 items 1-4.
|
||||
;;
|
||||
;; Covers:
|
||||
;; hk-str? / hk-str-head / hk-str-tail / hk-str-null? (runtime helpers)
|
||||
;; chr / ord / toUpper / toLower (builtins in eval)
|
||||
;; cons-pattern on strings via match.sx (":"-intercept)
|
||||
;; empty-list pattern on strings via match.sx ("[]"-intercept)
|
||||
|
||||
;; ── hk-str? predicate ────────────────────────────────────────────────────
|
||||
(hk-test "hk-str? native string" (hk-str? "hello") true)
|
||||
|
||||
(hk-test "hk-str? empty string" (hk-str? "") true)
|
||||
|
||||
(hk-test "hk-str? view dict" (hk-str? {:hk-off 1 :hk-str "hi"}) true)
|
||||
|
||||
(hk-test "hk-str? rejects number" (hk-str? 42) false)
|
||||
|
||||
;; ── hk-str-null? predicate ───────────────────────────────────────────────
|
||||
(hk-test "hk-str-null? empty string" (hk-str-null? "") true)
|
||||
|
||||
(hk-test "hk-str-null? non-empty" (hk-str-null? "a") false)
|
||||
|
||||
(hk-test "hk-str-null? exhausted view" (hk-str-null? {:hk-off 2 :hk-str "hi"}) true)
|
||||
|
||||
(hk-test "hk-str-null? live view" (hk-str-null? {:hk-off 1 :hk-str "hi"}) false)
|
||||
|
||||
;; ── hk-str-head ──────────────────────────────────────────────────────────
|
||||
(hk-test "hk-str-head native string" (hk-str-head "hello") 104)
|
||||
|
||||
(hk-test "hk-str-head view at offset" (hk-str-head {:hk-off 1 :hk-str "hello"}) 101)
|
||||
|
||||
;; ── hk-str-tail ──────────────────────────────────────────────────────────
|
||||
(hk-test "hk-str-tail of single char is nil" (hk-str-tail "h") (list "[]"))
|
||||
|
||||
(hk-test
|
||||
"hk-str-tail of two-char string is live view"
|
||||
(hk-str-null? (hk-str-tail "hi"))
|
||||
false)
|
||||
|
||||
(hk-test
|
||||
"hk-str-tail head of tail of hi is i"
|
||||
(hk-str-head (hk-str-tail "hi"))
|
||||
105)
|
||||
|
||||
;; ── chr / ord ────────────────────────────────────────────────────────────
|
||||
(hk-test "chr 65 = A" (hk-eval-expr-source "chr 65") "A")
|
||||
|
||||
(hk-test "chr 104 = h" (hk-eval-expr-source "chr 104") "h")
|
||||
|
||||
(hk-test "ord char literal 'A' = 65" (hk-eval-expr-source "ord 'A'") 65)
|
||||
|
||||
(hk-test "ord char literal 'a' = 97" (hk-eval-expr-source "ord 'a'") 97)
|
||||
|
||||
(hk-test
|
||||
"ord of head string = char code"
|
||||
(hk-eval-expr-source "ord (head \"hello\")")
|
||||
104)
|
||||
|
||||
;; ── toUpper / toLower ────────────────────────────────────────────────────
|
||||
(hk-test "toUpper 97 = 65 (a->A)" (hk-eval-expr-source "toUpper 97") 65)
|
||||
|
||||
(hk-test
|
||||
"toUpper 65 = 65 (already upper)"
|
||||
(hk-eval-expr-source "toUpper 65")
|
||||
65)
|
||||
|
||||
(hk-test
|
||||
"toUpper 48 = 48 (digit unchanged)"
|
||||
(hk-eval-expr-source "toUpper 48")
|
||||
48)
|
||||
|
||||
(hk-test "toLower 65 = 97 (A->a)" (hk-eval-expr-source "toLower 65") 97)
|
||||
|
||||
(hk-test
|
||||
"toLower 97 = 97 (already lower)"
|
||||
(hk-eval-expr-source "toLower 97")
|
||||
97)
|
||||
|
||||
(hk-test
|
||||
"toLower 48 = 48 (digit unchanged)"
|
||||
(hk-eval-expr-source "toLower 48")
|
||||
48)
|
||||
|
||||
;; ── Pattern matching on strings ──────────────────────────────────────────
|
||||
(hk-test
|
||||
"cons pattern: head of hello = 104"
|
||||
(hk-eval-expr-source "case \"hello\" of { (x:_) -> x }")
|
||||
104)
|
||||
|
||||
(hk-test
|
||||
"cons pattern: tail is traversable"
|
||||
(hk-eval-expr-source "case \"hi\" of { (_:xs) -> case xs of { (y:_) -> y } }")
|
||||
105)
|
||||
|
||||
(hk-test
|
||||
"empty list pattern matches empty string"
|
||||
(hk-eval-expr-source "case \"\" of { [] -> True; _ -> False }")
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"empty list pattern fails on non-empty"
|
||||
(hk-eval-expr-source "case \"a\" of { [] -> True; _ -> False }")
|
||||
(list "False"))
|
||||
|
||||
(hk-test
|
||||
"cons pattern fails on empty string"
|
||||
(hk-eval-expr-source "case \"\" of { (_:_) -> True; _ -> False }")
|
||||
(list "False"))
|
||||
|
||||
;; ── Haskell programs using string traversal ──────────────────────────────
|
||||
(hk-test
|
||||
"null prelude on empty string"
|
||||
(hk-eval-expr-source "null \"\"")
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"null prelude on non-empty string"
|
||||
(hk-eval-expr-source "null \"abc\"")
|
||||
(list "False"))
|
||||
|
||||
(hk-test
|
||||
"length of string via cons recursion"
|
||||
(hk-eval-expr-source "let { f [] = 0; f (_:xs) = 1 + f xs } in f \"hello\"")
|
||||
5)
|
||||
|
||||
(hk-test
|
||||
"map ord over string gives char codes"
|
||||
(hk-deep-force (hk-eval-expr-source "map ord \"abc\""))
|
||||
(list ":" 97 (list ":" 98 (list ":" 99 (list "[]")))))
|
||||
|
||||
(hk-test
|
||||
"map toUpper over char codes then chr"
|
||||
(hk-eval-expr-source "chr (toUpper (ord (head \"abc\")))")
|
||||
"A")
|
||||
|
||||
(hk-test
|
||||
"head then ord using prelude head"
|
||||
(hk-eval-expr-source "ord (head \"hello\")")
|
||||
104)
|
||||
@@ -226,28 +226,6 @@
|
||||
value)
|
||||
(list (quote set!) (hs-to-sx target) value)))))))
|
||||
(true (list (quote set!) (hs-to-sx target) value)))))))
|
||||
;; Throttle/debounce extraction state — module-level so they don't get
|
||||
;; redefined on every emit-on call (which was causing JIT churn). Set
|
||||
;; via _strip-throttle-debounce at the start of each emit-on, used in
|
||||
;; the handler-build step inside scan-on.
|
||||
(define _throttle-ms nil)
|
||||
(define _debounce-ms nil)
|
||||
(define
|
||||
_strip-throttle-debounce
|
||||
(fn
|
||||
(lst)
|
||||
(cond
|
||||
((<= (len lst) 1) lst)
|
||||
((= (first lst) :throttle)
|
||||
(do
|
||||
(set! _throttle-ms (nth lst 1))
|
||||
(_strip-throttle-debounce (rest (rest lst)))))
|
||||
((= (first lst) :debounce)
|
||||
(do
|
||||
(set! _debounce-ms (nth lst 1))
|
||||
(_strip-throttle-debounce (rest (rest lst)))))
|
||||
(true
|
||||
(cons (first lst) (_strip-throttle-debounce (rest lst)))))))
|
||||
(define
|
||||
emit-on
|
||||
(fn
|
||||
@@ -256,8 +234,6 @@
|
||||
((parts (rest ast)))
|
||||
(let
|
||||
((event-name (first parts)))
|
||||
(set! _throttle-ms nil)
|
||||
(set! _debounce-ms nil)
|
||||
(define
|
||||
scan-on
|
||||
(fn
|
||||
@@ -290,13 +266,6 @@
|
||||
((wrapped-body (if catch-info (let ((var (make-symbol (nth catch-info 0))) (catch-body (hs-to-sx (nth catch-info 1)))) (if finally-info (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (hs-to-sx finally-info) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))) (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body))))
|
||||
(let
|
||||
((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let ((base-handler (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))) (if count-filter-info (let ((mn (get count-filter-info "min")) (mx (get count-filter-info "max"))) (list (quote let) (list (list (quote __hs-count) 0)) (list (quote fn) (list (quote event)) (list (quote begin) (list (quote set!) (quote __hs-count) (list (quote +) (quote __hs-count) 1)) (list (quote when) (if (= mx -1) (list (quote >=) (quote __hs-count) mn) (list (quote and) (list (quote >=) (quote __hs-count) mn) (list (quote <=) (quote __hs-count) mx))) (nth base-handler 2)))))) base-handler)))))
|
||||
(let
|
||||
((handler (cond
|
||||
(_throttle-ms
|
||||
(list (quote hs-throttle!) handler (hs-to-sx _throttle-ms)))
|
||||
(_debounce-ms
|
||||
(list (quote hs-debounce!) handler (hs-to-sx _debounce-ms)))
|
||||
(true handler))))
|
||||
(let
|
||||
((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
|
||||
(cond
|
||||
@@ -356,7 +325,7 @@
|
||||
(first pair)
|
||||
handler))
|
||||
or-sources)))
|
||||
on-call))))))))))))))
|
||||
on-call)))))))))))))
|
||||
((= (first items) :from)
|
||||
(scan-on
|
||||
(rest (rest items))
|
||||
@@ -500,7 +469,7 @@
|
||||
count-filter-info
|
||||
elsewhere?
|
||||
or-sources)))))
|
||||
(scan-on (_strip-throttle-debounce (rest parts)) nil nil false nil nil nil nil nil false nil)))))
|
||||
(scan-on (rest parts) nil nil false nil nil nil nil nil false nil)))))
|
||||
(define
|
||||
emit-send
|
||||
(fn
|
||||
@@ -2521,15 +2490,6 @@
|
||||
(quote fn)
|
||||
(list (quote it))
|
||||
(hs-to-sx body))))
|
||||
((and (list? expr) (= (first expr) (quote attr)))
|
||||
(list
|
||||
(quote hs-attr-watch!)
|
||||
(hs-to-sx (nth expr 2))
|
||||
(nth expr 1)
|
||||
(list
|
||||
(quote fn)
|
||||
(list (quote it))
|
||||
(hs-to-sx body))))
|
||||
(true nil))))
|
||||
((= head (quote init))
|
||||
(list
|
||||
|
||||
@@ -1358,17 +1358,7 @@
|
||||
cls
|
||||
(first extra-classes)
|
||||
tgt))
|
||||
((and
|
||||
(= (tp-type) "keyword") (= (tp-val) "for")
|
||||
;; Only consume 'for' as a duration clause if the next
|
||||
;; token is NOT '<ident> in ...' — that pattern is a
|
||||
;; for-in loop, not a toggle duration.
|
||||
(not
|
||||
(and
|
||||
(> (len tokens) (+ p 2))
|
||||
(= (get (nth tokens (+ p 1)) "type") "ident")
|
||||
(= (get (nth tokens (+ p 2)) "value") "in")))
|
||||
(do (adv!) true))
|
||||
((match-kw "for")
|
||||
(let
|
||||
((dur (parse-expr)))
|
||||
(list (quote toggle-class-for) cls tgt dur)))
|
||||
@@ -3100,17 +3090,7 @@
|
||||
(= (tp-val) "queue"))
|
||||
(do (adv!) (adv!)))
|
||||
(let
|
||||
((every? (match-kw "every"))
|
||||
(throttle-ms nil)
|
||||
(debounce-ms nil))
|
||||
;; 'throttled at <duration>' / 'debounced at <duration>'
|
||||
;; — parsed as handler modifiers, captured as :throttle / :debounce parts.
|
||||
(when (and (= (tp-type) "ident") (= (tp-val) "throttled"))
|
||||
(adv!)
|
||||
(when (match-kw "at") (set! throttle-ms (parse-expr))))
|
||||
(when (and (= (tp-type) "ident") (= (tp-val) "debounced"))
|
||||
(adv!)
|
||||
(when (match-kw "at") (set! debounce-ms (parse-expr))))
|
||||
((every? (match-kw "every")))
|
||||
(let
|
||||
((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
|
||||
(let
|
||||
@@ -3125,10 +3105,6 @@
|
||||
(match-kw "end")
|
||||
(let
|
||||
((parts (list (quote on) event-name)))
|
||||
(let
|
||||
((parts (if throttle-ms (append parts (list :throttle throttle-ms)) parts)))
|
||||
(let
|
||||
((parts (if debounce-ms (append parts (list :debounce debounce-ms)) parts)))
|
||||
(let
|
||||
((parts (if every? (append parts (list :every true)) parts)))
|
||||
(let
|
||||
@@ -3151,7 +3127,7 @@
|
||||
((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
|
||||
(let
|
||||
((parts (append parts (list (if (> (len event-vars) 0) (cons (quote do) (append (map (fn (nm) (list (quote ref) nm)) event-vars) (if (and (list? body) (= (first body) (quote do))) (rest body) (list body)))) body)))))
|
||||
parts))))))))))))))))))))))))))))
|
||||
parts))))))))))))))))))))))))))
|
||||
(define
|
||||
parse-init-feat
|
||||
(fn
|
||||
@@ -3201,7 +3177,6 @@
|
||||
(or
|
||||
(= (tp-type) "hat")
|
||||
(= (tp-type) "local")
|
||||
(= (tp-type) "attr")
|
||||
(and (= (tp-type) "keyword") (= (tp-val) "dom")))
|
||||
(let
|
||||
((expr (parse-expr)))
|
||||
|
||||
@@ -12,29 +12,6 @@
|
||||
|
||||
;; Register an event listener. Returns unlisten function.
|
||||
;; (hs-on target event-name handler) → unlisten-fn
|
||||
(begin
|
||||
(define _hs-config-log-all false)
|
||||
(define _hs-log-captured (list))
|
||||
(define
|
||||
hs-set-log-all!
|
||||
(fn (flag) (set! _hs-config-log-all (if flag true false))))
|
||||
(define hs-get-log-captured (fn () _hs-log-captured))
|
||||
(define
|
||||
hs-clear-log-captured!
|
||||
(fn () (begin (set! _hs-log-captured (list)) nil)))
|
||||
(define
|
||||
hs-log-event!
|
||||
(fn
|
||||
(msg)
|
||||
(when
|
||||
_hs-config-log-all
|
||||
(begin
|
||||
(set! _hs-log-captured (append _hs-log-captured (list msg)))
|
||||
(host-call (host-global "console") "log" msg)
|
||||
nil)))))
|
||||
|
||||
;; Run an initializer function immediately.
|
||||
;; (hs-init thunk) — called at element boot time
|
||||
(define
|
||||
hs-each
|
||||
(fn
|
||||
@@ -45,52 +22,17 @@
|
||||
;; (hs-init thunk) — called at element boot time
|
||||
(define meta (host-new "Object"))
|
||||
|
||||
;; Run an initializer function immediately.
|
||||
;; (hs-init thunk) — called at element boot time
|
||||
(define
|
||||
hs-on-every
|
||||
(fn (target event-name handler) (dom-listen target event-name handler)))
|
||||
|
||||
;; ── Async / timing ──────────────────────────────────────────────
|
||||
|
||||
;; Wait for a duration in milliseconds.
|
||||
;; In hyperscript, wait is async-transparent — execution pauses.
|
||||
;; Here we use perform/IO suspension for true pause semantics.
|
||||
(define
|
||||
hs-on-every
|
||||
(fn (target event-name handler) (dom-listen target event-name handler)))
|
||||
|
||||
;; Throttle: drops events that arrive within the window. First event fires
|
||||
;; immediately; subsequent events within `ms` of the previous fire are dropped.
|
||||
;; Returns a wrapped handler suitable for hs-on / hs-on-every.
|
||||
(define
|
||||
hs-throttle!
|
||||
(fn
|
||||
(handler ms)
|
||||
(let
|
||||
((__hs-last-fire 0))
|
||||
(fn
|
||||
(event)
|
||||
(let
|
||||
((__hs-now (host-call (host-global "Date") "now")))
|
||||
(when
|
||||
(>= (- __hs-now __hs-last-fire) ms)
|
||||
(set! __hs-last-fire __hs-now)
|
||||
(handler event)))))))
|
||||
|
||||
;; Debounce: waits until `ms` has elapsed since the last event before firing.
|
||||
;; In our synchronous test mock no time passes, so the timer fires immediately
|
||||
;; via setTimeout(_, 0); the wrapped handler still gets called once per burst.
|
||||
(define
|
||||
hs-debounce!
|
||||
(fn
|
||||
(handler ms)
|
||||
(let
|
||||
((__hs-timer nil))
|
||||
(fn
|
||||
(event)
|
||||
(when __hs-timer (host-call (host-global "window") "clearTimeout" __hs-timer))
|
||||
(set! __hs-timer
|
||||
(host-call (host-global "window") "setTimeout"
|
||||
(host-new-function (list "ev") "return arguments[0](arguments[1]);")
|
||||
ms handler event))))))
|
||||
|
||||
;; Wait for a DOM event on a target.
|
||||
;; (hs-wait-for target event-name) — suspends until event fires
|
||||
(define
|
||||
_hs-on-caller
|
||||
(let
|
||||
@@ -103,7 +45,8 @@
|
||||
(host-set! _ctx "meta" _m)
|
||||
_ctx)))
|
||||
|
||||
;; Wait for CSS transitions/animations to settle on an element.
|
||||
;; Wait for a DOM event on a target.
|
||||
;; (hs-wait-for target event-name) — suspends until event fires
|
||||
(define
|
||||
hs-on
|
||||
(fn
|
||||
@@ -123,14 +66,14 @@
|
||||
(append prev (list unlisten)))
|
||||
unlisten))))))
|
||||
|
||||
;; ── Class manipulation ──────────────────────────────────────────
|
||||
|
||||
;; Toggle a single class on an element.
|
||||
;; Wait for CSS transitions/animations to settle on an element.
|
||||
(define
|
||||
hs-on-every
|
||||
(fn (target event-name handler) (dom-listen target event-name handler)))
|
||||
|
||||
;; Toggle between two classes — exactly one is active at a time.
|
||||
;; ── Class manipulation ──────────────────────────────────────────
|
||||
|
||||
;; Toggle a single class on an element.
|
||||
(define
|
||||
hs-on-intersection-attach!
|
||||
(fn
|
||||
@@ -146,8 +89,7 @@
|
||||
(host-call observer "observe" target)
|
||||
observer)))))
|
||||
|
||||
;; Take a class from siblings — add to target, remove from others.
|
||||
;; (hs-take! target cls) — like radio button class behavior
|
||||
;; Toggle between two classes — exactly one is active at a time.
|
||||
(define
|
||||
hs-on-mutation-attach!
|
||||
(fn
|
||||
@@ -168,18 +110,19 @@
|
||||
(host-call observer "observe" target opts)
|
||||
observer))))))
|
||||
|
||||
;; Take a class from siblings — add to target, remove from others.
|
||||
;; (hs-take! target cls) — like radio button class behavior
|
||||
(define hs-init (fn (thunk) (thunk)))
|
||||
|
||||
;; ── DOM insertion ───────────────────────────────────────────────
|
||||
|
||||
;; Put content at a position relative to a target.
|
||||
;; pos: "into" | "before" | "after"
|
||||
(define hs-init (fn (thunk) (thunk)))
|
||||
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
|
||||
|
||||
;; ── Navigation / traversal ──────────────────────────────────────
|
||||
|
||||
;; Navigate to a URL.
|
||||
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
|
||||
|
||||
;; Find next sibling matching a selector (or any sibling).
|
||||
(begin
|
||||
(define
|
||||
hs-wait-for
|
||||
@@ -192,7 +135,7 @@
|
||||
(target event-name timeout-ms)
|
||||
(perform (list (quote io-wait-event) target event-name timeout-ms)))))
|
||||
|
||||
;; Find previous sibling matching a selector.
|
||||
;; Find next sibling matching a selector (or any sibling).
|
||||
(define
|
||||
hs-settle
|
||||
(fn
|
||||
@@ -200,7 +143,7 @@
|
||||
(hs-null-raise! target)
|
||||
(when (not (nil? target)) (perform (list (quote io-settle) target)))))
|
||||
|
||||
;; First element matching selector within a scope.
|
||||
;; Find previous sibling matching a selector.
|
||||
(define
|
||||
hs-toggle-class!
|
||||
(fn
|
||||
@@ -210,7 +153,7 @@
|
||||
(not (nil? target))
|
||||
(host-call (host-get target "classList") "toggle" cls))))
|
||||
|
||||
;; Last element matching selector.
|
||||
;; First element matching selector within a scope.
|
||||
(define
|
||||
hs-toggle-var-cycle!
|
||||
(fn
|
||||
@@ -232,7 +175,7 @@
|
||||
var-name
|
||||
(if (= idx -1) (first values) (nth values (mod (+ idx 1) n))))))))
|
||||
|
||||
;; First/last within a specific scope.
|
||||
;; Last element matching selector.
|
||||
(define
|
||||
hs-toggle-between!
|
||||
(fn
|
||||
@@ -245,6 +188,7 @@
|
||||
(do (dom-remove-class target cls1) (dom-add-class target cls2))
|
||||
(do (dom-remove-class target cls2) (dom-add-class target cls1))))))
|
||||
|
||||
;; First/last within a specific scope.
|
||||
(define
|
||||
hs-toggle-style!
|
||||
(fn
|
||||
@@ -268,9 +212,6 @@
|
||||
(dom-set-style target prop "hidden")
|
||||
(dom-set-style target prop "")))))))
|
||||
|
||||
;; ── Iteration ───────────────────────────────────────────────────
|
||||
|
||||
;; Repeat a thunk N times.
|
||||
(define
|
||||
hs-toggle-style-between!
|
||||
(fn
|
||||
@@ -282,7 +223,9 @@
|
||||
(dom-set-style target prop val2)
|
||||
(dom-set-style target prop val1)))))
|
||||
|
||||
;; Repeat forever (until break — relies on exception/continuation).
|
||||
;; ── Iteration ───────────────────────────────────────────────────
|
||||
|
||||
;; Repeat a thunk N times.
|
||||
(define
|
||||
hs-toggle-style-cycle!
|
||||
(fn
|
||||
@@ -303,10 +246,7 @@
|
||||
(true (find-next (rest remaining))))))
|
||||
(dom-set-style target prop (find-next vals)))))
|
||||
|
||||
;; ── Fetch ───────────────────────────────────────────────────────
|
||||
|
||||
;; Fetch a URL, parse response according to format.
|
||||
;; (hs-fetch url format) — format is "json" | "text" | "html"
|
||||
;; Repeat forever (until break — relies on exception/continuation).
|
||||
(define
|
||||
hs-take!
|
||||
(fn
|
||||
@@ -329,7 +269,8 @@
|
||||
(when with-cls (dom-remove-class target with-cls))))
|
||||
(let
|
||||
((attr-val (if (> (len extra) 0) (first extra) nil))
|
||||
(with-val (if (> (len extra) 1) (nth extra 1) nil)))
|
||||
(with-val
|
||||
(if (> (len extra) 1) (nth extra 1) nil)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
@@ -346,10 +287,10 @@
|
||||
(dom-set-attr target name attr-val)
|
||||
(dom-set-attr target name ""))))))))
|
||||
|
||||
;; ── Type coercion ───────────────────────────────────────────────
|
||||
;; ── Fetch ───────────────────────────────────────────────────────
|
||||
|
||||
;; Coerce a value to a type by name.
|
||||
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
|
||||
;; Fetch a URL, parse response according to format.
|
||||
;; (hs-fetch url format) — format is "json" | "text" | "html"
|
||||
(begin
|
||||
(define
|
||||
hs-element?
|
||||
@@ -506,10 +447,10 @@
|
||||
(dom-insert-adjacent-html target "beforeend" value)
|
||||
(hs-boot-subtree! target)))))))))))
|
||||
|
||||
;; ── Object creation ─────────────────────────────────────────────
|
||||
;; ── Type coercion ───────────────────────────────────────────────
|
||||
|
||||
;; Make a new object of a given type.
|
||||
;; (hs-make type-name) — creates empty object/collection
|
||||
;; Coerce a value to a type by name.
|
||||
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
|
||||
(define
|
||||
hs-add-to!
|
||||
(fn
|
||||
@@ -523,11 +464,10 @@
|
||||
((hs-is-set? target) (do (host-call target "add" value) target))
|
||||
(true (do (host-call target "push" value) target)))))
|
||||
|
||||
;; ── Behavior installation ───────────────────────────────────────
|
||||
;; ── Object creation ─────────────────────────────────────────────
|
||||
|
||||
;; Install a behavior on an element.
|
||||
;; A behavior is a function that takes (me ...params) and sets up features.
|
||||
;; (hs-install behavior-fn me ...args)
|
||||
;; Make a new object of a given type.
|
||||
;; (hs-make type-name) — creates empty object/collection
|
||||
(define
|
||||
hs-remove-from!
|
||||
(fn
|
||||
@@ -537,10 +477,11 @@
|
||||
((hs-is-set? target) (do (host-call target "delete" value) target))
|
||||
(true (host-call target "splice" (host-call target "indexOf" value) 1)))))
|
||||
|
||||
;; ── Measurement ─────────────────────────────────────────────────
|
||||
;; ── Behavior installation ───────────────────────────────────────
|
||||
|
||||
;; Measure an element's bounding rect, store as local variables.
|
||||
;; Returns a dict with x, y, width, height, top, left, right, bottom.
|
||||
;; Install a behavior on an element.
|
||||
;; A behavior is a function that takes (me ...params) and sets up features.
|
||||
;; (hs-install behavior-fn me ...args)
|
||||
(define
|
||||
hs-splice-at!
|
||||
(fn
|
||||
@@ -553,7 +494,10 @@
|
||||
((i (if (< idx 0) (+ n idx) idx)))
|
||||
(cond
|
||||
((or (< i 0) (>= i n)) target)
|
||||
(true (concat (slice target 0 i) (slice target (+ i 1) n))))))
|
||||
(true
|
||||
(concat
|
||||
(slice target 0 i)
|
||||
(slice target (+ i 1) n))))))
|
||||
(do
|
||||
(when
|
||||
target
|
||||
@@ -564,10 +508,10 @@
|
||||
(host-call target "splice" i 1))))
|
||||
target))))
|
||||
|
||||
;; Return the current text selection as a string. In the browser this is
|
||||
;; `window.getSelection().toString()`. In the mock test runner, a test
|
||||
;; setup stashes the desired selection text at `window.__test_selection`
|
||||
;; and the fallback path returns that so tests can assert on the result.
|
||||
;; ── Measurement ─────────────────────────────────────────────────
|
||||
|
||||
;; Measure an element's bounding rect, store as local variables.
|
||||
;; Returns a dict with x, y, width, height, top, left, right, bottom.
|
||||
(define
|
||||
hs-index
|
||||
(fn
|
||||
@@ -579,11 +523,10 @@
|
||||
((string? obj) (nth obj key))
|
||||
(true (host-get obj key)))))
|
||||
|
||||
|
||||
;; ── Transition ──────────────────────────────────────────────────
|
||||
|
||||
;; Transition a CSS property to a value, optionally with duration.
|
||||
;; (hs-transition target prop value duration)
|
||||
;; Return the current text selection as a string. In the browser this is
|
||||
;; `window.getSelection().toString()`. In the mock test runner, a test
|
||||
;; setup stashes the desired selection text at `window.__test_selection`
|
||||
;; and the fallback path returns that so tests can assert on the result.
|
||||
(define
|
||||
hs-put-at!
|
||||
(fn
|
||||
@@ -605,6 +548,11 @@
|
||||
((= pos "start") (host-call target "unshift" value)))
|
||||
target)))))))
|
||||
|
||||
|
||||
;; ── Transition ──────────────────────────────────────────────────
|
||||
|
||||
;; Transition a CSS property to a value, optionally with duration.
|
||||
;; (hs-transition target prop value duration)
|
||||
(define
|
||||
hs-dict-without
|
||||
(fn
|
||||
@@ -641,11 +589,6 @@
|
||||
((w (host-global "window")))
|
||||
(if w (host-call w "prompt" msg) nil))))
|
||||
|
||||
|
||||
;; ── Transition ──────────────────────────────────────────────────
|
||||
|
||||
;; Transition a CSS property to a value, optionally with duration.
|
||||
;; (hs-transition target prop value duration)
|
||||
(define
|
||||
hs-answer
|
||||
(fn
|
||||
@@ -654,6 +597,11 @@
|
||||
((w (host-global "window")))
|
||||
(if w (if (host-call w "confirm" msg) yes-val no-val) no-val))))
|
||||
|
||||
|
||||
;; ── Transition ──────────────────────────────────────────────────
|
||||
|
||||
;; Transition a CSS property to a value, optionally with duration.
|
||||
;; (hs-transition target prop value duration)
|
||||
(define
|
||||
hs-answer-alert
|
||||
(fn
|
||||
@@ -714,10 +662,6 @@
|
||||
(if (nil? sel) "" (host-call sel "toString" (list))))
|
||||
stash)))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define
|
||||
hs-reset!
|
||||
(fn
|
||||
@@ -764,6 +708,10 @@
|
||||
(when default-val (dom-set-prop target "value" default-val)))))
|
||||
(true nil)))))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define
|
||||
hs-next
|
||||
(fn
|
||||
@@ -782,8 +730,7 @@
|
||||
((dom-matches? el sel) el)
|
||||
(true (find-next (dom-next-sibling el))))))
|
||||
(find-next sibling)))))
|
||||
;; ── Sandbox/test runtime additions ──────────────────────────────
|
||||
;; Property access — dot notation and .length
|
||||
|
||||
(define
|
||||
hs-previous
|
||||
(fn
|
||||
@@ -802,9 +749,10 @@
|
||||
((dom-matches? el sel) el)
|
||||
(true (find-prev (dom-get-prop el "previousElementSibling"))))))
|
||||
(find-prev sibling)))))
|
||||
;; DOM query stub — sandbox returns empty list
|
||||
;; ── Sandbox/test runtime additions ──────────────────────────────
|
||||
;; Property access — dot notation and .length
|
||||
(define _hs-last-query-sel nil)
|
||||
;; Method dispatch — obj.method(args)
|
||||
;; DOM query stub — sandbox returns empty list
|
||||
(define
|
||||
hs-null-raise!
|
||||
(fn
|
||||
@@ -815,9 +763,7 @@
|
||||
((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
|
||||
(host-set! (host-global "window") "_hs_null_error" msg)
|
||||
(guard (_null-e (true nil)) (raise msg))))))
|
||||
|
||||
;; ── 0.9.90 features ─────────────────────────────────────────────
|
||||
;; beep! — debug logging, returns value unchanged
|
||||
;; Method dispatch — obj.method(args)
|
||||
(define
|
||||
hs-empty-raise!
|
||||
(fn
|
||||
@@ -831,7 +777,9 @@
|
||||
((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
|
||||
(host-set! (host-global "window") "_hs_null_error" msg)
|
||||
(guard (_null-e (true nil)) (raise msg))))))
|
||||
;; Property-based is — check obj.key truthiness
|
||||
|
||||
;; ── 0.9.90 features ─────────────────────────────────────────────
|
||||
;; beep! — debug logging, returns value unchanged
|
||||
(define
|
||||
hs-query-all-checked
|
||||
(fn
|
||||
@@ -839,14 +787,14 @@
|
||||
(let
|
||||
((result (hs-query-all sel)))
|
||||
(do (hs-empty-raise! result) result))))
|
||||
;; Array slicing (inclusive both ends)
|
||||
;; Property-based is — check obj.key truthiness
|
||||
(define
|
||||
hs-dispatch!
|
||||
(fn
|
||||
(target event detail)
|
||||
(hs-null-raise! target)
|
||||
(when (not (nil? target)) (dom-dispatch target event detail))))
|
||||
;; Collection: sorted by
|
||||
;; Array slicing (inclusive both ends)
|
||||
(define
|
||||
hs-query-all
|
||||
(fn
|
||||
@@ -854,7 +802,7 @@
|
||||
(do
|
||||
(host-set! (host-global "window") "_hs_last_query_sel" sel)
|
||||
(dom-query-all (dom-document) sel))))
|
||||
;; Collection: sorted by descending
|
||||
;; Collection: sorted by
|
||||
(define
|
||||
hs-query-all-in
|
||||
(fn
|
||||
@@ -863,17 +811,17 @@
|
||||
(nil? target)
|
||||
(hs-query-all sel)
|
||||
(host-call target "querySelectorAll" sel))))
|
||||
;; Collection: split by
|
||||
;; Collection: sorted by descending
|
||||
(define
|
||||
hs-list-set
|
||||
(fn
|
||||
(lst idx val)
|
||||
(append (take lst idx) (cons val (drop lst (+ idx 1))))))
|
||||
;; Collection: joined by
|
||||
;; Collection: split by
|
||||
(define
|
||||
hs-to-number
|
||||
(fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
|
||||
|
||||
;; Collection: joined by
|
||||
(define
|
||||
hs-query-first
|
||||
(fn
|
||||
@@ -1003,7 +951,7 @@
|
||||
((= (str ex) "hs-continue") (do-loop (rest remaining)))
|
||||
(true (raise ex))))))))
|
||||
(do-loop items))))
|
||||
;; Collection: joined by
|
||||
|
||||
(begin
|
||||
(define
|
||||
hs-append
|
||||
@@ -1044,7 +992,7 @@
|
||||
(host-get value "outerHTML")
|
||||
(str value))))
|
||||
(true nil)))))
|
||||
|
||||
;; Collection: joined by
|
||||
(define
|
||||
hs-sender
|
||||
(fn
|
||||
@@ -1136,7 +1084,6 @@
|
||||
(hs-host-to-sx (perform (list "io-parse-json" raw))))
|
||||
((= fmt "number")
|
||||
(hs-to-number (perform (list "io-parse-text" raw))))
|
||||
((= fmt "html") (perform (list "io-parse-html" raw)))
|
||||
(true (perform (list "io-parse-text" raw)))))))))
|
||||
|
||||
(define hs-fetch (fn (url format) (hs-fetch-impl url format false)))
|
||||
@@ -1676,10 +1623,14 @@
|
||||
((ch (substring sel i (+ i 1))))
|
||||
(cond
|
||||
((= ch ".")
|
||||
(do (flush!) (set! mode "class") (walk (+ i 1))))
|
||||
(do
|
||||
(flush!)
|
||||
(set! mode "class")
|
||||
(walk (+ i 1))))
|
||||
((= ch "#")
|
||||
(do (flush!) (set! mode "id") (walk (+ i 1))))
|
||||
(true (do (set! cur (str cur ch)) (walk (+ i 1)))))))))
|
||||
(true
|
||||
(do (set! cur (str cur ch)) (walk (+ i 1)))))))))
|
||||
(walk 0)
|
||||
(flush!)
|
||||
{:tag tag :classes classes :id id}))))
|
||||
@@ -1773,11 +1724,11 @@
|
||||
(value type-name)
|
||||
(if (nil? value) false (hs-type-check value type-name))))
|
||||
|
||||
|
||||
(define
|
||||
hs-strict-eq
|
||||
(fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
|
||||
|
||||
|
||||
(define
|
||||
hs-id=
|
||||
(fn
|
||||
@@ -1809,20 +1760,6 @@
|
||||
((nil? suffix) false)
|
||||
(true (ends-with? (str s) (str suffix))))))
|
||||
|
||||
(define
|
||||
hs-attr-watch!
|
||||
(fn
|
||||
(target attr-name handler)
|
||||
(let
|
||||
((mo-class (host-get (host-global "window") "MutationObserver")))
|
||||
(when
|
||||
mo-class
|
||||
(let
|
||||
((cb (fn (records observer) (for-each (fn (rec) (when (= (host-get rec "attributeName") attr-name) (handler (host-call target "getAttribute" attr-name)))) records))))
|
||||
(let
|
||||
((mo (host-new "MutationObserver" cb)))
|
||||
(host-call mo "observe" target {:attributeFilter (list attr-name) :attributes true})))))))
|
||||
|
||||
(define
|
||||
hs-scoped-set!
|
||||
(fn
|
||||
@@ -1868,7 +1805,10 @@
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((pos (host-call a "compareDocumentPosition" b)))
|
||||
(if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
|
||||
(if
|
||||
(number? pos)
|
||||
(not (= 0 (mod (/ pos 4) 2)))
|
||||
false)))
|
||||
(true (< (str a) (str b))))))
|
||||
|
||||
(define
|
||||
@@ -1989,7 +1929,10 @@
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((pos (host-call a "compareDocumentPosition" b)))
|
||||
(if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
|
||||
(if
|
||||
(number? pos)
|
||||
(not (= 0 (mod (/ pos 4) 2)))
|
||||
false)))
|
||||
(true (< (str a) (str b))))))
|
||||
|
||||
(define
|
||||
@@ -2042,7 +1985,9 @@
|
||||
|
||||
(define
|
||||
hs-morph-char
|
||||
(fn (s p) (if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
|
||||
(fn
|
||||
(s p)
|
||||
(if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
|
||||
|
||||
(define
|
||||
hs-morph-index-from
|
||||
@@ -2070,7 +2015,10 @@
|
||||
(q)
|
||||
(let
|
||||
((c (hs-morph-char s q)))
|
||||
(if (and c (< (index-of stop c) 0)) (loop (+ q 1)) q))))
|
||||
(if
|
||||
(and c (< (index-of stop c) 0))
|
||||
(loop (+ q 1))
|
||||
q))))
|
||||
(let ((e (loop p))) (list (substring s p e) e))))
|
||||
|
||||
(define
|
||||
@@ -2112,7 +2060,9 @@
|
||||
(append
|
||||
acc
|
||||
(list
|
||||
(list name (substring s (+ p4 1) close)))))))
|
||||
(list
|
||||
name
|
||||
(substring s (+ p4 1) close)))))))
|
||||
((= c2 "'")
|
||||
(let
|
||||
((close (hs-morph-index-from s "'" (+ p4 1))))
|
||||
@@ -2122,7 +2072,9 @@
|
||||
(append
|
||||
acc
|
||||
(list
|
||||
(list name (substring s (+ p4 1) close)))))))
|
||||
(list
|
||||
name
|
||||
(substring s (+ p4 1) close)))))))
|
||||
(true
|
||||
(let
|
||||
((r2 (hs-morph-read-until s p4 " \t\n/>")))
|
||||
@@ -2206,7 +2158,9 @@
|
||||
(for-each
|
||||
(fn
|
||||
(c)
|
||||
(when (> (string-length c) 0) (dom-add-class el c)))
|
||||
(when
|
||||
(> (string-length c) 0)
|
||||
(dom-add-class el c)))
|
||||
(split v " ")))
|
||||
((and keep-id (= n "id")) nil)
|
||||
(true (dom-set-attr el n v)))))
|
||||
@@ -2307,7 +2261,8 @@
|
||||
((parts (split resolved ":")))
|
||||
(let
|
||||
((prop (first parts))
|
||||
(val (if (> (len parts) 1) (nth parts 1) nil)))
|
||||
(val
|
||||
(if (> (len parts) 1) (nth parts 1) nil)))
|
||||
(cond
|
||||
((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
|
||||
(let
|
||||
@@ -2347,7 +2302,8 @@
|
||||
((parts (split resolved ":")))
|
||||
(let
|
||||
((prop (first parts))
|
||||
(val (if (> (len parts) 1) (nth parts 1) nil)))
|
||||
(val
|
||||
(if (> (len parts) 1) (nth parts 1) nil)))
|
||||
(cond
|
||||
((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
|
||||
(let
|
||||
@@ -2452,10 +2408,14 @@
|
||||
(if
|
||||
(= depth 1)
|
||||
j
|
||||
(find-close (+ j 1) (- depth 1)))
|
||||
(find-close
|
||||
(+ j 1)
|
||||
(- depth 1)))
|
||||
(if
|
||||
(= (nth raw j) "{")
|
||||
(find-close (+ j 1) (+ depth 1))
|
||||
(find-close
|
||||
(+ j 1)
|
||||
(+ depth 1))
|
||||
(find-close (+ j 1) depth))))))
|
||||
(let
|
||||
((close (find-close start 1)))
|
||||
@@ -2566,7 +2526,10 @@
|
||||
(if
|
||||
(= (len lst) 0)
|
||||
-1
|
||||
(if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
|
||||
(if
|
||||
(= (first lst) item)
|
||||
i
|
||||
(idx-loop (rest lst) (+ i 1))))))
|
||||
(idx-loop obj 0)))
|
||||
(true
|
||||
(let
|
||||
@@ -2658,7 +2621,8 @@
|
||||
(cond
|
||||
((= end "hs-pick-end") n)
|
||||
((= end "hs-pick-start") 0)
|
||||
((and (number? end) (< end 0)) (max 0 (+ n end)))
|
||||
((and (number? end) (< end 0))
|
||||
(max 0 (+ n end)))
|
||||
(true end))))
|
||||
(cond
|
||||
((string? col) (slice col s e))
|
||||
@@ -2838,8 +2802,6 @@
|
||||
hs-sorted-by-desc
|
||||
(fn (col key-fn) (reverse (hs-sorted-by col key-fn))))
|
||||
|
||||
;; ── SourceInfo API ────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
hs-dom-has-var?
|
||||
(fn
|
||||
@@ -2859,6 +2821,8 @@
|
||||
((store (host-get el "__hs_vars")))
|
||||
(if (nil? store) nil (host-get store name)))))
|
||||
|
||||
;; ── SourceInfo API ────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
hs-dom-set-var-raw!
|
||||
(fn
|
||||
@@ -2949,12 +2913,7 @@
|
||||
|
||||
(define
|
||||
hs-null-error!
|
||||
(fn
|
||||
(selector)
|
||||
(let
|
||||
((msg (str "'" selector "' is null")))
|
||||
(host-set! (host-global "window") "_hs_null_error" msg)
|
||||
(guard (_null-e (true nil)) (raise msg)))))
|
||||
(fn (selector) (raise (str "'" selector "' is null"))))
|
||||
|
||||
(define
|
||||
hs-named-target
|
||||
@@ -2974,7 +2933,9 @@
|
||||
((results (hs-query-all selector)))
|
||||
(if
|
||||
(and
|
||||
(or (nil? results) (and (list? results) (= (len results) 0)))
|
||||
(or
|
||||
(nil? results)
|
||||
(and (list? results) (= (len results) 0)))
|
||||
(string? selector)
|
||||
(> (len selector) 0)
|
||||
(= (substring selector 0 1) "#"))
|
||||
|
||||
@@ -855,230 +855,4 @@
|
||||
:else (do (t-advance! 1) (scan-template!)))))))
|
||||
(scan-template!)
|
||||
(t-emit! "eof" nil)
|
||||
tokens)))
|
||||
|
||||
;; ── Stream wrapper for upstream-style stateful tokenizer API ───────────────
|
||||
;;
|
||||
;; Upstream _hyperscript exposes a Tokens object with cursor + follow-set
|
||||
;; semantics on _hyperscript.internals.tokenizer. Our hs-tokenize returns a
|
||||
;; flat list; the stream wrapper adds the stateful operations.
|
||||
;;
|
||||
;; Type names map ours → upstream's (e.g. "ident" → "IDENTIFIER").
|
||||
|
||||
(define
|
||||
hs-stream-type-map
|
||||
(fn
|
||||
(t)
|
||||
(cond
|
||||
((= t "ident") "IDENTIFIER")
|
||||
((= t "number") "NUMBER")
|
||||
((= t "string") "STRING")
|
||||
((= t "class") "CLASS_REF")
|
||||
((= t "id") "ID_REF")
|
||||
((= t "attr") "ATTRIBUTE_REF")
|
||||
((= t "style") "STYLE_REF")
|
||||
((= t "whitespace") "WHITESPACE")
|
||||
((= t "op") "OPERATOR")
|
||||
((= t "eof") "EOF")
|
||||
(true (upcase t)))))
|
||||
|
||||
;; Create a stream from a source string.
|
||||
;; Returns a dict — mutable via dict-set!.
|
||||
(define
|
||||
hs-stream
|
||||
(fn
|
||||
(src)
|
||||
{:tokens (hs-tokenize src) :pos 0 :follows (list) :last-match nil :last-ws nil}))
|
||||
|
||||
;; Skip whitespace tokens, advancing pos to the next non-WS token.
|
||||
;; Captures the last skipped whitespace value into :last-ws.
|
||||
(define
|
||||
hs-stream-skip-ws!
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((tokens (get s :tokens)))
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((p (get s :pos)))
|
||||
(when
|
||||
(and (< p (len tokens))
|
||||
(= (get (nth tokens p) :type) "whitespace"))
|
||||
(do
|
||||
(dict-set! s :last-ws (get (nth tokens p) :value))
|
||||
(dict-set! s :pos (+ p 1))
|
||||
(loop))))))
|
||||
(loop))))
|
||||
|
||||
;; Current token (after skipping whitespace).
|
||||
(define
|
||||
hs-stream-current
|
||||
(fn
|
||||
(s)
|
||||
(do
|
||||
(hs-stream-skip-ws! s)
|
||||
(let
|
||||
((tokens (get s :tokens)) (p (get s :pos)))
|
||||
(if (< p (len tokens)) (nth tokens p) nil)))))
|
||||
|
||||
;; Returns the current token if its value matches; advances and updates
|
||||
;; :last-match. Returns nil otherwise (no advance).
|
||||
;; Honors the follow set: tokens whose value is in :follows do NOT match.
|
||||
(define
|
||||
hs-stream-match
|
||||
(fn
|
||||
(s value)
|
||||
(let
|
||||
((cur (hs-stream-current s)))
|
||||
(cond
|
||||
((nil? cur) nil)
|
||||
((some (fn (f) (= f value)) (get s :follows)) nil)
|
||||
((= (get cur :value) value)
|
||||
(do
|
||||
(dict-set! s :pos (+ (get s :pos) 1))
|
||||
(dict-set! s :last-match cur)
|
||||
cur))
|
||||
(true nil)))))
|
||||
|
||||
;; Match by upstream-style type name. Accepts any number of allowed types.
|
||||
(define
|
||||
hs-stream-match-type
|
||||
(fn
|
||||
(s &rest types)
|
||||
(let
|
||||
((cur (hs-stream-current s)))
|
||||
(cond
|
||||
((nil? cur) nil)
|
||||
((some (fn (t) (= (hs-stream-type-map (get cur :type)) t)) types)
|
||||
(do
|
||||
(dict-set! s :pos (+ (get s :pos) 1))
|
||||
(dict-set! s :last-match cur)
|
||||
cur))
|
||||
(true nil)))))
|
||||
|
||||
;; Match if value is one of the given names.
|
||||
(define
|
||||
hs-stream-match-any
|
||||
(fn
|
||||
(s &rest names)
|
||||
(let
|
||||
((cur (hs-stream-current s)))
|
||||
(cond
|
||||
((nil? cur) nil)
|
||||
((some (fn (n) (= (get cur :value) n)) names)
|
||||
(do
|
||||
(dict-set! s :pos (+ (get s :pos) 1))
|
||||
(dict-set! s :last-match cur)
|
||||
cur))
|
||||
(true nil)))))
|
||||
|
||||
;; Match an op token whose value is in the list.
|
||||
(define
|
||||
hs-stream-match-any-op
|
||||
(fn
|
||||
(s &rest ops)
|
||||
(let
|
||||
((cur (hs-stream-current s)))
|
||||
(cond
|
||||
((nil? cur) nil)
|
||||
((and (= (get cur :type) "op")
|
||||
(some (fn (o) (= (get cur :value) o)) ops))
|
||||
(do
|
||||
(dict-set! s :pos (+ (get s :pos) 1))
|
||||
(dict-set! s :last-match cur)
|
||||
cur))
|
||||
(true nil)))))
|
||||
|
||||
;; Peek N non-WS tokens ahead. Returns the token if its value matches; nil otherwise.
|
||||
(define
|
||||
hs-stream-peek
|
||||
(fn
|
||||
(s value offset)
|
||||
(let
|
||||
((tokens (get s :tokens)))
|
||||
(define
|
||||
skip-n-non-ws
|
||||
(fn
|
||||
(p remaining)
|
||||
(cond
|
||||
((>= p (len tokens)) -1)
|
||||
((= (get (nth tokens p) :type) "whitespace")
|
||||
(skip-n-non-ws (+ p 1) remaining))
|
||||
((= remaining 0) p)
|
||||
(true (skip-n-non-ws (+ p 1) (- remaining 1))))))
|
||||
(let
|
||||
((p (skip-n-non-ws (get s :pos) offset)))
|
||||
(if (and (>= p 0) (< p (len tokens))
|
||||
(= (get (nth tokens p) :value) value))
|
||||
(nth tokens p)
|
||||
nil)))))
|
||||
|
||||
;; Consume tokens until one whose value matches the marker. Returns
|
||||
;; the consumed list (excluding the marker). Marker becomes current.
|
||||
(define
|
||||
hs-stream-consume-until
|
||||
(fn
|
||||
(s marker)
|
||||
(let
|
||||
((tokens (get s :tokens)) (out (list)))
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
(acc)
|
||||
(let
|
||||
((p (get s :pos)))
|
||||
(cond
|
||||
((>= p (len tokens)) acc)
|
||||
((= (get (nth tokens p) :value) marker) acc)
|
||||
(true
|
||||
(do
|
||||
(dict-set! s :pos (+ p 1))
|
||||
(loop (append acc (list (nth tokens p))))))))))
|
||||
(loop out))))
|
||||
|
||||
;; Consume until the next whitespace token; returns the consumed list.
|
||||
(define
|
||||
hs-stream-consume-until-ws
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((tokens (get s :tokens)))
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
(acc)
|
||||
(let
|
||||
((p (get s :pos)))
|
||||
(cond
|
||||
((>= p (len tokens)) acc)
|
||||
((= (get (nth tokens p) :type) "whitespace") acc)
|
||||
(true
|
||||
(do
|
||||
(dict-set! s :pos (+ p 1))
|
||||
(loop (append acc (list (nth tokens p))))))))))
|
||||
(loop (list)))))
|
||||
|
||||
;; Follow-set management.
|
||||
(define hs-stream-push-follow! (fn (s v) (dict-set! s :follows (cons v (get s :follows)))))
|
||||
(define
|
||||
hs-stream-pop-follow!
|
||||
(fn (s) (let ((f (get s :follows))) (when (> (len f) 0) (dict-set! s :follows (rest f))))))
|
||||
(define
|
||||
hs-stream-push-follows!
|
||||
(fn (s vs) (for-each (fn (v) (hs-stream-push-follow! s v)) vs)))
|
||||
(define
|
||||
hs-stream-pop-follows!
|
||||
(fn (s n) (when (> n 0) (do (hs-stream-pop-follow! s) (hs-stream-pop-follows! s (- n 1))))))
|
||||
(define
|
||||
hs-stream-clear-follows!
|
||||
(fn (s) (let ((saved (get s :follows))) (do (dict-set! s :follows (list)) saved))))
|
||||
(define
|
||||
hs-stream-restore-follows!
|
||||
(fn (s saved) (dict-set! s :follows saved)))
|
||||
|
||||
;; Last-consumed token / whitespace.
|
||||
(define hs-stream-last-match (fn (s) (get s :last-match)))
|
||||
(define hs-stream-last-ws (fn (s) (get s :last-ws)))
|
||||
tokens)))
|
||||
@@ -1,214 +0,0 @@
|
||||
;; lib/kernel/eval.sx — Kernel evaluator.
|
||||
;;
|
||||
;; The evaluator is `lookup-and-combine`: there are no hardcoded special
|
||||
;; forms. Even $if / $define! / $lambda are ordinary operatives bound in
|
||||
;; the standard environment (Phase 4). This file builds the dispatch
|
||||
;; machinery and the operative/applicative tagged-value protocol.
|
||||
;;
|
||||
;; Tagged values
|
||||
;; -------------
|
||||
;; {:refl-tag :env :bindings DICT :parent PARENT-OR-NIL}
|
||||
;; A first-class Kernel environment. Bindings is a mutable SX dict
|
||||
;; keyed by symbol name; parent walks up the lookup chain. Shape
|
||||
;; and operations are inherited from lib/guest/reflective/env.sx
|
||||
;; (canonical wire shape) — Kernel-side names are thin wrappers.
|
||||
;;
|
||||
;; {:knl-tag :operative :impl FN}
|
||||
;; Primitive operative. FN receives (args dyn-env) — args are the
|
||||
;; UN-evaluated argument expressions, dyn-env is the calling env.
|
||||
;;
|
||||
;; {:knl-tag :operative :params P :env-param EP :body B :static-env SE}
|
||||
;; User-defined operative (built by $vau). Same tag; dispatch in
|
||||
;; kernel-call-operative forks on which keys are present.
|
||||
;;
|
||||
;; {:knl-tag :applicative :underlying OP}
|
||||
;; An applicative wraps an operative. Calls evaluate args first,
|
||||
;; then forward to the underlying operative.
|
||||
;;
|
||||
;; The env-param of a user operative may be the sentinel :knl-ignore,
|
||||
;; in which case the dynamic env is not bound.
|
||||
;;
|
||||
;; Public API
|
||||
;; (kernel-eval EXPR ENV) — primary entry
|
||||
;; (kernel-combine COMBINER ARGS DYN-ENV)
|
||||
;; (kernel-call-operative OP ARGS DYN-ENV)
|
||||
;; (kernel-bind-params! ENV PARAMS ARGS)
|
||||
;; (kernel-make-env) / (kernel-extend-env P)
|
||||
;; (kernel-env-bind! E N V) / (kernel-env-lookup E N)
|
||||
;; (kernel-env-has? E N) / (kernel-env? V)
|
||||
;; (kernel-make-primitive-operative IMPL)
|
||||
;; (kernel-make-primitive-applicative IMPL)
|
||||
;; (kernel-make-user-operative PARAMS EPARAM BODY STATIC-ENV)
|
||||
;; (kernel-wrap OP) / (kernel-unwrap APP)
|
||||
;; (kernel-operative? V) / (kernel-applicative? V) / (kernel-combiner? V)
|
||||
;;
|
||||
;; Consumes: lib/kernel/parser.sx (kernel-string?, kernel-string-value)
|
||||
|
||||
;; ── Environments — delegated to lib/guest/reflective/env.sx ──────
|
||||
;; The env values themselves now carry `:refl-tag :env` (shared with the
|
||||
;; reflective kit). Kernel's API names stay; bodies are thin wrappers.
|
||||
|
||||
(define kernel-env? refl-env?)
|
||||
(define kernel-make-env refl-make-env)
|
||||
(define kernel-extend-env refl-extend-env)
|
||||
(define kernel-env-bind! refl-env-bind!)
|
||||
(define kernel-env-has? refl-env-has?)
|
||||
(define kernel-env-lookup refl-env-lookup)
|
||||
|
||||
;; ── Tagged-value constructors and predicates ─────────────────────
|
||||
|
||||
(define kernel-make-primitive-operative (fn (impl) {:impl impl :knl-tag :operative}))
|
||||
|
||||
(define
|
||||
kernel-make-user-operative
|
||||
(fn (params eparam body static-env) {:knl-tag :operative :static-env static-env :params params :body body :env-param eparam}))
|
||||
|
||||
(define
|
||||
kernel-operative?
|
||||
(fn (v) (and (dict? v) (= (get v :knl-tag) :operative))))
|
||||
|
||||
(define
|
||||
kernel-applicative?
|
||||
(fn (v) (and (dict? v) (= (get v :knl-tag) :applicative))))
|
||||
|
||||
(define
|
||||
kernel-combiner?
|
||||
(fn (v) (or (kernel-operative? v) (kernel-applicative? v))))
|
||||
|
||||
(define
|
||||
kernel-wrap
|
||||
(fn
|
||||
(op)
|
||||
(cond
|
||||
((kernel-operative? op) {:knl-tag :applicative :underlying op})
|
||||
(:else (error "kernel-wrap: argument must be an operative")))))
|
||||
|
||||
(define
|
||||
kernel-unwrap
|
||||
(fn
|
||||
(app)
|
||||
(cond
|
||||
((kernel-applicative? app) (get app :underlying))
|
||||
(:else (error "kernel-unwrap: argument must be an applicative")))))
|
||||
|
||||
(define
|
||||
kernel-make-primitive-applicative
|
||||
(fn
|
||||
(impl)
|
||||
(kernel-wrap
|
||||
(kernel-make-primitive-operative (fn (args dyn-env) (impl args))))))
|
||||
|
||||
;; As above, but IMPL receives (args dyn-env). Used by combinators that
|
||||
;; re-enter the evaluator (map, filter, reduce, apply, eval, ...).
|
||||
(define kernel-make-primitive-applicative-with-env
|
||||
(fn (impl)
|
||||
(kernel-wrap
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env) (impl args dyn-env))))))
|
||||
|
||||
;; ── The evaluator ────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
kernel-eval
|
||||
(fn
|
||||
(expr env)
|
||||
(cond
|
||||
((number? expr) expr)
|
||||
((boolean? expr) expr)
|
||||
((nil? expr) expr)
|
||||
((kernel-string? expr) (kernel-string-value expr))
|
||||
((string? expr) (kernel-env-lookup env expr))
|
||||
((list? expr)
|
||||
(cond
|
||||
((= (length expr) 0) expr)
|
||||
(:else
|
||||
(let
|
||||
((combiner (kernel-eval (first expr) env))
|
||||
(args (rest expr)))
|
||||
(kernel-combine combiner args env)))))
|
||||
(:else (error (str "kernel-eval: unknown form: " expr))))))
|
||||
|
||||
(define
|
||||
kernel-combine
|
||||
(fn
|
||||
(combiner args dyn-env)
|
||||
(cond
|
||||
((kernel-operative? combiner)
|
||||
(kernel-call-operative combiner args dyn-env))
|
||||
((kernel-applicative? combiner)
|
||||
(kernel-combine
|
||||
(get combiner :underlying)
|
||||
(kernel-eval-args args dyn-env)
|
||||
dyn-env))
|
||||
(:else (error (str "kernel-eval: not a combiner: " combiner))))))
|
||||
|
||||
;; Operatives may be primitive (:impl is a host fn) or user-defined
|
||||
;; (carry :params / :env-param / :body / :static-env). The dispatch
|
||||
;; fork is here so kernel-combine stays small.
|
||||
(define
|
||||
kernel-call-operative
|
||||
(fn
|
||||
(op args dyn-env)
|
||||
(cond
|
||||
((dict-has? op :impl) ((get op :impl) args dyn-env))
|
||||
((dict-has? op :body)
|
||||
(let
|
||||
((local (kernel-extend-env (get op :static-env))))
|
||||
(kernel-bind-params! local (get op :params) args)
|
||||
(let
|
||||
((eparam (get op :env-param)))
|
||||
(when
|
||||
(not (= eparam :knl-ignore))
|
||||
(kernel-env-bind! local eparam dyn-env)))
|
||||
;; :body is a list of forms — evaluate in sequence, return last.
|
||||
(knl-eval-body (get op :body) local)))
|
||||
(:else (error "kernel-call-operative: malformed operative")))))
|
||||
|
||||
(define knl-eval-body
|
||||
(fn (forms env)
|
||||
(cond
|
||||
((= (length forms) 1) (kernel-eval (first forms) env))
|
||||
(:else
|
||||
(begin
|
||||
(kernel-eval (first forms) env)
|
||||
(knl-eval-body (rest forms) env))))))
|
||||
|
||||
;; Phase 3 supports a flat parameter list only — destructuring later.
|
||||
(define
|
||||
kernel-bind-params!
|
||||
(fn
|
||||
(env params args)
|
||||
(cond
|
||||
((or (nil? params) (= (length params) 0))
|
||||
(cond
|
||||
((or (nil? args) (= (length args) 0)) nil)
|
||||
(:else (error "kernel-call: too many arguments"))))
|
||||
((or (nil? args) (= (length args) 0))
|
||||
(error "kernel-call: too few arguments"))
|
||||
(:else
|
||||
(begin
|
||||
(kernel-env-bind! env (first params) (first args))
|
||||
(kernel-bind-params! env (rest params) (rest args)))))))
|
||||
|
||||
(define
|
||||
kernel-eval-args
|
||||
(fn
|
||||
(args env)
|
||||
(cond
|
||||
((or (nil? args) (= (length args) 0)) (list))
|
||||
(:else
|
||||
(cons
|
||||
(kernel-eval (first args) env)
|
||||
(kernel-eval-args (rest args) env))))))
|
||||
|
||||
(define
|
||||
kernel-eval-program
|
||||
(fn
|
||||
(forms env)
|
||||
(cond
|
||||
((or (nil? forms) (= (length forms) 0)) nil)
|
||||
((= (length forms) 1) (kernel-eval (first forms) env))
|
||||
(:else
|
||||
(begin
|
||||
(kernel-eval (first forms) env)
|
||||
(kernel-eval-program (rest forms) env))))))
|
||||
@@ -1,253 +0,0 @@
|
||||
;; lib/kernel/parser.sx — Kernel s-expression reader.
|
||||
;;
|
||||
;; Reads R-1RK lexical syntax: numbers, strings, symbols, booleans (#t/#f),
|
||||
;; the empty list (), nested lists, and ; line comments. Reader macros
|
||||
;; (' ` , ,@) deferred to Phase 6 per the plan.
|
||||
;;
|
||||
;; Public AST shape:
|
||||
;; number → SX number
|
||||
;; #t / #f → SX true / false
|
||||
;; () → SX empty list (Kernel's nil — the empty list)
|
||||
;; "..." → {:knl-string "..."} wrapped to distinguish from symbols
|
||||
;; foo → "foo" bare SX string is a Kernel symbol
|
||||
;; (a b c) → SX list of forms
|
||||
;;
|
||||
;; Public API:
|
||||
;; (kernel-parse SRC) — first form; errors on extra trailing input
|
||||
;; (kernel-parse-all SRC) — all top-level forms, as SX list
|
||||
;; (kernel-string? V) — recognise wrapped string literal
|
||||
;; (kernel-string-value V) — extract the underlying string
|
||||
;;
|
||||
;; Consumes: lib/guest/lex.sx (lex-digit?, lex-whitespace?)
|
||||
|
||||
(define kernel-string-make (fn (s) {:knl-string s}))
|
||||
(define
|
||||
kernel-string?
|
||||
(fn (v) (and (dict? v) (string? (get v :knl-string)))))
|
||||
(define kernel-string-value (fn (v) (get v :knl-string)))
|
||||
|
||||
;; Atom delimiters: characters that end a symbol or numeric token.
|
||||
(define
|
||||
knl-delim?
|
||||
(fn
|
||||
(c)
|
||||
(or
|
||||
(nil? c)
|
||||
(lex-whitespace? c)
|
||||
(= c "(")
|
||||
(= c ")")
|
||||
(= c "\"")
|
||||
(= c ";")
|
||||
(= c "'")
|
||||
(= c "`")
|
||||
(= c ","))))
|
||||
|
||||
;; Numeric grammar: [+-]? (digit+ ('.' digit+)? | '.' digit+) ([eE][+-]?digit+)?
|
||||
(define
|
||||
knl-numeric?
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((n (string-length s)))
|
||||
(cond
|
||||
((= n 0) false)
|
||||
(:else
|
||||
(let
|
||||
((c0 (substring s 0 1)))
|
||||
(let
|
||||
((start (if (or (= c0 "+") (= c0 "-")) 1 0)))
|
||||
(knl-num-body? s start n))))))))
|
||||
|
||||
(define
|
||||
knl-num-body?
|
||||
(fn
|
||||
(s start n)
|
||||
(cond
|
||||
((>= start n) false)
|
||||
((= (substring s start (+ start 1)) ".")
|
||||
(knl-num-need-digits? s (+ start 1) n false))
|
||||
((lex-digit? (substring s start (+ start 1)))
|
||||
(knl-num-int-tail? s (+ start 1) n))
|
||||
(:else false))))
|
||||
|
||||
(define
|
||||
knl-num-int-tail?
|
||||
(fn
|
||||
(s i n)
|
||||
(cond
|
||||
((>= i n) true)
|
||||
((lex-digit? (substring s i (+ i 1)))
|
||||
(knl-num-int-tail? s (+ i 1) n))
|
||||
((= (substring s i (+ i 1)) ".")
|
||||
(knl-num-need-digits? s (+ i 1) n true))
|
||||
((or (= (substring s i (+ i 1)) "e") (= (substring s i (+ i 1)) "E"))
|
||||
(knl-num-exp-sign? s (+ i 1) n))
|
||||
(:else false))))
|
||||
|
||||
(define
|
||||
knl-num-need-digits?
|
||||
(fn
|
||||
(s i n had-int)
|
||||
(cond
|
||||
((>= i n) had-int)
|
||||
((lex-digit? (substring s i (+ i 1)))
|
||||
(knl-num-frac-tail? s (+ i 1) n))
|
||||
(:else false))))
|
||||
|
||||
(define
|
||||
knl-num-frac-tail?
|
||||
(fn
|
||||
(s i n)
|
||||
(cond
|
||||
((>= i n) true)
|
||||
((lex-digit? (substring s i (+ i 1)))
|
||||
(knl-num-frac-tail? s (+ i 1) n))
|
||||
((or (= (substring s i (+ i 1)) "e") (= (substring s i (+ i 1)) "E"))
|
||||
(knl-num-exp-sign? s (+ i 1) n))
|
||||
(:else false))))
|
||||
|
||||
(define
|
||||
knl-num-exp-sign?
|
||||
(fn
|
||||
(s i n)
|
||||
(cond
|
||||
((>= i n) false)
|
||||
((or (= (substring s i (+ i 1)) "+") (= (substring s i (+ i 1)) "-"))
|
||||
(knl-num-exp-digits? s (+ i 1) n false))
|
||||
(:else (knl-num-exp-digits? s i n false)))))
|
||||
|
||||
(define
|
||||
knl-num-exp-digits?
|
||||
(fn
|
||||
(s i n had)
|
||||
(cond
|
||||
((>= i n) had)
|
||||
((lex-digit? (substring s i (+ i 1)))
|
||||
(knl-num-exp-digits? s (+ i 1) n true))
|
||||
(:else false))))
|
||||
|
||||
;; Reader: a closure over (src, pos). Exposes :read-form and :read-all.
|
||||
(define
|
||||
knl-make-reader
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((pos 0) (n (string-length src)))
|
||||
(define
|
||||
at
|
||||
(fn () (if (< pos n) (substring src pos (+ pos 1)) nil)))
|
||||
(define adv (fn () (set! pos (+ pos 1))))
|
||||
(define
|
||||
skip-line
|
||||
(fn () (when (and (at) (not (= (at) "\n"))) (adv) (skip-line))))
|
||||
(define
|
||||
skip-ws
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((nil? (at)) nil)
|
||||
((lex-whitespace? (at)) (do (adv) (skip-ws)))
|
||||
((= (at) ";") (do (adv) (skip-line) (skip-ws)))
|
||||
(:else nil))))
|
||||
(define
|
||||
read-string-body
|
||||
(fn
|
||||
(acc)
|
||||
(cond
|
||||
((nil? (at)) (error "kernel-parse: unterminated string"))
|
||||
((= (at) "\"") (do (adv) acc))
|
||||
((= (at) "\\")
|
||||
(do
|
||||
(adv)
|
||||
(let
|
||||
((c (at)))
|
||||
(when (nil? c) (error "kernel-parse: trailing backslash"))
|
||||
(adv)
|
||||
(read-string-body
|
||||
(str
|
||||
acc
|
||||
(cond
|
||||
((= c "n") "\n")
|
||||
((= c "t") "\t")
|
||||
((= c "r") "\r")
|
||||
((= c "\"") "\"")
|
||||
((= c "\\") "\\")
|
||||
(:else c)))))))
|
||||
(:else
|
||||
(let ((c (at))) (adv) (read-string-body (str acc c)))))))
|
||||
(define
|
||||
read-atom-body
|
||||
(fn
|
||||
(acc)
|
||||
(cond
|
||||
((knl-delim? (at)) acc)
|
||||
(:else (let ((c (at))) (adv) (read-atom-body (str acc c)))))))
|
||||
(define
|
||||
classify-atom
|
||||
(fn
|
||||
(s)
|
||||
(cond
|
||||
((= s "#t") true)
|
||||
((= s "#f") false)
|
||||
((knl-numeric? s) (string->number s))
|
||||
(:else s))))
|
||||
(define
|
||||
read-form
|
||||
(fn
|
||||
()
|
||||
(skip-ws)
|
||||
(cond
|
||||
((nil? (at)) :knl-eof)
|
||||
((= (at) ")") (error "kernel-parse: unexpected ')'"))
|
||||
((= (at) "(") (do (adv) (read-list (list))))
|
||||
((= (at) "\"")
|
||||
(do (adv) (kernel-string-make (read-string-body ""))))
|
||||
((= (at) "'")
|
||||
(do (adv) (list "$quote" (read-form))))
|
||||
((= (at) "`")
|
||||
(do (adv) (list "$quasiquote" (read-form))))
|
||||
((= (at) ",")
|
||||
(do (adv)
|
||||
(cond
|
||||
((= (at) "@")
|
||||
(do (adv) (list "$unquote-splicing" (read-form))))
|
||||
(:else (list "$unquote" (read-form))))))
|
||||
(:else (classify-atom (read-atom-body ""))))))
|
||||
(define
|
||||
read-list
|
||||
(fn
|
||||
(acc)
|
||||
(skip-ws)
|
||||
(cond
|
||||
((nil? (at)) (error "kernel-parse: unterminated list"))
|
||||
((= (at) ")") (do (adv) acc))
|
||||
(:else (read-list (append acc (list (read-form))))))))
|
||||
(define
|
||||
read-all
|
||||
(fn
|
||||
(acc)
|
||||
(skip-ws)
|
||||
(if (nil? (at)) acc (read-all (append acc (list (read-form)))))))
|
||||
{:read-form read-form :read-all read-all})))
|
||||
|
||||
(define
|
||||
kernel-parse-all
|
||||
(fn (src) ((get (knl-make-reader src) :read-all) (list))))
|
||||
|
||||
(define
|
||||
kernel-parse
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((r (knl-make-reader src)))
|
||||
(let
|
||||
((form ((get r :read-form))))
|
||||
(cond
|
||||
((= form :knl-eof) (error "kernel-parse: empty input"))
|
||||
(:else
|
||||
(let
|
||||
((next ((get r :read-form))))
|
||||
(if
|
||||
(= next :knl-eof)
|
||||
form
|
||||
(error "kernel-parse: trailing input after first form")))))))))
|
||||
@@ -1,911 +0,0 @@
|
||||
;; lib/kernel/runtime.sx — the operative–applicative substrate and the
|
||||
;; standard Kernel environment.
|
||||
;;
|
||||
;; Phase 3 supplied four user-visible combiners ($vau, $lambda, wrap,
|
||||
;; unwrap). Phase 4 fills out the rest of the R-1RK core: $if, $define!,
|
||||
;; $sequence, eval, make-environment, get-current-environment, plus
|
||||
;; arithmetic, equality, list/pair, and boolean primitives — enough to
|
||||
;; write factorial.
|
||||
;;
|
||||
;; The standard env is built by EXTENDING the base env, not replacing
|
||||
;; it. So `kernel-standard-env` includes everything from `kernel-base-env`.
|
||||
;;
|
||||
;; Public API
|
||||
;; (kernel-base-env) — Phase 3 combiners
|
||||
;; (kernel-standard-env) — Phase 4 standard environment
|
||||
|
||||
(define
|
||||
knl-eparam-sentinel
|
||||
(fn
|
||||
(sym)
|
||||
(cond
|
||||
((= sym "_") :knl-ignore)
|
||||
((= sym "#ignore") :knl-ignore)
|
||||
(:else sym))))
|
||||
|
||||
(define
|
||||
knl-formals-ok?
|
||||
(fn
|
||||
(formals)
|
||||
(cond
|
||||
((not (list? formals)) false)
|
||||
((= (length formals) 0) true)
|
||||
((string? (first formals)) (knl-formals-ok? (rest formals)))
|
||||
(:else false))))
|
||||
|
||||
;; ── $vau ─────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
kernel-vau-impl
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(cond
|
||||
((< (length args) 3)
|
||||
(error "$vau: expects (formals env-param body...)"))
|
||||
(:else
|
||||
(let
|
||||
((formals (first args))
|
||||
(eparam-raw (nth args 1))
|
||||
(body-forms (rest (rest args))))
|
||||
(cond
|
||||
((not (knl-formals-ok? formals))
|
||||
(error "$vau: formals must be a list of symbols"))
|
||||
((not (string? eparam-raw))
|
||||
(error "$vau: env-param must be a symbol"))
|
||||
(:else
|
||||
(kernel-make-user-operative
|
||||
formals
|
||||
(knl-eparam-sentinel eparam-raw)
|
||||
body-forms
|
||||
dyn-env))))))))
|
||||
|
||||
(define
|
||||
kernel-vau-operative
|
||||
(kernel-make-primitive-operative kernel-vau-impl))
|
||||
|
||||
;; ── $lambda ──────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
kernel-lambda-impl
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(cond
|
||||
((< (length args) 2)
|
||||
(error "$lambda: expects (formals body...)"))
|
||||
(:else
|
||||
(let
|
||||
((formals (first args)) (body-forms (rest args)))
|
||||
(cond
|
||||
((not (knl-formals-ok? formals))
|
||||
(error "$lambda: formals must be a list of symbols"))
|
||||
(:else
|
||||
(kernel-wrap
|
||||
(kernel-make-user-operative
|
||||
formals
|
||||
:knl-ignore
|
||||
body-forms
|
||||
dyn-env)))))))))
|
||||
|
||||
(define
|
||||
kernel-lambda-operative
|
||||
(kernel-make-primitive-operative kernel-lambda-impl))
|
||||
|
||||
;; ── wrap / unwrap / predicates ───────────────────────────────────
|
||||
|
||||
(define
|
||||
kernel-wrap-applicative
|
||||
(kernel-make-primitive-applicative
|
||||
(fn
|
||||
(args)
|
||||
(cond
|
||||
((not (= (length args) 1))
|
||||
(error "wrap: expects exactly 1 argument"))
|
||||
(:else (kernel-wrap (first args)))))))
|
||||
|
||||
(define
|
||||
kernel-unwrap-applicative
|
||||
(kernel-make-primitive-applicative
|
||||
(fn
|
||||
(args)
|
||||
(cond
|
||||
((not (= (length args) 1))
|
||||
(error "unwrap: expects exactly 1 argument"))
|
||||
(:else (kernel-unwrap (first args)))))))
|
||||
|
||||
(define
|
||||
kernel-operative?-applicative
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (kernel-operative? (first args)))))
|
||||
|
||||
(define
|
||||
kernel-applicative?-applicative
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (kernel-applicative? (first args)))))
|
||||
|
||||
(define
|
||||
kernel-base-env
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind! env "$vau" kernel-vau-operative)
|
||||
(kernel-env-bind! env "$lambda" kernel-lambda-operative)
|
||||
(kernel-env-bind! env "wrap" kernel-wrap-applicative)
|
||||
(kernel-env-bind! env "unwrap" kernel-unwrap-applicative)
|
||||
(kernel-env-bind! env "operative?" kernel-operative?-applicative)
|
||||
(kernel-env-bind! env "applicative?" kernel-applicative?-applicative)
|
||||
env)))
|
||||
|
||||
;; ── $if / $define! / $sequence ───────────────────────────────────
|
||||
|
||||
(define
|
||||
kernel-if-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(cond
|
||||
((not (= (length args) 3))
|
||||
(error "$if: expects (condition then-expr else-expr)"))
|
||||
(:else
|
||||
(let
|
||||
((c (kernel-eval (first args) dyn-env)))
|
||||
(if
|
||||
c
|
||||
(kernel-eval (nth args 1) dyn-env)
|
||||
(kernel-eval (nth args 2) dyn-env))))))))
|
||||
|
||||
(define
|
||||
kernel-define!-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(cond
|
||||
((not (= (length args) 2))
|
||||
(error "$define!: expects (name expr)"))
|
||||
((not (string? (first args)))
|
||||
(error "$define!: name must be a symbol"))
|
||||
(:else
|
||||
(let
|
||||
((v (kernel-eval (nth args 1) dyn-env)))
|
||||
(kernel-env-bind! dyn-env (first args) v)
|
||||
v))))))
|
||||
|
||||
(define
|
||||
kernel-sequence-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(cond
|
||||
((or (nil? args) (= (length args) 0)) nil)
|
||||
((= (length args) 1) (kernel-eval (first args) dyn-env))
|
||||
(:else
|
||||
(begin
|
||||
(kernel-eval (first args) dyn-env)
|
||||
((get kernel-sequence-operative :impl) (rest args) dyn-env)))))))
|
||||
|
||||
;; ── eval / make-environment / get-current-environment ───────────
|
||||
|
||||
(define
|
||||
kernel-quote-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(cond
|
||||
((not (= (length args) 1)) (error "$quote: expects 1 argument"))
|
||||
(:else (first args))))))
|
||||
|
||||
;; Quasiquote: walks the template, evaluating `$unquote` forms in the
|
||||
;; dynamic env and splicing `$unquote-splicing` list results.
|
||||
(define knl-quasi-walk
|
||||
(fn (form dyn-env)
|
||||
(cond
|
||||
((not (list? form)) form)
|
||||
((= (length form) 0) form)
|
||||
((and (string? (first form)) (= (first form) "$unquote"))
|
||||
(cond
|
||||
((not (= (length form) 2))
|
||||
(error "$unquote: expects exactly 1 argument"))
|
||||
(:else (kernel-eval (nth form 1) dyn-env))))
|
||||
(:else (knl-quasi-walk-list form dyn-env)))))
|
||||
|
||||
(define knl-quasi-walk-list
|
||||
(fn (forms dyn-env)
|
||||
(cond
|
||||
((or (nil? forms) (= (length forms) 0)) (list))
|
||||
(:else
|
||||
(let ((head (first forms)))
|
||||
(cond
|
||||
((and (list? head)
|
||||
(= (length head) 2)
|
||||
(string? (first head))
|
||||
(= (first head) "$unquote-splicing"))
|
||||
(let ((spliced (kernel-eval (nth head 1) dyn-env)))
|
||||
(cond
|
||||
((not (list? spliced))
|
||||
(error "$unquote-splicing: value must be a list"))
|
||||
(:else
|
||||
(knl-list-concat
|
||||
spliced
|
||||
(knl-quasi-walk-list (rest forms) dyn-env))))))
|
||||
(:else
|
||||
(cons (knl-quasi-walk head dyn-env)
|
||||
(knl-quasi-walk-list (rest forms) dyn-env)))))))))
|
||||
|
||||
(define knl-list-concat
|
||||
(fn (xs ys)
|
||||
(cond
|
||||
((or (nil? xs) (= (length xs) 0)) ys)
|
||||
(:else (cons (first xs) (knl-list-concat (rest xs) ys))))))
|
||||
|
||||
;; $cond — multi-clause branch.
|
||||
;; ($cond (TEST1 EXPR1 ...) (TEST2 EXPR2 ...) ...)
|
||||
;; Evaluates each TEST in order; first truthy one runs its EXPRs (in
|
||||
;; sequence) and returns the last; if no TEST is truthy, returns nil.
|
||||
;; A clause with TEST = `else` always matches (sugar for $if's default).
|
||||
(define knl-cond-impl
|
||||
(fn (clauses dyn-env)
|
||||
(cond
|
||||
((or (nil? clauses) (= (length clauses) 0)) nil)
|
||||
(:else
|
||||
(let ((clause (first clauses)))
|
||||
(cond
|
||||
((not (list? clause))
|
||||
(error "$cond: each clause must be a list"))
|
||||
((= (length clause) 0)
|
||||
(error "$cond: empty clause"))
|
||||
((and (string? (first clause)) (= (first clause) "else"))
|
||||
(knl-cond-eval-body (rest clause) dyn-env))
|
||||
(:else
|
||||
(let ((test-val (kernel-eval (first clause) dyn-env)))
|
||||
(cond
|
||||
(test-val (knl-cond-eval-body (rest clause) dyn-env))
|
||||
(:else (knl-cond-impl (rest clauses) dyn-env)))))))))))
|
||||
|
||||
(define knl-cond-eval-body
|
||||
(fn (body dyn-env)
|
||||
(cond
|
||||
((or (nil? body) (= (length body) 0)) nil)
|
||||
((= (length body) 1) (kernel-eval (first body) dyn-env))
|
||||
(:else
|
||||
(begin
|
||||
(kernel-eval (first body) dyn-env)
|
||||
(knl-cond-eval-body (rest body) dyn-env))))))
|
||||
|
||||
(define kernel-cond-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env) (knl-cond-impl args dyn-env))))
|
||||
|
||||
;; $when COND BODY... — evaluate body iff COND is truthy; else nil.
|
||||
(define kernel-when-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((< (length args) 1)
|
||||
(error "$when: expects (cond body...)"))
|
||||
(:else
|
||||
(let ((c (kernel-eval (first args) dyn-env)))
|
||||
(cond
|
||||
(c (knl-cond-eval-body (rest args) dyn-env))
|
||||
(:else nil))))))))
|
||||
|
||||
;; $and? — short-circuit AND. Operative (not applicative) so untaken
|
||||
;; clauses are NOT evaluated. Empty $and? returns true (the identity).
|
||||
(define knl-and?-impl
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((or (nil? args) (= (length args) 0)) true)
|
||||
((= (length args) 1) (kernel-eval (first args) dyn-env))
|
||||
(:else
|
||||
(let ((v (kernel-eval (first args) dyn-env)))
|
||||
(cond
|
||||
(v (knl-and?-impl (rest args) dyn-env))
|
||||
(:else v)))))))
|
||||
|
||||
(define kernel-and?-operative
|
||||
(kernel-make-primitive-operative knl-and?-impl))
|
||||
|
||||
;; $or? — short-circuit OR. Operative; untaken clauses NOT evaluated.
|
||||
;; Empty $or? returns false (the identity).
|
||||
(define knl-or?-impl
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((or (nil? args) (= (length args) 0)) false)
|
||||
((= (length args) 1) (kernel-eval (first args) dyn-env))
|
||||
(:else
|
||||
(let ((v (kernel-eval (first args) dyn-env)))
|
||||
(cond
|
||||
(v v)
|
||||
(:else (knl-or?-impl (rest args) dyn-env))))))))
|
||||
|
||||
(define kernel-or?-operative
|
||||
(kernel-make-primitive-operative knl-or?-impl))
|
||||
|
||||
;; $unless COND BODY... — evaluate body iff COND is falsy; else nil.
|
||||
(define kernel-unless-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((< (length args) 1)
|
||||
(error "$unless: expects (cond body...)"))
|
||||
(:else
|
||||
(let ((c (kernel-eval (first args) dyn-env)))
|
||||
(cond
|
||||
(c nil)
|
||||
(:else (knl-cond-eval-body (rest args) dyn-env)))))))))
|
||||
|
||||
(define kernel-quasiquote-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((not (= (length args) 1))
|
||||
(error "$quasiquote: expects exactly 1 argument"))
|
||||
(:else (knl-quasi-walk (first args) dyn-env))))))
|
||||
|
||||
(define
|
||||
kernel-eval-applicative
|
||||
(kernel-make-primitive-applicative
|
||||
(fn
|
||||
(args)
|
||||
(cond
|
||||
((not (= (length args) 2))
|
||||
(error "eval: expects (expr env)"))
|
||||
((not (kernel-env? (nth args 1)))
|
||||
(error "eval: second arg must be a kernel env"))
|
||||
(:else (kernel-eval (first args) (nth args 1)))))))
|
||||
|
||||
(define
|
||||
kernel-make-environment-applicative
|
||||
(kernel-make-primitive-applicative
|
||||
(fn
|
||||
(args)
|
||||
(cond
|
||||
((= (length args) 0) (kernel-make-env))
|
||||
((= (length args) 1)
|
||||
(cond
|
||||
((not (kernel-env? (first args)))
|
||||
(error "make-environment: parent must be a kernel env"))
|
||||
(:else (kernel-extend-env (first args)))))
|
||||
(:else (error "make-environment: 0 or 1 argument"))))))
|
||||
|
||||
;; ── arithmetic and comparison (binary; trivial to extend later) ─
|
||||
|
||||
(define
|
||||
kernel-get-current-env-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(cond
|
||||
((not (= (length args) 0))
|
||||
(error "get-current-environment: expects 0 arguments"))
|
||||
(:else dyn-env)))))
|
||||
|
||||
(define
|
||||
knl-bin-app
|
||||
(fn
|
||||
(name f)
|
||||
(kernel-make-primitive-applicative
|
||||
(fn
|
||||
(args)
|
||||
(cond
|
||||
((not (= (length args) 2))
|
||||
(error (str name ": expects 2 arguments")))
|
||||
(:else (f (first args) (nth args 1))))))))
|
||||
|
||||
;; Variadic left-fold helper. ZERO-RES is the identity (`(+)` → 0);
|
||||
;; ONE-FN handles single-arg case (`(- x)` negates; `(+ x)` returns x).
|
||||
(define knl-fold-step
|
||||
(fn (f acc rest-args)
|
||||
(cond
|
||||
((or (nil? rest-args) (= (length rest-args) 0)) acc)
|
||||
(:else
|
||||
(knl-fold-step f (f acc (first rest-args)) (rest rest-args))))))
|
||||
|
||||
(define knl-fold-app
|
||||
(fn (name f zero-res one-fn)
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args)
|
||||
(cond
|
||||
((= (length args) 0) zero-res)
|
||||
((= (length args) 1) (one-fn (first args)))
|
||||
(:else (knl-fold-step f (first args) (rest args))))))))
|
||||
|
||||
;; Variadic n-ary chained comparison: `(< 1 2 3)` ≡ `(< 1 2)` AND `(< 2 3)`.
|
||||
(define knl-chain-step
|
||||
(fn (cmp prev rest-args)
|
||||
(cond
|
||||
((or (nil? rest-args) (= (length rest-args) 0)) true)
|
||||
(:else
|
||||
(let ((next (first rest-args)))
|
||||
(cond
|
||||
((cmp prev next)
|
||||
(knl-chain-step cmp next (rest rest-args)))
|
||||
(:else false)))))))
|
||||
|
||||
(define knl-chain-cmp
|
||||
(fn (name cmp)
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args)
|
||||
(cond
|
||||
((< (length args) 2)
|
||||
(error (str name ": expects at least 2 arguments")))
|
||||
(:else (knl-chain-step cmp (first args) (rest args))))))))
|
||||
|
||||
;; ── list / pair primitives ──────────────────────────────────────
|
||||
|
||||
(define
|
||||
knl-unary-app
|
||||
(fn
|
||||
(name f)
|
||||
(kernel-make-primitive-applicative
|
||||
(fn
|
||||
(args)
|
||||
(cond
|
||||
((not (= (length args) 1))
|
||||
(error (str name ": expects 1 argument")))
|
||||
(:else (f (first args))))))))
|
||||
|
||||
(define kernel-cons-applicative (knl-bin-app "cons" (fn (a b) (cons a b))))
|
||||
|
||||
(define
|
||||
kernel-car-applicative
|
||||
(knl-unary-app
|
||||
"car"
|
||||
(fn
|
||||
(xs)
|
||||
(cond
|
||||
((or (nil? xs) (and (list? xs) (= (length xs) 0)))
|
||||
(error "car: empty list"))
|
||||
(:else (first xs))))))
|
||||
|
||||
(define
|
||||
kernel-cdr-applicative
|
||||
(knl-unary-app
|
||||
"cdr"
|
||||
(fn
|
||||
(xs)
|
||||
(cond
|
||||
((or (nil? xs) (and (list? xs) (= (length xs) 0)))
|
||||
(error "cdr: empty list"))
|
||||
(:else (rest xs))))))
|
||||
|
||||
(define
|
||||
kernel-list-applicative
|
||||
(kernel-make-primitive-applicative (fn (args) args)))
|
||||
|
||||
(define
|
||||
kernel-length-applicative
|
||||
(knl-unary-app "length" (fn (xs) (length xs))))
|
||||
|
||||
(define
|
||||
kernel-null?-applicative
|
||||
(knl-unary-app
|
||||
"null?"
|
||||
(fn (v) (or (nil? v) (and (list? v) (= (length v) 0))))))
|
||||
|
||||
;; ── boolean / equality ──────────────────────────────────────────
|
||||
|
||||
(define
|
||||
kernel-pair?-applicative
|
||||
(knl-unary-app
|
||||
"pair?"
|
||||
(fn (v) (and (list? v) (> (length v) 0)))))
|
||||
|
||||
(define knl-append-step
|
||||
(fn (xs ys)
|
||||
(cond
|
||||
((or (nil? xs) (= (length xs) 0)) ys)
|
||||
(:else (cons (first xs) (knl-append-step (rest xs) ys))))))
|
||||
|
||||
(define knl-all-lists?
|
||||
(fn (xs)
|
||||
(cond
|
||||
((or (nil? xs) (= (length xs) 0)) true)
|
||||
((list? (first xs)) (knl-all-lists? (rest xs)))
|
||||
(:else false))))
|
||||
|
||||
(define knl-append-all
|
||||
(fn (lists)
|
||||
(cond
|
||||
((or (nil? lists) (= (length lists) 0)) (list))
|
||||
((= (length lists) 1) (first lists))
|
||||
(:else
|
||||
(knl-append-step (first lists)
|
||||
(knl-append-all (rest lists)))))))
|
||||
|
||||
(define kernel-append-applicative
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args)
|
||||
(cond
|
||||
((knl-all-lists? args) (knl-append-all args))
|
||||
(:else (error "append: all arguments must be lists"))))))
|
||||
|
||||
(define knl-reverse-step
|
||||
(fn (xs acc)
|
||||
(cond
|
||||
((or (nil? xs) (= (length xs) 0)) acc)
|
||||
(:else (knl-reverse-step (rest xs) (cons (first xs) acc))))))
|
||||
|
||||
(define kernel-reverse-applicative
|
||||
(knl-unary-app "reverse"
|
||||
(fn (xs)
|
||||
(cond
|
||||
((not (list? xs)) (error "reverse: argument must be a list"))
|
||||
(:else (knl-reverse-step xs (list)))))))
|
||||
|
||||
(define kernel-not-applicative (knl-unary-app "not" (fn (v) (not v))))
|
||||
|
||||
;; Type predicates (Kernel-visible). Note `string?` covers BOTH symbols
|
||||
;; and string-literals in our representation (symbols are bare SX
|
||||
;; strings); a `kernel-string?` applicative distinguishes the two if
|
||||
;; needed.
|
||||
(define kernel-number?-applicative
|
||||
(knl-unary-app "number?" (fn (v) (number? v))))
|
||||
(define kernel-string?-applicative
|
||||
(knl-unary-app "string?" (fn (v) (string? v))))
|
||||
(define kernel-list?-applicative
|
||||
(knl-unary-app "list?" (fn (v) (list? v))))
|
||||
(define kernel-boolean?-applicative
|
||||
(knl-unary-app "boolean?" (fn (v) (boolean? v))))
|
||||
(define kernel-symbol?-applicative
|
||||
(knl-unary-app "symbol?" (fn (v) (string? v))))
|
||||
|
||||
(define kernel-eq?-applicative (knl-bin-app "eq?" (fn (a b) (= a b))))
|
||||
|
||||
;; ── the standard environment ────────────────────────────────────
|
||||
|
||||
(define
|
||||
kernel-equal?-applicative
|
||||
(knl-bin-app "equal?" (fn (a b) (= a b))))
|
||||
|
||||
;; ── List combinators: map / filter / reduce ─────────────────────
|
||||
;; These re-enter the evaluator on each element, so they use the
|
||||
;; with-env applicative constructor.
|
||||
|
||||
;; When the combiner is an applicative, we MUST unwrap before calling
|
||||
;; — otherwise kernel-combine will re-evaluate the already-evaluated
|
||||
;; element values (and crash if an element is itself a list).
|
||||
(define knl-apply-op
|
||||
(fn (combiner)
|
||||
(cond
|
||||
((kernel-applicative? combiner) (kernel-unwrap combiner))
|
||||
(:else combiner))))
|
||||
|
||||
(define knl-map-step
|
||||
(fn (fn-val xs dyn-env)
|
||||
(let ((op (knl-apply-op fn-val)))
|
||||
(knl-map-walk op xs dyn-env))))
|
||||
|
||||
(define knl-map-walk
|
||||
(fn (op xs dyn-env)
|
||||
(cond
|
||||
((or (nil? xs) (= (length xs) 0)) (list))
|
||||
(:else
|
||||
(cons (kernel-combine op (list (first xs)) dyn-env)
|
||||
(knl-map-walk op (rest xs) dyn-env))))))
|
||||
|
||||
(define kernel-map-applicative
|
||||
(kernel-make-primitive-applicative-with-env
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((not (= (length args) 2))
|
||||
(error "map: expects (fn list)"))
|
||||
((not (kernel-combiner? (first args)))
|
||||
(error "map: first arg must be a combiner"))
|
||||
((not (list? (nth args 1)))
|
||||
(error "map: second arg must be a list"))
|
||||
(:else (knl-map-step (first args) (nth args 1) dyn-env))))))
|
||||
|
||||
(define knl-filter-step
|
||||
(fn (pred xs dyn-env)
|
||||
(knl-filter-walk (knl-apply-op pred) xs dyn-env)))
|
||||
|
||||
(define knl-filter-walk
|
||||
(fn (op xs dyn-env)
|
||||
(cond
|
||||
((or (nil? xs) (= (length xs) 0)) (list))
|
||||
(:else
|
||||
(let ((keep? (kernel-combine op (list (first xs)) dyn-env)))
|
||||
(cond
|
||||
(keep?
|
||||
(cons (first xs) (knl-filter-walk op (rest xs) dyn-env)))
|
||||
(:else (knl-filter-walk op (rest xs) dyn-env))))))))
|
||||
|
||||
(define kernel-filter-applicative
|
||||
(kernel-make-primitive-applicative-with-env
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((not (= (length args) 2))
|
||||
(error "filter: expects (pred list)"))
|
||||
((not (kernel-combiner? (first args)))
|
||||
(error "filter: first arg must be a combiner"))
|
||||
((not (list? (nth args 1)))
|
||||
(error "filter: second arg must be a list"))
|
||||
(:else (knl-filter-step (first args) (nth args 1) dyn-env))))))
|
||||
|
||||
(define knl-reduce-step
|
||||
(fn (fn-val xs acc dyn-env)
|
||||
(knl-reduce-walk (knl-apply-op fn-val) xs acc dyn-env)))
|
||||
|
||||
(define knl-reduce-walk
|
||||
(fn (op xs acc dyn-env)
|
||||
(cond
|
||||
((or (nil? xs) (= (length xs) 0)) acc)
|
||||
(:else
|
||||
(knl-reduce-walk
|
||||
op
|
||||
(rest xs)
|
||||
(kernel-combine op (list acc (first xs)) dyn-env)
|
||||
dyn-env)))))
|
||||
|
||||
;; (apply COMBINER ARGS-LIST) — call COMBINER with the elements of
|
||||
;; ARGS-LIST as arguments. The Kernel canonical use: turn a constructed
|
||||
;; list of values into a function call. We skip the applicative's
|
||||
;; auto-eval step (via unwrap) because ARGS-LIST is already values, not
|
||||
;; expressions; for a bare operative, we pass through directly.
|
||||
(define kernel-apply-applicative
|
||||
(kernel-make-primitive-applicative-with-env
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((not (= (length args) 2))
|
||||
(error "apply: expects (combiner args-list)"))
|
||||
((not (kernel-combiner? (first args)))
|
||||
(error "apply: first arg must be a combiner"))
|
||||
((not (list? (nth args 1)))
|
||||
(error "apply: second arg must be a list"))
|
||||
(:else
|
||||
(let ((op (cond
|
||||
((kernel-applicative? (first args))
|
||||
(kernel-unwrap (first args)))
|
||||
(:else (first args)))))
|
||||
(kernel-combine op (nth args 1) dyn-env)))))))
|
||||
|
||||
(define kernel-reduce-applicative
|
||||
(kernel-make-primitive-applicative-with-env
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((not (= (length args) 3))
|
||||
(error "reduce: expects (fn init list)"))
|
||||
((not (kernel-combiner? (first args)))
|
||||
(error "reduce: first arg must be a combiner"))
|
||||
((not (list? (nth args 2)))
|
||||
(error "reduce: third arg must be a list"))
|
||||
(:else
|
||||
(knl-reduce-step (first args) (nth args 2)
|
||||
(nth args 1) dyn-env))))))
|
||||
|
||||
;; ── Encapsulations: Kernel's opaque-type idiom ──────────────────
|
||||
;;
|
||||
;; (make-encapsulation-type) → (encapsulator predicate decapsulator)
|
||||
;;
|
||||
;; Each call returns three applicatives over a fresh family identity.
|
||||
;; - (encapsulator V) → an opaque wrapper around V.
|
||||
;; - (predicate V) → true iff V was wrapped by THIS family.
|
||||
;; - (decapsulator W) → the inner value; errors on wrong family.
|
||||
;;
|
||||
;; Family identity is a fresh empty dict; SX compares dicts by reference,
|
||||
;; so two `(make-encapsulation-type)` calls return distinct families.
|
||||
;;
|
||||
;; Pattern usage (Phase 5 lacks destructuring, so accessors are explicit):
|
||||
;; ($define! triple (make-encapsulation-type))
|
||||
;; ($define! wrap-promise (car triple))
|
||||
;; ($define! promise? (car (cdr triple)))
|
||||
;; ($define! unwrap-promise (car (cdr (cdr triple))))
|
||||
|
||||
(define kernel-make-encap-type-impl
|
||||
(fn (args)
|
||||
(cond
|
||||
((not (= (length args) 0))
|
||||
(error "make-encapsulation-type: expects 0 arguments"))
|
||||
(:else
|
||||
(let ((family {}))
|
||||
(let ((encap
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (vargs)
|
||||
(cond
|
||||
((not (= (length vargs) 1))
|
||||
(error "encapsulator: expects 1 argument"))
|
||||
(:else
|
||||
{:knl-tag :encap
|
||||
:family family
|
||||
:value (first vargs)})))))
|
||||
(pred
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (vargs)
|
||||
(cond
|
||||
((not (= (length vargs) 1))
|
||||
(error "predicate: expects 1 argument"))
|
||||
(:else
|
||||
(let ((v (first vargs)))
|
||||
(and (dict? v)
|
||||
(= (get v :knl-tag) :encap)
|
||||
(= (get v :family) family))))))))
|
||||
(decap
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (vargs)
|
||||
(cond
|
||||
((not (= (length vargs) 1))
|
||||
(error "decapsulator: expects 1 argument"))
|
||||
(:else
|
||||
(let ((v (first vargs)))
|
||||
(cond
|
||||
((not (and (dict? v)
|
||||
(= (get v :knl-tag) :encap)))
|
||||
(error "decapsulator: not an encapsulation"))
|
||||
((not (= (get v :family) family))
|
||||
(error "decapsulator: wrong family"))
|
||||
(:else (get v :value))))))))))
|
||||
(list encap pred decap)))))))
|
||||
|
||||
(define kernel-make-encap-type-applicative
|
||||
(kernel-make-primitive-applicative kernel-make-encap-type-impl))
|
||||
|
||||
;; ── Hygiene: $let, $define-in!, make-environment ────────────────
|
||||
;;
|
||||
;; Kernel-on-SX is hygienic *by default* because user-defined operatives
|
||||
;; (Phase 3) bind their formals + any $define! in a CHILD env extending
|
||||
;; the operative's static-env, never the dyn-env. The caller's env is
|
||||
;; only mutated when code explicitly says so (e.g. `(eval expr env-arg)`).
|
||||
;;
|
||||
;; Phase 6 adds two helpers that make the property easy to lean on:
|
||||
;;
|
||||
;; ($let ((NAME EXPR) ...) BODY)
|
||||
;; Evaluates each EXPR in the calling env, binds NAME in a fresh
|
||||
;; child env, evaluates BODY in that child env. NAMES don't leak.
|
||||
;;
|
||||
;; ($define-in! ENV NAME EXPR)
|
||||
;; Binds NAME=value-of-EXPR in the *specified* env, not the dyn-env.
|
||||
;; Useful for operatives that need to mutate a sandbox env without
|
||||
;; touching their caller's env.
|
||||
;;
|
||||
;; Shutt's full scope-set / frame-stamp hygiene (lifted symbols carrying
|
||||
;; provenance markers so introduced bindings can shadow without
|
||||
;; capturing) is research-grade and not implemented here. Notes for
|
||||
;; `lib/guest/reflective/hygiene.sx` candidate API below the std env.
|
||||
|
||||
(define knl-bind-let-vals!
|
||||
(fn (local bindings dyn-env)
|
||||
(cond
|
||||
((or (nil? bindings) (= (length bindings) 0)) nil)
|
||||
(:else
|
||||
(let ((b (first bindings)))
|
||||
(cond
|
||||
((not (and (list? b) (= (length b) 2)))
|
||||
(error "$let: each binding must be (name expr)"))
|
||||
((not (string? (first b)))
|
||||
(error "$let: binding name must be a symbol"))
|
||||
(:else
|
||||
(begin
|
||||
(kernel-env-bind! local
|
||||
(first b)
|
||||
(kernel-eval (nth b 1) dyn-env))
|
||||
(knl-bind-let-vals! local (rest bindings) dyn-env)))))))))
|
||||
|
||||
(define kernel-let-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((< (length args) 2)
|
||||
(error "$let: expects (bindings body...)"))
|
||||
((not (list? (first args)))
|
||||
(error "$let: bindings must be a list"))
|
||||
(:else
|
||||
(let ((local (kernel-extend-env dyn-env)))
|
||||
(knl-bind-let-vals! local (first args) dyn-env)
|
||||
(knl-eval-body (rest args) local)))))))
|
||||
|
||||
;; $let* — sequential let. Each binding sees prior names in scope.
|
||||
;; Implemented by nesting envs one per binding; the body runs in the
|
||||
;; innermost env, so later bindings shadow earlier ones if names repeat.
|
||||
(define knl-let*-step
|
||||
(fn (bindings env body-forms)
|
||||
(cond
|
||||
((or (nil? bindings) (= (length bindings) 0))
|
||||
(knl-eval-body body-forms env))
|
||||
(:else
|
||||
(let ((b (first bindings)))
|
||||
(cond
|
||||
((not (and (list? b) (= (length b) 2)))
|
||||
(error "$let*: each binding must be (name expr)"))
|
||||
((not (string? (first b)))
|
||||
(error "$let*: binding name must be a symbol"))
|
||||
(:else
|
||||
(let ((child (kernel-extend-env env)))
|
||||
(kernel-env-bind! child
|
||||
(first b)
|
||||
(kernel-eval (nth b 1) env))
|
||||
(knl-let*-step (rest bindings) child body-forms)))))))))
|
||||
|
||||
(define kernel-let*-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((< (length args) 2)
|
||||
(error "$let*: expects (bindings body...)"))
|
||||
((not (list? (first args)))
|
||||
(error "$let*: bindings must be a list"))
|
||||
(:else
|
||||
(knl-let*-step (first args) dyn-env (rest args)))))))
|
||||
|
||||
(define kernel-define-in!-operative
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env)
|
||||
(cond
|
||||
((not (= (length args) 3))
|
||||
(error "$define-in!: expects (env-expr name expr)"))
|
||||
((not (string? (nth args 1)))
|
||||
(error "$define-in!: name must be a symbol"))
|
||||
(:else
|
||||
(let ((target (kernel-eval (first args) dyn-env)))
|
||||
(cond
|
||||
((not (kernel-env? target))
|
||||
(error "$define-in!: first arg must evaluate to an env"))
|
||||
(:else
|
||||
(let ((v (kernel-eval (nth args 2) dyn-env)))
|
||||
(kernel-env-bind! target (nth args 1) v)
|
||||
v)))))))))
|
||||
|
||||
(define
|
||||
kernel-standard-env
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((env (kernel-base-env)))
|
||||
(kernel-env-bind! env "$if" kernel-if-operative)
|
||||
(kernel-env-bind! env "$define!" kernel-define!-operative)
|
||||
(kernel-env-bind! env "$sequence" kernel-sequence-operative)
|
||||
(kernel-env-bind! env "$quote" kernel-quote-operative)
|
||||
(kernel-env-bind! env "$quasiquote" kernel-quasiquote-operative)
|
||||
(kernel-env-bind! env "$cond" kernel-cond-operative)
|
||||
(kernel-env-bind! env "$when" kernel-when-operative)
|
||||
(kernel-env-bind! env "$unless" kernel-unless-operative)
|
||||
(kernel-env-bind! env "$and?" kernel-and?-operative)
|
||||
(kernel-env-bind! env "$or?" kernel-or?-operative)
|
||||
(kernel-env-bind! env "eval" kernel-eval-applicative)
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"make-environment"
|
||||
kernel-make-environment-applicative)
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"get-current-environment"
|
||||
kernel-get-current-env-operative)
|
||||
(kernel-env-bind! env "+"
|
||||
(knl-fold-app "+" (fn (a b) (+ a b)) 0 (fn (x) x)))
|
||||
(kernel-env-bind! env "-"
|
||||
(knl-fold-app "-" (fn (a b) (- a b)) 0 (fn (x) (- 0 x))))
|
||||
(kernel-env-bind! env "*"
|
||||
(knl-fold-app "*" (fn (a b) (* a b)) 1 (fn (x) x)))
|
||||
(kernel-env-bind! env "/"
|
||||
(knl-fold-app "/" (fn (a b) (/ a b)) 1 (fn (x) (/ 1 x))))
|
||||
(kernel-env-bind! env "<" (knl-chain-cmp "<" (fn (a b) (< a b))))
|
||||
(kernel-env-bind! env ">" (knl-chain-cmp ">" (fn (a b) (> a b))))
|
||||
(kernel-env-bind! env "<=?" (knl-chain-cmp "<=?" (fn (a b) (<= a b))))
|
||||
(kernel-env-bind! env ">=?" (knl-chain-cmp ">=?" (fn (a b) (>= a b))))
|
||||
(kernel-env-bind! env "=?" kernel-eq?-applicative)
|
||||
(kernel-env-bind! env "equal?" kernel-equal?-applicative)
|
||||
(kernel-env-bind! env "eq?" kernel-eq?-applicative)
|
||||
(kernel-env-bind! env "cons" kernel-cons-applicative)
|
||||
(kernel-env-bind! env "car" kernel-car-applicative)
|
||||
(kernel-env-bind! env "cdr" kernel-cdr-applicative)
|
||||
(kernel-env-bind! env "list" kernel-list-applicative)
|
||||
(kernel-env-bind! env "length" kernel-length-applicative)
|
||||
(kernel-env-bind! env "null?" kernel-null?-applicative)
|
||||
(kernel-env-bind! env "pair?" kernel-pair?-applicative)
|
||||
(kernel-env-bind! env "map" kernel-map-applicative)
|
||||
(kernel-env-bind! env "filter" kernel-filter-applicative)
|
||||
(kernel-env-bind! env "reduce" kernel-reduce-applicative)
|
||||
(kernel-env-bind! env "apply" kernel-apply-applicative)
|
||||
(kernel-env-bind! env "append" kernel-append-applicative)
|
||||
(kernel-env-bind! env "reverse" kernel-reverse-applicative)
|
||||
(kernel-env-bind! env "number?" kernel-number?-applicative)
|
||||
(kernel-env-bind! env "string?" kernel-string?-applicative)
|
||||
(kernel-env-bind! env "list?" kernel-list?-applicative)
|
||||
(kernel-env-bind! env "boolean?" kernel-boolean?-applicative)
|
||||
(kernel-env-bind! env "symbol?" kernel-symbol?-applicative)
|
||||
(kernel-env-bind! env "not" kernel-not-applicative)
|
||||
(kernel-env-bind! env "make-encapsulation-type"
|
||||
kernel-make-encap-type-applicative)
|
||||
(kernel-env-bind! env "$let" kernel-let-operative)
|
||||
(kernel-env-bind! env "$let*" kernel-let*-operative)
|
||||
(kernel-env-bind! env "$define-in!" kernel-define-in!-operative)
|
||||
env)))
|
||||
@@ -1,183 +0,0 @@
|
||||
;; lib/kernel/tests/encap.sx — exercises make-encapsulation-type.
|
||||
;;
|
||||
;; The Phase 5 Kernel idiom: build opaque types whose constructor,
|
||||
;; predicate, and accessor are all standard Kernel applicatives. The
|
||||
;; identity is per-call, so two `(make-encapsulation-type)` calls
|
||||
;; produce non-interchangeable families.
|
||||
|
||||
(define ken-test-pass 0)
|
||||
(define ken-test-fail 0)
|
||||
(define ken-test-fails (list))
|
||||
|
||||
(define
|
||||
ken-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! ken-test-pass (+ ken-test-pass 1))
|
||||
(begin
|
||||
(set! ken-test-fail (+ ken-test-fail 1))
|
||||
(append! ken-test-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define ken-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
|
||||
|
||||
;; A helper that builds a standard env with `encap`/`pred?`/`decap`
|
||||
;; bound from a single call to make-encapsulation-type.
|
||||
(define
|
||||
ken-make-encap-env
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ken-eval-in "($define! triple (make-encapsulation-type))" env)
|
||||
(ken-eval-in "($define! encap (car triple))" env)
|
||||
(ken-eval-in "($define! pred? (car (cdr triple)))" env)
|
||||
(ken-eval-in "($define! decap (car (cdr (cdr triple))))" env)
|
||||
env)))
|
||||
|
||||
;; ── construction ────────────────────────────────────────────────
|
||||
(ken-test
|
||||
"make: returns 3-element list"
|
||||
(ken-eval-in "(length (make-encapsulation-type))" (kernel-standard-env))
|
||||
3)
|
||||
|
||||
(ken-test
|
||||
"make: first is applicative"
|
||||
(kernel-applicative?
|
||||
(ken-eval-in "(car (make-encapsulation-type))" (kernel-standard-env)))
|
||||
true)
|
||||
|
||||
(ken-test
|
||||
"make: second is applicative"
|
||||
(kernel-applicative?
|
||||
(ken-eval-in
|
||||
"(car (cdr (make-encapsulation-type)))"
|
||||
(kernel-standard-env)))
|
||||
true)
|
||||
|
||||
(ken-test
|
||||
"make: third is applicative"
|
||||
(kernel-applicative?
|
||||
(ken-eval-in
|
||||
"(car (cdr (cdr (make-encapsulation-type))))"
|
||||
(kernel-standard-env)))
|
||||
true)
|
||||
|
||||
;; ── round-trip ──────────────────────────────────────────────────
|
||||
(ken-test
|
||||
"round-trip: number"
|
||||
(ken-eval-in "(decap (encap 42))" (ken-make-encap-env))
|
||||
42)
|
||||
|
||||
(ken-test
|
||||
"round-trip: string"
|
||||
(ken-eval-in "(decap (encap ($quote hello)))" (ken-make-encap-env))
|
||||
"hello")
|
||||
|
||||
(ken-test
|
||||
"round-trip: list"
|
||||
(ken-eval-in "(decap (encap (list 1 2 3)))" (ken-make-encap-env))
|
||||
(list 1 2 3))
|
||||
|
||||
;; ── predicate ───────────────────────────────────────────────────
|
||||
(ken-test
|
||||
"pred?: wrapped value"
|
||||
(ken-eval-in "(pred? (encap 1))" (ken-make-encap-env))
|
||||
true)
|
||||
|
||||
(ken-test
|
||||
"pred?: raw value"
|
||||
(ken-eval-in "(pred? 1)" (ken-make-encap-env))
|
||||
false)
|
||||
|
||||
(ken-test
|
||||
"pred?: raw string"
|
||||
(ken-eval-in "(pred? ($quote foo))" (ken-make-encap-env))
|
||||
false)
|
||||
|
||||
(ken-test
|
||||
"pred?: raw list"
|
||||
(ken-eval-in "(pred? (list))" (ken-make-encap-env))
|
||||
false)
|
||||
|
||||
;; ── opacity: different families are not interchangeable ─────────
|
||||
(ken-test
|
||||
"opacity: foreign value rejected by predicate"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ken-eval-in "($define! tA (make-encapsulation-type))" env)
|
||||
(ken-eval-in "($define! tB (make-encapsulation-type))" env)
|
||||
(ken-eval-in "($define! encA (car tA))" env)
|
||||
(ken-eval-in "($define! predB (car (cdr tB)))" env)
|
||||
(ken-eval-in "(predB (encA 42))" env))
|
||||
false)
|
||||
|
||||
(ken-test
|
||||
"opacity: decap rejects foreign value"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ken-eval-in "($define! tA (make-encapsulation-type))" env)
|
||||
(ken-eval-in "($define! tB (make-encapsulation-type))" env)
|
||||
(ken-eval-in "($define! encA (car tA))" env)
|
||||
(ken-eval-in "($define! decapB (car (cdr (cdr tB))))" env)
|
||||
(guard (e (true :raised)) (ken-eval-in "(decapB (encA 42))" env)))
|
||||
:raised)
|
||||
|
||||
(ken-test
|
||||
"opacity: decap rejects raw value"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(ken-eval-in "(decap 42)" (ken-make-encap-env)))
|
||||
:raised)
|
||||
|
||||
;; ── promise: classic Kernel encapsulation use case ──────────────
|
||||
;; A "promise" wraps a thunk to compute on demand and memoises the
|
||||
;; first result. Built entirely with the standard encap idiom.
|
||||
(ken-test
|
||||
"promise: force returns thunk result"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ken-eval-in
|
||||
"($sequence\n ($define! ptriple (make-encapsulation-type))\n ($define! make-promise (car ptriple))\n ($define! promise? (car (cdr ptriple)))\n ($define! decode-promise (car (cdr (cdr ptriple))))\n ($define! force ($lambda (p) ((decode-promise p))))\n ($define! delay ($lambda (thunk) (make-promise thunk)))\n (force (delay ($lambda () (+ 19 23)))))"
|
||||
env))
|
||||
42)
|
||||
|
||||
(ken-test
|
||||
"promise: promise? recognises its own type"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ken-eval-in
|
||||
"($sequence\n ($define! ptriple (make-encapsulation-type))\n ($define! make-promise (car ptriple))\n ($define! promise? (car (cdr ptriple)))\n (promise? (make-promise ($lambda () 42))))"
|
||||
env))
|
||||
true)
|
||||
|
||||
(ken-test
|
||||
"promise: promise? false on plain value"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ken-eval-in
|
||||
"($sequence\n ($define! ptriple (make-encapsulation-type))\n ($define! promise? (car (cdr ptriple)))\n (promise? 99))"
|
||||
env))
|
||||
false)
|
||||
|
||||
;; ── independent families don't leak ─────────────────────────────
|
||||
(ken-test
|
||||
"two families: distinct identity"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ken-eval-in
|
||||
"($sequence\n ($define! t1 (make-encapsulation-type))\n ($define! t2 (make-encapsulation-type))\n ($define! enc1 (car t1))\n ($define! pred2 (car (cdr t2)))\n (pred2 (enc1 ($quote stuff))))"
|
||||
env))
|
||||
false)
|
||||
|
||||
(ken-test
|
||||
"same family: re-bound shares identity"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ken-eval-in
|
||||
"($sequence\n ($define! t (make-encapsulation-type))\n ($define! e (car t))\n ($define! p (car (cdr t)))\n ($define! d (car (cdr (cdr t))))\n (list (p (e 7)) (d (e 7))))"
|
||||
env))
|
||||
(list true 7))
|
||||
|
||||
(define ken-tests-run! (fn () {:total (+ ken-test-pass ken-test-fail) :passed ken-test-pass :failed ken-test-fail :fails ken-test-fails}))
|
||||
@@ -1,270 +0,0 @@
|
||||
;; lib/kernel/tests/eval.sx — exercises lib/kernel/eval.sx.
|
||||
;;
|
||||
;; Phase 2 covers literal evaluation, symbol lookup, and combiner
|
||||
;; dispatch (operative vs applicative). Standard-environment operatives
|
||||
;; ($if, $define!, $lambda, …) arrive in Phase 4, so tests build a
|
||||
;; minimal env on the fly and verify the dispatch contract directly.
|
||||
|
||||
(define ke-test-pass 0)
|
||||
(define ke-test-fail 0)
|
||||
(define ke-test-fails (list))
|
||||
|
||||
(define
|
||||
ke-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! ke-test-pass (+ ke-test-pass 1))
|
||||
(begin
|
||||
(set! ke-test-fail (+ ke-test-fail 1))
|
||||
(append! ke-test-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── helpers ──────────────────────────────────────────────────────
|
||||
|
||||
(define ke-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
|
||||
|
||||
(define
|
||||
ke-make-test-env
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"+"
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (+ (first args) (nth args 1)))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"list"
|
||||
(kernel-make-primitive-applicative (fn (args) args)))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"$quote"
|
||||
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"$if"
|
||||
(kernel-make-primitive-operative
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(if
|
||||
(kernel-eval (first args) dyn-env)
|
||||
(kernel-eval (nth args 1) dyn-env)
|
||||
(kernel-eval (nth args 2) dyn-env)))))
|
||||
env)))
|
||||
|
||||
;; ── literal evaluation ───────────────────────────────────────────
|
||||
(ke-test "lit: number" (ke-eval-src "42" (kernel-make-env)) 42)
|
||||
(ke-test "lit: zero" (ke-eval-src "0" (kernel-make-env)) 0)
|
||||
(ke-test "lit: float" (ke-eval-src "3.14" (kernel-make-env)) 3.14)
|
||||
(ke-test "lit: true" (ke-eval-src "#t" (kernel-make-env)) true)
|
||||
(ke-test "lit: false" (ke-eval-src "#f" (kernel-make-env)) false)
|
||||
(ke-test "lit: string" (ke-eval-src "\"hello\"" (kernel-make-env)) "hello")
|
||||
(ke-test "lit: empty list" (ke-eval-src "()" (kernel-make-env)) (list))
|
||||
|
||||
;; ── symbol lookup ────────────────────────────────────────────────
|
||||
(ke-test
|
||||
"sym: bound to number"
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind! env "x" 100)
|
||||
(ke-eval-src "x" env))
|
||||
100)
|
||||
|
||||
(ke-test
|
||||
"sym: bound to string"
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind! env "name" "kernel")
|
||||
(ke-eval-src "name" env))
|
||||
"kernel")
|
||||
|
||||
(ke-test
|
||||
"sym: parent-chain lookup"
|
||||
(let
|
||||
((p (kernel-make-env)))
|
||||
(kernel-env-bind! p "outer" 1)
|
||||
(let
|
||||
((c (kernel-extend-env p)))
|
||||
(kernel-env-bind! c "inner" 2)
|
||||
(+ (ke-eval-src "outer" c) (ke-eval-src "inner" c))))
|
||||
3)
|
||||
|
||||
(ke-test
|
||||
"sym: child shadows parent"
|
||||
(let
|
||||
((p (kernel-make-env)))
|
||||
(kernel-env-bind! p "x" 1)
|
||||
(let
|
||||
((c (kernel-extend-env p)))
|
||||
(kernel-env-bind! c "x" 2)
|
||||
(ke-eval-src "x" c)))
|
||||
2)
|
||||
|
||||
(ke-test
|
||||
"env-has?: present"
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind! env "x" 1)
|
||||
(kernel-env-has? env "x"))
|
||||
true)
|
||||
|
||||
(ke-test
|
||||
"env-has?: missing"
|
||||
(kernel-env-has? (kernel-make-env) "nope")
|
||||
false)
|
||||
|
||||
;; ── tagged-value predicates ─────────────────────────────────────
|
||||
(ke-test
|
||||
"tag: operative?"
|
||||
(kernel-operative? (kernel-make-primitive-operative (fn (a e) nil)))
|
||||
true)
|
||||
|
||||
(ke-test
|
||||
"tag: applicative?"
|
||||
(kernel-applicative? (kernel-make-primitive-applicative (fn (a) nil)))
|
||||
true)
|
||||
|
||||
(ke-test
|
||||
"tag: combiner? operative"
|
||||
(kernel-combiner? (kernel-make-primitive-operative (fn (a e) nil)))
|
||||
true)
|
||||
|
||||
(ke-test
|
||||
"tag: combiner? applicative"
|
||||
(kernel-combiner? (kernel-make-primitive-applicative (fn (a) nil)))
|
||||
true)
|
||||
|
||||
(ke-test "tag: combiner? number" (kernel-combiner? 42) false)
|
||||
|
||||
(ke-test "tag: number is not operative" (kernel-operative? 42) false)
|
||||
|
||||
;; ── wrap / unwrap ────────────────────────────────────────────────
|
||||
(ke-test
|
||||
"wrap+unwrap roundtrip"
|
||||
(let
|
||||
((op (kernel-make-primitive-operative (fn (a e) :sentinel))))
|
||||
(= (kernel-unwrap (kernel-wrap op)) op))
|
||||
true)
|
||||
|
||||
(ke-test
|
||||
"wrap produces applicative"
|
||||
(kernel-applicative?
|
||||
(kernel-wrap (kernel-make-primitive-operative (fn (a e) nil))))
|
||||
true)
|
||||
|
||||
(ke-test
|
||||
"unwrap of primitive-applicative is operative"
|
||||
(kernel-operative?
|
||||
(kernel-unwrap (kernel-make-primitive-applicative (fn (a) nil))))
|
||||
true)
|
||||
|
||||
;; ── combiner dispatch — applicatives evaluate their args ─────────
|
||||
(ke-test
|
||||
"applicative: simple call"
|
||||
(ke-eval-src "(+ 2 3)" (ke-make-test-env))
|
||||
5)
|
||||
|
||||
(ke-test
|
||||
"applicative: nested"
|
||||
(ke-eval-src "(+ (+ 1 2) (+ 3 4))" (ke-make-test-env))
|
||||
10)
|
||||
|
||||
(ke-test
|
||||
"applicative: receives evaluated args"
|
||||
(let
|
||||
((env (ke-make-test-env)))
|
||||
(kernel-env-bind! env "x" 10)
|
||||
(kernel-env-bind! env "y" 20)
|
||||
(ke-eval-src "(+ x y)" env))
|
||||
30)
|
||||
|
||||
(ke-test
|
||||
"applicative: list builds an SX list of values"
|
||||
(let
|
||||
((env (ke-make-test-env)))
|
||||
(kernel-env-bind! env "a" 1)
|
||||
(kernel-env-bind! env "b" 2)
|
||||
(ke-eval-src "(list a b 99)" env))
|
||||
(list 1 2 99))
|
||||
|
||||
;; ── combiner dispatch — operatives DO NOT evaluate their args ───
|
||||
(ke-test
|
||||
"operative: $quote returns symbol unevaluated"
|
||||
(ke-eval-src "($quote foo)" (ke-make-test-env))
|
||||
"foo")
|
||||
|
||||
(ke-test
|
||||
"operative: $quote returns list unevaluated"
|
||||
(ke-eval-src "($quote (+ 1 2))" (ke-make-test-env))
|
||||
(list "+" 1 2))
|
||||
|
||||
(ke-test
|
||||
"operative: $if true branch"
|
||||
(ke-eval-src "($if #t 1 2)" (ke-make-test-env))
|
||||
1)
|
||||
|
||||
(ke-test
|
||||
"operative: $if false branch"
|
||||
(ke-eval-src "($if #f 1 2)" (ke-make-test-env))
|
||||
2)
|
||||
|
||||
(ke-test
|
||||
"operative: $if doesn't eval untaken branch"
|
||||
(ke-eval-src "($if #t 99 unbound)" (ke-make-test-env))
|
||||
99)
|
||||
|
||||
(ke-test
|
||||
"operative: $if takes dynamic env for branches"
|
||||
(let
|
||||
((env (ke-make-test-env)))
|
||||
(kernel-env-bind! env "x" 7)
|
||||
(ke-eval-src "($if #t x 0)" env))
|
||||
7)
|
||||
|
||||
;; ── operative built ON-THE-FLY can inspect raw expressions ──────
|
||||
(ke-test
|
||||
"operative: sees raw symbol head"
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"head"
|
||||
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
|
||||
(ke-eval-src "(head (+ 1 2))" env))
|
||||
(list "+" 1 2))
|
||||
|
||||
(ke-test
|
||||
"operative: sees dynamic env"
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind! env "x" 999)
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"$probe"
|
||||
(kernel-make-primitive-operative
|
||||
(fn (args dyn-env) (kernel-env-lookup dyn-env "x"))))
|
||||
(ke-eval-src "($probe ignored)" env))
|
||||
999)
|
||||
|
||||
;; ── error cases ──────────────────────────────────────────────────
|
||||
(ke-test
|
||||
"error: unbound symbol"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(kernel-eval (kernel-parse "nope") (kernel-make-env)))
|
||||
:raised)
|
||||
|
||||
(ke-test
|
||||
"error: combine non-combiner"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(let
|
||||
((env (kernel-make-env)))
|
||||
(kernel-env-bind! env "x" 42)
|
||||
(kernel-eval (kernel-parse "(x 1)") env)))
|
||||
:raised)
|
||||
|
||||
(define ke-tests-run! (fn () {:total (+ ke-test-pass ke-test-fail) :passed ke-test-pass :failed ke-test-fail :fails ke-test-fails}))
|
||||
@@ -1,220 +0,0 @@
|
||||
;; lib/kernel/tests/hygiene.sx — exercises Phase 6 hygiene helpers.
|
||||
;;
|
||||
;; Kernel-on-SX is hygienic by default: $vau/$lambda close over their
|
||||
;; static env, and bind their formals (plus any $define!s in the body)
|
||||
;; in a CHILD env. The caller's env is only mutated when user code
|
||||
;; explicitly threads the env-param through `eval` or `$define-in!`.
|
||||
;;
|
||||
;; These tests verify the property, plus the Phase 6 helpers ($let and
|
||||
;; $define-in!). Shutt's full scope-set hygiene (lifted symbols with
|
||||
;; provenance markers) is research-grade and is NOT implemented — see
|
||||
;; the plan's reflective-API notes for the proposed approach.
|
||||
|
||||
(define kh-test-pass 0)
|
||||
(define kh-test-fail 0)
|
||||
(define kh-test-fails (list))
|
||||
|
||||
(define
|
||||
kh-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! kh-test-pass (+ kh-test-pass 1))
|
||||
(begin
|
||||
(set! kh-test-fail (+ kh-test-fail 1))
|
||||
(append! kh-test-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define kh-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
|
||||
|
||||
;; ── Default hygiene: $define! inside operative body stays local ─
|
||||
|
||||
(kh-test
|
||||
"hygiene: vau body $define! doesn't escape"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define! x 1)" env)
|
||||
(kh-eval-in
|
||||
"($define! my-op ($vau () _ ($sequence ($define! x 999) x)))"
|
||||
env)
|
||||
(kh-eval-in "(my-op)" env)
|
||||
(kh-eval-in "x" env))
|
||||
1)
|
||||
|
||||
(kh-test
|
||||
"hygiene: vau body $define! visible inside body"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define! x 1)" env)
|
||||
(kh-eval-in
|
||||
"($define! my-op ($vau () _ ($sequence ($define! x 999) x)))"
|
||||
env)
|
||||
(kh-eval-in "(my-op)" env))
|
||||
999)
|
||||
|
||||
(kh-test
|
||||
"hygiene: lambda body $define! doesn't escape"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define! y 50)" env)
|
||||
(kh-eval-in "($define! f ($lambda () ($sequence ($define! y 7) y)))" env)
|
||||
(kh-eval-in "(f)" env)
|
||||
(kh-eval-in "y" env))
|
||||
50)
|
||||
|
||||
(kh-test
|
||||
"hygiene: caller's binding visible inside operative"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define! caller-x 88)" env)
|
||||
(kh-eval-in "($define! my-op ($vau () _ caller-x))" env)
|
||||
(kh-eval-in "(my-op)" env))
|
||||
88)
|
||||
|
||||
;; ── $let — proper hygienic scoping ──────────────────────────────
|
||||
|
||||
(kh-test
|
||||
"let: returns body value"
|
||||
(kh-eval-in "($let ((x 5)) (+ x 1))" (kernel-standard-env))
|
||||
6)
|
||||
|
||||
(kh-test
|
||||
"let: multiple bindings"
|
||||
(kh-eval-in "($let ((x 3) (y 4)) (+ x y))" (kernel-standard-env))
|
||||
7)
|
||||
|
||||
(kh-test
|
||||
"let: bindings shadow outer"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define! x 1)" env)
|
||||
(kh-eval-in "($let ((x 99)) x)" env))
|
||||
99)
|
||||
|
||||
(kh-test
|
||||
"let: bindings don't leak after"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define! x 1)" env)
|
||||
(kh-eval-in "($let ((x 99)) x)" env)
|
||||
(kh-eval-in "x" env))
|
||||
1)
|
||||
|
||||
(kh-test
|
||||
"let: parallel — RHS sees outer, not inner"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define! x 1)" env)
|
||||
(kh-eval-in "($let ((x 10) (y x)) y)" env))
|
||||
1)
|
||||
|
||||
(kh-test
|
||||
"let: nested"
|
||||
(kh-eval-in "($let ((x 1)) ($let ((y 2)) (+ x y)))" (kernel-standard-env))
|
||||
3)
|
||||
|
||||
(kh-test
|
||||
"let: error on malformed binding"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(kh-eval-in "($let ((x)) x)" (kernel-standard-env)))
|
||||
:raised)
|
||||
|
||||
(kh-test
|
||||
"let: error on non-symbol name"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(kh-eval-in "($let ((1 2)) 1)" (kernel-standard-env)))
|
||||
:raised)
|
||||
|
||||
;; ── $define-in! — explicit env targeting ────────────────────────
|
||||
|
||||
(kh-test
|
||||
"define-in!: binds in chosen env, not dyn-env"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define! sandbox (make-environment))" env)
|
||||
(kh-eval-in "($define-in! sandbox z 77)" env)
|
||||
(kernel-env-has? (kh-eval-in "sandbox" env) "z"))
|
||||
true)
|
||||
|
||||
(kh-test
|
||||
"define-in!: doesn't pollute caller"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define! sandbox (make-environment))" env)
|
||||
(kh-eval-in "($define-in! sandbox z 77)" env)
|
||||
(kernel-env-has? env "z"))
|
||||
false)
|
||||
|
||||
(kh-test
|
||||
"define-in!: error on non-env target"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define-in! 42 x 1)" env)))
|
||||
:raised)
|
||||
|
||||
;; ── Closure does NOT see post-definition caller binds ───────────
|
||||
;; The classic "lexical scope wins over dynamic" test.
|
||||
|
||||
(kh-test
|
||||
"lexical: closure sees its own static env"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define! x 1)" env)
|
||||
(kh-eval-in "($define! get-x ($lambda () x))" env)
|
||||
(kh-eval-in "($define! x 999)" env)
|
||||
(kh-eval-in "(get-x)" env))
|
||||
999)
|
||||
|
||||
(kh-test
|
||||
"lexical: $let-bound name invisible outside"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($let ((private 42)) private)" env)
|
||||
(kh-eval-in "private" env)))
|
||||
:raised)
|
||||
|
||||
;; ── Operative + $let: hygiene compose ───────────────────────────
|
||||
|
||||
(kh-test
|
||||
"let-inside-vau: temp doesn't escape body"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define! x 1)" env)
|
||||
(kh-eval-in "($define! op ($vau () _ ($let ((x 5)) x)))" env)
|
||||
(kh-eval-in "(op)" env)
|
||||
(kh-eval-in "x" env))
|
||||
1)
|
||||
|
||||
;; ── $let* — sequential let ──────────────────────────────────────
|
||||
(kh-test "let*: empty bindings"
|
||||
(kh-eval-in "($let* () 42)" (kernel-standard-env)) 42)
|
||||
(kh-test "let*: single binding"
|
||||
(kh-eval-in "($let* ((x 5)) (+ x 1))" (kernel-standard-env)) 6)
|
||||
(kh-test "let*: later sees earlier"
|
||||
(kh-eval-in "($let* ((x 1) (y (+ x 1)) (z (+ y 1))) z)"
|
||||
(kernel-standard-env)) 3)
|
||||
(kh-test "let*: bindings don't leak after"
|
||||
(let ((env (kernel-standard-env)))
|
||||
(kh-eval-in "($define! x 1)" env)
|
||||
(kh-eval-in "($let* ((x 99) (y (+ x 1))) y)" env)
|
||||
(kh-eval-in "x" env)) 1)
|
||||
(kh-test "let*: same-name later binding shadows earlier"
|
||||
(kh-eval-in "($let* ((x 1) (x 2)) x)" (kernel-standard-env)) 2)
|
||||
(kh-test "let*: multi-expression body"
|
||||
(kh-eval-in "($let* ((x 5)) ($define! double (+ x x)) double)"
|
||||
(kernel-standard-env)) 10)
|
||||
(kh-test "let*: error on malformed binding"
|
||||
(guard (e (true :raised))
|
||||
(kh-eval-in "($let* ((x)) x)" (kernel-standard-env)))
|
||||
:raised)
|
||||
(kh-test "let: multi-body"
|
||||
(kh-eval-in "($let ((x 5)) ($define! tmp (+ x 1)) tmp)"
|
||||
(kernel-standard-env)) 6)
|
||||
|
||||
(define kh-tests-run! (fn () {:total (+ kh-test-pass kh-test-fail) :passed kh-test-pass :failed kh-test-fail :fails kh-test-fails}))
|
||||
@@ -1,162 +0,0 @@
|
||||
;; lib/kernel/tests/metacircular.sx — Kernel-in-Kernel demo.
|
||||
;;
|
||||
;; Demonstrates reflective completeness: a Kernel program implements
|
||||
;; a recognisable subset of Kernel's own evaluation rules and produces
|
||||
;; matching values for a battery of test programs.
|
||||
;;
|
||||
;; This is a SHALLOW metacircular: it dispatches on expression shape
|
||||
;; itself (numbers, booleans, lists, symbols), recursively meta-evals
|
||||
;; each argument of an applicative call, and delegates only to the
|
||||
;; host evaluator for the leaf cases (operatives, symbol lookup). The
|
||||
;; point is to show that env-as-value, first-class operatives, and
|
||||
;; first-class evaluators all line up — enough so a Kernel program
|
||||
;; can itself reason about Kernel programs.
|
||||
|
||||
(define kmc-test-pass 0)
|
||||
(define kmc-test-fail 0)
|
||||
(define kmc-test-fails (list))
|
||||
|
||||
(define
|
||||
kmc-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! kmc-test-pass (+ kmc-test-pass 1))
|
||||
(begin
|
||||
(set! kmc-test-fail (+ kmc-test-fail 1))
|
||||
(append! kmc-test-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; Build a Kernel env with m-eval and m-apply defined. The two refer
|
||||
;; to each other and to standard primitives, so we use the standard
|
||||
;; env as the static-env for both.
|
||||
(define
|
||||
kmc-make-env
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(kernel-eval
|
||||
(kernel-parse
|
||||
"($define! m-eval\n ($lambda (expr env)\n ($cond\n ((number? expr) expr)\n ((boolean? expr) expr)\n ((null? expr) expr)\n ((symbol? expr) (eval expr env))\n ((list? expr)\n ($let ((head-val (m-eval (car expr) env)))\n ($cond\n ((applicative? head-val)\n (apply head-val\n (map ($lambda (a) (m-eval a env)) (cdr expr))))\n (else (eval expr env)))))\n (else expr))))")
|
||||
env)
|
||||
env)))
|
||||
|
||||
(define
|
||||
kmc-eval
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((env (kmc-make-env)))
|
||||
(kernel-eval
|
||||
(kernel-parse
|
||||
(str "(m-eval (quote " src ") (get-current-environment))"))
|
||||
env))))
|
||||
|
||||
;; ── literals self-evaluate via m-eval ──────────────────────────
|
||||
(kmc-test
|
||||
"m-eval: integer literal"
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval 42 (get-current-environment))")
|
||||
(kmc-make-env))
|
||||
42)
|
||||
|
||||
(kmc-test
|
||||
"m-eval: boolean true"
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval #t (get-current-environment))")
|
||||
(kmc-make-env))
|
||||
true)
|
||||
|
||||
(kmc-test
|
||||
"m-eval: boolean false"
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval #f (get-current-environment))")
|
||||
(kmc-make-env))
|
||||
false)
|
||||
|
||||
(kmc-test
|
||||
"m-eval: empty list"
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval () (get-current-environment))")
|
||||
(kmc-make-env))
|
||||
(list))
|
||||
|
||||
;; ── symbol lookup goes through env ─────────────────────────────
|
||||
(kmc-test
|
||||
"m-eval: symbol lookup"
|
||||
(let
|
||||
((env (kmc-make-env)))
|
||||
(kernel-eval (kernel-parse "($define! shared-x 99)") env)
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval ($quote shared-x) (get-current-environment))")
|
||||
env))
|
||||
99)
|
||||
|
||||
;; ── applicative calls are dispatched by m-eval recursively ─────
|
||||
(kmc-test
|
||||
"m-eval: addition"
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval ($quote (+ 1 2)) (get-current-environment))")
|
||||
(kmc-make-env))
|
||||
3)
|
||||
|
||||
(kmc-test
|
||||
"m-eval: nested arithmetic"
|
||||
(kernel-eval
|
||||
(kernel-parse
|
||||
"(m-eval ($quote (+ (* 2 3) (- 10 4))) (get-current-environment))")
|
||||
(kmc-make-env))
|
||||
12)
|
||||
|
||||
(kmc-test
|
||||
"m-eval: variadic +"
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval ($quote (+ 1 2 3 4 5)) (get-current-environment))")
|
||||
(kmc-make-env))
|
||||
15)
|
||||
|
||||
(kmc-test
|
||||
"m-eval: list construction"
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval ($quote (list 1 2 3)) (get-current-environment))")
|
||||
(kmc-make-env))
|
||||
(list 1 2 3))
|
||||
|
||||
(kmc-test "m-eval: cons reverse-style"
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval ($quote (cons 0 (list 1 2))) (get-current-environment))")
|
||||
(kmc-make-env)) (list 0 1 2))
|
||||
|
||||
(kmc-test "m-eval: nested apply"
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval ($quote (apply + (list 10 20 30))) (get-current-environment))")
|
||||
(kmc-make-env)) 60)
|
||||
|
||||
;; ── operatives delegate to host eval (transparently for the caller) ─
|
||||
(kmc-test
|
||||
"m-eval: $if true branch (via delegation)"
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval ($quote ($if #t 1 2)) (get-current-environment))")
|
||||
(kmc-make-env))
|
||||
1)
|
||||
|
||||
(kmc-test
|
||||
"m-eval: $if false branch"
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval ($quote ($if #f 1 2)) (get-current-environment))")
|
||||
(kmc-make-env))
|
||||
2)
|
||||
|
||||
;; ── m-eval can call a user-defined lambda ──────────────────────
|
||||
(kmc-test
|
||||
"m-eval: user lambda call"
|
||||
(let
|
||||
((env (kmc-make-env)))
|
||||
(kernel-eval (kernel-parse "($define! sq ($lambda (x) (* x x)))") env)
|
||||
(kernel-eval
|
||||
(kernel-parse "(m-eval ($quote (sq 7)) (get-current-environment))")
|
||||
env))
|
||||
49)
|
||||
|
||||
(define kmc-tests-run! (fn () {:total (+ kmc-test-pass kmc-test-fail) :passed kmc-test-pass :failed kmc-test-fail :fails kmc-test-fails}))
|
||||
@@ -1,158 +0,0 @@
|
||||
;; lib/kernel/tests/parse.sx — exercises lib/kernel/parser.sx.
|
||||
|
||||
(define knl-test-pass 0)
|
||||
(define knl-test-fail 0)
|
||||
(define knl-test-fails (list))
|
||||
|
||||
(define
|
||||
knl-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! knl-test-pass (+ knl-test-pass 1))
|
||||
(begin
|
||||
(set! knl-test-fail (+ knl-test-fail 1))
|
||||
(append! knl-test-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── atoms: numbers ────────────────────────────────────────────────
|
||||
(knl-test "num: integer" (kernel-parse "42") 42)
|
||||
(knl-test "num: zero" (kernel-parse "0") 0)
|
||||
(knl-test "num: negative integer" (kernel-parse "-7") -7)
|
||||
(knl-test "num: positive sign" (kernel-parse "+5") 5)
|
||||
(knl-test "num: float" (kernel-parse "3.14") 3.14)
|
||||
(knl-test "num: negative float" (kernel-parse "-2.5") -2.5)
|
||||
(knl-test "num: leading dot" (kernel-parse ".5") 0.5)
|
||||
(knl-test "num: exponent" (kernel-parse "1e3") 1000)
|
||||
(knl-test "num: exponent with sign" (kernel-parse "2.5e-1") 0.25)
|
||||
(knl-test "num: capital E exponent" (kernel-parse "1E2") 100)
|
||||
|
||||
;; ── atoms: booleans ───────────────────────────────────────────────
|
||||
(knl-test "bool: true" (kernel-parse "#t") true)
|
||||
(knl-test "bool: false" (kernel-parse "#f") false)
|
||||
|
||||
;; ── atoms: empty list (Kernel nil) ────────────────────────────────
|
||||
(knl-test "nil: ()" (kernel-parse "()") (list))
|
||||
(knl-test "nil: (= () (list))" (= (kernel-parse "()") (list)) true)
|
||||
|
||||
;; ── atoms: symbols ────────────────────────────────────────────────
|
||||
(knl-test "sym: word" (kernel-parse "foo") "foo")
|
||||
(knl-test "sym: hyphenated" (kernel-parse "foo-bar") "foo-bar")
|
||||
(knl-test "sym: dollar-bang" (kernel-parse "$define!") "$define!")
|
||||
(knl-test "sym: question" (kernel-parse "null?") "null?")
|
||||
(knl-test "sym: lt-eq" (kernel-parse "<=") "<=")
|
||||
(knl-test "sym: bare plus" (kernel-parse "+") "+")
|
||||
(knl-test "sym: bare minus" (kernel-parse "-") "-")
|
||||
(knl-test "sym: plus-letter" (kernel-parse "+a") "+a")
|
||||
(knl-test "sym: arrow" (kernel-parse "->") "->")
|
||||
(knl-test "sym: dot-prefixed" (kernel-parse ".foo") ".foo")
|
||||
|
||||
;; ── atoms: strings ────────────────────────────────────────────────
|
||||
(knl-test "str: empty" (kernel-string-value (kernel-parse "\"\"")) "")
|
||||
(knl-test
|
||||
"str: hello"
|
||||
(kernel-string-value (kernel-parse "\"hello\""))
|
||||
"hello")
|
||||
(knl-test "str: predicate" (kernel-string? (kernel-parse "\"x\"")) true)
|
||||
(knl-test "str: not symbol" (kernel-string? (kernel-parse "x")) false)
|
||||
(knl-test
|
||||
"str: escape newline"
|
||||
(kernel-string-value (kernel-parse "\"a\\nb\""))
|
||||
"a\nb")
|
||||
(knl-test
|
||||
"str: escape tab"
|
||||
(kernel-string-value (kernel-parse "\"a\\tb\""))
|
||||
"a\tb")
|
||||
(knl-test
|
||||
"str: escape quote"
|
||||
(kernel-string-value (kernel-parse "\"a\\\"b\""))
|
||||
"a\"b")
|
||||
(knl-test
|
||||
"str: escape backslash"
|
||||
(kernel-string-value (kernel-parse "\"a\\\\b\""))
|
||||
"a\\b")
|
||||
|
||||
;; ── lists ─────────────────────────────────────────────────────────
|
||||
(knl-test "list: flat" (kernel-parse "(a b c)") (list "a" "b" "c"))
|
||||
(knl-test
|
||||
"list: nested"
|
||||
(kernel-parse "(a (b c) d)")
|
||||
(list "a" (list "b" "c") "d"))
|
||||
(knl-test
|
||||
"list: deeply nested"
|
||||
(kernel-parse "(((x)))")
|
||||
(list (list (list "x"))))
|
||||
(knl-test
|
||||
"list: mixed atoms"
|
||||
(kernel-parse "(1 #t foo)")
|
||||
(list 1 true "foo"))
|
||||
(knl-test
|
||||
"list: empty inside"
|
||||
(kernel-parse "(a () b)")
|
||||
(list "a" (list) "b"))
|
||||
|
||||
;; ── whitespace + comments ─────────────────────────────────────────
|
||||
(knl-test "ws: leading" (kernel-parse " 42") 42)
|
||||
(knl-test "ws: trailing" (kernel-parse "42 ") 42)
|
||||
(knl-test "ws: tabs/newlines" (kernel-parse "\n\t 42 \n") 42)
|
||||
(knl-test "comment: line" (kernel-parse "; nope\n42") 42)
|
||||
(knl-test "comment: trailing" (kernel-parse "42 ; tail") 42)
|
||||
(knl-test
|
||||
"comment: inside list"
|
||||
(kernel-parse "(a ; mid\n b)")
|
||||
(list "a" "b"))
|
||||
|
||||
;; ── parse-all ─────────────────────────────────────────────────────
|
||||
(knl-test "all: empty input" (kernel-parse-all "") (list))
|
||||
(knl-test "all: only whitespace" (kernel-parse-all " ") (list))
|
||||
(knl-test "all: only comment" (kernel-parse-all "; nope") (list))
|
||||
(knl-test
|
||||
"all: three forms"
|
||||
(kernel-parse-all "1 2 3")
|
||||
(list 1 2 3))
|
||||
(knl-test
|
||||
"all: mixed"
|
||||
(kernel-parse-all "($if #t 1 2) foo")
|
||||
(list (list "$if" true 1 2) "foo"))
|
||||
|
||||
;; ── classic Kernel programs (smoke) ───────────────────────────────
|
||||
(knl-test
|
||||
"klisp: vau form"
|
||||
(kernel-parse "($vau (x e) e (eval x e))")
|
||||
(list "$vau" (list "x" "e") "e" (list "eval" "x" "e")))
|
||||
(knl-test
|
||||
"klisp: define lambda"
|
||||
(kernel-parse "($define! sq ($lambda (x) (* x x)))")
|
||||
(list "$define!" "sq" (list "$lambda" (list "x") (list "*" "x" "x"))))
|
||||
|
||||
;; ── round-trip identity for primitive symbols ─────────────────────
|
||||
(knl-test "identity: $vau" (kernel-parse "$vau") "$vau")
|
||||
(knl-test "identity: $lambda" (kernel-parse "$lambda") "$lambda")
|
||||
(knl-test "identity: wrap" (kernel-parse "wrap") "wrap")
|
||||
(knl-test "identity: unwrap" (kernel-parse "unwrap") "unwrap")
|
||||
|
||||
;; ── reader macros ─────────────────────────────────────────────────
|
||||
(knl-test "reader: 'foo → ($quote foo)"
|
||||
(kernel-parse "'foo") (list "$quote" "foo"))
|
||||
(knl-test "reader: '(a b c)"
|
||||
(kernel-parse "'(a b c)") (list "$quote" (list "a" "b" "c")))
|
||||
(knl-test "reader: nested quotes"
|
||||
(kernel-parse "''x")
|
||||
(list "$quote" (list "$quote" "x")))
|
||||
(knl-test "reader: ` quasiquote"
|
||||
(kernel-parse "`x") (list "$quasiquote" "x"))
|
||||
(knl-test "reader: , unquote"
|
||||
(kernel-parse ",x") (list "$unquote" "x"))
|
||||
(knl-test "reader: ,@ unquote-splicing"
|
||||
(kernel-parse ",@x") (list "$unquote-splicing" "x"))
|
||||
(knl-test "reader: quasi-mix"
|
||||
(kernel-parse "`(a ,b ,@c)")
|
||||
(list "$quasiquote"
|
||||
(list "a"
|
||||
(list "$unquote" "b")
|
||||
(list "$unquote-splicing" "c"))))
|
||||
(knl-test "reader: quote separates from neighbouring atom"
|
||||
(kernel-parse "(a 'b c)")
|
||||
(list "a" (list "$quote" "b") "c"))
|
||||
|
||||
(define knl-tests-run! (fn () {:total (+ knl-test-pass knl-test-fail) :passed knl-test-pass :failed knl-test-fail :fails knl-test-fails}))
|
||||
@@ -1,445 +0,0 @@
|
||||
;; lib/kernel/tests/standard.sx — exercises the Kernel standard env.
|
||||
;;
|
||||
;; Phase 4 tests verify that the standard env is rich enough to run
|
||||
;; classic Kernel programs: factorial via recursion, list operations,
|
||||
;; first-class environment manipulation. Each test starts from a fresh
|
||||
;; standard env via `(kernel-standard-env)`.
|
||||
|
||||
(define ks-test-pass 0)
|
||||
(define ks-test-fail 0)
|
||||
(define ks-test-fails (list))
|
||||
|
||||
(define
|
||||
ks-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! ks-test-pass (+ ks-test-pass 1))
|
||||
(begin
|
||||
(set! ks-test-fail (+ ks-test-fail 1))
|
||||
(append! ks-test-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define
|
||||
ks-eval
|
||||
(fn (src) (kernel-eval (kernel-parse src) (kernel-standard-env))))
|
||||
|
||||
(define ks-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
|
||||
|
||||
(define
|
||||
ks-eval-all
|
||||
(fn (src env) (kernel-eval-program (kernel-parse-all src) env)))
|
||||
|
||||
;; ── $if ──────────────────────────────────────────────────────────
|
||||
(ks-test "if: true branch" (ks-eval "($if #t 1 2)") 1)
|
||||
(ks-test "if: false branch" (ks-eval "($if #f 1 2)") 2)
|
||||
(ks-test "if: predicate"
|
||||
(ks-eval "($if (<=? 1 2) ($quote yes) ($quote no))") "yes")
|
||||
(ks-test
|
||||
"if: untaken branch not evaluated"
|
||||
(ks-eval "($if #t 42 nope)")
|
||||
42)
|
||||
|
||||
;; ── $define! + arithmetic ───────────────────────────────────────
|
||||
(ks-test
|
||||
"define!: returns value"
|
||||
(let ((env (kernel-standard-env))) (ks-eval-in "($define! x 5)" env))
|
||||
5)
|
||||
|
||||
(ks-test
|
||||
"define!: bound in env"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in "($define! x 5)" env)
|
||||
(ks-eval-in "x" env))
|
||||
5)
|
||||
|
||||
(ks-test "arith: +" (ks-eval "(+ 2 3)") 5)
|
||||
(ks-test "arith: -" (ks-eval "(- 10 4)") 6)
|
||||
(ks-test "arith: *" (ks-eval "(* 6 7)") 42)
|
||||
(ks-test "arith: /" (ks-eval "(/ 20 5)") 4)
|
||||
(ks-test "cmp: < true" (ks-eval "(< 1 2)") true)
|
||||
(ks-test "cmp: < false" (ks-eval "(< 2 1)") false)
|
||||
(ks-test "cmp: >=" (ks-eval "(>=? 2 2)") true)
|
||||
(ks-test "cmp: <=" (ks-eval "(<=? 2 3)") true)
|
||||
(ks-test "cmp: =" (ks-eval "(=? 7 7)") true)
|
||||
|
||||
;; ── $sequence ────────────────────────────────────────────────────
|
||||
(ks-test "sequence: empty" (ks-eval "($sequence)") nil)
|
||||
(ks-test "sequence: single" (ks-eval "($sequence 99)") 99)
|
||||
(ks-test
|
||||
"sequence: multi-effect"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in "($sequence ($define! a 1) ($define! b 2) (+ a b))" env))
|
||||
3)
|
||||
|
||||
;; ── list primitives ──────────────────────────────────────────────
|
||||
(ks-test
|
||||
"list: builds"
|
||||
(ks-eval "(list 1 2 3)")
|
||||
(list 1 2 3))
|
||||
(ks-test "list: empty" (ks-eval "(list)") (list))
|
||||
(ks-test
|
||||
"cons: prepend"
|
||||
(ks-eval "(cons 0 (list 1 2 3))")
|
||||
(list 0 1 2 3))
|
||||
(ks-test "car: head" (ks-eval "(car (list 10 20 30))") 10)
|
||||
(ks-test
|
||||
"cdr: tail"
|
||||
(ks-eval "(cdr (list 10 20 30))")
|
||||
(list 20 30))
|
||||
(ks-test "length: 3" (ks-eval "(length (list 1 2 3))") 3)
|
||||
(ks-test "length: 0" (ks-eval "(length (list))") 0)
|
||||
(ks-test "null?: empty" (ks-eval "(null? (list))") true)
|
||||
(ks-test "null?: nonempty" (ks-eval "(null? (list 1))") false)
|
||||
(ks-test "pair?: empty" (ks-eval "(pair? (list))") false)
|
||||
(ks-test "pair?: nonempty" (ks-eval "(pair? (list 1))") true)
|
||||
|
||||
;; ── $quote ───────────────────────────────────────────────────────
|
||||
(ks-test "quote: symbol" (ks-eval "($quote foo)") "foo")
|
||||
(ks-test
|
||||
"quote: list"
|
||||
(ks-eval "($quote (+ 1 2))")
|
||||
(list "+" 1 2))
|
||||
|
||||
;; ── boolean / not ────────────────────────────────────────────────
|
||||
(ks-test "not: true" (ks-eval "(not #t)") false)
|
||||
(ks-test "not: false" (ks-eval "(not #f)") true)
|
||||
|
||||
;; ── factorial ────────────────────────────────────────────────────
|
||||
(ks-test
|
||||
"factorial: 5!"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in
|
||||
"($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
|
||||
env)
|
||||
(ks-eval-in "(factorial 5)" env))
|
||||
120)
|
||||
|
||||
(ks-test
|
||||
"factorial: 0! = 1"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in
|
||||
"($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
|
||||
env)
|
||||
(ks-eval-in "(factorial 0)" env))
|
||||
1)
|
||||
|
||||
(ks-test
|
||||
"factorial: 10!"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in
|
||||
"($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
|
||||
env)
|
||||
(ks-eval-in "(factorial 10)" env))
|
||||
3628800)
|
||||
|
||||
;; ── recursive list operations ────────────────────────────────────
|
||||
(ks-test
|
||||
"sum: recursive over list"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in
|
||||
"($define! sum ($lambda (xs) ($if (null? xs) 0 (+ (car xs) (sum (cdr xs))))))"
|
||||
env)
|
||||
(ks-eval-in "(sum (list 1 2 3 4 5))" env))
|
||||
15)
|
||||
|
||||
(ks-test
|
||||
"len: recursive count"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in
|
||||
"($define! mylen ($lambda (xs) ($if (null? xs) 0 (+ 1 (mylen (cdr xs))))))"
|
||||
env)
|
||||
(ks-eval-in "(mylen (list 1 2 3 4))" env))
|
||||
4)
|
||||
|
||||
(ks-test
|
||||
"map-add1: build new list"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in
|
||||
"($define! add1-all ($lambda (xs) ($if (null? xs) (list) (cons (+ 1 (car xs)) (add1-all (cdr xs))))))"
|
||||
env)
|
||||
(ks-eval-in "(add1-all (list 10 20 30))" env))
|
||||
(list 11 21 31))
|
||||
|
||||
;; ── eval as a first-class applicative ────────────────────────────
|
||||
(ks-test
|
||||
"eval: applies to constructed form"
|
||||
(ks-eval "(eval (list ($quote +) 2 3) (get-current-environment))")
|
||||
5)
|
||||
|
||||
(ks-test
|
||||
"eval: with a fresh make-environment"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(ks-eval "(eval ($quote (+ 1 2)) (make-environment))"))
|
||||
:raised)
|
||||
|
||||
(ks-test
|
||||
"eval: in extended env sees parent's bindings"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in "($define! shared 7)" env)
|
||||
(ks-eval-in
|
||||
"(eval ($quote shared) (make-environment (get-current-environment)))"
|
||||
env))
|
||||
7)
|
||||
|
||||
;; ── get-current-environment ──────────────────────────────────────
|
||||
(ks-test
|
||||
"get-current-environment: returns env"
|
||||
(kernel-env? (ks-eval "(get-current-environment)"))
|
||||
true)
|
||||
|
||||
(ks-test
|
||||
"get-current-environment: contains $if"
|
||||
(let
|
||||
((env (ks-eval "(get-current-environment)")))
|
||||
(kernel-env-has? env "$if"))
|
||||
true)
|
||||
|
||||
(ks-test
|
||||
"make-environment: empty"
|
||||
(let ((env (ks-eval "(make-environment)"))) (kernel-env-has? env "$if"))
|
||||
false)
|
||||
|
||||
(ks-test
|
||||
"make-environment: child sees parent"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in "($define! marker 123)" env)
|
||||
(let
|
||||
((child (ks-eval-in "(make-environment (get-current-environment))" env)))
|
||||
(kernel-env-has? child "marker")))
|
||||
true)
|
||||
|
||||
;; ── closures and lexical scope ───────────────────────────────────
|
||||
(ks-test
|
||||
"closure: captures binding"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in
|
||||
"($define! make-adder ($lambda (n) ($lambda (x) (+ x n))))"
|
||||
env)
|
||||
(ks-eval-in "($define! add5 (make-adder 5))" env)
|
||||
(ks-eval-in "(add5 10)" env))
|
||||
15)
|
||||
|
||||
(ks-test
|
||||
"closure: nested lookups"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in
|
||||
"($define! curry-add ($lambda (a) ($lambda (b) ($lambda (c) (+ a (+ b c))))))"
|
||||
env)
|
||||
(ks-eval-in "(((curry-add 1) 2) 3)" env))
|
||||
6)
|
||||
|
||||
;; ── operative defined in standard env can reach $define! ─────────
|
||||
(ks-test
|
||||
"custom: define-via-vau"
|
||||
(let
|
||||
((env (kernel-standard-env)))
|
||||
(ks-eval-in
|
||||
"($define! $let-it ($vau (name expr) e ($sequence ($define! tmp (eval expr e)) (eval (list ($quote $define!) name (list ($quote $quote) tmp)) e) tmp)))"
|
||||
env)
|
||||
(ks-eval-in "($let-it z 77)" env)
|
||||
(ks-eval-in "z" env))
|
||||
77)
|
||||
|
||||
;; ── quasiquote ──────────────────────────────────────────────────
|
||||
(ks-test "qq: plain atom" (ks-eval "`hello") "hello")
|
||||
(ks-test "qq: plain list" (ks-eval "`(a b c)") (list "a" "b" "c"))
|
||||
(ks-test "qq: unquote splices value"
|
||||
(let ((env (kernel-standard-env)))
|
||||
(ks-eval-in "($define! x 42)" env)
|
||||
(ks-eval-in "`(a ,x b)" env)) (list "a" 42 "b"))
|
||||
(ks-test "qq: unquote-splicing splices list"
|
||||
(let ((env (kernel-standard-env)))
|
||||
(ks-eval-in "($define! xs (list 1 2 3))" env)
|
||||
(ks-eval-in "`(a ,@xs b)" env)) (list "a" 1 2 3 "b"))
|
||||
(ks-test "qq: unquote-splicing at end"
|
||||
(let ((env (kernel-standard-env)))
|
||||
(ks-eval-in "($define! xs (list 9 8))" env)
|
||||
(ks-eval-in "`(a b ,@xs)" env)) (list "a" "b" 9 8))
|
||||
(ks-test "qq: unquote-splicing at start"
|
||||
(let ((env (kernel-standard-env)))
|
||||
(ks-eval-in "($define! xs (list 1 2))" env)
|
||||
(ks-eval-in "`(,@xs c)" env)) (list 1 2 "c"))
|
||||
(ks-test "qq: nested list with unquote inside"
|
||||
(let ((env (kernel-standard-env)))
|
||||
(ks-eval-in "($define! x 5)" env)
|
||||
(ks-eval-in "`(a (b ,x) c)" env))
|
||||
(list "a" (list "b" 5) "c"))
|
||||
(ks-test "qq: error on bare unquote-splicing into non-list"
|
||||
(let ((env (kernel-standard-env)))
|
||||
(ks-eval-in "($define! x 42)" env)
|
||||
(guard (e (true :raised))
|
||||
(ks-eval-in "`(a ,@x b)" env)))
|
||||
:raised)
|
||||
|
||||
;; ── $cond / $when / $unless ─────────────────────────────────────
|
||||
(ks-test "cond: first match"
|
||||
(ks-eval "($cond (#f 1) (#t 2) (#t 3))") 2)
|
||||
(ks-test "cond: else fallback"
|
||||
(ks-eval "($cond (#f 1) (else 99))") 99)
|
||||
(ks-test "cond: no match returns nil"
|
||||
(ks-eval "($cond (#f 1) (#f 2))") nil)
|
||||
(ks-test "cond: empty clauses returns nil"
|
||||
(ks-eval "($cond)") nil)
|
||||
(ks-test "cond: multi-expr body"
|
||||
(ks-eval "($cond (#t 1 2 3))") 3)
|
||||
(ks-test "cond: doesn't evaluate untaken clauses"
|
||||
;; If the second clause's test were evaluated, the unbound `nope` would error.
|
||||
(ks-eval "($cond (#t 7) (nope ignored))") 7)
|
||||
(ks-test "cond: predicate evaluation"
|
||||
(let ((env (kernel-standard-env)))
|
||||
(ks-eval-in "($define! n 5)" env)
|
||||
(ks-eval-in "($cond ((< n 0) ($quote negative)) ((= n 0) ($quote zero)) (else ($quote positive)))" env))
|
||||
"positive")
|
||||
|
||||
(ks-test "when: true runs body"
|
||||
(ks-eval "($when #t 1 2 3)") 3)
|
||||
(ks-test "when: false returns nil"
|
||||
(ks-eval "($when #f 1 2 3)") nil)
|
||||
(ks-test "when: skips body when false"
|
||||
(ks-eval "($when #f nope)") nil)
|
||||
|
||||
(ks-test "unless: false runs body"
|
||||
(ks-eval "($unless #f 99)") 99)
|
||||
(ks-test "unless: true returns nil"
|
||||
(ks-eval "($unless #t 99)") nil)
|
||||
(ks-test "unless: skips body when true"
|
||||
(ks-eval "($unless #t nope)") nil)
|
||||
|
||||
;; ── $and? / $or? short-circuit ──────────────────────────────────
|
||||
(ks-test "and: empty returns true" (ks-eval "($and?)") true)
|
||||
(ks-test "and: single returns value" (ks-eval "($and? 42)") 42)
|
||||
(ks-test "and: all true returns last"
|
||||
(ks-eval "($and? 1 2 3)") 3)
|
||||
(ks-test "and: first false short-circuits"
|
||||
(ks-eval "($and? #f nope)") false)
|
||||
(ks-test "and: false in middle short-circuits"
|
||||
(ks-eval "($and? 1 #f nope)") false)
|
||||
(ks-test "or: empty returns false" (ks-eval "($or?)") false)
|
||||
(ks-test "or: single returns value" (ks-eval "($or? 42)") 42)
|
||||
(ks-test "or: first truthy short-circuits"
|
||||
(ks-eval "($or? 99 nope)") 99)
|
||||
(ks-test "or: all false returns last"
|
||||
(ks-eval "($or? #f #f #f)") false)
|
||||
(ks-test "or: middle truthy"
|
||||
(ks-eval "($or? #f 42 nope)") 42)
|
||||
|
||||
;; ── variadic arithmetic ─────────────────────────────────────────
|
||||
(ks-test "+: zero args = 0" (ks-eval "(+)") 0)
|
||||
(ks-test "+: one arg = arg" (ks-eval "(+ 7)") 7)
|
||||
(ks-test "+: two args" (ks-eval "(+ 3 4)") 7)
|
||||
(ks-test "+: five args" (ks-eval "(+ 1 2 3 4 5)") 15)
|
||||
|
||||
(ks-test "*: zero args = 1" (ks-eval "(*)") 1)
|
||||
(ks-test "*: one arg" (ks-eval "(* 7)") 7)
|
||||
(ks-test "*: four args" (ks-eval "(* 1 2 3 4)") 24)
|
||||
|
||||
(ks-test "-: one arg negates" (ks-eval "(- 10)") -10)
|
||||
(ks-test "-: two args" (ks-eval "(- 10 3)") 7)
|
||||
(ks-test "-: four args fold" (ks-eval "(- 100 1 2 3)") 94)
|
||||
|
||||
(ks-test "/: two args" (ks-eval "(/ 20 5)") 4)
|
||||
(ks-test "/: three args fold" (ks-eval "(/ 100 2 5)") 10)
|
||||
|
||||
;; ── variadic chained comparison ─────────────────────────────────
|
||||
(ks-test "<: chained ascending" (ks-eval "(< 1 2 3 4 5)") true)
|
||||
(ks-test "<: not strict" (ks-eval "(< 1 2 2 3)") false)
|
||||
(ks-test "<: anti-monotonic" (ks-eval "(< 5 3)") false)
|
||||
(ks-test ">: chained descending" (ks-eval "(> 5 4 3 2 1)") true)
|
||||
(ks-test "<=? ascending equals" (ks-eval "(<=? 1 1 2 3 3)") true)
|
||||
(ks-test "<=? violation" (ks-eval "(<=? 1 2 1)") false)
|
||||
(ks-test ">=? descending equals" (ks-eval "(>=? 3 3 2 1)") true)
|
||||
|
||||
;; ── list combinators ────────────────────────────────────────────
|
||||
(ks-test "map: square"
|
||||
(ks-eval "(map ($lambda (x) (* x x)) (list 1 2 3 4))")
|
||||
(list 1 4 9 16))
|
||||
(ks-test "map: empty list"
|
||||
(ks-eval "(map ($lambda (x) x) (list))") (list))
|
||||
(ks-test "map: identity preserves"
|
||||
(ks-eval "(map ($lambda (x) x) (list 1 2 3))") (list 1 2 3))
|
||||
(ks-test "map: with closure over outer"
|
||||
(let ((env (kernel-standard-env)))
|
||||
(ks-eval-in "($define! k 10)" env)
|
||||
(ks-eval-in "(map ($lambda (x) (+ x k)) (list 1 2 3))" env))
|
||||
(list 11 12 13))
|
||||
|
||||
(ks-test "filter: positives"
|
||||
(ks-eval "(filter ($lambda (x) (< 0 x)) (list -2 -1 0 1 2))")
|
||||
(list 1 2))
|
||||
(ks-test "filter: empty result"
|
||||
(ks-eval "(filter ($lambda (x) #f) (list 1 2 3))") (list))
|
||||
(ks-test "filter: all match"
|
||||
(ks-eval "(filter ($lambda (x) #t) (list 1 2 3))") (list 1 2 3))
|
||||
|
||||
(ks-test "reduce: sum"
|
||||
(ks-eval "(reduce ($lambda (a b) (+ a b)) 0 (list 1 2 3 4 5))") 15)
|
||||
(ks-test "reduce: product"
|
||||
(ks-eval "(reduce ($lambda (a b) (* a b)) 1 (list 1 2 3 4))") 24)
|
||||
(ks-test "reduce: empty returns init"
|
||||
(ks-eval "(reduce ($lambda (a b) (+ a b)) 42 (list))") 42)
|
||||
(ks-test "reduce: build list"
|
||||
(ks-eval "(reduce ($lambda (acc x) (cons x acc)) () (list 1 2 3))")
|
||||
(list 3 2 1))
|
||||
|
||||
;; ── apply ────────────────────────────────────────────────────────
|
||||
(ks-test "apply: + over list"
|
||||
(ks-eval "(apply + (list 1 2 3 4 5))") 15)
|
||||
(ks-test "apply: lambda"
|
||||
(ks-eval "(apply ($lambda (a b c) (* a (+ b c))) (list 2 3 4))") 14)
|
||||
(ks-test "apply: list identity"
|
||||
(ks-eval "(apply list (list 1 2 3))") (list 1 2 3))
|
||||
(ks-test "apply: empty args list"
|
||||
(ks-eval "(apply + (list))") 0)
|
||||
(ks-test "apply: single arg list"
|
||||
(ks-eval "(apply ($lambda (x) (* x 10)) (list 7))") 70)
|
||||
(ks-test "apply: built via map+apply"
|
||||
;; (apply + (map ($lambda (x) (* x x)) (list 1 2 3))) → 1+4+9 = 14
|
||||
(ks-eval
|
||||
"(apply + (map ($lambda (x) (* x x)) (list 1 2 3)))") 14)
|
||||
(ks-test "apply: error on non-list args"
|
||||
(guard (e (true :raised))
|
||||
(ks-eval "(apply + 5)"))
|
||||
:raised)
|
||||
|
||||
;; ── append / reverse ────────────────────────────────────────────
|
||||
(ks-test "append: two lists"
|
||||
(ks-eval "(append (list 1 2) (list 3 4))") (list 1 2 3 4))
|
||||
(ks-test "append: three lists"
|
||||
(ks-eval "(append (list 1) (list 2) (list 3))") (list 1 2 3))
|
||||
(ks-test "append: empty list"
|
||||
(ks-eval "(append)") (list))
|
||||
(ks-test "append: one list"
|
||||
(ks-eval "(append (list 1 2 3))") (list 1 2 3))
|
||||
(ks-test "append: empty + nonempty"
|
||||
(ks-eval "(append (list) (list 1 2))") (list 1 2))
|
||||
(ks-test "append: nonempty + empty"
|
||||
(ks-eval "(append (list 1 2) (list))") (list 1 2))
|
||||
(ks-test "append: error on non-list"
|
||||
(guard (e (true :raised))
|
||||
(ks-eval "(append (list 1) 5)"))
|
||||
:raised)
|
||||
|
||||
(ks-test "reverse: four elements"
|
||||
(ks-eval "(reverse (list 1 2 3 4))") (list 4 3 2 1))
|
||||
(ks-test "reverse: empty"
|
||||
(ks-eval "(reverse (list))") (list))
|
||||
(ks-test "reverse: single"
|
||||
(ks-eval "(reverse (list 99))") (list 99))
|
||||
(ks-test "reverse: double reverse is identity"
|
||||
(ks-eval "(reverse (reverse (list 1 2 3)))") (list 1 2 3))
|
||||
|
||||
(define ks-tests-run! (fn () {:total (+ ks-test-pass ks-test-fail) :passed ks-test-pass :failed ks-test-fail :fails ks-test-fails}))
|
||||
@@ -1,309 +0,0 @@
|
||||
;; lib/kernel/tests/vau.sx — exercises lib/kernel/runtime.sx.
|
||||
;;
|
||||
;; Verifies the Phase 3 promise: user-defined operatives and applicatives
|
||||
;; constructible from inside the language. Tests build a Kernel
|
||||
;; base-env, bind a few helper applicatives (+, *, list, =, $if), and
|
||||
;; run programs that construct and use custom combiners.
|
||||
|
||||
(define kv-test-pass 0)
|
||||
(define kv-test-fail 0)
|
||||
(define kv-test-fails (list))
|
||||
|
||||
(define
|
||||
kv-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! kv-test-pass (+ kv-test-pass 1))
|
||||
(begin
|
||||
(set! kv-test-fail (+ kv-test-fail 1))
|
||||
(append! kv-test-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define kv-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
|
||||
|
||||
(define
|
||||
kv-make-env
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((env (kernel-base-env)))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"+"
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (+ (first args) (nth args 1)))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"*"
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (* (first args) (nth args 1)))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"-"
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (- (first args) (nth args 1)))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"="
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (= (first args) (nth args 1)))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"list"
|
||||
(kernel-make-primitive-applicative (fn (args) args)))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"cons"
|
||||
(kernel-make-primitive-applicative
|
||||
(fn (args) (cons (first args) (nth args 1)))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"$quote"
|
||||
(kernel-make-primitive-operative (fn (args dyn-env) (first args))))
|
||||
(kernel-env-bind!
|
||||
env
|
||||
"$if"
|
||||
(kernel-make-primitive-operative
|
||||
(fn
|
||||
(args dyn-env)
|
||||
(if
|
||||
(kernel-eval (first args) dyn-env)
|
||||
(kernel-eval (nth args 1) dyn-env)
|
||||
(kernel-eval (nth args 2) dyn-env)))))
|
||||
env)))
|
||||
|
||||
;; ── $vau: builds an operative ───────────────────────────────────
|
||||
(kv-test
|
||||
"vau: identity returns first arg unevaluated"
|
||||
(kv-eval-src "(($vau (a) _ a) hello)" (kv-make-env))
|
||||
"hello")
|
||||
|
||||
(kv-test
|
||||
"vau: returns args as raw expressions"
|
||||
(kv-eval-src "(($vau (a b) _ (list a b)) (+ 1 2) (+ 3 4))" (kv-make-env))
|
||||
(list (list "+" 1 2) (list "+" 3 4)))
|
||||
|
||||
(kv-test
|
||||
"vau: env-param is a kernel env"
|
||||
(kernel-env? (kv-eval-src "(($vau () e e))" (kv-make-env)))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"vau: returns operative"
|
||||
(kernel-operative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"vau: returns operative not applicative"
|
||||
(kernel-applicative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
|
||||
false)
|
||||
|
||||
(kv-test
|
||||
"vau: zero-arg body"
|
||||
(kv-eval-src "(($vau () _ 42))" (kv-make-env))
|
||||
42)
|
||||
|
||||
(kv-test
|
||||
"vau: static-env closure captured"
|
||||
(let
|
||||
((outer (kv-make-env)))
|
||||
(kernel-env-bind! outer "captured" 17)
|
||||
(let
|
||||
((op (kv-eval-src "($vau () _ captured)" outer))
|
||||
(caller (kv-make-env)))
|
||||
(kernel-env-bind! caller "captured" 99)
|
||||
(kernel-combine op (list) caller)))
|
||||
17)
|
||||
|
||||
(kv-test
|
||||
"vau: env-param exposes caller's dynamic env"
|
||||
(let
|
||||
((outer (kv-make-env)))
|
||||
(kernel-env-bind! outer "x" 1)
|
||||
(let
|
||||
((op (kv-eval-src "($vau () e e)" outer)) (caller (kv-make-env)))
|
||||
(kernel-env-bind! caller "x" 2)
|
||||
(let
|
||||
((e-val (kernel-combine op (list) caller)))
|
||||
(kernel-env-lookup e-val "x"))))
|
||||
2)
|
||||
|
||||
;; ── $lambda: applicatives evaluate their args ───────────────────
|
||||
(kv-test
|
||||
"lambda: identity"
|
||||
(kv-eval-src "(($lambda (x) x) 42)" (kv-make-env))
|
||||
42)
|
||||
|
||||
(kv-test
|
||||
"lambda: addition"
|
||||
(kv-eval-src "(($lambda (x y) (+ x y)) 3 4)" (kv-make-env))
|
||||
7)
|
||||
|
||||
(kv-test
|
||||
"lambda: args are evaluated before bind"
|
||||
(kv-eval-src "(($lambda (x) x) (+ 2 3))" (kv-make-env))
|
||||
5)
|
||||
|
||||
(kv-test
|
||||
"lambda: zero args"
|
||||
(kv-eval-src "(($lambda () 99))" (kv-make-env))
|
||||
99)
|
||||
|
||||
(kv-test
|
||||
"lambda: returns applicative"
|
||||
(kernel-applicative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"lambda: returns applicative not operative"
|
||||
(kernel-operative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
|
||||
false)
|
||||
|
||||
(kv-test
|
||||
"lambda: higher-order"
|
||||
(kv-eval-src "(($lambda (f) (f 10)) ($lambda (x) (+ x 1)))" (kv-make-env))
|
||||
11)
|
||||
|
||||
;; ── wrap / unwrap as user-callable applicatives ─────────────────
|
||||
|
||||
(kv-test
|
||||
"wrap: makes applicative from operative"
|
||||
(kernel-applicative? (kv-eval-src "(wrap ($vau (x) _ x))" (kv-make-env)))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"wrap: result evaluates its arg"
|
||||
(kv-eval-src "((wrap ($vau (x) _ x)) (+ 1 2))" (kv-make-env))
|
||||
3)
|
||||
|
||||
(kv-test
|
||||
"unwrap: extracts operative from applicative"
|
||||
(kernel-operative? (kv-eval-src "(unwrap ($lambda (x) x))" (kv-make-env)))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"wrap/unwrap roundtrip preserves identity"
|
||||
(kv-eval-src
|
||||
"(($lambda (op) (= op (unwrap (wrap op)))) ($vau (x) _ x))"
|
||||
(kv-make-env))
|
||||
true)
|
||||
|
||||
;; ── operative? / applicative? as user-visible predicates ────────
|
||||
|
||||
(kv-test
|
||||
"operative? on vau result"
|
||||
(kv-eval-src "(operative? ($vau (x) _ x))" (kv-make-env))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"operative? on lambda result"
|
||||
(kv-eval-src "(operative? ($lambda (x) x))" (kv-make-env))
|
||||
false)
|
||||
|
||||
(kv-test
|
||||
"applicative? on lambda result"
|
||||
(kv-eval-src "(applicative? ($lambda (x) x))" (kv-make-env))
|
||||
true)
|
||||
|
||||
(kv-test
|
||||
"applicative? on vau result"
|
||||
(kv-eval-src "(applicative? ($vau (x) _ x))" (kv-make-env))
|
||||
false)
|
||||
|
||||
(kv-test
|
||||
"operative? on number"
|
||||
(kv-eval-src "(operative? 42)" (kv-make-env))
|
||||
false)
|
||||
|
||||
;; ── Build BOTH layers from user code ────────────────────────────
|
||||
;; The headline Phase 3 test: defining an operative on top of an
|
||||
;; applicative defined on top of a vau.
|
||||
|
||||
(kv-test
|
||||
"custom: applicative + operative compose"
|
||||
(let
|
||||
((env (kv-make-env)))
|
||||
(kernel-env-bind! env "square" (kv-eval-src "($lambda (x) (* x x))" env))
|
||||
(kv-eval-src "(square 4)" env))
|
||||
16)
|
||||
|
||||
(kv-test "custom: operative captures argument syntax"
|
||||
;; ($capture x) returns the raw expression `x`, regardless of value.
|
||||
(let ((env (kv-make-env)))
|
||||
(kernel-env-bind! env "$capture"
|
||||
(kv-eval-src "($vau (form) _ form)" env))
|
||||
(kv-eval-src "($capture (+ 1 2))" env))
|
||||
(list "+" 1 2))
|
||||
|
||||
(kv-test "custom: applicative re-wraps an operative"
|
||||
;; Build a captured operative, then wrap it into an applicative that
|
||||
;; evaluates args before re-entry. This exercises wrap+$vau composed.
|
||||
(let ((env (kv-make-env)))
|
||||
(kernel-env-bind! env "id-app"
|
||||
(kv-eval-src "(wrap ($vau (x) _ x))" env))
|
||||
(kv-eval-src "(id-app (+ 10 20))" env))
|
||||
30)
|
||||
|
||||
;; ── Error cases ──────────────────────────────────────────────────
|
||||
|
||||
(kv-test
|
||||
"vau: rejects non-list formals"
|
||||
(guard (e (true :raised)) (kv-eval-src "($vau x _ x)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(kv-test
|
||||
"vau: rejects non-symbol formal"
|
||||
(guard (e (true :raised)) (kv-eval-src "($vau (1) _ x)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(kv-test
|
||||
"vau: rejects non-symbol env-param"
|
||||
(guard (e (true :raised)) (kv-eval-src "($vau (x) 7 x)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(kv-test
|
||||
"vau: too few args at call site"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(kv-eval-src "(($vau (x y) _ x) 1)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(kv-test
|
||||
"vau: too many args at call site"
|
||||
(guard
|
||||
(e (true :raised))
|
||||
(kv-eval-src "(($vau (x) _ x) 1 2)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(kv-test
|
||||
"wrap: rejects non-operative"
|
||||
(guard (e (true :raised)) (kv-eval-src "(wrap 42)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
(kv-test
|
||||
"unwrap: rejects non-applicative"
|
||||
(guard (e (true :raised)) (kv-eval-src "(unwrap 42)" (kv-make-env)))
|
||||
:raised)
|
||||
|
||||
;; ── Multi-expression body (implicit $sequence) ──────────────────
|
||||
|
||||
(kv-test "lambda: two body forms — value of last"
|
||||
(kv-eval-src "(($lambda (n) (+ n 1) (+ n 10)) 5)" (kv-make-env)) 15)
|
||||
|
||||
(kv-test "lambda: three body forms"
|
||||
(kv-eval-src "(($lambda (n) n (+ n 1) (+ n 2)) 10)" (kv-make-env)) 12)
|
||||
|
||||
(kv-test "vau: two body forms"
|
||||
(kv-eval-src "(($vau (a b) _ a (list a b)) 7 8)" (kv-make-env))
|
||||
(list 7 8))
|
||||
|
||||
(kv-test "lambda: $define! in early body visible in later body"
|
||||
(kv-eval-src
|
||||
"(($lambda (n) ($define! double (+ n n)) double) 6)"
|
||||
(kv-make-env)) 12)
|
||||
|
||||
(kv-test "lambda: zero-arg multi-body"
|
||||
(kv-eval-src "(($lambda () 1 2 3))" (kv-make-env)) 3)
|
||||
|
||||
(define kv-tests-run! (fn () {:total (+ kv-test-pass kv-test-fail) :passed kv-test-pass :failed kv-test-fail :fails kv-test-fails}))
|
||||
@@ -1,590 +0,0 @@
|
||||
;; lib/minikanren/clpfd.sx — Phase 6: native CLP(FD) on miniKanren.
|
||||
;;
|
||||
;; The substitution dict carries an extra reserved key "_fd" that holds a
|
||||
;; constraint-store record:
|
||||
;;
|
||||
;; {:domains {var-name -> sorted-int-list}
|
||||
;; :constraints (... pending constraint closures ...)}
|
||||
;;
|
||||
;; Domains are sorted SX lists of ints (no duplicates).
|
||||
;; Constraints are functions s -> s-or-nil that propagate / re-check.
|
||||
;; They are re-fired after every label binding via fd-fire-store.
|
||||
|
||||
(define fd-key "_fd")
|
||||
|
||||
;; --- domain primitives ---
|
||||
|
||||
(define
|
||||
fd-dom-rev
|
||||
(fn
|
||||
(xs acc)
|
||||
(cond
|
||||
((empty? xs) acc)
|
||||
(:else (fd-dom-rev (rest xs) (cons (first xs) acc))))))
|
||||
|
||||
(define
|
||||
fd-dom-insert
|
||||
(fn
|
||||
(x desc)
|
||||
(cond
|
||||
((empty? desc) (list x))
|
||||
((= x (first desc)) desc)
|
||||
((> x (first desc)) (cons x desc))
|
||||
(:else (cons (first desc) (fd-dom-insert x (rest desc)))))))
|
||||
|
||||
(define
|
||||
fd-dom-sort-dedupe
|
||||
(fn
|
||||
(xs acc)
|
||||
(cond
|
||||
((empty? xs) (fd-dom-rev acc (list)))
|
||||
(:else (fd-dom-sort-dedupe (rest xs) (fd-dom-insert (first xs) acc))))))
|
||||
|
||||
(define fd-dom-from-list (fn (xs) (fd-dom-sort-dedupe xs (list))))
|
||||
|
||||
(define fd-dom-empty? (fn (d) (empty? d)))
|
||||
(define
|
||||
fd-dom-singleton?
|
||||
(fn (d) (and (not (empty? d)) (empty? (rest d)))))
|
||||
(define fd-dom-min (fn (d) (first d)))
|
||||
|
||||
(define
|
||||
fd-dom-last
|
||||
(fn
|
||||
(d)
|
||||
(cond ((empty? (rest d)) (first d)) (:else (fd-dom-last (rest d))))))
|
||||
|
||||
(define fd-dom-max (fn (d) (fd-dom-last d)))
|
||||
(define fd-dom-member? (fn (x d) (some (fn (y) (= x y)) d)))
|
||||
|
||||
(define
|
||||
fd-dom-intersect
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((empty? a) (list))
|
||||
((empty? b) (list))
|
||||
((= (first a) (first b))
|
||||
(cons (first a) (fd-dom-intersect (rest a) (rest b))))
|
||||
((< (first a) (first b)) (fd-dom-intersect (rest a) b))
|
||||
(:else (fd-dom-intersect a (rest b))))))
|
||||
|
||||
(define
|
||||
fd-dom-without
|
||||
(fn
|
||||
(x d)
|
||||
(cond
|
||||
((empty? d) (list))
|
||||
((= (first d) x) (rest d))
|
||||
((> (first d) x) d)
|
||||
(:else (cons (first d) (fd-dom-without x (rest d)))))))
|
||||
|
||||
(define
|
||||
fd-dom-range
|
||||
(fn
|
||||
(lo hi)
|
||||
(cond
|
||||
((> lo hi) (list))
|
||||
(:else (cons lo (fd-dom-range (+ lo 1) hi))))))
|
||||
|
||||
;; --- constraint store accessors ---
|
||||
|
||||
(define fd-store-empty (fn () {:domains {} :constraints (list)}))
|
||||
|
||||
(define
|
||||
fd-store-of
|
||||
(fn
|
||||
(s)
|
||||
(cond ((has-key? s fd-key) (get s fd-key)) (:else (fd-store-empty)))))
|
||||
|
||||
(define fd-domains-of (fn (s) (get (fd-store-of s) :domains)))
|
||||
(define fd-with-store (fn (s store) (assoc s fd-key store)))
|
||||
|
||||
(define
|
||||
fd-domain-of
|
||||
(fn
|
||||
(s var-name)
|
||||
(let
|
||||
((doms (fd-domains-of s)))
|
||||
(cond ((has-key? doms var-name) (get doms var-name)) (:else nil)))))
|
||||
|
||||
(define
|
||||
fd-set-domain
|
||||
(fn
|
||||
(s var-name d)
|
||||
(cond
|
||||
((fd-dom-empty? d) nil)
|
||||
(:else
|
||||
(let
|
||||
((store (fd-store-of s)))
|
||||
(let
|
||||
((doms-prime (assoc (get store :domains) var-name d)))
|
||||
(let
|
||||
((store-prime (assoc store :domains doms-prime)))
|
||||
(fd-with-store s store-prime))))))))
|
||||
|
||||
(define
|
||||
fd-add-constraint
|
||||
(fn
|
||||
(s c)
|
||||
(let
|
||||
((store (fd-store-of s)))
|
||||
(let
|
||||
((cs-prime (cons c (get store :constraints))))
|
||||
(let
|
||||
((store-prime (assoc store :constraints cs-prime)))
|
||||
(fd-with-store s store-prime))))))
|
||||
|
||||
(define
|
||||
fd-fire-list
|
||||
(fn
|
||||
(cs s)
|
||||
(cond
|
||||
((empty? cs) s)
|
||||
(:else
|
||||
(let
|
||||
((s2 ((first cs) s)))
|
||||
(cond ((= s2 nil) nil) (:else (fd-fire-list (rest cs) s2))))))))
|
||||
|
||||
(define
|
||||
fd-store-signature
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((doms (fd-domains-of s)))
|
||||
(let
|
||||
((dom-sizes (reduce (fn (acc k) (+ acc (len (get doms k)))) 0 (keys doms))))
|
||||
(+ dom-sizes (len (keys s)))))))
|
||||
|
||||
(define
|
||||
fd-fire-store
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((s2 (fd-fire-list (get (fd-store-of s) :constraints) s)))
|
||||
(cond
|
||||
((= s2 nil) nil)
|
||||
((= (fd-store-signature s) (fd-store-signature s2)) s2)
|
||||
(:else (fd-fire-store s2))))))
|
||||
|
||||
;; --- user-facing goals ---
|
||||
|
||||
(define
|
||||
fd-in
|
||||
(fn
|
||||
(x dom-list)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((new-dom (fd-dom-from-list dom-list)))
|
||||
(let
|
||||
((wx (mk-walk x s)))
|
||||
(cond
|
||||
((number? wx)
|
||||
(cond ((fd-dom-member? wx new-dom) (unit s)) (:else mzero)))
|
||||
((is-var? wx)
|
||||
(let
|
||||
((existing (fd-domain-of s (var-name wx))))
|
||||
(let
|
||||
((narrowed (cond ((= existing nil) new-dom) (:else (fd-dom-intersect existing new-dom)))))
|
||||
(let
|
||||
((s2 (fd-set-domain s (var-name wx) narrowed)))
|
||||
(cond ((= s2 nil) mzero) (:else (unit s2)))))))
|
||||
(:else mzero)))))))
|
||||
|
||||
;; --- fd-neq ---
|
||||
|
||||
(define
|
||||
fd-neq-prop
|
||||
(fn
|
||||
(x y s)
|
||||
(let
|
||||
((wx (mk-walk x s)) (wy (mk-walk y s)))
|
||||
(cond
|
||||
((and (number? wx) (number? wy))
|
||||
(cond ((= wx wy) nil) (:else s)))
|
||||
((and (number? wx) (is-var? wy))
|
||||
(let
|
||||
((y-dom (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((= y-dom nil) s)
|
||||
(:else
|
||||
(fd-set-domain s (var-name wy) (fd-dom-without wx y-dom))))))
|
||||
((and (number? wy) (is-var? wx))
|
||||
(let
|
||||
((x-dom (fd-domain-of s (var-name wx))))
|
||||
(cond
|
||||
((= x-dom nil) s)
|
||||
(:else
|
||||
(fd-set-domain s (var-name wx) (fd-dom-without wy x-dom))))))
|
||||
(:else s)))))
|
||||
|
||||
(define
|
||||
fd-neq
|
||||
(fn
|
||||
(x y)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((c (fn (s-prime) (fd-neq-prop x y s-prime))))
|
||||
(let
|
||||
((s2 (fd-add-constraint s c)))
|
||||
(let
|
||||
((s3 (c s2)))
|
||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||
|
||||
;; --- fd-lt ---
|
||||
|
||||
(define
|
||||
fd-lt-prop
|
||||
(fn
|
||||
(x y s)
|
||||
(let
|
||||
((wx (mk-walk x s)) (wy (mk-walk y s)))
|
||||
(cond
|
||||
((and (number? wx) (number? wy))
|
||||
(cond ((< wx wy) s) (:else nil)))
|
||||
((and (number? wx) (is-var? wy))
|
||||
(let
|
||||
((yd (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((= yd nil) s)
|
||||
(:else
|
||||
(fd-set-domain
|
||||
s
|
||||
(var-name wy)
|
||||
(filter (fn (v) (> v wx)) yd))))))
|
||||
((and (is-var? wx) (number? wy))
|
||||
(let
|
||||
((xd (fd-domain-of s (var-name wx))))
|
||||
(cond
|
||||
((= xd nil) s)
|
||||
(:else
|
||||
(fd-set-domain
|
||||
s
|
||||
(var-name wx)
|
||||
(filter (fn (v) (< v wy)) xd))))))
|
||||
((and (is-var? wx) (is-var? wy))
|
||||
(let
|
||||
((xd (fd-domain-of s (var-name wx)))
|
||||
(yd (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((or (= xd nil) (= yd nil)) s)
|
||||
(:else
|
||||
(let
|
||||
((xd-prime (filter (fn (v) (< v (fd-dom-max yd))) xd)))
|
||||
(let
|
||||
((s2 (fd-set-domain s (var-name wx) xd-prime)))
|
||||
(cond
|
||||
((= s2 nil) nil)
|
||||
(:else
|
||||
(let
|
||||
((yd-prime (filter (fn (v) (> v (fd-dom-min xd-prime))) yd)))
|
||||
(fd-set-domain s2 (var-name wy) yd-prime))))))))))
|
||||
(:else s)))))
|
||||
|
||||
(define
|
||||
fd-lt
|
||||
(fn
|
||||
(x y)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((c (fn (sp) (fd-lt-prop x y sp))))
|
||||
(let
|
||||
((s2 (fd-add-constraint s c)))
|
||||
(let
|
||||
((s3 (c s2)))
|
||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||
|
||||
;; --- fd-lte ---
|
||||
|
||||
(define
|
||||
fd-lte-prop
|
||||
(fn
|
||||
(x y s)
|
||||
(let
|
||||
((wx (mk-walk x s)) (wy (mk-walk y s)))
|
||||
(cond
|
||||
((and (number? wx) (number? wy))
|
||||
(cond ((<= wx wy) s) (:else nil)))
|
||||
((and (number? wx) (is-var? wy))
|
||||
(let
|
||||
((yd (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((= yd nil) s)
|
||||
(:else
|
||||
(fd-set-domain
|
||||
s
|
||||
(var-name wy)
|
||||
(filter (fn (v) (>= v wx)) yd))))))
|
||||
((and (is-var? wx) (number? wy))
|
||||
(let
|
||||
((xd (fd-domain-of s (var-name wx))))
|
||||
(cond
|
||||
((= xd nil) s)
|
||||
(:else
|
||||
(fd-set-domain
|
||||
s
|
||||
(var-name wx)
|
||||
(filter (fn (v) (<= v wy)) xd))))))
|
||||
((and (is-var? wx) (is-var? wy))
|
||||
(let
|
||||
((xd (fd-domain-of s (var-name wx)))
|
||||
(yd (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((or (= xd nil) (= yd nil)) s)
|
||||
(:else
|
||||
(let
|
||||
((xd-prime (filter (fn (v) (<= v (fd-dom-max yd))) xd)))
|
||||
(let
|
||||
((s2 (fd-set-domain s (var-name wx) xd-prime)))
|
||||
(cond
|
||||
((= s2 nil) nil)
|
||||
(:else
|
||||
(let
|
||||
((yd-prime (filter (fn (v) (>= v (fd-dom-min xd-prime))) yd)))
|
||||
(fd-set-domain s2 (var-name wy) yd-prime))))))))))
|
||||
(:else s)))))
|
||||
|
||||
(define
|
||||
fd-lte
|
||||
(fn
|
||||
(x y)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((c (fn (sp) (fd-lte-prop x y sp))))
|
||||
(let
|
||||
((s2 (fd-add-constraint s c)))
|
||||
(let
|
||||
((s3 (c s2)))
|
||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||
|
||||
;; --- fd-eq ---
|
||||
|
||||
(define
|
||||
fd-eq-prop
|
||||
(fn
|
||||
(x y s)
|
||||
(let
|
||||
((wx (mk-walk x s)) (wy (mk-walk y s)))
|
||||
(cond
|
||||
((and (number? wx) (number? wy))
|
||||
(cond ((= wx wy) s) (:else nil)))
|
||||
((and (number? wx) (is-var? wy))
|
||||
(let
|
||||
((yd (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((and (not (= yd nil)) (not (fd-dom-member? wx yd))) nil)
|
||||
(:else
|
||||
(let
|
||||
((s2 (mk-unify wy wx s)))
|
||||
(cond ((= s2 nil) nil) (:else s2)))))))
|
||||
((and (is-var? wx) (number? wy))
|
||||
(let
|
||||
((xd (fd-domain-of s (var-name wx))))
|
||||
(cond
|
||||
((and (not (= xd nil)) (not (fd-dom-member? wy xd))) nil)
|
||||
(:else
|
||||
(let
|
||||
((s2 (mk-unify wx wy s)))
|
||||
(cond ((= s2 nil) nil) (:else s2)))))))
|
||||
((and (is-var? wx) (is-var? wy))
|
||||
(let
|
||||
((xd (fd-domain-of s (var-name wx)))
|
||||
(yd (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((and (= xd nil) (= yd nil))
|
||||
(let
|
||||
((s2 (mk-unify wx wy s)))
|
||||
(cond ((= s2 nil) nil) (:else s2))))
|
||||
(:else
|
||||
(let
|
||||
((shared (cond ((= xd nil) yd) ((= yd nil) xd) (:else (fd-dom-intersect xd yd)))))
|
||||
(cond
|
||||
((fd-dom-empty? shared) nil)
|
||||
(:else
|
||||
(let
|
||||
((s2 (fd-set-domain s (var-name wx) shared)))
|
||||
(cond
|
||||
((= s2 nil) nil)
|
||||
(:else
|
||||
(let
|
||||
((s3 (fd-set-domain s2 (var-name wy) shared)))
|
||||
(cond
|
||||
((= s3 nil) nil)
|
||||
(:else (mk-unify wx wy s3))))))))))))))
|
||||
(:else s)))))
|
||||
|
||||
(define
|
||||
fd-eq
|
||||
(fn
|
||||
(x y)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((c (fn (sp) (fd-eq-prop x y sp))))
|
||||
(let
|
||||
((s2 (fd-add-constraint s c)))
|
||||
(let
|
||||
((s3 (c s2)))
|
||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||
|
||||
;; --- labelling ---
|
||||
|
||||
(define
|
||||
fd-try-each-value
|
||||
(fn
|
||||
(x dom s)
|
||||
(cond
|
||||
((empty? dom) mzero)
|
||||
(:else
|
||||
(let
|
||||
((s2 (mk-unify x (first dom) s)))
|
||||
(let
|
||||
((s3 (cond ((= s2 nil) nil) (:else (fd-fire-store s2)))))
|
||||
(let
|
||||
((this-stream (cond ((= s3 nil) mzero) (:else (unit s3))))
|
||||
(rest-stream (fd-try-each-value x (rest dom) s)))
|
||||
(mk-mplus this-stream rest-stream))))))))
|
||||
|
||||
(define
|
||||
fd-label-one
|
||||
(fn
|
||||
(x)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((wx (mk-walk x s)))
|
||||
(cond
|
||||
((number? wx) (unit s))
|
||||
((is-var? wx)
|
||||
(let
|
||||
((dom (fd-domain-of s (var-name wx))))
|
||||
(cond
|
||||
((= dom nil) mzero)
|
||||
(:else (fd-try-each-value wx dom s)))))
|
||||
(:else mzero))))))
|
||||
|
||||
(define
|
||||
fd-label
|
||||
(fn
|
||||
(vars)
|
||||
(cond
|
||||
((empty? vars) succeed)
|
||||
(:else (mk-conj (fd-label-one (first vars)) (fd-label (rest vars)))))))
|
||||
|
||||
;; --- fd-distinct (pairwise distinct via fd-neq) ---
|
||||
|
||||
(define
|
||||
fd-distinct-from-head
|
||||
(fn
|
||||
(x others)
|
||||
(cond
|
||||
((empty? others) succeed)
|
||||
(:else
|
||||
(mk-conj
|
||||
(fd-neq x (first others))
|
||||
(fd-distinct-from-head x (rest others)))))))
|
||||
|
||||
(define
|
||||
fd-distinct
|
||||
(fn
|
||||
(vars)
|
||||
(cond
|
||||
((empty? vars) succeed)
|
||||
((empty? (rest vars)) succeed)
|
||||
(:else
|
||||
(mk-conj
|
||||
(fd-distinct-from-head (first vars) (rest vars))
|
||||
(fd-distinct (rest vars)))))))
|
||||
|
||||
;; --- fd-plus (x + y = z, ground-cases propagator) ---
|
||||
|
||||
(define
|
||||
fd-bind-or-narrow
|
||||
(fn
|
||||
(w target s)
|
||||
(cond
|
||||
((number? w) (cond ((= w target) s) (:else nil)))
|
||||
((is-var? w)
|
||||
(let
|
||||
((wd (fd-domain-of s (var-name w))))
|
||||
(cond
|
||||
((and (not (= wd nil)) (not (fd-dom-member? target wd))) nil)
|
||||
(:else
|
||||
(let
|
||||
((s2 (mk-unify w target s)))
|
||||
(cond ((= s2 nil) nil) (:else s2)))))))
|
||||
(:else nil))))
|
||||
|
||||
(define
|
||||
fd-plus-prop
|
||||
(fn
|
||||
(x y z s)
|
||||
(let
|
||||
((wx (mk-walk x s)) (wy (mk-walk y s)) (wz (mk-walk z s)))
|
||||
(cond
|
||||
((and (number? wx) (number? wy) (number? wz))
|
||||
(cond ((= (+ wx wy) wz) s) (:else nil)))
|
||||
((and (number? wx) (number? wy))
|
||||
(fd-bind-or-narrow wz (+ wx wy) s))
|
||||
((and (number? wx) (number? wz))
|
||||
(fd-bind-or-narrow wy (- wz wx) s))
|
||||
((and (number? wy) (number? wz))
|
||||
(fd-bind-or-narrow wx (- wz wy) s))
|
||||
(:else s)))))
|
||||
|
||||
(define
|
||||
fd-plus
|
||||
(fn
|
||||
(x y z)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((c (fn (sp) (fd-plus-prop x y z sp))))
|
||||
(let
|
||||
((s2 (fd-add-constraint s c)))
|
||||
(let
|
||||
((s3 (c s2)))
|
||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||
|
||||
;; --- fd-times (x * y = z, ground-cases propagator) ---
|
||||
|
||||
(define
|
||||
fd-times-prop
|
||||
(fn
|
||||
(x y z s)
|
||||
(let
|
||||
((wx (mk-walk x s)) (wy (mk-walk y s)) (wz (mk-walk z s)))
|
||||
(cond
|
||||
((and (number? wx) (number? wy) (number? wz))
|
||||
(cond ((= (* wx wy) wz) s) (:else nil)))
|
||||
((and (number? wx) (number? wy))
|
||||
(fd-bind-or-narrow wz (* wx wy) s))
|
||||
((and (number? wx) (number? wz))
|
||||
(cond
|
||||
((= wx 0) (cond ((= wz 0) s) (:else nil)))
|
||||
((not (= (mod wz wx) 0)) nil)
|
||||
(:else (fd-bind-or-narrow wy (/ wz wx) s))))
|
||||
((and (number? wy) (number? wz))
|
||||
(cond
|
||||
((= wy 0) (cond ((= wz 0) s) (:else nil)))
|
||||
((not (= (mod wz wy) 0)) nil)
|
||||
(:else (fd-bind-or-narrow wx (/ wz wy) s))))
|
||||
(:else s)))))
|
||||
|
||||
(define
|
||||
fd-times
|
||||
(fn
|
||||
(x y z)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((c (fn (sp) (fd-times-prop x y z sp))))
|
||||
(let
|
||||
((s2 (fd-add-constraint s c)))
|
||||
(let
|
||||
((s3 (c s2)))
|
||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||
@@ -1,42 +0,0 @@
|
||||
;; lib/minikanren/conda.sx — Phase 5 piece A: `conda`, the soft-cut.
|
||||
;;
|
||||
;; (conda (g0 g ...) (h0 h ...) ...)
|
||||
;; — first clause whose head g0 produces ANY answer wins; ALL of g0's
|
||||
;; answers are then conj'd with the rest of that clause; later
|
||||
;; clauses are NOT tried.
|
||||
;; — differs from condu only in not wrapping g0 in onceo: condu
|
||||
;; commits to the SINGLE first answer, conda lets the head's full
|
||||
;; answer-set flow into the rest of the clause.
|
||||
;; (Reasoned Schemer chapter 10; Byrd 5.3.)
|
||||
|
||||
(define
|
||||
conda-try
|
||||
(fn
|
||||
(clauses s)
|
||||
(cond
|
||||
((empty? clauses) mzero)
|
||||
(:else
|
||||
(let
|
||||
((cl (first clauses)))
|
||||
(let
|
||||
((head-goal (first cl)) (rest-goals (rest cl)))
|
||||
(let
|
||||
((peek (stream-take 1 (head-goal s))))
|
||||
(if
|
||||
(empty? peek)
|
||||
(conda-try (rest clauses) s)
|
||||
(mk-bind (head-goal s) (mk-conj-list rest-goals))))))))))
|
||||
|
||||
(defmacro
|
||||
conda
|
||||
(&rest clauses)
|
||||
(quasiquote
|
||||
(fn
|
||||
(s)
|
||||
(conda-try
|
||||
(list
|
||||
(splice-unquote
|
||||
(map
|
||||
(fn (cl) (quasiquote (list (splice-unquote cl))))
|
||||
clauses)))
|
||||
s))))
|
||||
@@ -1,39 +0,0 @@
|
||||
;; lib/minikanren/conde.sx — Phase 2 piece C: `conde`, the canonical
|
||||
;; miniKanren and-or form, with implicit Zzz inverse-eta delay so recursive
|
||||
;; relations like appendo terminate.
|
||||
;;
|
||||
;; (conde (g1a g1b ...) (g2a g2b ...) ...)
|
||||
;; ≡ (mk-disj (Zzz (mk-conj g1a g1b ...))
|
||||
;; (Zzz (mk-conj g2a g2b ...)) ...)
|
||||
;;
|
||||
;; `Zzz g` wraps a goal expression in (fn (S) (fn () (g S))) so that
|
||||
;; `g`'s body isn't constructed until the surrounding fn is applied to a
|
||||
;; substitution AND the returned thunk is forced. This is what gives
|
||||
;; miniKanren its laziness — recursive goal definitions can be `(conde
|
||||
;; ... (... (recur ...)))` without infinite descent at construction time.
|
||||
;;
|
||||
;; Hygiene: the substitution parameter is gensym'd so that user goal
|
||||
;; expressions which themselves bind `s` (e.g. `(appendo l s ls)`) keep
|
||||
;; their lexical `s` and don't accidentally reference the wrapper's
|
||||
;; substitution. Without gensym, miniKanren relations that follow the
|
||||
;; common (l s ls) parameter convention are silently miscompiled.
|
||||
|
||||
(defmacro
|
||||
Zzz
|
||||
(g)
|
||||
(let
|
||||
((s-sym (gensym "zzz-s-")))
|
||||
(quasiquote
|
||||
(fn ((unquote s-sym)) (fn () ((unquote g) (unquote s-sym)))))))
|
||||
|
||||
(defmacro
|
||||
conde
|
||||
(&rest clauses)
|
||||
(quasiquote
|
||||
(mk-disj
|
||||
(splice-unquote
|
||||
(map
|
||||
(fn
|
||||
(clause)
|
||||
(quasiquote (Zzz (mk-conj (splice-unquote clause)))))
|
||||
clauses)))))
|
||||
@@ -1,58 +0,0 @@
|
||||
;; lib/minikanren/condu.sx — Phase 2 piece D: `condu` and `onceo`.
|
||||
;;
|
||||
;; Both are commitment forms (no backtracking into discarded options):
|
||||
;;
|
||||
;; (onceo g) — succeeds at most once: takes the first answer
|
||||
;; stream-take produces from (g s).
|
||||
;;
|
||||
;; (condu (g0 g ...) (h0 h ...) ...)
|
||||
;; — first clause whose head goal succeeds wins; only
|
||||
;; the first answer of the head is propagated to the
|
||||
;; rest of that clause; later clauses are not tried.
|
||||
;; (Reasoned Schemer chapter 10; Byrd 5.4.)
|
||||
|
||||
(define
|
||||
onceo
|
||||
(fn
|
||||
(g)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((peek (stream-take 1 (g s))))
|
||||
(if (empty? peek) mzero (unit (first peek)))))))
|
||||
|
||||
;; condu-try — runtime walker over a list of clauses (each clause a list of
|
||||
;; goals). Forces the head with stream-take 1; if head fails, recurse to
|
||||
;; the next clause; if head succeeds, commits its single answer through
|
||||
;; the rest of the clause.
|
||||
(define
|
||||
condu-try
|
||||
(fn
|
||||
(clauses s)
|
||||
(cond
|
||||
((empty? clauses) mzero)
|
||||
(:else
|
||||
(let
|
||||
((cl (first clauses)))
|
||||
(let
|
||||
((head-goal (first cl)) (rest-goals (rest cl)))
|
||||
(let
|
||||
((peek (stream-take 1 (head-goal s))))
|
||||
(if
|
||||
(empty? peek)
|
||||
(condu-try (rest clauses) s)
|
||||
((mk-conj-list rest-goals) (first peek))))))))))
|
||||
|
||||
(defmacro
|
||||
condu
|
||||
(&rest clauses)
|
||||
(quasiquote
|
||||
(fn
|
||||
(s)
|
||||
(condu-try
|
||||
(list
|
||||
(splice-unquote
|
||||
(map
|
||||
(fn (cl) (quasiquote (list (splice-unquote cl))))
|
||||
clauses)))
|
||||
s))))
|
||||
@@ -1,25 +0,0 @@
|
||||
;; lib/minikanren/defrel.sx — Prolog-style defrel macro.
|
||||
;;
|
||||
;; (defrel (NAME ARG1 ARG2 ...)
|
||||
;; (CLAUSE1 ...)
|
||||
;; (CLAUSE2 ...)
|
||||
;; ...)
|
||||
;;
|
||||
;; expands to
|
||||
;;
|
||||
;; (define NAME (fn (ARG1 ARG2 ...) (conde (CLAUSE1 ...) (CLAUSE2 ...))))
|
||||
;;
|
||||
;; This puts each clause's goals immediately after the head, mirroring
|
||||
;; Prolog's `name(Args) :- goals.` shape. Clauses are conde-conjoined
|
||||
;; goals — `Zzz`-wrapping is automatic via `conde`, so recursive
|
||||
;; relations terminate on partial answers.
|
||||
|
||||
(defmacro
|
||||
defrel
|
||||
(head &rest clauses)
|
||||
(let
|
||||
((name (first head)) (args (rest head)))
|
||||
(list
|
||||
(quote define)
|
||||
name
|
||||
(list (quote fn) args (cons (quote conde) clauses)))))
|
||||
@@ -1,25 +0,0 @@
|
||||
;; lib/minikanren/fd.sx — Phase 6 piece A: minimal finite-domain helpers.
|
||||
;;
|
||||
;; A full CLP(FD) engine (arc consistency, native integer domains, fd-plus
|
||||
;; etc.) is Phase 6 proper. For now we expose two small relations layered
|
||||
;; on the existing list machinery — they're sufficient for permutation
|
||||
;; puzzles, the N-queens-style core of constraint solving:
|
||||
;;
|
||||
;; (ino x dom) — x is a member of dom (alias for membero with the
|
||||
;; constraint-store-friendly argument order).
|
||||
;; (all-distincto l) — all elements of l are pairwise distinct.
|
||||
;;
|
||||
;; all-distincto uses nafc + membero on the tail — it requires the head
|
||||
;; element of each recursive step to be ground enough for membero to be
|
||||
;; finitary, so order matters: prefer (in x dom) goals BEFORE
|
||||
;; (all-distincto (list x ...)) so values get committed first.
|
||||
|
||||
(define ino (fn (x dom) (membero x dom)))
|
||||
|
||||
(define
|
||||
all-distincto
|
||||
(fn
|
||||
(l)
|
||||
(conde
|
||||
((nullo l))
|
||||
((fresh (a d) (conso a d l) (nafc (membero a d)) (all-distincto d))))))
|
||||
@@ -1,23 +0,0 @@
|
||||
;; lib/minikanren/fresh.sx — Phase 2 piece B: `fresh` for introducing
|
||||
;; logic variables inside a goal body.
|
||||
;;
|
||||
;; (fresh (x y z) goal1 goal2 ...)
|
||||
;; ≡ (let ((x (make-var)) (y (make-var)) (z (make-var)))
|
||||
;; (mk-conj goal1 goal2 ...))
|
||||
;;
|
||||
;; A macro rather than a function so user-named vars are real lexical
|
||||
;; bindings — which is also what miniKanren convention expects.
|
||||
;; The empty-vars form (fresh () goal ...) is just a goal grouping.
|
||||
|
||||
(defmacro
|
||||
fresh
|
||||
(vars &rest goals)
|
||||
(quasiquote
|
||||
(let
|
||||
(unquote (map (fn (v) (list v (list (quote make-var)))) vars))
|
||||
(mk-conj (splice-unquote goals)))))
|
||||
|
||||
;; call-fresh — functional alternative for code that builds goals
|
||||
;; programmatically:
|
||||
;; ((call-fresh (fn (x) (== x 7))) empty-s) → ({:_.N 7})
|
||||
(define call-fresh (fn (f) (fn (s) ((f (make-var)) s))))
|
||||
@@ -1,58 +0,0 @@
|
||||
;; lib/minikanren/goals.sx — Phase 2 piece B: core goals.
|
||||
;;
|
||||
;; A goal is a function (fn (s) → stream-of-substitutions).
|
||||
;; Goals built here:
|
||||
;; succeed — always returns (unit s)
|
||||
;; fail — always returns mzero
|
||||
;; == — unifies two terms; succeeds with a singleton, else fails
|
||||
;; ==-check — opt-in occurs-checked equality
|
||||
;; conj2 / mk-conj — sequential conjunction of goals
|
||||
;; disj2 / mk-disj — interleaved disjunction of goals (raw — `conde` adds
|
||||
;; the implicit-conj-per-clause sugar in a later commit)
|
||||
|
||||
(define succeed (fn (s) (unit s)))
|
||||
|
||||
(define fail (fn (s) mzero))
|
||||
|
||||
(define
|
||||
==
|
||||
(fn
|
||||
(u v)
|
||||
(fn
|
||||
(s)
|
||||
(let ((s2 (mk-unify u v s))) (if (= s2 nil) mzero (unit s2))))))
|
||||
|
||||
(define
|
||||
==-check
|
||||
(fn
|
||||
(u v)
|
||||
(fn
|
||||
(s)
|
||||
(let ((s2 (mk-unify-check u v s))) (if (= s2 nil) mzero (unit s2))))))
|
||||
|
||||
(define conj2 (fn (g1 g2) (fn (s) (mk-bind (g1 s) g2))))
|
||||
|
||||
(define disj2 (fn (g1 g2) (fn (s) (mk-mplus (g1 s) (g2 s)))))
|
||||
|
||||
;; Fold goals in a list. (mk-conj-list ()) ≡ succeed; (mk-disj-list ()) ≡ fail.
|
||||
(define
|
||||
mk-conj-list
|
||||
(fn
|
||||
(gs)
|
||||
(cond
|
||||
((empty? gs) succeed)
|
||||
((empty? (rest gs)) (first gs))
|
||||
(:else (conj2 (first gs) (mk-conj-list (rest gs)))))))
|
||||
|
||||
(define
|
||||
mk-disj-list
|
||||
(fn
|
||||
(gs)
|
||||
(cond
|
||||
((empty? gs) fail)
|
||||
((empty? (rest gs)) (first gs))
|
||||
(:else (disj2 (first gs) (mk-disj-list (rest gs)))))))
|
||||
|
||||
(define mk-conj (fn (&rest gs) (mk-conj-list gs)))
|
||||
|
||||
(define mk-disj (fn (&rest gs) (mk-disj-list gs)))
|
||||
@@ -1,151 +0,0 @@
|
||||
;; lib/minikanren/intarith.sx — fast integer arithmetic via project.
|
||||
;;
|
||||
;; These are ground-only escapes into host arithmetic. They run at native
|
||||
;; speed (host ints) but require their arguments to walk to actual numbers
|
||||
;; — they are not relational the way `pluso` (Peano) is. Use them when
|
||||
;; the puzzle size makes Peano impractical.
|
||||
;;
|
||||
;; Naming: `-i` suffix marks "integer-only" goals.
|
||||
|
||||
(define
|
||||
pluso-i
|
||||
(fn
|
||||
(a b c)
|
||||
(project
|
||||
(a b)
|
||||
(if (and (number? a) (number? b)) (== c (+ a b)) fail))))
|
||||
|
||||
(define
|
||||
minuso-i
|
||||
(fn
|
||||
(a b c)
|
||||
(project
|
||||
(a b)
|
||||
(if (and (number? a) (number? b)) (== c (- a b)) fail))))
|
||||
|
||||
(define
|
||||
*o-i
|
||||
(fn
|
||||
(a b c)
|
||||
(project
|
||||
(a b)
|
||||
(if (and (number? a) (number? b)) (== c (* a b)) fail))))
|
||||
|
||||
(define
|
||||
lto-i
|
||||
(fn
|
||||
(a b)
|
||||
(project
|
||||
(a b)
|
||||
(if (and (number? a) (and (number? b) (< a b))) succeed fail))))
|
||||
|
||||
(define
|
||||
lteo-i
|
||||
(fn
|
||||
(a b)
|
||||
(project
|
||||
(a b)
|
||||
(if (and (number? a) (and (number? b) (<= a b))) succeed fail))))
|
||||
|
||||
(define
|
||||
neqo-i
|
||||
(fn
|
||||
(a b)
|
||||
(project
|
||||
(a b)
|
||||
(if (and (number? a) (and (number? b) (not (= a b)))) succeed fail))))
|
||||
|
||||
(define numbero (fn (x) (project (x) (if (number? x) succeed fail))))
|
||||
|
||||
(define stringo (fn (x) (project (x) (if (string? x) succeed fail))))
|
||||
|
||||
(define symbolo (fn (x) (project (x) (if (symbol? x) succeed fail))))
|
||||
|
||||
(define
|
||||
even-i
|
||||
(fn (n) (project (n) (if (and (number? n) (even? n)) succeed fail))))
|
||||
|
||||
(define
|
||||
odd-i
|
||||
(fn (n) (project (n) (if (and (number? n) (odd? n)) succeed fail))))
|
||||
|
||||
(define
|
||||
sortedo
|
||||
(fn
|
||||
(l)
|
||||
(conde
|
||||
((nullo l))
|
||||
((fresh (a) (== l (list a))))
|
||||
((fresh (a b rest mid) (conso a mid l) (conso b rest mid) (lteo-i a b) (sortedo mid))))))
|
||||
|
||||
(define
|
||||
mino
|
||||
(fn
|
||||
(l m)
|
||||
(conde
|
||||
((fresh (a) (== l (list a)) (== m a)))
|
||||
((fresh (a d rest-min) (conso a d l) (mino d rest-min) (conde ((lteo-i a rest-min) (== m a)) ((lto-i rest-min a) (== m rest-min))))))))
|
||||
|
||||
(define
|
||||
maxo
|
||||
(fn
|
||||
(l m)
|
||||
(conde
|
||||
((fresh (a) (== l (list a)) (== m a)))
|
||||
((fresh (a d rest-max) (conso a d l) (maxo d rest-max) (conde ((lteo-i rest-max a) (== m a)) ((lto-i a rest-max) (== m rest-max))))))))
|
||||
|
||||
(define
|
||||
sumo
|
||||
(fn
|
||||
(l total)
|
||||
(conde
|
||||
((nullo l) (== total 0))
|
||||
((fresh (a d rest-sum) (conso a d l) (sumo d rest-sum) (pluso-i a rest-sum total))))))
|
||||
|
||||
(define
|
||||
producto
|
||||
(fn
|
||||
(l total)
|
||||
(conde
|
||||
((nullo l) (== total 1))
|
||||
((fresh (a d rest-prod) (conso a d l) (producto d rest-prod) (*o-i a rest-prod total))))))
|
||||
|
||||
(define
|
||||
lengtho-i
|
||||
(fn
|
||||
(l n)
|
||||
(conde
|
||||
((nullo l) (== n 0))
|
||||
((fresh (a d n-1) (conso a d l) (lengtho-i d n-1) (pluso-i 1 n-1 n))))))
|
||||
|
||||
(define
|
||||
enumerate-from-i
|
||||
(fn
|
||||
(start l result)
|
||||
(conde
|
||||
((nullo l) (nullo result))
|
||||
((fresh (a d r-rest start-prime) (conso a d l) (conso (list start a) r-rest result) (pluso-i 1 start start-prime) (enumerate-from-i start-prime d r-rest))))))
|
||||
|
||||
(define enumerate-i (fn (l result) (enumerate-from-i 0 l result)))
|
||||
|
||||
(define
|
||||
counto
|
||||
(fn
|
||||
(x l n)
|
||||
(conde
|
||||
((nullo l) (== n 0))
|
||||
((fresh (a d n-rest) (conso a d l) (conde ((== a x) (counto x d n-rest) (pluso-i 1 n-rest n)) ((nafc (== a x)) (counto x d n))))))))
|
||||
|
||||
(define
|
||||
mk-arith-prog
|
||||
(fn
|
||||
(start step len)
|
||||
(cond
|
||||
((= len 0) (list))
|
||||
(:else (cons start (mk-arith-prog (+ start step) step (- len 1)))))))
|
||||
|
||||
(define
|
||||
arith-progo
|
||||
(fn
|
||||
(start step len result)
|
||||
(project (start step len) (== result (mk-arith-prog start step len)))))
|
||||
@@ -1,76 +0,0 @@
|
||||
;; lib/minikanren/matche.sx — Phase 5 piece D: pattern matching over terms.
|
||||
;;
|
||||
;; (matche TARGET
|
||||
;; (PATTERN1 g1 g2 ...)
|
||||
;; (PATTERN2 g1 ...)
|
||||
;; ...)
|
||||
;;
|
||||
;; Pattern grammar:
|
||||
;; _ wildcard — fresh anonymous var
|
||||
;; x plain symbol — fresh var, bind by name
|
||||
;; ATOM literal (number, string, boolean) — must equal
|
||||
;; :keyword keyword literal — emitted bare (keywords self-evaluate
|
||||
;; to their string name in SX, so quoting them changes
|
||||
;; their type from string to keyword)
|
||||
;; () empty list — must equal
|
||||
;; (p1 p2 ... pn) list pattern — recurse on each element
|
||||
;;
|
||||
;; The macro expands to a `conde` whose clauses are
|
||||
;; `((fresh (vars-in-pat) (== target pat-expr) body...))`.
|
||||
;;
|
||||
;; Repeated symbol names within a pattern produce the same fresh var, so
|
||||
;; they unify by `==`. Fixed-length list patterns only — head/tail
|
||||
;; destructuring uses `(fresh (a d) (conso a d target) body)` directly.
|
||||
;;
|
||||
;; Note: the macro builds the expansion via `cons` / `list` rather than a
|
||||
;; quasiquote — quasiquote does not recurse into nested lambda bodies in
|
||||
;; SX, so `\`(matche-clause (quote ,target) cl)` left literal
|
||||
;; `(unquote target)` in the output.
|
||||
|
||||
(define matche-symbol-var? (fn (s) (symbol? s)))
|
||||
|
||||
(define
|
||||
matche-collect-vars-acc
|
||||
(fn
|
||||
(pat acc)
|
||||
(cond
|
||||
((matche-symbol-var? pat)
|
||||
(if (some (fn (s) (= s pat)) acc) acc (append acc (list pat))))
|
||||
((and (list? pat) (not (empty? pat)))
|
||||
(reduce (fn (a p) (matche-collect-vars-acc p a)) acc pat))
|
||||
(:else acc))))
|
||||
|
||||
(define
|
||||
matche-collect-vars
|
||||
(fn (pat) (matche-collect-vars-acc pat (list))))
|
||||
|
||||
(define
|
||||
matche-pattern->expr
|
||||
(fn
|
||||
(pat)
|
||||
(cond
|
||||
((matche-symbol-var? pat) pat)
|
||||
((and (list? pat) (empty? pat)) (list (quote list)))
|
||||
((list? pat) (cons (quote list) (map matche-pattern->expr pat)))
|
||||
((keyword? pat) pat)
|
||||
(:else (list (quote quote) pat)))))
|
||||
|
||||
(define
|
||||
matche-clause
|
||||
(fn
|
||||
(target cl)
|
||||
(let
|
||||
((pat (first cl)) (body (rest cl)))
|
||||
(let
|
||||
((vars (matche-collect-vars pat)))
|
||||
(let
|
||||
((pat-expr (matche-pattern->expr pat)))
|
||||
(list
|
||||
(cons
|
||||
(quote fresh)
|
||||
(cons vars (cons (list (quote ==) target pat-expr) body)))))))))
|
||||
|
||||
(defmacro
|
||||
matche
|
||||
(target &rest clauses)
|
||||
(cons (quote conde) (map (fn (cl) (matche-clause target cl)) clauses)))
|
||||
@@ -1,24 +0,0 @@
|
||||
;; lib/minikanren/nafc.sx — Phase 5 piece C: negation as finite failure.
|
||||
;;
|
||||
;; (nafc g)
|
||||
;; succeeds (yields the input substitution) if g has zero answers
|
||||
;; against that substitution; fails (mzero) if g has at least one.
|
||||
;;
|
||||
;; Caveat: `nafc` is unsound under the open-world assumption. It only
|
||||
;; makes sense for goals over fully-ground terms, or with the explicit
|
||||
;; understanding that adding more facts could flip the answer. Use
|
||||
;; `(project (...) ...)` to ensure the relevant vars are ground first.
|
||||
;;
|
||||
;; Caveat 2: stream-take forces g for at least one answer; if g is
|
||||
;; infinitely-ground (say, a divergent search over an unbound list),
|
||||
;; nafc itself will diverge. Standard miniKanren limitation.
|
||||
|
||||
(define
|
||||
nafc
|
||||
(fn
|
||||
(g)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((peek (stream-take 1 (g s))))
|
||||
(if (empty? peek) (unit s) mzero)))))
|
||||
@@ -1,51 +0,0 @@
|
||||
;; lib/minikanren/peano.sx — Peano-encoded natural-number relations.
|
||||
;;
|
||||
;; Same encoding as `lengtho`: zero is the keyword `:z`; successors are
|
||||
;; `(:s n)`. So 3 = `(:s (:s (:s :z)))`. `(:z)` and `(:s ...)` are normal
|
||||
;; SX values that unify positionally — no special primitives needed.
|
||||
;;
|
||||
;; Peano arithmetic is the canonical miniKanren way to test addition /
|
||||
;; multiplication / less-than relationally without an FD constraint store.
|
||||
;; (CLP(FD) integers come in Phase 6.)
|
||||
|
||||
(define zeroo (fn (n) (== n :z)))
|
||||
|
||||
(define succ-of (fn (n m) (== m (list :s n))))
|
||||
|
||||
(define
|
||||
pluso
|
||||
(fn
|
||||
(a b c)
|
||||
(conde
|
||||
((== a :z) (== b c))
|
||||
((fresh (a-1 c-1) (== a (list :s a-1)) (== c (list :s c-1)) (pluso a-1 b c-1))))))
|
||||
|
||||
(define minuso (fn (a b c) (pluso b c a)))
|
||||
|
||||
(define lteo (fn (a b) (fresh (k) (pluso a k b))))
|
||||
|
||||
(define lto (fn (a b) (fresh (sa) (succ-of a sa) (lteo sa b))))
|
||||
|
||||
(define
|
||||
eveno
|
||||
(fn
|
||||
(n)
|
||||
(conde
|
||||
((== n :z))
|
||||
((fresh (m) (== n (list :s (list :s m))) (eveno m))))))
|
||||
|
||||
(define
|
||||
oddo
|
||||
(fn
|
||||
(n)
|
||||
(conde
|
||||
((== n (list :s :z)))
|
||||
((fresh (m) (== n (list :s (list :s m))) (oddo m))))))
|
||||
|
||||
(define
|
||||
*o
|
||||
(fn
|
||||
(a b c)
|
||||
(conde
|
||||
((== a :z) (== c :z))
|
||||
((fresh (a-1 ab-1) (== a (list :s a-1)) (*o a-1 b ab-1) (pluso b ab-1 c))))))
|
||||
@@ -1,25 +0,0 @@
|
||||
;; lib/minikanren/project.sx — Phase 5 piece B: `project`.
|
||||
;;
|
||||
;; (project (x y) g1 g2 ...)
|
||||
;; — rebinds each named var to (mk-walk* var s) within the body's
|
||||
;; lexical scope, then runs the conjunction of the body goals on
|
||||
;; the same substitution. Use to escape into regular SX (arithmetic,
|
||||
;; string ops, host predicates) when you need a ground value.
|
||||
;;
|
||||
;; If any of the projected vars is still unbound at this point, the body
|
||||
;; sees the raw `(:var NAME)` term — that is intentional and lets you
|
||||
;; mix project with `(== ground? var)` patterns or with conda guards.
|
||||
;;
|
||||
;; Hygiene: substitution parameter is gensym'd so it doesn't capture user
|
||||
;; vars (`s` is a popular relation parameter name).
|
||||
|
||||
(defmacro
|
||||
project
|
||||
(vars &rest goals)
|
||||
(let
|
||||
((s-sym (gensym "proj-s-")))
|
||||
(quasiquote
|
||||
(fn
|
||||
((unquote s-sym))
|
||||
((let (unquote (map (fn (v) (list v (list (quote mk-walk*) v s-sym))) vars)) (mk-conj (splice-unquote goals)))
|
||||
(unquote s-sym))))))
|
||||
@@ -1,67 +0,0 @@
|
||||
;; lib/minikanren/queens.sx — N-queens via ino + all-distincto + project.
|
||||
;;
|
||||
;; Encoding: q = (c1 c2 ... cn) where ci is the column of the queen in
|
||||
;; row i. Each ci ∈ {1..n}; all distinct (no two queens share a column);
|
||||
;; no two queens on the same diagonal (|ci - cj| ≠ |i - j| for i ≠ j).
|
||||
;;
|
||||
;; The diagonal check uses `project` to escape into host arithmetic
|
||||
;; once both column values are ground.
|
||||
|
||||
(define
|
||||
safe-diag
|
||||
(fn
|
||||
(a b dist)
|
||||
(project (a b) (if (= (abs (- a b)) dist) fail succeed))))
|
||||
|
||||
(define
|
||||
safe-cell-vs-rest
|
||||
(fn
|
||||
(c c-row others next-row)
|
||||
(cond
|
||||
((empty? others) succeed)
|
||||
(:else
|
||||
(mk-conj
|
||||
(safe-diag c (first others) (- next-row c-row))
|
||||
(safe-cell-vs-rest c c-row (rest others) (+ next-row 1)))))))
|
||||
|
||||
(define
|
||||
all-cells-safe
|
||||
(fn
|
||||
(cols start-row)
|
||||
(cond
|
||||
((empty? cols) succeed)
|
||||
(:else
|
||||
(mk-conj
|
||||
(safe-cell-vs-rest
|
||||
(first cols)
|
||||
start-row
|
||||
(rest cols)
|
||||
(+ start-row 1))
|
||||
(all-cells-safe (rest cols) (+ start-row 1)))))))
|
||||
|
||||
(define
|
||||
range-1-to-n
|
||||
(fn
|
||||
(n)
|
||||
(cond
|
||||
((= n 0) (list))
|
||||
(:else (append (range-1-to-n (- n 1)) (list n))))))
|
||||
|
||||
(define
|
||||
ino-each
|
||||
(fn
|
||||
(cols dom)
|
||||
(cond
|
||||
((empty? cols) succeed)
|
||||
(:else (mk-conj (ino (first cols) dom) (ino-each (rest cols) dom))))))
|
||||
|
||||
(define
|
||||
queens-cols
|
||||
(fn
|
||||
(cols n)
|
||||
(let
|
||||
((dom (range-1-to-n n)))
|
||||
(mk-conj
|
||||
(ino-each cols dom)
|
||||
(all-distincto cols)
|
||||
(all-cells-safe cols 1)))))
|
||||
@@ -1,361 +0,0 @@
|
||||
;; lib/minikanren/relations.sx — Phase 4 standard relations.
|
||||
;;
|
||||
;; Programs use native SX lists as data. Relations decompose lists via the
|
||||
;; tagged cons-cell shape `(:cons h t)` because SX has no improper pairs;
|
||||
;; the unifier treats `(:cons h t)` and the native list `(h . t)` as
|
||||
;; equivalent, and `mk-walk*` flattens cons cells back to flat lists for
|
||||
;; reification.
|
||||
|
||||
;; --- pair / list shape relations ---
|
||||
|
||||
(define nullo (fn (l) (== l (list))))
|
||||
|
||||
(define pairo (fn (p) (fresh (a d) (== p (mk-cons a d)))))
|
||||
|
||||
(define caro (fn (p a) (fresh (d) (== p (mk-cons a d)))))
|
||||
|
||||
(define cdro (fn (p d) (fresh (a) (== p (mk-cons a d)))))
|
||||
|
||||
(define conso (fn (a d p) (== p (mk-cons a d))))
|
||||
|
||||
(define firsto caro)
|
||||
(define resto cdro)
|
||||
|
||||
(define
|
||||
listo
|
||||
(fn (l) (conde ((nullo l)) ((fresh (a d) (conso a d l) (listo d))))))
|
||||
|
||||
;; --- appendo: the canary ---
|
||||
;;
|
||||
;; (appendo l s ls) — `ls` is the concatenation of `l` and `s`.
|
||||
;; Runs forwards (l, s known → ls), backwards (ls known → all (l, s) pairs),
|
||||
;; and bidirectionally (mix of bound + unbound).
|
||||
|
||||
(define
|
||||
appendo
|
||||
(fn
|
||||
(l s ls)
|
||||
(conde
|
||||
((nullo l) (== s ls))
|
||||
((fresh (a d res) (conso a d l) (conso a res ls) (appendo d s res))))))
|
||||
|
||||
;; --- membero ---
|
||||
;; (membero x l) — x appears (at least once) in l.
|
||||
|
||||
(define
|
||||
appendo3
|
||||
(fn
|
||||
(l1 l2 l3 result)
|
||||
(fresh (l12) (appendo l1 l2 l12) (appendo l12 l3 result))))
|
||||
|
||||
(define
|
||||
partitiono
|
||||
(fn
|
||||
(pred l yes no)
|
||||
(conde
|
||||
((nullo l) (nullo yes) (nullo no))
|
||||
((fresh (a d y-rest n-rest) (conso a d l) (conde ((pred a) (conso a y-rest yes) (== no n-rest) (partitiono pred d y-rest n-rest)) ((nafc (pred a)) (== yes y-rest) (conso a n-rest no) (partitiono pred d y-rest n-rest))))))))
|
||||
|
||||
(define
|
||||
foldr-o
|
||||
(fn
|
||||
(rel l acc result)
|
||||
(conde
|
||||
((nullo l) (== result acc))
|
||||
((fresh (a d r-rest) (conso a d l) (foldr-o rel d acc r-rest) (rel a r-rest result))))))
|
||||
|
||||
(define
|
||||
foldl-o
|
||||
(fn
|
||||
(rel l acc result)
|
||||
(conde
|
||||
((nullo l) (== result acc))
|
||||
((fresh (a d new-acc) (conso a d l) (rel acc a new-acc) (foldl-o rel d new-acc result))))))
|
||||
|
||||
(define
|
||||
flat-mapo
|
||||
(fn
|
||||
(rel l result)
|
||||
(conde
|
||||
((nullo l) (nullo result))
|
||||
((fresh (a d a-result rest-result) (conso a d l) (rel a a-result) (flat-mapo rel d rest-result) (appendo a-result rest-result result))))))
|
||||
|
||||
(define
|
||||
nub-o
|
||||
(fn
|
||||
(l result)
|
||||
(conde
|
||||
((nullo l) (nullo result))
|
||||
((fresh (a d r-rest) (conso a d l) (conde ((membero a d) (nub-o d result)) ((nafc (membero a d)) (conso a r-rest result) (nub-o d r-rest))))))))
|
||||
|
||||
|
||||
(define
|
||||
take-while-o
|
||||
(fn
|
||||
(pred l result)
|
||||
(conde
|
||||
((nullo l) (nullo result))
|
||||
((fresh (a d r-rest) (conso a d l) (conde ((pred a) (conso a r-rest result) (take-while-o pred d r-rest)) ((nafc (pred a)) (== result (list)))))))))
|
||||
|
||||
(define
|
||||
drop-while-o
|
||||
(fn
|
||||
(pred l result)
|
||||
(conde
|
||||
((nullo l) (nullo result))
|
||||
((fresh (a d) (conso a d l) (conde ((pred a) (drop-while-o pred d result)) ((nafc (pred a)) (== result l))))))))
|
||||
|
||||
(define
|
||||
membero
|
||||
(fn
|
||||
(x l)
|
||||
(conde
|
||||
((fresh (d) (conso x d l)))
|
||||
((fresh (a d) (conso a d l) (membero x d))))))
|
||||
|
||||
(define
|
||||
not-membero
|
||||
(fn
|
||||
(x l)
|
||||
(conde
|
||||
((nullo l))
|
||||
((fresh (a d) (conso a d l) (nafc (== a x)) (not-membero x d))))))
|
||||
|
||||
(define
|
||||
subseto
|
||||
(fn
|
||||
(l1 l2)
|
||||
(conde
|
||||
((nullo l1))
|
||||
((fresh (a d) (conso a d l1) (membero a l2) (subseto d l2))))))
|
||||
|
||||
(define
|
||||
reverseo
|
||||
(fn
|
||||
(l r)
|
||||
(conde
|
||||
((nullo l) (nullo r))
|
||||
((fresh (a d res-rev) (conso a d l) (reverseo d res-rev) (appendo res-rev (list a) r))))))
|
||||
|
||||
(define
|
||||
rev-acco
|
||||
(fn
|
||||
(l acc result)
|
||||
(conde
|
||||
((nullo l) (== result acc))
|
||||
((fresh (a d acc-prime) (conso a d l) (conso a acc acc-prime) (rev-acco d acc-prime result))))))
|
||||
|
||||
(define rev-2o (fn (l result) (rev-acco l (list) result)))
|
||||
|
||||
(define palindromeo (fn (l) (fresh (rev) (reverseo l rev) (== l rev))))
|
||||
|
||||
(define prefixo (fn (p l) (fresh (rest) (appendo p rest l))))
|
||||
|
||||
(define suffixo (fn (s l) (fresh (front) (appendo front s l))))
|
||||
|
||||
(define
|
||||
subo
|
||||
(fn
|
||||
(s l)
|
||||
(fresh
|
||||
(front-and-s back front)
|
||||
(appendo front-and-s back l)
|
||||
(appendo front s front-and-s))))
|
||||
|
||||
(define
|
||||
selecto
|
||||
(fn
|
||||
(x rest l)
|
||||
(conde
|
||||
((conso x rest l))
|
||||
((fresh (a d r) (conso a d l) (conso a r rest) (selecto x r d))))))
|
||||
|
||||
(define
|
||||
lengtho
|
||||
(fn
|
||||
(l n)
|
||||
(conde
|
||||
((nullo l) (== n :z))
|
||||
((fresh (a d n-1) (conso a d l) (== n (list :s n-1)) (lengtho d n-1))))))
|
||||
|
||||
(define
|
||||
inserto
|
||||
(fn
|
||||
(a l p)
|
||||
(conde
|
||||
((conso a l p))
|
||||
((fresh (h t pt) (conso h t l) (conso h pt p) (inserto a t pt))))))
|
||||
|
||||
(define
|
||||
permuteo
|
||||
(fn
|
||||
(l p)
|
||||
(conde
|
||||
((nullo l) (nullo p))
|
||||
((fresh (a d perm-d) (conso a d l) (permuteo d perm-d) (inserto a perm-d p))))))
|
||||
|
||||
(define
|
||||
flatteno
|
||||
(fn
|
||||
(tree flat)
|
||||
(conde
|
||||
((nullo tree) (nullo flat))
|
||||
((pairo tree)
|
||||
(fresh
|
||||
(h t hf tf)
|
||||
(conso h t tree)
|
||||
(flatteno h hf)
|
||||
(flatteno t tf)
|
||||
(appendo hf tf flat)))
|
||||
((nafc (nullo tree)) (nafc (pairo tree)) (== flat (list tree))))))
|
||||
|
||||
(define
|
||||
rembero
|
||||
(fn
|
||||
(x l out)
|
||||
(conde
|
||||
((nullo l) (nullo out))
|
||||
((fresh (a d) (conso a d l) (== a x) (== out d)))
|
||||
((fresh (a d res) (conso a d l) (nafc (== a x)) (conso a res out) (rembero x d res))))))
|
||||
|
||||
(define
|
||||
removeo-allo
|
||||
(fn
|
||||
(x l result)
|
||||
(conde
|
||||
((nullo l) (nullo result))
|
||||
((fresh (a d) (conso a d l) (== a x) (removeo-allo x d result)))
|
||||
((fresh (a d r-rest) (conso a d l) (nafc (== a x)) (conso a r-rest result) (removeo-allo x d r-rest))))))
|
||||
|
||||
(define
|
||||
assoco
|
||||
(fn
|
||||
(key pairs val)
|
||||
(fresh
|
||||
(rest)
|
||||
(conde
|
||||
((conso (list key val) rest pairs))
|
||||
((fresh (other) (conso other rest pairs) (assoco key rest val)))))))
|
||||
|
||||
(define
|
||||
nth-o
|
||||
(fn
|
||||
(n l elem)
|
||||
(conde
|
||||
((== n :z) (fresh (d) (conso elem d l)))
|
||||
((fresh (n-1 a d) (== n (list :s n-1)) (conso a d l) (nth-o n-1 d elem))))))
|
||||
|
||||
(define
|
||||
samelengtho
|
||||
(fn
|
||||
(l1 l2)
|
||||
(conde
|
||||
((nullo l1) (nullo l2))
|
||||
((fresh (a d a-prime d-prime) (conso a d l1) (conso a-prime d-prime l2) (samelengtho d d-prime))))))
|
||||
|
||||
(define
|
||||
mapo
|
||||
(fn
|
||||
(rel l1 l2)
|
||||
(conde
|
||||
((nullo l1) (nullo l2))
|
||||
((fresh (a d a-prime d-prime) (conso a d l1) (conso a-prime d-prime l2) (rel a a-prime) (mapo rel d d-prime))))))
|
||||
|
||||
(define
|
||||
iterate-no
|
||||
(fn
|
||||
(rel n x result)
|
||||
(conde
|
||||
((== n :z) (== result x))
|
||||
((fresh (n-1 mid) (== n (list :s n-1)) (rel x mid) (iterate-no rel n-1 mid result))))))
|
||||
|
||||
(define
|
||||
pairlisto
|
||||
(fn
|
||||
(l1 l2 pairs)
|
||||
(conde
|
||||
((nullo l1) (nullo l2) (nullo pairs))
|
||||
((fresh (a1 d1 a2 d2 d-pairs) (conso a1 d1 l1) (conso a2 d2 l2) (conso (list a1 a2) d-pairs pairs) (pairlisto d1 d2 d-pairs))))))
|
||||
|
||||
(define
|
||||
zip-with-o
|
||||
(fn
|
||||
(rel l1 l2 result)
|
||||
(conde
|
||||
((nullo l1) (nullo l2) (nullo result))
|
||||
((fresh (a1 d1 a2 d2 a-result d-result) (conso a1 d1 l1) (conso a2 d2 l2) (rel a1 a2 a-result) (conso a-result d-result result) (zip-with-o rel d1 d2 d-result))))))
|
||||
|
||||
(define
|
||||
swap-firsto
|
||||
(fn
|
||||
(l result)
|
||||
(fresh
|
||||
(a b rest mid-l mid-r)
|
||||
(conso a mid-l l)
|
||||
(conso b rest mid-l)
|
||||
(conso b mid-r result)
|
||||
(conso a rest mid-r))))
|
||||
|
||||
(define
|
||||
everyo
|
||||
(fn
|
||||
(rel l)
|
||||
(conde
|
||||
((nullo l))
|
||||
((fresh (a d) (conso a d l) (rel a) (everyo rel d))))))
|
||||
|
||||
(define
|
||||
someo
|
||||
(fn
|
||||
(rel l)
|
||||
(conde
|
||||
((fresh (a d) (conso a d l) (rel a)))
|
||||
((fresh (a d) (conso a d l) (someo rel d))))))
|
||||
|
||||
(define
|
||||
lasto
|
||||
(fn
|
||||
(l x)
|
||||
(conde
|
||||
((conso x (list) l))
|
||||
((fresh (a d) (conso a d l) (lasto d x))))))
|
||||
|
||||
(define
|
||||
init-o
|
||||
(fn
|
||||
(l init)
|
||||
(conde
|
||||
((fresh (x) (conso x (list) l) (== init (list))))
|
||||
((fresh (a d d-init) (conso a d l) (conso a d-init init) (init-o d d-init))))))
|
||||
|
||||
(define
|
||||
tako
|
||||
(fn
|
||||
(n l prefix)
|
||||
(conde
|
||||
((== n :z) (== prefix (list)))
|
||||
((fresh (n-1 a d p-rest) (== n (list :s n-1)) (conso a d l) (conso a p-rest prefix) (tako n-1 d p-rest))))))
|
||||
|
||||
(define
|
||||
dropo
|
||||
(fn
|
||||
(n l suffix)
|
||||
(conde
|
||||
((== n :z) (== suffix l))
|
||||
((fresh (n-1 a d) (== n (list :s n-1)) (conso a d l) (dropo n-1 d suffix))))))
|
||||
|
||||
(define
|
||||
repeato
|
||||
(fn
|
||||
(x n result)
|
||||
(conde
|
||||
((== n :z) (== result (list)))
|
||||
((fresh (n-1 r-rest) (== n (list :s n-1)) (conso x r-rest result) (repeato x n-1 r-rest))))))
|
||||
|
||||
(define
|
||||
concato
|
||||
(fn
|
||||
(lists result)
|
||||
(conde
|
||||
((nullo lists) (nullo result))
|
||||
((fresh (h t r-rest) (conso h t lists) (appendo h r-rest result) (concato t r-rest))))))
|
||||
@@ -1,56 +0,0 @@
|
||||
;; lib/minikanren/run.sx — Phase 3: drive a goal + reify the query var.
|
||||
;;
|
||||
;; reify-name N — make the canonical "_.N" reified symbol.
|
||||
;; reify-s term rs — walk term in rs, add a mapping from each fresh
|
||||
;; unbound var to its _.N name (left-to-right order).
|
||||
;; reify q s — walk* q in s, build reify-s, walk* again to
|
||||
;; substitute reified names in.
|
||||
;; run-n n q-name g... — defmacro: bind q-name to a fresh var, conj goals,
|
||||
;; take ≤ n answers from the stream, reify each
|
||||
;; through q-name. n = -1 takes all (used by run*).
|
||||
;; run* — defmacro: (run* q g...) ≡ (run-n -1 q g...)
|
||||
;; run — defmacro: (run n q g...) ≡ (run-n n q g...)
|
||||
;; The two-segment form is the standard TRS API.
|
||||
|
||||
(define reify-name (fn (n) (make-symbol (str "_." n))))
|
||||
|
||||
(define
|
||||
reify-s
|
||||
(fn
|
||||
(term rs)
|
||||
(let
|
||||
((w (mk-walk term rs)))
|
||||
(cond
|
||||
((is-var? w) (extend (var-name w) (reify-name (len rs)) rs))
|
||||
((mk-list-pair? w) (reduce (fn (acc a) (reify-s a acc)) rs w))
|
||||
(:else rs)))))
|
||||
|
||||
(define
|
||||
reify
|
||||
(fn
|
||||
(term s)
|
||||
(let
|
||||
((w (mk-walk* term s)))
|
||||
(let ((rs (reify-s w (empty-subst)))) (mk-walk* w rs)))))
|
||||
|
||||
(defmacro
|
||||
run-n
|
||||
(n q-name &rest goals)
|
||||
(quasiquote
|
||||
(let
|
||||
(((unquote q-name) (make-var)))
|
||||
(map
|
||||
(fn (s) (reify (unquote q-name) s))
|
||||
(stream-take
|
||||
(unquote n)
|
||||
((mk-conj (splice-unquote goals)) empty-s))))))
|
||||
|
||||
(defmacro
|
||||
run*
|
||||
(q-name &rest goals)
|
||||
(quasiquote (run-n -1 (unquote q-name) (splice-unquote goals))))
|
||||
|
||||
(defmacro
|
||||
run
|
||||
(n q-name &rest goals)
|
||||
(quasiquote (run-n (unquote n) (unquote q-name) (splice-unquote goals))))
|
||||
@@ -1,66 +0,0 @@
|
||||
;; lib/minikanren/stream.sx — Phase 2 piece A: lazy streams of substitutions.
|
||||
;;
|
||||
;; SX has no improper pairs (cons requires a list cdr), so we use a
|
||||
;; tagged stream-cell shape for mature stream elements:
|
||||
;;
|
||||
;; stream ::= mzero empty (the SX empty list)
|
||||
;; | (:s HEAD TAIL) mature cell, TAIL is a stream
|
||||
;; | thunk (fn () ...) → stream when forced
|
||||
;;
|
||||
;; HEAD is a substitution dict. TAIL is again a stream (possibly a thunk),
|
||||
;; which is what gives us laziness — mk-mplus can return a mature head with
|
||||
;; a thunk in the tail, deferring the rest of the search.
|
||||
|
||||
(define mzero (list))
|
||||
|
||||
(define s-cons (fn (h t) (list :s h t)))
|
||||
|
||||
(define
|
||||
s-cons?
|
||||
(fn (s) (and (list? s) (not (empty? s)) (= (first s) :s))))
|
||||
|
||||
(define s-car (fn (s) (nth s 1)))
|
||||
(define s-cdr (fn (s) (nth s 2)))
|
||||
|
||||
(define unit (fn (s) (s-cons s mzero)))
|
||||
|
||||
(define stream-pause? (fn (s) (and (not (list? s)) (callable? s))))
|
||||
|
||||
;; mk-mplus — interleave two streams. If s1 is paused we suspend and
|
||||
;; swap (Reasoned Schemer "interleave"); otherwise mature-cons head with
|
||||
;; mk-mplus of the rest.
|
||||
(define
|
||||
mk-mplus
|
||||
(fn
|
||||
(s1 s2)
|
||||
(cond
|
||||
((empty? s1) s2)
|
||||
((stream-pause? s1) (fn () (mk-mplus s2 (s1))))
|
||||
(:else (s-cons (s-car s1) (mk-mplus (s-cdr s1) s2))))))
|
||||
|
||||
;; mk-bind — apply goal g to every substitution in stream s, mk-mplus-ing.
|
||||
(define
|
||||
mk-bind
|
||||
(fn
|
||||
(s g)
|
||||
(cond
|
||||
((empty? s) mzero)
|
||||
((stream-pause? s) (fn () (mk-bind (s) g)))
|
||||
(:else (mk-mplus (g (s-car s)) (mk-bind (s-cdr s) g))))))
|
||||
|
||||
;; stream-take — force up to n results out of a (possibly lazy) stream
|
||||
;; into a flat SX list of substitutions. n = -1 means take all.
|
||||
(define
|
||||
stream-take
|
||||
(fn
|
||||
(n s)
|
||||
(cond
|
||||
((= n 0) (list))
|
||||
((empty? s) (list))
|
||||
((stream-pause? s) (stream-take n (s)))
|
||||
(:else
|
||||
(cons
|
||||
(s-car s)
|
||||
(stream-take
|
||||
(if (= n -1) -1 (- n 1))
|
||||
(s-cdr s)))))))
|
||||
@@ -1,157 +0,0 @@
|
||||
;; lib/minikanren/tabling.sx — Phase 7 piece A: naive memoization.
|
||||
;;
|
||||
;; A `table-2` wrapper for 2-arg relations (input, output). Caches by
|
||||
;; ground input (walked at call time). On hit, replays the cached output
|
||||
;; values; on miss, runs the relation, collects all output values from
|
||||
;; the answer stream, stores, then replays.
|
||||
;;
|
||||
;; Limitations of naive memoization (vs proper SLG / producer-consumer
|
||||
;; tabling):
|
||||
;; - Each call must terminate before its result enters the cache —
|
||||
;; so cyclic recursive calls with the SAME ground input would still
|
||||
;; diverge (not addressed here).
|
||||
;; - Caching by full ground walk only; partially-ground args fall
|
||||
;; through to the underlying relation.
|
||||
;;
|
||||
;; Despite the limitations, naive memoization is enough for the
|
||||
;; canonical demo: Fibonacci goes from exponential to linear because
|
||||
;; each fib(k) result is computed at most once.
|
||||
;;
|
||||
;; Cache lifetime: a single global mk-tab-cache. Use `(mk-tab-clear!)`
|
||||
;; between independent queries.
|
||||
|
||||
(define mk-tab-cache {})
|
||||
|
||||
(define mk-tab-clear! (fn () (set! mk-tab-cache {})))
|
||||
|
||||
(define
|
||||
mk-tab-lookup
|
||||
(fn
|
||||
(key)
|
||||
(cond
|
||||
((has-key? mk-tab-cache key) (get mk-tab-cache key))
|
||||
(:else :miss))))
|
||||
|
||||
(define
|
||||
mk-tab-store!
|
||||
(fn (key vals) (set! mk-tab-cache (assoc mk-tab-cache key vals))))
|
||||
|
||||
(define
|
||||
mk-tab-ground-term?
|
||||
(fn
|
||||
(t)
|
||||
(cond
|
||||
((is-var? t) false)
|
||||
((mk-cons-cell? t)
|
||||
(and
|
||||
(mk-tab-ground-term? (mk-cons-head t))
|
||||
(mk-tab-ground-term? (mk-cons-tail t))))
|
||||
((mk-list-pair? t) (every? mk-tab-ground-term? t))
|
||||
(:else true))))
|
||||
|
||||
(define
|
||||
mk-tab-replay-vals
|
||||
(fn
|
||||
(vals output s)
|
||||
(cond
|
||||
((empty? vals) mzero)
|
||||
(:else
|
||||
(let
|
||||
((sp (mk-unify output (first vals) s)))
|
||||
(let
|
||||
((this-stream (cond ((= sp nil) mzero) (:else (unit sp)))))
|
||||
(mk-mplus this-stream (mk-tab-replay-vals (rest vals) output s))))))))
|
||||
|
||||
(define
|
||||
table-2
|
||||
(fn
|
||||
(name rel-fn)
|
||||
(fn
|
||||
(input output)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((winput (mk-walk* input s)))
|
||||
(cond
|
||||
((mk-tab-ground-term? winput)
|
||||
(let
|
||||
((key (str name "@" winput)))
|
||||
(let
|
||||
((cached (mk-tab-lookup key)))
|
||||
(cond
|
||||
((= cached :miss)
|
||||
(let
|
||||
((all-substs (stream-take -1 ((rel-fn input output) s))))
|
||||
(let
|
||||
((vals (map (fn (s2) (mk-walk* output s2)) all-substs)))
|
||||
(begin
|
||||
(mk-tab-store! key vals)
|
||||
(mk-tab-replay-vals vals output s)))))
|
||||
(:else (mk-tab-replay-vals cached output s))))))
|
||||
(:else ((rel-fn input output) s))))))))
|
||||
|
||||
;; --- table-1: 1-arg relation (one input, no output to cache) ---
|
||||
;; The relation is a predicate `(p input)` that succeeds or fails.
|
||||
;; Cache stores either :ok or :no.
|
||||
|
||||
(define
|
||||
table-1
|
||||
(fn
|
||||
(name rel-fn)
|
||||
(fn
|
||||
(input)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((winput (mk-walk* input s)))
|
||||
(cond
|
||||
((mk-tab-ground-term? winput)
|
||||
(let
|
||||
((key (str name "@1@" winput)))
|
||||
(let
|
||||
((cached (mk-tab-lookup key)))
|
||||
(cond
|
||||
((= cached :miss)
|
||||
(let
|
||||
((stream ((rel-fn input) s)))
|
||||
(let
|
||||
((peek (stream-take 1 stream)))
|
||||
(cond
|
||||
((empty? peek)
|
||||
(begin (mk-tab-store! key :no) mzero))
|
||||
(:else (begin (mk-tab-store! key :ok) stream))))))
|
||||
((= cached :ok) (unit s))
|
||||
((= cached :no) mzero)
|
||||
(:else mzero)))))
|
||||
(:else ((rel-fn input) s))))))))
|
||||
|
||||
;; --- table-3: 3-arg relation (input1 input2 output) ---
|
||||
;; Cache keyed by (input1, input2). Output values cached as a list.
|
||||
|
||||
(define
|
||||
table-3
|
||||
(fn
|
||||
(name rel-fn)
|
||||
(fn
|
||||
(i1 i2 output)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((wi1 (mk-walk* i1 s)) (wi2 (mk-walk* i2 s)))
|
||||
(cond
|
||||
((and (mk-tab-ground-term? wi1) (mk-tab-ground-term? wi2))
|
||||
(let
|
||||
((key (str name "@3@" wi1 "/" wi2)))
|
||||
(let
|
||||
((cached (mk-tab-lookup key)))
|
||||
(cond
|
||||
((= cached :miss)
|
||||
(let
|
||||
((all-substs (stream-take -1 ((rel-fn i1 i2 output) s))))
|
||||
(let
|
||||
((vals (map (fn (s2) (mk-walk* output s2)) all-substs)))
|
||||
(begin
|
||||
(mk-tab-store! key vals)
|
||||
(mk-tab-replay-vals vals output s)))))
|
||||
(:else (mk-tab-replay-vals cached output s))))))
|
||||
(:else ((rel-fn i1 i2 output) s))))))))
|
||||
@@ -1,49 +0,0 @@
|
||||
;; lib/minikanren/tests/appendo3.sx — 3-list append.
|
||||
|
||||
(mk-test
|
||||
"appendo3-forward"
|
||||
(run*
|
||||
q
|
||||
(appendo3
|
||||
(list 1 2)
|
||||
(list 3 4)
|
||||
(list 5 6)
|
||||
q))
|
||||
(list
|
||||
(list 1 2 3 4 5 6)))
|
||||
|
||||
(mk-test
|
||||
"appendo3-empty-everything"
|
||||
(run* q (appendo3 (list) (list) (list) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"appendo3-recover-middle"
|
||||
(run*
|
||||
q
|
||||
(appendo3
|
||||
(list 1 2)
|
||||
q
|
||||
(list 5 6)
|
||||
(list 1 2 3 4 5 6)))
|
||||
(list (list 3 4)))
|
||||
|
||||
(mk-test
|
||||
"appendo3-empty-middle"
|
||||
(run*
|
||||
q
|
||||
(appendo3
|
||||
(list 1 2)
|
||||
(list)
|
||||
(list 3 4)
|
||||
q))
|
||||
(list (list 1 2 3 4)))
|
||||
|
||||
(mk-test
|
||||
"appendo3-empty-first-and-last"
|
||||
(run*
|
||||
q
|
||||
(appendo3 (list) (list 1 2 3) (list) q))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,33 +0,0 @@
|
||||
;; lib/minikanren/tests/arith-prog.sx — arithmetic progression generation.
|
||||
|
||||
(mk-test
|
||||
"arith-progo-zero-len"
|
||||
(run* q (arith-progo 5 1 0 q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"arith-progo-1-to-5"
|
||||
(run* q (arith-progo 1 1 5 q))
|
||||
(list (list 1 2 3 4 5)))
|
||||
|
||||
(mk-test
|
||||
"arith-progo-evens-from-0"
|
||||
(run* q (arith-progo 0 2 5 q))
|
||||
(list (list 0 2 4 6 8)))
|
||||
|
||||
(mk-test
|
||||
"arith-progo-descending"
|
||||
(run* q (arith-progo 10 -1 4 q))
|
||||
(list (list 10 9 8 7)))
|
||||
|
||||
(mk-test
|
||||
"arith-progo-zero-step"
|
||||
(run* q (arith-progo 7 0 3 q))
|
||||
(list (list 7 7 7)))
|
||||
|
||||
(mk-test
|
||||
"arith-progo-negative-start"
|
||||
(run* q (arith-progo -3 2 4 q))
|
||||
(list (list -3 -1 1 3)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,54 +0,0 @@
|
||||
;; lib/minikanren/tests/btree-walko.sx — walk a leaves-of-binary-tree relation
|
||||
;; using matche dispatch on (:leaf v) and (:node left right) patterns.
|
||||
|
||||
(define
|
||||
btree-walko
|
||||
(fn
|
||||
(tree v)
|
||||
(matche
|
||||
tree
|
||||
((:leaf x) (== v x))
|
||||
((:node l r) (conde ((btree-walko l v)) ((btree-walko r v)))))))
|
||||
|
||||
;; A small test tree: ((1 2) (3 (4 5))).
|
||||
(define
|
||||
test-btree
|
||||
(list
|
||||
:node (list :node (list :leaf 1) (list :leaf 2))
|
||||
(list
|
||||
:node (list :leaf 3)
|
||||
(list :node (list :leaf 4) (list :leaf 5)))))
|
||||
|
||||
(mk-test
|
||||
"btree-walko-enumerates-all-leaves"
|
||||
(let
|
||||
((leaves (run* q (btree-walko test-btree q))))
|
||||
(and
|
||||
(= (len leaves) 5)
|
||||
(and
|
||||
(some (fn (l) (= l 1)) leaves)
|
||||
(and
|
||||
(some (fn (l) (= l 2)) leaves)
|
||||
(and
|
||||
(some (fn (l) (= l 3)) leaves)
|
||||
(and
|
||||
(some (fn (l) (= l 4)) leaves)
|
||||
(some (fn (l) (= l 5)) leaves)))))))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"btree-walko-find-3-membership"
|
||||
(run 1 q (btree-walko test-btree 3))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"btree-walko-find-99-not-present"
|
||||
(run* q (btree-walko test-btree 99))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"btree-walko-leaf-only"
|
||||
(run* q (btree-walko (list :leaf 42) q))
|
||||
(list 42))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,87 +0,0 @@
|
||||
;; lib/minikanren/tests/classics.sx — small classic-style puzzles that
|
||||
;; exercise the full system end to end (relations + conde + matche +
|
||||
;; fresh + run*). Each test is a self-contained miniKanren program.
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
;; Pet puzzle (3 friends, 3 pets, 1-each).
|
||||
;; -----------------------------------------------------------------------
|
||||
|
||||
(mk-test
|
||||
"classics-pet-puzzle"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(a b c)
|
||||
(== q (list a b c))
|
||||
(permuteo (list :dog :cat :fish) (list a b c))
|
||||
(== b :fish)
|
||||
(conde ((== a :cat)) ((== a :fish)))))
|
||||
(list (list :cat :fish :dog)))
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
;; Family-relations puzzle (uses membero on a fact list).
|
||||
;; -----------------------------------------------------------------------
|
||||
|
||||
(define
|
||||
parent-facts
|
||||
(list
|
||||
(list "alice" "bob")
|
||||
(list "alice" "carol")
|
||||
(list "bob" "dave")
|
||||
(list "carol" "eve")
|
||||
(list "dave" "frank")))
|
||||
|
||||
(define parento (fn (x y) (membero (list x y) parent-facts)))
|
||||
|
||||
(define grandparento (fn (x z) (fresh (y) (parento x y) (parento y z))))
|
||||
|
||||
(mk-test
|
||||
"classics-grandparents-of-frank"
|
||||
(run* q (grandparento q "frank"))
|
||||
(list "bob"))
|
||||
|
||||
(mk-test
|
||||
"classics-grandchildren-of-alice"
|
||||
(run* q (grandparento "alice" q))
|
||||
(list "dave" "eve"))
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
;; Symbolic differentiation, matche-driven.
|
||||
;; Variable :x: d/dx x = 1
|
||||
;; Sum (:+ a b): d/dx (a+b) = (da + db)
|
||||
;; Product (:* a b): d/dx (a*b) = (da*b + a*db)
|
||||
;; -----------------------------------------------------------------------
|
||||
|
||||
(define
|
||||
diffo
|
||||
(fn
|
||||
(expr var d)
|
||||
(matche
|
||||
expr
|
||||
(:x (== d 1))
|
||||
((:+ a b)
|
||||
(fresh
|
||||
(da db)
|
||||
(== d (list :+ da db))
|
||||
(diffo a var da)
|
||||
(diffo b var db)))
|
||||
((:* a b)
|
||||
(fresh
|
||||
(da db)
|
||||
(== d (list :+ (list :* da b) (list :* a db)))
|
||||
(diffo a var da)
|
||||
(diffo b var db))))))
|
||||
|
||||
(mk-test "classics-diff-of-x" (run* q (diffo :x :x q)) (list 1))
|
||||
|
||||
(mk-test
|
||||
"classics-diff-of-x-plus-x"
|
||||
(run* q (diffo (list :+ :x :x) :x q))
|
||||
(list (list :+ 1 1)))
|
||||
|
||||
(mk-test
|
||||
"classics-diff-of-x-times-x"
|
||||
(run* q (diffo (list :* :x :x) :x q))
|
||||
(list (list :+ (list :* 1 :x) (list :* :x 1))))
|
||||
|
||||
(mk-tests-run!)
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user