Compare commits
298 Commits
e8246340fc
...
loops/ocam
| Author | SHA1 | Date | |
|---|---|---|---|
| 0231bb46a6 | |||
| fed07059a3 | |||
| c8327823ee | |||
| fad81e0b0c | |||
| 3ccce58e0a | |||
| 8ab2f80615 | |||
| 230f803abb | |||
| b240408a4c | |||
| 67ece98ba1 | |||
| 33be068c01 | |||
| bf468e5ec3 | |||
| 90ba37ecc8 | |||
| 3f00e62577 | |||
| 97a29c6bac | |||
| 73efd229be | |||
| 6d89da9380 | |||
| d3340107e6 | |||
| aaa6020037 | |||
| 8ef24847d3 | |||
| b3ee88e9bb | |||
| 2c7a1bfc47 | |||
| 047ea62d43 | |||
| 2726ed9b8a | |||
| 6d7df11224 | |||
| 8a80bd3923 | |||
| 609205b551 | |||
| f9371e7d22 | |||
| 7f310a4da7 | |||
| 6780acd0af | |||
| b771ea306c | |||
| 6c77dec495 | |||
| 0a3f02d636 | |||
| 800dca67ca | |||
| fd1f94f292 | |||
| 1d1c35a438 | |||
| ca34cede88 | |||
| cb626fc402 | |||
| 175a77fba5 | |||
| 3fe3b7b66f | |||
| 689438d12e | |||
| d1a4616ac4 | |||
| 32f6c4ee0c | |||
| 62712accdd | |||
| c69a7694c8 | |||
| 5384ff6c42 | |||
| bcb7db2ea4 | |||
| 5eed0dd5f5 | |||
| 3ea8967571 | |||
| e057d9f18f | |||
| 4761d41a0d | |||
| bed374c9e1 | |||
| b4571f0f9f | |||
| 0ef26b20f3 | |||
| 19d0ef0f38 | |||
| 1dd350d592 | |||
| 4fdf6980da | |||
| cccef832d9 | |||
| 526ffbb5f0 | |||
| 99f321f532 | |||
| dfd89d998e | |||
| 74d8ade089 | |||
| 872302ede1 | |||
| 57a63826e3 | |||
| 7a67637826 | |||
| 42a506faff | |||
| 713d506bb8 | |||
| bcaa41d1ae | |||
| edbb03e205 | |||
| 551ed44f7f | |||
| 76de0a20f8 | |||
| 353dcb67d6 | |||
| 36e02c906a | |||
| 5c1b4349aa | |||
| e23aa9c273 | |||
| da54c3ea53 | |||
| 63901931c4 | |||
| e77a2d3a81 | |||
| 836e01dbb4 | |||
| fb0e83d3a1 | |||
| 0b79d4d4b4 | |||
| 58ea001f12 | |||
| da96a79104 | |||
| ed8aaf8af7 | |||
| 37f7405dcf | |||
| 4e6a345342 | |||
| 21dbd195d5 | |||
| 87f9a84365 | |||
| 46e49dc947 | |||
| ea7120751d | |||
| 89a807a1ed | |||
| 391a2d0c4f | |||
| 5959989324 | |||
| 320d78a993 | |||
| 2a01758f28 | |||
| 533be5b36b | |||
| 853504642f | |||
| 00ffba9306 | |||
| cecde8733a | |||
| c16a8f2d53 | |||
| d4eb57fa07 | |||
| 73917745a0 | |||
| c8206e718a | |||
| 288c0f8c3e | |||
| 2c7246e11d | |||
| 4840a9f660 | |||
| 53968c2480 | |||
| 3759aad7a6 | |||
| 14575a9cd7 | |||
| be13f2daba | |||
| 810f61a1c1 | |||
| 37a514d566 | |||
| 7e838bb62b | |||
| b2ff367c6b | |||
| 17a7a91d73 | |||
| df6efeb68e | |||
| 60e3ce1c96 | |||
| eb621240d7 | |||
| e8a0c86de0 | |||
| 4eeb7e59b4 | |||
| f1df5b1b72 | |||
| 254ef0daff | |||
| b6e723fc3e | |||
| 2e84492d96 | |||
| 1bde4e834f | |||
| 554ef48c63 | |||
| b7b841821c | |||
| 2129e04bfd | |||
| 89726ed6c2 | |||
| 5d71be364e | |||
| ce013fa138 | |||
| 07de86365e | |||
| 5b38f4d499 | |||
| a3a93c20b8 | |||
| 30b237a891 | |||
| 667dfcfd7c | |||
| 7f8bf5f455 | |||
| a98d683e60 | |||
| a2f3c533b8 | |||
| 0f2eb45f5c | |||
| 1c40fec8fa | |||
| b94a47a9a9 | |||
| 7de014cd75 | |||
| 0eef5bc8e6 | |||
| 50981a2a9b | |||
| 05487b497d | |||
| af38d98583 | |||
| f5122a9a5d | |||
| 097c7f4590 | |||
| 5c587c0f61 | |||
| acc8b01ddb | |||
| 027678f31e | |||
| cca3a28206 | |||
| b8dfc080dd | |||
| ac19b7aced | |||
| aa0a7fa1a2 | |||
| bafa2410e4 | |||
| a91ff62730 | |||
| 073ea44fdb | |||
| aee7226b9c | |||
| b3d5da5361 | |||
| da6d8e39c9 | |||
| 32aba1823d | |||
| 3be2dc6e78 | |||
| b0cbdaf713 | |||
| aaaf054441 | |||
| 70b9b4f6cf | |||
| 095bb62ef9 | |||
| 13fb1bd7a9 | |||
| 39f4c7a9a8 | |||
| 1a828d5b9f | |||
| 5c70747ac7 | |||
| c272b1ea04 | |||
| 9a8bbff5b2 | |||
| 75a1adbbd5 | |||
| 90418c120b | |||
| e42ff3b1f6 | |||
| 97a8c06690 | |||
| 0c3b5d21fa | |||
| 98ba772acd | |||
| 4d32c80a99 | |||
| ddd1e40d00 | |||
| 7ca5bfbb70 | |||
| 2d519461c4 | |||
| 24416f8cef | |||
| ec12b721e8 | |||
| 5d33f8f20b | |||
| 7773c40337 | |||
| 7c40506571 | |||
| 82ffc695a5 | |||
| b526d81a4c | |||
| 64f4f10c32 | |||
| 8ca3ef342d | |||
| 41190c6d23 | |||
| dab8718289 | |||
| 7e64695a74 | |||
| cb14a07413 | |||
| 8188a82a58 | |||
| a0e8b64f5c | |||
| 55fe1e4468 | |||
| f68ea63e46 | |||
| a66b262267 | |||
| 073588812a | |||
| 1ed3216ba6 | |||
| 5618dd1ef5 | |||
| 19497c9fba | |||
| a34cfe69dc | |||
| 8af3630625 | |||
| 34d518d555 | |||
| 9907c1c58c | |||
| 207dfc60ad | |||
| 1b38f89055 | |||
| 14b52cfaa7 | |||
| bd2cd8aad1 | |||
| 0234ae329e | |||
| f895a118fb | |||
| bc4f4a5477 | |||
| 982e9680fe | |||
| 6dc535dde3 | |||
| 0530120bc7 | |||
| 6d9ac1e55a | |||
| a4ef9a8ec9 | |||
| ce75bd6848 | |||
| c7d8b7dd62 | |||
| 029c1783f4 | |||
| b92a98fb45 | |||
| 8fab20c8bc | |||
| de8b1dd681 | |||
| ce81ce2e95 | |||
| 8c7ad62b44 | |||
| fff8fe2dc8 | |||
| 360a3ed51f | |||
| 50a219b688 | |||
| d9979eaf6c | |||
| 66da0e5b84 | |||
| f070bddb0e | |||
| 0858986877 | |||
| d8f1882b50 | |||
| 0bc6dbd233 | |||
| cabf5dc9c3 | |||
| 4909ebe2ad | |||
| f05d405bac | |||
| ffa74399fd | |||
| ecdd90345e | |||
| 2f271fa6a6 | |||
| dbe3c6c203 | |||
| 404c908a9a | |||
| b297c83b1d | |||
| 85867e329b | |||
| cd93b11328 | |||
| 4bca2cacff | |||
| d61ee088c5 | |||
| f40dfbbeb5 | |||
| 9f05e24c52 | |||
| 86343345dc | |||
| ad252088c3 | |||
| 76ccbfbab6 | |||
| 98049d5458 | |||
| 0cf5c8f219 | |||
| 9f539ab392 | |||
| 986b15c0e5 | |||
| ee002f2e02 | |||
| 16df48ff74 | |||
| dac9cf124f | |||
| 46d0eb258e | |||
| de7be332c8 | |||
| 756d5fba64 | |||
| 5bc7895ce0 | |||
| 81247eb6ea | |||
| d2bf0c0d00 | |||
| 202ea9cf5f | |||
| 812aa75d43 | |||
| 6d7197182e | |||
| a0abdcf520 | |||
| 88c02c7c73 | |||
| bc557a5ad2 | |||
| d8f6250962 | |||
| 851e0585cf | |||
| 7fb65cd26a | |||
| 9473911cf3 | |||
| 74b80e6b0e | |||
| c8bfd22786 | |||
| 26863242a0 | |||
| 4c6790046c | |||
| 19f1cad11d | |||
| 5603ecc3a6 | |||
| d45e653a87 | |||
| 317f93b2af | |||
| 6a1f63f0d1 | |||
| 937342bbf0 | |||
| 9b8b0b4325 | |||
| a11f3c33b6 | |||
| 9b833a9442 | |||
| 4dca583ee3 | |||
| a6ab944c39 | |||
| 9102e57d89 | |||
| 9648dac88d | |||
| 9a090c6e42 | |||
| 85b7fed4fc |
@@ -528,183 +528,6 @@ let () =
|
|||||||
| [Rational (_, d)] -> Integer d
|
| [Rational (_, d)] -> Integer d
|
||||||
| [Integer _] -> Integer 1
|
| [Integer _] -> Integer 1
|
||||||
| _ -> raise (Eval_error "denominator: expected rational or integer"));
|
| _ -> 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 ->
|
register "parse-int" (fun args ->
|
||||||
let parse_leading_int s =
|
let parse_leading_int s =
|
||||||
let len = String.length s in
|
let len = String.length s in
|
||||||
@@ -3576,62 +3399,6 @@ let () =
|
|||||||
Nil
|
Nil
|
||||||
| _ -> raise (Eval_error "channel-set-blocking!: (channel bool)"));
|
| _ -> 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);
|
|
||||||
|
|
||||||
(* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *)
|
(* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *)
|
||||||
let resolve_inet_addr host =
|
let resolve_inet_addr host =
|
||||||
if host = "" || host = "0.0.0.0" then Unix.inet_addr_any
|
if host = "" || host = "0.0.0.0" then Unix.inet_addr_any
|
||||||
|
|||||||
@@ -270,15 +270,6 @@
|
|||||||
(collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)})))
|
(collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)})))
|
||||||
((= tt :name)
|
((= tt :name)
|
||||||
(cond
|
(cond
|
||||||
((and (< (+ i 1) (len tokens)) (= (tok-type (nth tokens (+ i 1))) :assign))
|
|
||||||
(let
|
|
||||||
((rhs-tokens (slice tokens (+ i 2) (len tokens))))
|
|
||||||
(let
|
|
||||||
((rhs-expr (parse-apl-expr rhs-tokens)))
|
|
||||||
(collect-segments-loop
|
|
||||||
tokens
|
|
||||||
(len tokens)
|
|
||||||
(append acc {:kind "val" :node (list :assign-expr tv rhs-expr)})))))
|
|
||||||
((some (fn (q) (= q tv)) apl-quad-fn-names)
|
((some (fn (q) (= q tv)) apl-quad-fn-names)
|
||||||
(let
|
(let
|
||||||
((op-result (collect-ops tokens (+ i 1))))
|
((op-result (collect-ops tokens (+ i 1))))
|
||||||
@@ -344,22 +335,10 @@
|
|||||||
((= tt :glyph)
|
((= tt :glyph)
|
||||||
(cond
|
(cond
|
||||||
((or (= tv "⍺") (= tv "⍵"))
|
((or (= tv "⍺") (= tv "⍵"))
|
||||||
(if
|
(collect-segments-loop
|
||||||
(and
|
tokens
|
||||||
(< (+ i 1) (len tokens))
|
(+ i 1)
|
||||||
(= (tok-type (nth tokens (+ i 1))) :assign))
|
(append acc {:kind "val" :node (list :name tv)})))
|
||||||
(let
|
|
||||||
((rhs-tokens (slice tokens (+ i 2) (len tokens))))
|
|
||||||
(let
|
|
||||||
((rhs-expr (parse-apl-expr rhs-tokens)))
|
|
||||||
(collect-segments-loop
|
|
||||||
tokens
|
|
||||||
(len tokens)
|
|
||||||
(append acc {:kind "val" :node (list :assign-expr tv rhs-expr)}))))
|
|
||||||
(collect-segments-loop
|
|
||||||
tokens
|
|
||||||
(+ i 1)
|
|
||||||
(append acc {:kind "val" :node (list :name tv)}))))
|
|
||||||
((= tv "∇")
|
((= tv "∇")
|
||||||
(collect-segments-loop
|
(collect-segments-loop
|
||||||
tokens
|
tokens
|
||||||
@@ -414,13 +393,7 @@
|
|||||||
ni
|
ni
|
||||||
(append acc {:kind "fn" :node fn-node})))))))
|
(append acc {:kind "fn" :node fn-node})))))))
|
||||||
((apl-parse-op-glyph? tv)
|
((apl-parse-op-glyph? tv)
|
||||||
(if
|
(collect-segments-loop tokens (+ i 1) acc))
|
||||||
(or (= tv "/") (= tv "⌿") (= tv "\\") (= tv "⍀"))
|
|
||||||
(collect-segments-loop
|
|
||||||
tokens
|
|
||||||
(+ i 1)
|
|
||||||
(append acc {:kind "fn" :node (list :fn-glyph tv)}))
|
|
||||||
(collect-segments-loop tokens (+ i 1) acc)))
|
|
||||||
(true (collect-segments-loop tokens (+ i 1) acc))))
|
(true (collect-segments-loop tokens (+ i 1) acc))))
|
||||||
(true (collect-segments-loop tokens (+ i 1) acc))))))))
|
(true (collect-segments-loop tokens (+ i 1) acc))))))))
|
||||||
|
|
||||||
|
|||||||
@@ -808,25 +808,6 @@
|
|||||||
((picked (map (fn (i) (nth arr-ravel i)) kept)))
|
((picked (map (fn (i) (nth arr-ravel i)) kept)))
|
||||||
(make-array (list (len picked)) picked))))))
|
(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
|
(define
|
||||||
apl-primes
|
apl-primes
|
||||||
(fn
|
(fn
|
||||||
@@ -1004,28 +985,6 @@
|
|||||||
(some (fn (c) (= c 0)) codes)
|
(some (fn (c) (= c 0)) codes)
|
||||||
(some (fn (c) (= c (nth e 1))) 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
|
(define
|
||||||
apl-cartesian
|
apl-cartesian
|
||||||
(fn
|
(fn
|
||||||
|
|||||||
@@ -312,146 +312,3 @@
|
|||||||
"train: mean of ⍳10 has shape ()"
|
"train: mean of ⍳10 has shape ()"
|
||||||
(mksh (apl-run "(+/÷≢) ⍳10"))
|
(mksh (apl-run "(+/÷≢) ⍳10"))
|
||||||
(list))
|
(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")
|
|
||||||
|
|||||||
@@ -252,6 +252,8 @@
|
|||||||
|
|
||||||
(apl-test "queens 7 → 40 solutions" (mkrv (apl-queens 7)) (list 40))
|
(apl-test "queens 7 → 40 solutions" (mkrv (apl-queens 7)) (list 40))
|
||||||
|
|
||||||
|
(apl-test "queens 8 → 92 solutions" (mkrv (apl-queens 8)) (list 92))
|
||||||
|
|
||||||
(apl-test "permutations of 3 has 6" (len (apl-permutations 3)) 6)
|
(apl-test "permutations of 3 has 6" (len (apl-permutations 3)) 6)
|
||||||
|
|
||||||
(apl-test "permutations of 4 has 24" (len (apl-permutations 4)) 24)
|
(apl-test "permutations of 4 has 24" (len (apl-permutations 4)) 24)
|
||||||
|
|||||||
@@ -39,11 +39,6 @@
|
|||||||
((= g "⊖") apl-reverse-first)
|
((= g "⊖") apl-reverse-first)
|
||||||
((= g "⍋") apl-grade-up)
|
((= g "⍋") apl-grade-up)
|
||||||
((= g "⍒") apl-grade-down)
|
((= 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 "⎕FMT") apl-quad-fmt)
|
||||||
((= g "⎕←") apl-quad-print)
|
((= g "⎕←") apl-quad-print)
|
||||||
(else (error "no monadic fn for glyph")))))
|
(else (error "no monadic fn for glyph")))))
|
||||||
@@ -85,11 +80,6 @@
|
|||||||
((= g "∊") apl-member)
|
((= g "∊") apl-member)
|
||||||
((= g "⍳") apl-index-of)
|
((= g "⍳") apl-index-of)
|
||||||
((= g "~") apl-without)
|
((= 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")))))
|
(else (error "no dyadic fn for glyph")))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -129,14 +119,8 @@
|
|||||||
(let
|
(let
|
||||||
((nm (nth node 1)))
|
((nm (nth node 1)))
|
||||||
(cond
|
(cond
|
||||||
((= nm "⍺")
|
((= nm "⍺") (get env "alpha"))
|
||||||
(let
|
((= nm "⍵") (get env "omega"))
|
||||||
((v (get env "⍺")))
|
|
||||||
(if (= v nil) (get env "alpha") v)))
|
|
||||||
((= nm "⍵")
|
|
||||||
(let
|
|
||||||
((v (get env "⍵")))
|
|
||||||
(if (= v nil) (get env "omega") v)))
|
|
||||||
((= nm "⎕IO") (apl-quad-io))
|
((= nm "⎕IO") (apl-quad-io))
|
||||||
((= nm "⎕ML") (apl-quad-ml))
|
((= nm "⎕ML") (apl-quad-ml))
|
||||||
((= nm "⎕FR") (apl-quad-fr))
|
((= nm "⎕FR") (apl-quad-fr))
|
||||||
@@ -148,11 +132,7 @@
|
|||||||
(if
|
(if
|
||||||
(and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇"))
|
(and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇"))
|
||||||
(apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env))
|
(apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env))
|
||||||
(let
|
((apl-resolve-monadic fn-node env) (apl-eval-ast arg env)))))
|
||||||
((arg-val (apl-eval-ast arg env)))
|
|
||||||
(let
|
|
||||||
((new-env (if (and (list? arg) (> (len arg) 0) (= (first arg) :assign-expr)) (assoc env (nth arg 1) arg-val) env)))
|
|
||||||
((apl-resolve-monadic fn-node new-env) arg-val))))))
|
|
||||||
((= tag :dyad)
|
((= tag :dyad)
|
||||||
(let
|
(let
|
||||||
((fn-node (nth node 1))
|
((fn-node (nth node 1))
|
||||||
@@ -164,13 +144,9 @@
|
|||||||
(get env "nabla")
|
(get env "nabla")
|
||||||
(apl-eval-ast lhs env)
|
(apl-eval-ast lhs env)
|
||||||
(apl-eval-ast rhs env))
|
(apl-eval-ast rhs env))
|
||||||
(let
|
((apl-resolve-dyadic fn-node env)
|
||||||
((rhs-val (apl-eval-ast rhs env)))
|
(apl-eval-ast lhs env)
|
||||||
(let
|
(apl-eval-ast rhs env)))))
|
||||||
((new-env (if (and (list? rhs) (> (len rhs) 0) (= (first rhs) :assign-expr)) (assoc env (nth rhs 1) rhs-val) env)))
|
|
||||||
((apl-resolve-dyadic fn-node new-env)
|
|
||||||
(apl-eval-ast lhs new-env)
|
|
||||||
rhs-val))))))
|
|
||||||
((= tag :program) (apl-eval-stmts (rest node) env))
|
((= tag :program) (apl-eval-stmts (rest node) env))
|
||||||
((= tag :dfn) node)
|
((= tag :dfn) node)
|
||||||
((= tag :bracket)
|
((= tag :bracket)
|
||||||
@@ -183,8 +159,6 @@
|
|||||||
(fn (a) (if (= a :all) nil (apl-eval-ast a env)))
|
(fn (a) (if (= a :all) nil (apl-eval-ast a env)))
|
||||||
axis-exprs)))
|
axis-exprs)))
|
||||||
(apl-bracket-multi axes arr))))
|
(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)))))))
|
(else (error (list "apl-eval-ast: unknown node tag" tag node)))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -564,5 +538,3 @@
|
|||||||
(else (error "apl-resolve-dyadic: unknown fn-node tag"))))))
|
(else (error "apl-resolve-dyadic: unknown fn-node tag"))))))
|
||||||
|
|
||||||
(define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
|
(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)")
|
(eval "(list er-fib-test-pass er-fib-test-count)")
|
||||||
EPOCHS
|
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 "(N M)" from the line after each "(ok-len <epoch> ...)" marker.
|
||||||
parse_pair() {
|
parse_pair() {
|
||||||
|
|||||||
@@ -1,16 +1,16 @@
|
|||||||
{
|
{
|
||||||
"language": "erlang",
|
"language": "erlang",
|
||||||
"total_pass": 530,
|
"total_pass": 0,
|
||||||
"total": 530,
|
"total": 0,
|
||||||
"suites": [
|
"suites": [
|
||||||
{"name":"tokenize","pass":62,"total":62,"status":"ok"},
|
{"name":"tokenize","pass":0,"total":0,"status":"ok"},
|
||||||
{"name":"parse","pass":52,"total":52,"status":"ok"},
|
{"name":"parse","pass":0,"total":0,"status":"ok"},
|
||||||
{"name":"eval","pass":346,"total":346,"status":"ok"},
|
{"name":"eval","pass":0,"total":0,"status":"ok"},
|
||||||
{"name":"runtime","pass":39,"total":39,"status":"ok"},
|
{"name":"runtime","pass":0,"total":0,"status":"ok"},
|
||||||
{"name":"ring","pass":4,"total":4,"status":"ok"},
|
{"name":"ring","pass":0,"total":0,"status":"ok"},
|
||||||
{"name":"ping-pong","pass":4,"total":4,"status":"ok"},
|
{"name":"ping-pong","pass":0,"total":0,"status":"ok"},
|
||||||
{"name":"bank","pass":8,"total":8,"status":"ok"},
|
{"name":"bank","pass":0,"total":0,"status":"ok"},
|
||||||
{"name":"echo","pass":7,"total":7,"status":"ok"},
|
{"name":"echo","pass":0,"total":0,"status":"ok"},
|
||||||
{"name":"fib","pass":8,"total":8,"status":"ok"}
|
{"name":"fib","pass":0,"total":0,"status":"ok"}
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -1,18 +1,18 @@
|
|||||||
# Erlang-on-SX Scoreboard
|
# Erlang-on-SX Scoreboard
|
||||||
|
|
||||||
**Total: 530 / 530 tests passing**
|
**Total: 0 / 0 tests passing**
|
||||||
|
|
||||||
| | Suite | Pass | Total |
|
| | Suite | Pass | Total |
|
||||||
|---|---|---|---|
|
|---|---|---|---|
|
||||||
| ✅ | tokenize | 62 | 62 |
|
| ✅ | tokenize | 0 | 0 |
|
||||||
| ✅ | parse | 52 | 52 |
|
| ✅ | parse | 0 | 0 |
|
||||||
| ✅ | eval | 346 | 346 |
|
| ✅ | eval | 0 | 0 |
|
||||||
| ✅ | runtime | 39 | 39 |
|
| ✅ | runtime | 0 | 0 |
|
||||||
| ✅ | ring | 4 | 4 |
|
| ✅ | ring | 0 | 0 |
|
||||||
| ✅ | ping-pong | 4 | 4 |
|
| ✅ | ping-pong | 0 | 0 |
|
||||||
| ✅ | bank | 8 | 8 |
|
| ✅ | bank | 0 | 0 |
|
||||||
| ✅ | echo | 7 | 7 |
|
| ✅ | echo | 0 | 0 |
|
||||||
| ✅ | fib | 8 | 8 |
|
| ✅ | fib | 0 | 0 |
|
||||||
|
|
||||||
|
|
||||||
Generated by `lib/erlang/conformance.sh`.
|
Generated by `lib/erlang/conformance.sh`.
|
||||||
|
|||||||
@@ -14,8 +14,6 @@ PRELOADS=(
|
|||||||
lib/haskell/runtime.sx
|
lib/haskell/runtime.sx
|
||||||
lib/haskell/match.sx
|
lib/haskell/match.sx
|
||||||
lib/haskell/eval.sx
|
lib/haskell/eval.sx
|
||||||
lib/haskell/map.sx
|
|
||||||
lib/haskell/set.sx
|
|
||||||
lib/haskell/testlib.sx
|
lib/haskell/testlib.sx
|
||||||
)
|
)
|
||||||
|
|
||||||
@@ -38,24 +36,6 @@ SUITES=(
|
|||||||
"matrix:lib/haskell/tests/program-matrix.sx"
|
"matrix:lib/haskell/tests/program-matrix.sx"
|
||||||
"wordcount:lib/haskell/tests/program-wordcount.sx"
|
"wordcount:lib/haskell/tests/program-wordcount.sx"
|
||||||
"powers:lib/haskell/tests/program-powers.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() {
|
emit_scoreboard_json() {
|
||||||
|
|||||||
@@ -131,280 +131,119 @@
|
|||||||
(let
|
(let
|
||||||
((tag (first node)))
|
((tag (first node)))
|
||||||
(cond
|
(cond
|
||||||
|
;; Transformations
|
||||||
((= tag "where")
|
((= tag "where")
|
||||||
(list
|
(list
|
||||||
:let (map hk-desugar (nth node 2))
|
:let
|
||||||
|
(map hk-desugar (nth node 2))
|
||||||
(hk-desugar (nth node 1))))
|
(hk-desugar (nth node 1))))
|
||||||
((= tag "guarded") (hk-guards-to-if (nth node 1)))
|
((= tag "guarded") (hk-guards-to-if (nth node 1)))
|
||||||
((= tag "list-comp")
|
((= 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")
|
((= tag "app")
|
||||||
(list
|
(list
|
||||||
:app (hk-desugar (nth node 1))
|
:app
|
||||||
(hk-desugar (nth node 2))))
|
|
||||||
((= tag "p-rec")
|
|
||||||
(let
|
|
||||||
((cname (nth node 1))
|
|
||||||
(field-pats (nth node 2))
|
|
||||||
(field-order (hk-record-field-names cname)))
|
|
||||||
(cond
|
|
||||||
((nil? field-order)
|
|
||||||
(raise (str "p-rec: no record info for " cname)))
|
|
||||||
(:else
|
|
||||||
(list
|
|
||||||
:p-con
|
|
||||||
cname
|
|
||||||
(map
|
|
||||||
(fn
|
|
||||||
(fname)
|
|
||||||
(let
|
|
||||||
((p (hk-find-rec-pair field-pats fname)))
|
|
||||||
(cond
|
|
||||||
((nil? p) (list :p-wild))
|
|
||||||
(:else (hk-desugar (nth p 1))))))
|
|
||||||
field-order))))))
|
|
||||||
((= tag "rec-update")
|
|
||||||
(list
|
|
||||||
:rec-update
|
|
||||||
(hk-desugar (nth node 1))
|
(hk-desugar (nth node 1))
|
||||||
(map
|
(hk-desugar (nth node 2))))
|
||||||
(fn (p) (list (first p) (hk-desugar (nth p 1))))
|
|
||||||
(nth node 2))))
|
|
||||||
((= tag "rec-create")
|
|
||||||
(let
|
|
||||||
((cname (nth node 1))
|
|
||||||
(field-pairs (nth node 2))
|
|
||||||
(field-order (hk-record-field-names cname)))
|
|
||||||
(cond
|
|
||||||
((nil? field-order)
|
|
||||||
(raise (str "rec-create: no record info for " cname)))
|
|
||||||
(:else
|
|
||||||
(let
|
|
||||||
((acc (list :con cname)))
|
|
||||||
(begin
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(fname)
|
|
||||||
(let
|
|
||||||
((pair
|
|
||||||
(hk-find-rec-pair field-pairs fname)))
|
|
||||||
(cond
|
|
||||||
((nil? pair)
|
|
||||||
(raise
|
|
||||||
(str
|
|
||||||
"rec-create: missing field "
|
|
||||||
fname
|
|
||||||
" for "
|
|
||||||
cname)))
|
|
||||||
(:else
|
|
||||||
(set!
|
|
||||||
acc
|
|
||||||
(list
|
|
||||||
:app
|
|
||||||
acc
|
|
||||||
(hk-desugar (nth pair 1))))))))
|
|
||||||
field-order)
|
|
||||||
acc))))))
|
|
||||||
((= tag "op")
|
((= tag "op")
|
||||||
(list
|
(list
|
||||||
:op (nth node 1)
|
:op
|
||||||
|
(nth node 1)
|
||||||
(hk-desugar (nth node 2))
|
(hk-desugar (nth node 2))
|
||||||
(hk-desugar (nth node 3))))
|
(hk-desugar (nth node 3))))
|
||||||
((= tag "neg") (list :neg (hk-desugar (nth node 1))))
|
((= tag "neg") (list :neg (hk-desugar (nth node 1))))
|
||||||
((= tag "if")
|
((= tag "if")
|
||||||
(list
|
(list
|
||||||
:if (hk-desugar (nth node 1))
|
:if
|
||||||
|
(hk-desugar (nth node 1))
|
||||||
(hk-desugar (nth node 2))
|
(hk-desugar (nth node 2))
|
||||||
(hk-desugar (nth node 3))))
|
(hk-desugar (nth node 3))))
|
||||||
((= tag "tuple") (list :tuple (map hk-desugar (nth node 1))))
|
((= tag "tuple")
|
||||||
((= tag "list") (list :list (map hk-desugar (nth node 1))))
|
(list :tuple (map hk-desugar (nth node 1))))
|
||||||
|
((= tag "list")
|
||||||
|
(list :list (map hk-desugar (nth node 1))))
|
||||||
((= tag "range")
|
((= tag "range")
|
||||||
(list
|
(list
|
||||||
:range (hk-desugar (nth node 1))
|
:range
|
||||||
|
(hk-desugar (nth node 1))
|
||||||
(hk-desugar (nth node 2))))
|
(hk-desugar (nth node 2))))
|
||||||
((= tag "range-step")
|
((= tag "range-step")
|
||||||
(list
|
(list
|
||||||
:range-step (hk-desugar (nth node 1))
|
:range-step
|
||||||
|
(hk-desugar (nth node 1))
|
||||||
(hk-desugar (nth node 2))
|
(hk-desugar (nth node 2))
|
||||||
(hk-desugar (nth node 3))))
|
(hk-desugar (nth node 3))))
|
||||||
((= tag "lambda")
|
((= tag "lambda")
|
||||||
(list :lambda (nth node 1) (hk-desugar (nth node 2))))
|
(list
|
||||||
|
:lambda
|
||||||
|
(nth node 1)
|
||||||
|
(hk-desugar (nth node 2))))
|
||||||
((= tag "let")
|
((= tag "let")
|
||||||
(list
|
(list
|
||||||
:let (map hk-desugar (nth node 1))
|
:let
|
||||||
|
(map hk-desugar (nth node 1))
|
||||||
(hk-desugar (nth node 2))))
|
(hk-desugar (nth node 2))))
|
||||||
((= tag "case")
|
((= tag "case")
|
||||||
(list
|
(list
|
||||||
:case (hk-desugar (nth node 1))
|
:case
|
||||||
|
(hk-desugar (nth node 1))
|
||||||
(map hk-desugar (nth node 2))))
|
(map hk-desugar (nth node 2))))
|
||||||
((= tag "alt")
|
((= 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 "do") (hk-desugar-do (nth node 1)))
|
||||||
((= tag "sect-left")
|
((= 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")
|
((= 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")
|
((= tag "program")
|
||||||
(list :program (map hk-desugar (hk-expand-records (nth node 1)))))
|
(list :program (map hk-desugar (nth node 1))))
|
||||||
((= tag "module")
|
((= tag "module")
|
||||||
(list
|
(list
|
||||||
:module (nth node 1)
|
:module
|
||||||
|
(nth node 1)
|
||||||
(nth node 2)
|
(nth node 2)
|
||||||
(nth node 3)
|
(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")
|
((= tag "fun-clause")
|
||||||
(list
|
(list
|
||||||
:fun-clause (nth node 1)
|
:fun-clause
|
||||||
(map hk-desugar (nth node 2))
|
(nth node 1)
|
||||||
(hk-desugar (nth node 3))))
|
|
||||||
((= tag "instance-decl")
|
|
||||||
(list
|
|
||||||
:instance-decl (nth node 1)
|
|
||||||
(nth node 2)
|
(nth node 2)
|
||||||
(map hk-desugar (nth node 3))))
|
(hk-desugar (nth node 3))))
|
||||||
((= tag "pat-bind")
|
((= 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")
|
((= 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)))))))
|
(:else node)))))))
|
||||||
|
|
||||||
;; Convenience — tokenize + layout + parse + desugar.
|
;; Convenience — tokenize + layout + parse + desugar.
|
||||||
(define hk-record-fields (dict))
|
(define
|
||||||
|
hk-core
|
||||||
|
(fn (src) (hk-desugar (hk-parse-top src))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
hk-register-record-fields!
|
hk-core-expr
|
||||||
(fn (cname fields) (dict-set! hk-record-fields cname fields)))
|
(fn (src) (hk-desugar (hk-parse src))))
|
||||||
|
|
||||||
(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))))
|
|
||||||
|
|||||||
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)
|
((nil? res) nil)
|
||||||
(:else (assoc res (nth pat 1) val)))))
|
(:else (assoc res (nth pat 1) val)))))
|
||||||
(:else
|
(:else
|
||||||
(let
|
(let ((fv (hk-force val)))
|
||||||
((fv (hk-force val)))
|
|
||||||
(cond
|
(cond
|
||||||
((= tag "p-int")
|
((= 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")
|
((= 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")
|
((= 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")
|
((= 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")
|
((= tag "p-con")
|
||||||
(let
|
(let
|
||||||
((pat-name (nth pat 1)) (pat-args (nth pat 2)))
|
((pat-name (nth pat 1)) (pat-args (nth pat 2)))
|
||||||
(cond
|
(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-is-con-val? fv)) nil)
|
||||||
((not (= (hk-val-con-name fv) pat-name)) nil)
|
((not (= (hk-val-con-name fv) pat-name)) nil)
|
||||||
(:else
|
(:else
|
||||||
(let
|
(let
|
||||||
((val-args (hk-val-con-args fv)))
|
((val-args (hk-val-con-args fv)))
|
||||||
(cond
|
(cond
|
||||||
((not (= (len val-args) (len pat-args))) nil)
|
((not (= (len pat-args) (len val-args)))
|
||||||
(:else (hk-match-all pat-args val-args env))))))))
|
nil)
|
||||||
|
(:else
|
||||||
|
(hk-match-all
|
||||||
|
pat-args
|
||||||
|
val-args
|
||||||
|
env))))))))
|
||||||
((= tag "p-tuple")
|
((= tag "p-tuple")
|
||||||
(let
|
(let
|
||||||
((items (nth pat 1)))
|
((items (nth pat 1)))
|
||||||
@@ -130,8 +134,13 @@
|
|||||||
((not (= (hk-val-con-name fv) "Tuple")) nil)
|
((not (= (hk-val-con-name fv) "Tuple")) nil)
|
||||||
((not (= (len (hk-val-con-args fv)) (len items)))
|
((not (= (len (hk-val-con-args fv)) (len items)))
|
||||||
nil)
|
nil)
|
||||||
(:else (hk-match-all items (hk-val-con-args fv) env)))))
|
(:else
|
||||||
((= tag "p-list") (hk-match-list-pat (nth pat 1) fv env))
|
(hk-match-all
|
||||||
|
items
|
||||||
|
(hk-val-con-args fv)
|
||||||
|
env)))))
|
||||||
|
((= tag "p-list")
|
||||||
|
(hk-match-list-pat (nth pat 1) fv env))
|
||||||
(:else nil))))))))))
|
(:else nil))))))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -152,26 +161,17 @@
|
|||||||
hk-match-list-pat
|
hk-match-list-pat
|
||||||
(fn
|
(fn
|
||||||
(items val env)
|
(items val env)
|
||||||
(let
|
(let ((fv (hk-force val)))
|
||||||
((fv (hk-force val)))
|
|
||||||
(cond
|
(cond
|
||||||
((empty? items)
|
((empty? items)
|
||||||
(if
|
(if
|
||||||
(or
|
(and
|
||||||
(and (hk-is-con-val? fv) (= (hk-val-con-name fv) "[]"))
|
(hk-is-con-val? fv)
|
||||||
(and (hk-str? fv) (hk-str-null? fv)))
|
(= (hk-val-con-name fv) "[]"))
|
||||||
env
|
env
|
||||||
nil))
|
nil))
|
||||||
(:else
|
(:else
|
||||||
(cond
|
(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-is-con-val? fv)) nil)
|
||||||
((not (= (hk-val-con-name fv) ":")) nil)
|
((not (= (hk-val-con-name fv) ":")) nil)
|
||||||
(:else
|
(:else
|
||||||
@@ -183,7 +183,11 @@
|
|||||||
((res (hk-match (first items) h env)))
|
((res (hk-match (first items) h env)))
|
||||||
(cond
|
(cond
|
||||||
((nil? res) nil)
|
((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 ─────
|
;; ── Convenience: parse a pattern from source for tests ─────
|
||||||
;; (Uses the parser's case-alt entry — `case _ of pat -> 0` —
|
;; (Uses the parser's case-alt entry — `case _ of pat -> 0` —
|
||||||
|
|||||||
@@ -208,19 +208,9 @@
|
|||||||
((= (get t "type") "char")
|
((= (get t "type") "char")
|
||||||
(do (hk-advance!) (list :char (get t "value"))))
|
(do (hk-advance!) (list :char (get t "value"))))
|
||||||
((= (get t "type") "varid")
|
((= (get t "type") "varid")
|
||||||
(do
|
(do (hk-advance!) (list :var (get t "value"))))
|
||||||
(hk-advance!)
|
|
||||||
(cond
|
|
||||||
((hk-match? "lbrace" nil)
|
|
||||||
(hk-parse-rec-update (list :var (get t "value"))))
|
|
||||||
(:else (list :var (get t "value"))))))
|
|
||||||
((= (get t "type") "conid")
|
((= (get t "type") "conid")
|
||||||
(do
|
(do (hk-advance!) (list :con (get t "value"))))
|
||||||
(hk-advance!)
|
|
||||||
(cond
|
|
||||||
((hk-match? "lbrace" nil)
|
|
||||||
(hk-parse-rec-create (get t "value")))
|
|
||||||
(:else (list :con (get t "value"))))))
|
|
||||||
((= (get t "type") "qvarid")
|
((= (get t "type") "qvarid")
|
||||||
(do (hk-advance!) (list :var (get t "value"))))
|
(do (hk-advance!) (list :var (get t "value"))))
|
||||||
((= (get t "type") "qconid")
|
((= (get t "type") "qconid")
|
||||||
@@ -466,90 +456,6 @@
|
|||||||
(do
|
(do
|
||||||
(hk-expect! "rbracket" nil)
|
(hk-expect! "rbracket" nil)
|
||||||
(list :list (list first-e))))))))))
|
(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
|
(define
|
||||||
hk-parse-fexp
|
hk-parse-fexp
|
||||||
(fn
|
(fn
|
||||||
@@ -790,12 +696,7 @@
|
|||||||
(:else
|
(:else
|
||||||
(do (hk-advance!) (list :p-var (get t "value")))))))
|
(do (hk-advance!) (list :p-var (get t "value")))))))
|
||||||
((= (get t "type") "conid")
|
((= (get t "type") "conid")
|
||||||
(do
|
(do (hk-advance!) (list :p-con (get t "value") (list))))
|
||||||
(hk-advance!)
|
|
||||||
(cond
|
|
||||||
((hk-match? "lbrace" nil)
|
|
||||||
(hk-parse-rec-pat (get t "value")))
|
|
||||||
(:else (list :p-con (get t "value") (list))))))
|
|
||||||
((= (get t "type") "qconid")
|
((= (get t "type") "qconid")
|
||||||
(do (hk-advance!) (list :p-con (get t "value") (list))))
|
(do (hk-advance!) (list :p-con (get t "value") (list))))
|
||||||
((= (get t "type") "lparen") (hk-parse-paren-pat))
|
((= (get t "type") "lparen") (hk-parse-paren-pat))
|
||||||
@@ -861,24 +762,16 @@
|
|||||||
(cond
|
(cond
|
||||||
((and (not (nil? t)) (or (= (get t "type") "conid") (= (get t "type") "qconid")))
|
((and (not (nil? t)) (or (= (get t "type") "conid") (= (get t "type") "qconid")))
|
||||||
(let
|
(let
|
||||||
((name (get (hk-advance!) "value")))
|
((name (get (hk-advance!) "value")) (args (list)))
|
||||||
(cond
|
(define
|
||||||
((hk-match? "lbrace" nil)
|
hk-pca-loop
|
||||||
(hk-parse-rec-pat name))
|
(fn
|
||||||
(:else
|
()
|
||||||
(let
|
(when
|
||||||
((args (list)))
|
(hk-apat-start? (hk-peek))
|
||||||
(define
|
(do (append! args (hk-parse-apat)) (hk-pca-loop)))))
|
||||||
hk-pca-loop
|
(hk-pca-loop)
|
||||||
(fn
|
(list :p-con name args)))
|
||||||
()
|
|
||||||
(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))))))
|
(:else (hk-parse-apat))))))
|
||||||
(define
|
(define
|
||||||
hk-parse-pat
|
hk-parse-pat
|
||||||
@@ -1319,47 +1212,16 @@
|
|||||||
(not (hk-match? "conid" nil))
|
(not (hk-match? "conid" nil))
|
||||||
(hk-err "expected constructor name"))
|
(hk-err "expected constructor name"))
|
||||||
(let
|
(let
|
||||||
((name (get (hk-advance!) "value")))
|
((name (get (hk-advance!) "value")) (fields (list)))
|
||||||
(cond
|
(define
|
||||||
((hk-match? "lbrace" nil)
|
hk-cd-loop
|
||||||
(begin
|
(fn
|
||||||
(hk-advance!)
|
()
|
||||||
(let
|
(when
|
||||||
((rec-fields (list)))
|
(hk-atype-start? (hk-peek))
|
||||||
(define
|
(do (append! fields (hk-parse-atype)) (hk-cd-loop)))))
|
||||||
hk-rec-loop
|
(hk-cd-loop)
|
||||||
(fn
|
(list :con-def name fields))))
|
||||||
()
|
|
||||||
(when
|
|
||||||
(hk-match? "varid" nil)
|
|
||||||
(let
|
|
||||||
((fname (get (hk-advance!) "value")))
|
|
||||||
(begin
|
|
||||||
(hk-expect! "reservedop" "::")
|
|
||||||
(let
|
|
||||||
((ftype (hk-parse-type)))
|
|
||||||
(begin
|
|
||||||
(append! rec-fields (list fname ftype))
|
|
||||||
(when
|
|
||||||
(hk-match? "comma" nil)
|
|
||||||
(begin (hk-advance!) (hk-rec-loop))))))))))
|
|
||||||
(hk-rec-loop)
|
|
||||||
(hk-expect! "rbrace" nil)
|
|
||||||
(list :con-rec name rec-fields))))
|
|
||||||
(:else
|
|
||||||
(let
|
|
||||||
((fields (list)))
|
|
||||||
(define
|
|
||||||
hk-cd-loop
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(when
|
|
||||||
(hk-atype-start? (hk-peek))
|
|
||||||
(begin
|
|
||||||
(append! fields (hk-parse-atype))
|
|
||||||
(hk-cd-loop)))))
|
|
||||||
(hk-cd-loop)
|
|
||||||
(list :con-def name fields)))))))
|
|
||||||
(define
|
(define
|
||||||
hk-parse-tvars
|
hk-parse-tvars
|
||||||
(fn
|
(fn
|
||||||
|
|||||||
@@ -12,7 +12,12 @@
|
|||||||
|
|
||||||
(define
|
(define
|
||||||
hk-register-con!
|
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)))
|
(define hk-is-con? (fn (name) (has-key? hk-constructors name)))
|
||||||
|
|
||||||
@@ -43,15 +48,26 @@
|
|||||||
(fn
|
(fn
|
||||||
(data-node)
|
(data-node)
|
||||||
(let
|
(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
|
(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))))
|
cons-list))))
|
||||||
|
|
||||||
;; (:newtype NAME TVARS CNAME FIELD)
|
;; (:newtype NAME TVARS CNAME FIELD)
|
||||||
(define
|
(define
|
||||||
hk-register-newtype!
|
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.
|
;; Walk a decls list, registering every `data` / `newtype` decl.
|
||||||
(define
|
(define
|
||||||
@@ -62,9 +78,15 @@
|
|||||||
(fn
|
(fn
|
||||||
(d)
|
(d)
|
||||||
(cond
|
(cond
|
||||||
((and (list? d) (not (empty? d)) (= (first d) "data"))
|
((and
|
||||||
|
(list? d)
|
||||||
|
(not (empty? d))
|
||||||
|
(= (first d) "data"))
|
||||||
(hk-register-data! d))
|
(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))
|
(hk-register-newtype! d))
|
||||||
(:else nil)))
|
(:else nil)))
|
||||||
decls)))
|
decls)))
|
||||||
@@ -77,12 +99,16 @@
|
|||||||
((nil? ast) nil)
|
((nil? ast) nil)
|
||||||
((not (list? ast)) nil)
|
((not (list? ast)) nil)
|
||||||
((empty? ast) nil)
|
((empty? ast) nil)
|
||||||
((= (first ast) "program") (hk-register-decls! (nth ast 1)))
|
((= (first ast) "program")
|
||||||
((= (first ast) "module") (hk-register-decls! (nth ast 4)))
|
(hk-register-decls! (nth ast 1)))
|
||||||
|
((= (first ast) "module")
|
||||||
|
(hk-register-decls! (nth ast 4)))
|
||||||
(:else nil))))
|
(:else nil))))
|
||||||
|
|
||||||
;; Convenience: source → AST → desugar → register.
|
;; 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 ─────────────────────
|
;; ── Built-in constructors pre-registered ─────────────────────
|
||||||
;; Bool — used implicitly by `if`, comparison operators.
|
;; Bool — used implicitly by `if`, comparison operators.
|
||||||
@@ -96,55 +122,9 @@
|
|||||||
;; Standard Prelude types — pre-registered so expression-level
|
;; Standard Prelude types — pre-registered so expression-level
|
||||||
;; programs can use them without a `data` decl.
|
;; programs can use them without a `data` decl.
|
||||||
(hk-register-con! "Nothing" 0 "Maybe")
|
(hk-register-con! "Nothing" 0 "Maybe")
|
||||||
(hk-register-con! "Just" 1 "Maybe")
|
(hk-register-con! "Just" 1 "Maybe")
|
||||||
(hk-register-con! "Left" 1 "Either")
|
(hk-register-con! "Left" 1 "Either")
|
||||||
(hk-register-con! "Right" 1 "Either")
|
(hk-register-con! "Right" 1 "Either")
|
||||||
(hk-register-con! "LT" 0 "Ordering")
|
(hk-register-con! "LT" 0 "Ordering")
|
||||||
(hk-register-con! "EQ" 0 "Ordering")
|
(hk-register-con! "EQ" 0 "Ordering")
|
||||||
(hk-register-con! "GT" 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",
|
"date": "2026-05-06",
|
||||||
"total_pass": 285,
|
"total_pass": 156,
|
||||||
"total_fail": 0,
|
"total_fail": 0,
|
||||||
"programs": {
|
"programs": {
|
||||||
"fib": {"pass": 2, "fail": 0},
|
"fib": {"pass": 2, "fail": 0},
|
||||||
@@ -9,7 +9,7 @@
|
|||||||
"nqueens": {"pass": 2, "fail": 0},
|
"nqueens": {"pass": 2, "fail": 0},
|
||||||
"calculator": {"pass": 5, "fail": 0},
|
"calculator": {"pass": 5, "fail": 0},
|
||||||
"collatz": {"pass": 11, "fail": 0},
|
"collatz": {"pass": 11, "fail": 0},
|
||||||
"palindrome": {"pass": 12, "fail": 0},
|
"palindrome": {"pass": 8, "fail": 0},
|
||||||
"maybe": {"pass": 12, "fail": 0},
|
"maybe": {"pass": 12, "fail": 0},
|
||||||
"fizzbuzz": {"pass": 12, "fail": 0},
|
"fizzbuzz": {"pass": 12, "fail": 0},
|
||||||
"anagram": {"pass": 9, "fail": 0},
|
"anagram": {"pass": 9, "fail": 0},
|
||||||
@@ -19,25 +19,7 @@
|
|||||||
"primes": {"pass": 12, "fail": 0},
|
"primes": {"pass": 12, "fail": 0},
|
||||||
"zipwith": {"pass": 9, "fail": 0},
|
"zipwith": {"pass": 9, "fail": 0},
|
||||||
"matrix": {"pass": 8, "fail": 0},
|
"matrix": {"pass": 8, "fail": 0},
|
||||||
"wordcount": {"pass": 10, "fail": 0},
|
"wordcount": {"pass": 7, "fail": 0},
|
||||||
"powers": {"pass": 14, "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}
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -1,6 +1,6 @@
|
|||||||
# Haskell-on-SX Scoreboard
|
# 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 |
|
| Program | Tests | Status |
|
||||||
|---------|-------|--------|
|
|---------|-------|--------|
|
||||||
@@ -10,7 +10,7 @@ Updated 2026-05-08 · Phase 6 (prelude extras + 18 programs)
|
|||||||
| nqueens.hs | 2/2 | ✓ |
|
| nqueens.hs | 2/2 | ✓ |
|
||||||
| calculator.hs | 5/5 | ✓ |
|
| calculator.hs | 5/5 | ✓ |
|
||||||
| collatz.hs | 11/11 | ✓ |
|
| collatz.hs | 11/11 | ✓ |
|
||||||
| palindrome.hs | 12/12 | ✓ |
|
| palindrome.hs | 8/8 | ✓ |
|
||||||
| maybe.hs | 12/12 | ✓ |
|
| maybe.hs | 12/12 | ✓ |
|
||||||
| fizzbuzz.hs | 12/12 | ✓ |
|
| fizzbuzz.hs | 12/12 | ✓ |
|
||||||
| anagram.hs | 9/9 | ✓ |
|
| anagram.hs | 9/9 | ✓ |
|
||||||
@@ -20,24 +20,6 @@ Updated 2026-05-08 · Phase 6 (prelude extras + 18 programs)
|
|||||||
| primes.hs | 12/12 | ✓ |
|
| primes.hs | 12/12 | ✓ |
|
||||||
| zipwith.hs | 9/9 | ✓ |
|
| zipwith.hs | 9/9 | ✓ |
|
||||||
| matrix.hs | 8/8 | ✓ |
|
| matrix.hs | 8/8 | ✓ |
|
||||||
| wordcount.hs | 10/10 | ✓ |
|
| wordcount.hs | 7/7 | ✓ |
|
||||||
| powers.hs | 14/14 | ✓ |
|
| powers.hs | 14/14 | ✓ |
|
||||||
| caesar.hs | 8/8 | ✓ |
|
| **Total** | **156/156** | **18/18 programs** |
|
||||||
| 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** |
|
|
||||||
|
|||||||
@@ -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/runtime.sx")
|
||||||
(load "lib/haskell/match.sx")
|
(load "lib/haskell/match.sx")
|
||||||
(load "lib/haskell/eval.sx")
|
(load "lib/haskell/eval.sx")
|
||||||
(load "lib/haskell/map.sx")
|
|
||||||
(load "lib/haskell/set.sx")
|
|
||||||
$INFER_LOAD
|
$INFER_LOAD
|
||||||
(load "lib/haskell/testlib.sx")
|
(load "lib/haskell/testlib.sx")
|
||||||
(epoch 2)
|
(epoch 2)
|
||||||
@@ -100,8 +98,6 @@ EPOCHS
|
|||||||
(load "lib/haskell/runtime.sx")
|
(load "lib/haskell/runtime.sx")
|
||||||
(load "lib/haskell/match.sx")
|
(load "lib/haskell/match.sx")
|
||||||
(load "lib/haskell/eval.sx")
|
(load "lib/haskell/eval.sx")
|
||||||
(load "lib/haskell/map.sx")
|
|
||||||
(load "lib/haskell/set.sx")
|
|
||||||
$INFER_LOAD
|
$INFER_LOAD
|
||||||
(load "lib/haskell/testlib.sx")
|
(load "lib/haskell/testlib.sx")
|
||||||
(epoch 2)
|
(epoch 2)
|
||||||
|
|||||||
@@ -56,21 +56,3 @@
|
|||||||
(append!
|
(append!
|
||||||
hk-test-fails
|
hk-test-fails
|
||||||
{:actual actual :expected expected :name name})))))
|
{: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"
|
"deriving Show: constructor with arg"
|
||||||
(hk-deep-force
|
(hk-deep-force
|
||||||
(hk-run "data Wrapper = Wrap Int deriving (Show)\nmain = show (Wrap 42)"))
|
(hk-run "data Wrapper = Wrap Int deriving (Show)\nmain = show (Wrap 42)"))
|
||||||
"Wrap 42")
|
"(Wrap 42)")
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"deriving Show: nested constructors"
|
"deriving Show: nested constructors"
|
||||||
(hk-deep-force
|
(hk-deep-force
|
||||||
(hk-run
|
(hk-run
|
||||||
"data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf Leaf)"))
|
"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
|
(hk-test
|
||||||
"deriving Show: second constructor"
|
"deriving Show: second constructor"
|
||||||
@@ -30,31 +30,6 @@
|
|||||||
|
|
||||||
;; ─── Eq ──────────────────────────────────────────────────────────────────────
|
;; ─── 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
|
(hk-test
|
||||||
"deriving Eq: same constructor"
|
"deriving Eq: same constructor"
|
||||||
(hk-deep-force
|
(hk-deep-force
|
||||||
@@ -83,12 +58,14 @@
|
|||||||
"data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Blue)"))
|
"data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Blue)"))
|
||||||
"True")
|
"True")
|
||||||
|
|
||||||
|
;; ─── combined Eq + Show ───────────────────────────────────────────────────────
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"deriving Eq Show: combined"
|
"deriving Eq Show: combined in parens"
|
||||||
(hk-deep-force
|
(hk-deep-force
|
||||||
(hk-run
|
(hk-run
|
||||||
"data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 5)"))
|
"data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 5)"))
|
||||||
"Circle 5")
|
"(Circle 5)")
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"deriving Eq Show: eq on constructor with arg"
|
"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)
|
1)
|
||||||
|
|
||||||
;; ── Laziness: app args evaluate only when forced ──
|
;; ── 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
|
(hk-test
|
||||||
"second arg never forced"
|
"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)
|
1)
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"first arg never forced"
|
"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)
|
99)
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
@@ -317,7 +251,9 @@
|
|||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
"lazy: const drops its second argument"
|
"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)
|
5)
|
||||||
|
|
||||||
(hk-test
|
(hk-test
|
||||||
@@ -334,10 +270,9 @@
|
|||||||
"result")
|
"result")
|
||||||
(list "True"))
|
(list "True"))
|
||||||
|
|
||||||
|
;; ── not / id built-ins ──
|
||||||
(hk-test "not True" (hk-eval-expr-source "not True") (list "False"))
|
(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 "not False" (hk-eval-expr-source "not False") (list "True"))
|
||||||
|
|
||||||
(hk-test "id" (hk-eval-expr-source "id 42") 42)
|
(hk-test "id" (hk-eval-expr-source "id 42") 42)
|
||||||
|
|
||||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
{: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
|
(hk-test
|
||||||
"readFile error on missing file"
|
"readFile error on missing file"
|
||||||
(begin
|
(guard
|
||||||
(set! hk-vfs (dict))
|
(e (true (>= (index-of e "file not found") 0)))
|
||||||
(let
|
(begin
|
||||||
((lines (hk-run-io "main = readFile \"no.txt\" >>= putStrLn")))
|
(set! hk-vfs (dict))
|
||||||
(>= (index-of (str lines) "file not found") 0)))
|
(hk-run-io "main = readFile \"no.txt\" >>= putStrLn")
|
||||||
|
false))
|
||||||
true)
|
true)
|
||||||
|
|
||||||
(hk-test
|
(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 neg" "negate 7" "-7")
|
||||||
(hk-ts "show bool T" "True" "True")
|
(hk-ts "show bool T" "True" "True")
|
||||||
(hk-ts "show bool F" "False" "False")
|
(hk-ts "show bool F" "False" "False")
|
||||||
(hk-ts "show list" "[1,2,3]" "[1,2,3]")
|
(hk-ts "show list" "[1,2,3]" "[1, 2, 3]")
|
||||||
(hk-ts "show Just" "Just 5" "Just 5")
|
(hk-ts "show Just" "Just 5" "(Just 5)")
|
||||||
(hk-ts "show Nothing" "Nothing" "Nothing")
|
(hk-ts "show Nothing" "Nothing" "Nothing")
|
||||||
(hk-ts "show LT" "LT" "LT")
|
(hk-ts "show LT" "LT" "LT")
|
||||||
(hk-ts "show tuple" "(1, True)" "(1,True)")
|
(hk-ts "show tuple" "(1, True)" "(1, True)")
|
||||||
|
|
||||||
;; ── Num extras ───────────────────────────────────────────────
|
;; ── Num extras ───────────────────────────────────────────────
|
||||||
(hk-test "signum pos" (hk-deep-force (hk-run "main = signum 5")) 1)
|
(hk-test "signum pos" (hk-deep-force (hk-run "main = signum 5")) 1)
|
||||||
@@ -59,13 +59,13 @@
|
|||||||
(hk-test
|
(hk-test
|
||||||
"foldr cons"
|
"foldr cons"
|
||||||
(hk-deep-force (hk-run "main = show (foldr (:) [] [1,2,3])"))
|
(hk-deep-force (hk-run "main = show (foldr (:) [] [1,2,3])"))
|
||||||
"[1,2,3]")
|
"[1, 2, 3]")
|
||||||
|
|
||||||
;; ── List ops ─────────────────────────────────────────────────
|
;; ── List ops ─────────────────────────────────────────────────
|
||||||
(hk-test
|
(hk-test
|
||||||
"reverse"
|
"reverse"
|
||||||
(hk-deep-force (hk-run "main = show (reverse [1,2,3])"))
|
(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 []" (hk-deep-force (hk-run "main = null []")) (list "True"))
|
||||||
(hk-test
|
(hk-test
|
||||||
"null xs"
|
"null xs"
|
||||||
@@ -82,7 +82,7 @@
|
|||||||
(hk-test
|
(hk-test
|
||||||
"zip"
|
"zip"
|
||||||
(hk-deep-force (hk-run "main = show (zip [1,2] [3,4])"))
|
(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 "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 "product" (hk-deep-force (hk-run "main = product [1,2,3,4]")) 24)
|
||||||
(hk-test "maximum" (hk-deep-force (hk-run "main = maximum [3,1,9,2]")) 9)
|
(hk-test "maximum" (hk-deep-force (hk-run "main = maximum [3,1,9,2]")) 9)
|
||||||
@@ -112,7 +112,7 @@
|
|||||||
(hk-test
|
(hk-test
|
||||||
"fmap list"
|
"fmap list"
|
||||||
(hk-deep-force (hk-run "main = show (fmap (+1) [1,2,3])"))
|
(hk-deep-force (hk-run "main = show (fmap (+1) [1,2,3])"))
|
||||||
"[2,3,4]")
|
"[2, 3, 4]")
|
||||||
|
|
||||||
;; ── Monad / Applicative ──────────────────────────────────────
|
;; ── Monad / Applicative ──────────────────────────────────────
|
||||||
(hk-test "return" (hk-deep-force (hk-run "main = return 7")) (list "IO" 7))
|
(hk-test "return" (hk-deep-force (hk-run "main = return 7")) (list "IO" 7))
|
||||||
@@ -134,7 +134,7 @@
|
|||||||
(hk-test
|
(hk-test
|
||||||
"lookup hit"
|
"lookup hit"
|
||||||
(hk-deep-force (hk-run "main = show (lookup 2 [(1,10),(2,20)])"))
|
(hk-deep-force (hk-run "main = show (lookup 2 [(1,10),(2,20)])"))
|
||||||
"Just 20")
|
"(Just 20)")
|
||||||
(hk-test
|
(hk-test
|
||||||
"lookup miss"
|
"lookup miss"
|
||||||
(hk-deep-force (hk-run "main = show (lookup 9 [(1,10)])"))
|
(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)
|
value)
|
||||||
(list (quote set!) (hs-to-sx target) value)))))))
|
(list (quote set!) (hs-to-sx target) value)))))))
|
||||||
(true (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
|
(define
|
||||||
emit-on
|
emit-on
|
||||||
(fn
|
(fn
|
||||||
@@ -256,8 +234,6 @@
|
|||||||
((parts (rest ast)))
|
((parts (rest ast)))
|
||||||
(let
|
(let
|
||||||
((event-name (first parts)))
|
((event-name (first parts)))
|
||||||
(set! _throttle-ms nil)
|
|
||||||
(set! _debounce-ms nil)
|
|
||||||
(define
|
(define
|
||||||
scan-on
|
scan-on
|
||||||
(fn
|
(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))))
|
((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
|
(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)))))
|
((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
|
(let
|
||||||
((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
|
((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
|
||||||
(cond
|
(cond
|
||||||
@@ -356,7 +325,7 @@
|
|||||||
(first pair)
|
(first pair)
|
||||||
handler))
|
handler))
|
||||||
or-sources)))
|
or-sources)))
|
||||||
on-call))))))))))))))
|
on-call)))))))))))))
|
||||||
((= (first items) :from)
|
((= (first items) :from)
|
||||||
(scan-on
|
(scan-on
|
||||||
(rest (rest items))
|
(rest (rest items))
|
||||||
@@ -500,7 +469,7 @@
|
|||||||
count-filter-info
|
count-filter-info
|
||||||
elsewhere?
|
elsewhere?
|
||||||
or-sources)))))
|
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
|
(define
|
||||||
emit-send
|
emit-send
|
||||||
(fn
|
(fn
|
||||||
@@ -2521,15 +2490,6 @@
|
|||||||
(quote fn)
|
(quote fn)
|
||||||
(list (quote it))
|
(list (quote it))
|
||||||
(hs-to-sx body))))
|
(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))))
|
(true nil))))
|
||||||
((= head (quote init))
|
((= head (quote init))
|
||||||
(list
|
(list
|
||||||
|
|||||||
@@ -1358,17 +1358,7 @@
|
|||||||
cls
|
cls
|
||||||
(first extra-classes)
|
(first extra-classes)
|
||||||
tgt))
|
tgt))
|
||||||
((and
|
((match-kw "for")
|
||||||
(= (tp-type) "keyword") (= (tp-val) "for")
|
|
||||||
;; Only consume 'for' as a duration clause if the next
|
|
||||||
;; token is NOT '<ident> in ...' — that pattern is a
|
|
||||||
;; for-in loop, not a toggle duration.
|
|
||||||
(not
|
|
||||||
(and
|
|
||||||
(> (len tokens) (+ p 2))
|
|
||||||
(= (get (nth tokens (+ p 1)) "type") "ident")
|
|
||||||
(= (get (nth tokens (+ p 2)) "value") "in")))
|
|
||||||
(do (adv!) true))
|
|
||||||
(let
|
(let
|
||||||
((dur (parse-expr)))
|
((dur (parse-expr)))
|
||||||
(list (quote toggle-class-for) cls tgt dur)))
|
(list (quote toggle-class-for) cls tgt dur)))
|
||||||
@@ -3100,17 +3090,7 @@
|
|||||||
(= (tp-val) "queue"))
|
(= (tp-val) "queue"))
|
||||||
(do (adv!) (adv!)))
|
(do (adv!) (adv!)))
|
||||||
(let
|
(let
|
||||||
((every? (match-kw "every"))
|
((every? (match-kw "every")))
|
||||||
(throttle-ms nil)
|
|
||||||
(debounce-ms nil))
|
|
||||||
;; 'throttled at <duration>' / 'debounced at <duration>'
|
|
||||||
;; — parsed as handler modifiers, captured as :throttle / :debounce parts.
|
|
||||||
(when (and (= (tp-type) "ident") (= (tp-val) "throttled"))
|
|
||||||
(adv!)
|
|
||||||
(when (match-kw "at") (set! throttle-ms (parse-expr))))
|
|
||||||
(when (and (= (tp-type) "ident") (= (tp-val) "debounced"))
|
|
||||||
(adv!)
|
|
||||||
(when (match-kw "at") (set! debounce-ms (parse-expr))))
|
|
||||||
(let
|
(let
|
||||||
((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
|
((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
|
||||||
(let
|
(let
|
||||||
@@ -3125,10 +3105,6 @@
|
|||||||
(match-kw "end")
|
(match-kw "end")
|
||||||
(let
|
(let
|
||||||
((parts (list (quote on) event-name)))
|
((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
|
(let
|
||||||
((parts (if every? (append parts (list :every true)) parts)))
|
((parts (if every? (append parts (list :every true)) parts)))
|
||||||
(let
|
(let
|
||||||
@@ -3151,7 +3127,7 @@
|
|||||||
((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
|
((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
|
||||||
(let
|
(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 (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
|
(define
|
||||||
parse-init-feat
|
parse-init-feat
|
||||||
(fn
|
(fn
|
||||||
@@ -3201,7 +3177,6 @@
|
|||||||
(or
|
(or
|
||||||
(= (tp-type) "hat")
|
(= (tp-type) "hat")
|
||||||
(= (tp-type) "local")
|
(= (tp-type) "local")
|
||||||
(= (tp-type) "attr")
|
|
||||||
(and (= (tp-type) "keyword") (= (tp-val) "dom")))
|
(and (= (tp-type) "keyword") (= (tp-val) "dom")))
|
||||||
(let
|
(let
|
||||||
((expr (parse-expr)))
|
((expr (parse-expr)))
|
||||||
|
|||||||
@@ -12,29 +12,6 @@
|
|||||||
|
|
||||||
;; Register an event listener. Returns unlisten function.
|
;; Register an event listener. Returns unlisten function.
|
||||||
;; (hs-on target event-name handler) → unlisten-fn
|
;; (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
|
(define
|
||||||
hs-each
|
hs-each
|
||||||
(fn
|
(fn
|
||||||
@@ -45,52 +22,17 @@
|
|||||||
;; (hs-init thunk) — called at element boot time
|
;; (hs-init thunk) — called at element boot time
|
||||||
(define meta (host-new "Object"))
|
(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 ──────────────────────────────────────────────
|
;; ── Async / timing ──────────────────────────────────────────────
|
||||||
|
|
||||||
;; Wait for a duration in milliseconds.
|
;; Wait for a duration in milliseconds.
|
||||||
;; In hyperscript, wait is async-transparent — execution pauses.
|
;; In hyperscript, wait is async-transparent — execution pauses.
|
||||||
;; Here we use perform/IO suspension for true pause semantics.
|
;; 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
|
(define
|
||||||
_hs-on-caller
|
_hs-on-caller
|
||||||
(let
|
(let
|
||||||
@@ -103,7 +45,8 @@
|
|||||||
(host-set! _ctx "meta" _m)
|
(host-set! _ctx "meta" _m)
|
||||||
_ctx)))
|
_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
|
(define
|
||||||
hs-on
|
hs-on
|
||||||
(fn
|
(fn
|
||||||
@@ -123,14 +66,14 @@
|
|||||||
(append prev (list unlisten)))
|
(append prev (list unlisten)))
|
||||||
unlisten))))))
|
unlisten))))))
|
||||||
|
|
||||||
;; ── Class manipulation ──────────────────────────────────────────
|
;; Wait for CSS transitions/animations to settle on an element.
|
||||||
|
|
||||||
;; Toggle a single class on an element.
|
|
||||||
(define
|
(define
|
||||||
hs-on-every
|
hs-on-every
|
||||||
(fn (target event-name handler) (dom-listen target event-name handler)))
|
(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
|
(define
|
||||||
hs-on-intersection-attach!
|
hs-on-intersection-attach!
|
||||||
(fn
|
(fn
|
||||||
@@ -146,8 +89,7 @@
|
|||||||
(host-call observer "observe" target)
|
(host-call observer "observe" target)
|
||||||
observer)))))
|
observer)))))
|
||||||
|
|
||||||
;; Take a class from siblings — add to target, remove from others.
|
;; Toggle between two classes — exactly one is active at a time.
|
||||||
;; (hs-take! target cls) — like radio button class behavior
|
|
||||||
(define
|
(define
|
||||||
hs-on-mutation-attach!
|
hs-on-mutation-attach!
|
||||||
(fn
|
(fn
|
||||||
@@ -168,18 +110,19 @@
|
|||||||
(host-call observer "observe" target opts)
|
(host-call observer "observe" target opts)
|
||||||
observer))))))
|
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 ───────────────────────────────────────────────
|
;; ── DOM insertion ───────────────────────────────────────────────
|
||||||
|
|
||||||
;; Put content at a position relative to a target.
|
;; Put content at a position relative to a target.
|
||||||
;; pos: "into" | "before" | "after"
|
;; pos: "into" | "before" | "after"
|
||||||
(define hs-init (fn (thunk) (thunk)))
|
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
|
||||||
|
|
||||||
;; ── Navigation / traversal ──────────────────────────────────────
|
;; ── Navigation / traversal ──────────────────────────────────────
|
||||||
|
|
||||||
;; Navigate to a URL.
|
;; 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
|
(begin
|
||||||
(define
|
(define
|
||||||
hs-wait-for
|
hs-wait-for
|
||||||
@@ -192,7 +135,7 @@
|
|||||||
(target event-name timeout-ms)
|
(target event-name timeout-ms)
|
||||||
(perform (list (quote io-wait-event) 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
|
(define
|
||||||
hs-settle
|
hs-settle
|
||||||
(fn
|
(fn
|
||||||
@@ -200,7 +143,7 @@
|
|||||||
(hs-null-raise! target)
|
(hs-null-raise! target)
|
||||||
(when (not (nil? target)) (perform (list (quote io-settle) 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
|
(define
|
||||||
hs-toggle-class!
|
hs-toggle-class!
|
||||||
(fn
|
(fn
|
||||||
@@ -210,7 +153,7 @@
|
|||||||
(not (nil? target))
|
(not (nil? target))
|
||||||
(host-call (host-get target "classList") "toggle" cls))))
|
(host-call (host-get target "classList") "toggle" cls))))
|
||||||
|
|
||||||
;; Last element matching selector.
|
;; First element matching selector within a scope.
|
||||||
(define
|
(define
|
||||||
hs-toggle-var-cycle!
|
hs-toggle-var-cycle!
|
||||||
(fn
|
(fn
|
||||||
@@ -232,7 +175,7 @@
|
|||||||
var-name
|
var-name
|
||||||
(if (= idx -1) (first values) (nth values (mod (+ idx 1) n))))))))
|
(if (= idx -1) (first values) (nth values (mod (+ idx 1) n))))))))
|
||||||
|
|
||||||
;; First/last within a specific scope.
|
;; Last element matching selector.
|
||||||
(define
|
(define
|
||||||
hs-toggle-between!
|
hs-toggle-between!
|
||||||
(fn
|
(fn
|
||||||
@@ -245,6 +188,7 @@
|
|||||||
(do (dom-remove-class target cls1) (dom-add-class target cls2))
|
(do (dom-remove-class target cls1) (dom-add-class target cls2))
|
||||||
(do (dom-remove-class target cls2) (dom-add-class target cls1))))))
|
(do (dom-remove-class target cls2) (dom-add-class target cls1))))))
|
||||||
|
|
||||||
|
;; First/last within a specific scope.
|
||||||
(define
|
(define
|
||||||
hs-toggle-style!
|
hs-toggle-style!
|
||||||
(fn
|
(fn
|
||||||
@@ -268,9 +212,6 @@
|
|||||||
(dom-set-style target prop "hidden")
|
(dom-set-style target prop "hidden")
|
||||||
(dom-set-style target prop "")))))))
|
(dom-set-style target prop "")))))))
|
||||||
|
|
||||||
;; ── Iteration ───────────────────────────────────────────────────
|
|
||||||
|
|
||||||
;; Repeat a thunk N times.
|
|
||||||
(define
|
(define
|
||||||
hs-toggle-style-between!
|
hs-toggle-style-between!
|
||||||
(fn
|
(fn
|
||||||
@@ -282,7 +223,9 @@
|
|||||||
(dom-set-style target prop val2)
|
(dom-set-style target prop val2)
|
||||||
(dom-set-style target prop val1)))))
|
(dom-set-style target prop val1)))))
|
||||||
|
|
||||||
;; Repeat forever (until break — relies on exception/continuation).
|
;; ── Iteration ───────────────────────────────────────────────────
|
||||||
|
|
||||||
|
;; Repeat a thunk N times.
|
||||||
(define
|
(define
|
||||||
hs-toggle-style-cycle!
|
hs-toggle-style-cycle!
|
||||||
(fn
|
(fn
|
||||||
@@ -303,10 +246,7 @@
|
|||||||
(true (find-next (rest remaining))))))
|
(true (find-next (rest remaining))))))
|
||||||
(dom-set-style target prop (find-next vals)))))
|
(dom-set-style target prop (find-next vals)))))
|
||||||
|
|
||||||
;; ── Fetch ───────────────────────────────────────────────────────
|
;; Repeat forever (until break — relies on exception/continuation).
|
||||||
|
|
||||||
;; Fetch a URL, parse response according to format.
|
|
||||||
;; (hs-fetch url format) — format is "json" | "text" | "html"
|
|
||||||
(define
|
(define
|
||||||
hs-take!
|
hs-take!
|
||||||
(fn
|
(fn
|
||||||
@@ -329,7 +269,8 @@
|
|||||||
(when with-cls (dom-remove-class target with-cls))))
|
(when with-cls (dom-remove-class target with-cls))))
|
||||||
(let
|
(let
|
||||||
((attr-val (if (> (len extra) 0) (first extra) nil))
|
((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
|
(do
|
||||||
(for-each
|
(for-each
|
||||||
(fn
|
(fn
|
||||||
@@ -346,10 +287,10 @@
|
|||||||
(dom-set-attr target name attr-val)
|
(dom-set-attr target name attr-val)
|
||||||
(dom-set-attr target name ""))))))))
|
(dom-set-attr target name ""))))))))
|
||||||
|
|
||||||
;; ── Type coercion ───────────────────────────────────────────────
|
;; ── Fetch ───────────────────────────────────────────────────────
|
||||||
|
|
||||||
;; Coerce a value to a type by name.
|
;; Fetch a URL, parse response according to format.
|
||||||
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
|
;; (hs-fetch url format) — format is "json" | "text" | "html"
|
||||||
(begin
|
(begin
|
||||||
(define
|
(define
|
||||||
hs-element?
|
hs-element?
|
||||||
@@ -506,10 +447,10 @@
|
|||||||
(dom-insert-adjacent-html target "beforeend" value)
|
(dom-insert-adjacent-html target "beforeend" value)
|
||||||
(hs-boot-subtree! target)))))))))))
|
(hs-boot-subtree! target)))))))))))
|
||||||
|
|
||||||
;; ── Object creation ─────────────────────────────────────────────
|
;; ── Type coercion ───────────────────────────────────────────────
|
||||||
|
|
||||||
;; Make a new object of a given type.
|
;; Coerce a value to a type by name.
|
||||||
;; (hs-make type-name) — creates empty object/collection
|
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
|
||||||
(define
|
(define
|
||||||
hs-add-to!
|
hs-add-to!
|
||||||
(fn
|
(fn
|
||||||
@@ -523,11 +464,10 @@
|
|||||||
((hs-is-set? target) (do (host-call target "add" value) target))
|
((hs-is-set? target) (do (host-call target "add" value) target))
|
||||||
(true (do (host-call target "push" value) target)))))
|
(true (do (host-call target "push" value) target)))))
|
||||||
|
|
||||||
;; ── Behavior installation ───────────────────────────────────────
|
;; ── Object creation ─────────────────────────────────────────────
|
||||||
|
|
||||||
;; Install a behavior on an element.
|
;; Make a new object of a given type.
|
||||||
;; A behavior is a function that takes (me ...params) and sets up features.
|
;; (hs-make type-name) — creates empty object/collection
|
||||||
;; (hs-install behavior-fn me ...args)
|
|
||||||
(define
|
(define
|
||||||
hs-remove-from!
|
hs-remove-from!
|
||||||
(fn
|
(fn
|
||||||
@@ -537,10 +477,11 @@
|
|||||||
((hs-is-set? target) (do (host-call target "delete" value) target))
|
((hs-is-set? target) (do (host-call target "delete" value) target))
|
||||||
(true (host-call target "splice" (host-call target "indexOf" value) 1)))))
|
(true (host-call target "splice" (host-call target "indexOf" value) 1)))))
|
||||||
|
|
||||||
;; ── Measurement ─────────────────────────────────────────────────
|
;; ── Behavior installation ───────────────────────────────────────
|
||||||
|
|
||||||
;; Measure an element's bounding rect, store as local variables.
|
;; Install a behavior on an element.
|
||||||
;; Returns a dict with x, y, width, height, top, left, right, bottom.
|
;; A behavior is a function that takes (me ...params) and sets up features.
|
||||||
|
;; (hs-install behavior-fn me ...args)
|
||||||
(define
|
(define
|
||||||
hs-splice-at!
|
hs-splice-at!
|
||||||
(fn
|
(fn
|
||||||
@@ -553,7 +494,10 @@
|
|||||||
((i (if (< idx 0) (+ n idx) idx)))
|
((i (if (< idx 0) (+ n idx) idx)))
|
||||||
(cond
|
(cond
|
||||||
((or (< i 0) (>= i n)) target)
|
((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
|
(do
|
||||||
(when
|
(when
|
||||||
target
|
target
|
||||||
@@ -564,10 +508,10 @@
|
|||||||
(host-call target "splice" i 1))))
|
(host-call target "splice" i 1))))
|
||||||
target))))
|
target))))
|
||||||
|
|
||||||
;; Return the current text selection as a string. In the browser this is
|
;; ── Measurement ─────────────────────────────────────────────────
|
||||||
;; `window.getSelection().toString()`. In the mock test runner, a test
|
|
||||||
;; setup stashes the desired selection text at `window.__test_selection`
|
;; Measure an element's bounding rect, store as local variables.
|
||||||
;; and the fallback path returns that so tests can assert on the result.
|
;; Returns a dict with x, y, width, height, top, left, right, bottom.
|
||||||
(define
|
(define
|
||||||
hs-index
|
hs-index
|
||||||
(fn
|
(fn
|
||||||
@@ -579,11 +523,10 @@
|
|||||||
((string? obj) (nth obj key))
|
((string? obj) (nth obj key))
|
||||||
(true (host-get obj key)))))
|
(true (host-get obj key)))))
|
||||||
|
|
||||||
|
;; Return the current text selection as a string. In the browser this is
|
||||||
;; ── Transition ──────────────────────────────────────────────────
|
;; `window.getSelection().toString()`. In the mock test runner, a test
|
||||||
|
;; setup stashes the desired selection text at `window.__test_selection`
|
||||||
;; Transition a CSS property to a value, optionally with duration.
|
;; and the fallback path returns that so tests can assert on the result.
|
||||||
;; (hs-transition target prop value duration)
|
|
||||||
(define
|
(define
|
||||||
hs-put-at!
|
hs-put-at!
|
||||||
(fn
|
(fn
|
||||||
@@ -605,6 +548,11 @@
|
|||||||
((= pos "start") (host-call target "unshift" value)))
|
((= pos "start") (host-call target "unshift" value)))
|
||||||
target)))))))
|
target)))))))
|
||||||
|
|
||||||
|
|
||||||
|
;; ── Transition ──────────────────────────────────────────────────
|
||||||
|
|
||||||
|
;; Transition a CSS property to a value, optionally with duration.
|
||||||
|
;; (hs-transition target prop value duration)
|
||||||
(define
|
(define
|
||||||
hs-dict-without
|
hs-dict-without
|
||||||
(fn
|
(fn
|
||||||
@@ -641,11 +589,6 @@
|
|||||||
((w (host-global "window")))
|
((w (host-global "window")))
|
||||||
(if w (host-call w "prompt" msg) nil))))
|
(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
|
(define
|
||||||
hs-answer
|
hs-answer
|
||||||
(fn
|
(fn
|
||||||
@@ -654,6 +597,11 @@
|
|||||||
((w (host-global "window")))
|
((w (host-global "window")))
|
||||||
(if w (if (host-call w "confirm" msg) yes-val no-val) no-val))))
|
(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
|
(define
|
||||||
hs-answer-alert
|
hs-answer-alert
|
||||||
(fn
|
(fn
|
||||||
@@ -714,10 +662,6 @@
|
|||||||
(if (nil? sel) "" (host-call sel "toString" (list))))
|
(if (nil? sel) "" (host-call sel "toString" (list))))
|
||||||
stash)))))
|
stash)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define
|
(define
|
||||||
hs-reset!
|
hs-reset!
|
||||||
(fn
|
(fn
|
||||||
@@ -764,6 +708,10 @@
|
|||||||
(when default-val (dom-set-prop target "value" default-val)))))
|
(when default-val (dom-set-prop target "value" default-val)))))
|
||||||
(true nil)))))))
|
(true nil)))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define
|
(define
|
||||||
hs-next
|
hs-next
|
||||||
(fn
|
(fn
|
||||||
@@ -782,8 +730,7 @@
|
|||||||
((dom-matches? el sel) el)
|
((dom-matches? el sel) el)
|
||||||
(true (find-next (dom-next-sibling el))))))
|
(true (find-next (dom-next-sibling el))))))
|
||||||
(find-next sibling)))))
|
(find-next sibling)))))
|
||||||
;; ── Sandbox/test runtime additions ──────────────────────────────
|
|
||||||
;; Property access — dot notation and .length
|
|
||||||
(define
|
(define
|
||||||
hs-previous
|
hs-previous
|
||||||
(fn
|
(fn
|
||||||
@@ -802,9 +749,10 @@
|
|||||||
((dom-matches? el sel) el)
|
((dom-matches? el sel) el)
|
||||||
(true (find-prev (dom-get-prop el "previousElementSibling"))))))
|
(true (find-prev (dom-get-prop el "previousElementSibling"))))))
|
||||||
(find-prev sibling)))))
|
(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)
|
(define _hs-last-query-sel nil)
|
||||||
;; Method dispatch — obj.method(args)
|
;; DOM query stub — sandbox returns empty list
|
||||||
(define
|
(define
|
||||||
hs-null-raise!
|
hs-null-raise!
|
||||||
(fn
|
(fn
|
||||||
@@ -815,9 +763,7 @@
|
|||||||
((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
|
((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
|
||||||
(host-set! (host-global "window") "_hs_null_error" msg)
|
(host-set! (host-global "window") "_hs_null_error" msg)
|
||||||
(guard (_null-e (true nil)) (raise msg))))))
|
(guard (_null-e (true nil)) (raise msg))))))
|
||||||
|
;; Method dispatch — obj.method(args)
|
||||||
;; ── 0.9.90 features ─────────────────────────────────────────────
|
|
||||||
;; beep! — debug logging, returns value unchanged
|
|
||||||
(define
|
(define
|
||||||
hs-empty-raise!
|
hs-empty-raise!
|
||||||
(fn
|
(fn
|
||||||
@@ -831,7 +777,9 @@
|
|||||||
((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
|
((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
|
||||||
(host-set! (host-global "window") "_hs_null_error" msg)
|
(host-set! (host-global "window") "_hs_null_error" msg)
|
||||||
(guard (_null-e (true nil)) (raise 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
|
(define
|
||||||
hs-query-all-checked
|
hs-query-all-checked
|
||||||
(fn
|
(fn
|
||||||
@@ -839,14 +787,14 @@
|
|||||||
(let
|
(let
|
||||||
((result (hs-query-all sel)))
|
((result (hs-query-all sel)))
|
||||||
(do (hs-empty-raise! result) result))))
|
(do (hs-empty-raise! result) result))))
|
||||||
;; Array slicing (inclusive both ends)
|
;; Property-based is — check obj.key truthiness
|
||||||
(define
|
(define
|
||||||
hs-dispatch!
|
hs-dispatch!
|
||||||
(fn
|
(fn
|
||||||
(target event detail)
|
(target event detail)
|
||||||
(hs-null-raise! target)
|
(hs-null-raise! target)
|
||||||
(when (not (nil? target)) (dom-dispatch target event detail))))
|
(when (not (nil? target)) (dom-dispatch target event detail))))
|
||||||
;; Collection: sorted by
|
;; Array slicing (inclusive both ends)
|
||||||
(define
|
(define
|
||||||
hs-query-all
|
hs-query-all
|
||||||
(fn
|
(fn
|
||||||
@@ -854,7 +802,7 @@
|
|||||||
(do
|
(do
|
||||||
(host-set! (host-global "window") "_hs_last_query_sel" sel)
|
(host-set! (host-global "window") "_hs_last_query_sel" sel)
|
||||||
(dom-query-all (dom-document) sel))))
|
(dom-query-all (dom-document) sel))))
|
||||||
;; Collection: sorted by descending
|
;; Collection: sorted by
|
||||||
(define
|
(define
|
||||||
hs-query-all-in
|
hs-query-all-in
|
||||||
(fn
|
(fn
|
||||||
@@ -863,17 +811,17 @@
|
|||||||
(nil? target)
|
(nil? target)
|
||||||
(hs-query-all sel)
|
(hs-query-all sel)
|
||||||
(host-call target "querySelectorAll" sel))))
|
(host-call target "querySelectorAll" sel))))
|
||||||
;; Collection: split by
|
;; Collection: sorted by descending
|
||||||
(define
|
(define
|
||||||
hs-list-set
|
hs-list-set
|
||||||
(fn
|
(fn
|
||||||
(lst idx val)
|
(lst idx val)
|
||||||
(append (take lst idx) (cons val (drop lst (+ idx 1))))))
|
(append (take lst idx) (cons val (drop lst (+ idx 1))))))
|
||||||
;; Collection: joined by
|
;; Collection: split by
|
||||||
(define
|
(define
|
||||||
hs-to-number
|
hs-to-number
|
||||||
(fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
|
(fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
|
||||||
|
;; Collection: joined by
|
||||||
(define
|
(define
|
||||||
hs-query-first
|
hs-query-first
|
||||||
(fn
|
(fn
|
||||||
@@ -1003,7 +951,7 @@
|
|||||||
((= (str ex) "hs-continue") (do-loop (rest remaining)))
|
((= (str ex) "hs-continue") (do-loop (rest remaining)))
|
||||||
(true (raise ex))))))))
|
(true (raise ex))))))))
|
||||||
(do-loop items))))
|
(do-loop items))))
|
||||||
;; Collection: joined by
|
|
||||||
(begin
|
(begin
|
||||||
(define
|
(define
|
||||||
hs-append
|
hs-append
|
||||||
@@ -1044,7 +992,7 @@
|
|||||||
(host-get value "outerHTML")
|
(host-get value "outerHTML")
|
||||||
(str value))))
|
(str value))))
|
||||||
(true nil)))))
|
(true nil)))))
|
||||||
|
;; Collection: joined by
|
||||||
(define
|
(define
|
||||||
hs-sender
|
hs-sender
|
||||||
(fn
|
(fn
|
||||||
@@ -1136,7 +1084,6 @@
|
|||||||
(hs-host-to-sx (perform (list "io-parse-json" raw))))
|
(hs-host-to-sx (perform (list "io-parse-json" raw))))
|
||||||
((= fmt "number")
|
((= fmt "number")
|
||||||
(hs-to-number (perform (list "io-parse-text" raw))))
|
(hs-to-number (perform (list "io-parse-text" raw))))
|
||||||
((= fmt "html") (perform (list "io-parse-html" raw)))
|
|
||||||
(true (perform (list "io-parse-text" raw)))))))))
|
(true (perform (list "io-parse-text" raw)))))))))
|
||||||
|
|
||||||
(define hs-fetch (fn (url format) (hs-fetch-impl url format false)))
|
(define hs-fetch (fn (url format) (hs-fetch-impl url format false)))
|
||||||
@@ -1676,10 +1623,14 @@
|
|||||||
((ch (substring sel i (+ i 1))))
|
((ch (substring sel i (+ i 1))))
|
||||||
(cond
|
(cond
|
||||||
((= ch ".")
|
((= ch ".")
|
||||||
(do (flush!) (set! mode "class") (walk (+ i 1))))
|
(do
|
||||||
|
(flush!)
|
||||||
|
(set! mode "class")
|
||||||
|
(walk (+ i 1))))
|
||||||
((= ch "#")
|
((= ch "#")
|
||||||
(do (flush!) (set! mode "id") (walk (+ i 1))))
|
(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)
|
(walk 0)
|
||||||
(flush!)
|
(flush!)
|
||||||
{:tag tag :classes classes :id id}))))
|
{:tag tag :classes classes :id id}))))
|
||||||
@@ -1773,11 +1724,11 @@
|
|||||||
(value type-name)
|
(value type-name)
|
||||||
(if (nil? value) false (hs-type-check value type-name))))
|
(if (nil? value) false (hs-type-check value type-name))))
|
||||||
|
|
||||||
|
|
||||||
(define
|
(define
|
||||||
hs-strict-eq
|
hs-strict-eq
|
||||||
(fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
|
(fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
|
||||||
|
|
||||||
|
|
||||||
(define
|
(define
|
||||||
hs-id=
|
hs-id=
|
||||||
(fn
|
(fn
|
||||||
@@ -1809,20 +1760,6 @@
|
|||||||
((nil? suffix) false)
|
((nil? suffix) false)
|
||||||
(true (ends-with? (str s) (str suffix))))))
|
(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
|
(define
|
||||||
hs-scoped-set!
|
hs-scoped-set!
|
||||||
(fn
|
(fn
|
||||||
@@ -1868,7 +1805,10 @@
|
|||||||
((and (dict? a) (dict? b))
|
((and (dict? a) (dict? b))
|
||||||
(let
|
(let
|
||||||
((pos (host-call a "compareDocumentPosition" b)))
|
((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))))))
|
(true (< (str a) (str b))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -1989,7 +1929,10 @@
|
|||||||
((and (dict? a) (dict? b))
|
((and (dict? a) (dict? b))
|
||||||
(let
|
(let
|
||||||
((pos (host-call a "compareDocumentPosition" b)))
|
((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))))))
|
(true (< (str a) (str b))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -2042,7 +1985,9 @@
|
|||||||
|
|
||||||
(define
|
(define
|
||||||
hs-morph-char
|
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
|
(define
|
||||||
hs-morph-index-from
|
hs-morph-index-from
|
||||||
@@ -2070,7 +2015,10 @@
|
|||||||
(q)
|
(q)
|
||||||
(let
|
(let
|
||||||
((c (hs-morph-char s q)))
|
((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))))
|
(let ((e (loop p))) (list (substring s p e) e))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -2112,7 +2060,9 @@
|
|||||||
(append
|
(append
|
||||||
acc
|
acc
|
||||||
(list
|
(list
|
||||||
(list name (substring s (+ p4 1) close)))))))
|
(list
|
||||||
|
name
|
||||||
|
(substring s (+ p4 1) close)))))))
|
||||||
((= c2 "'")
|
((= c2 "'")
|
||||||
(let
|
(let
|
||||||
((close (hs-morph-index-from s "'" (+ p4 1))))
|
((close (hs-morph-index-from s "'" (+ p4 1))))
|
||||||
@@ -2122,7 +2072,9 @@
|
|||||||
(append
|
(append
|
||||||
acc
|
acc
|
||||||
(list
|
(list
|
||||||
(list name (substring s (+ p4 1) close)))))))
|
(list
|
||||||
|
name
|
||||||
|
(substring s (+ p4 1) close)))))))
|
||||||
(true
|
(true
|
||||||
(let
|
(let
|
||||||
((r2 (hs-morph-read-until s p4 " \t\n/>")))
|
((r2 (hs-morph-read-until s p4 " \t\n/>")))
|
||||||
@@ -2206,7 +2158,9 @@
|
|||||||
(for-each
|
(for-each
|
||||||
(fn
|
(fn
|
||||||
(c)
|
(c)
|
||||||
(when (> (string-length c) 0) (dom-add-class el c)))
|
(when
|
||||||
|
(> (string-length c) 0)
|
||||||
|
(dom-add-class el c)))
|
||||||
(split v " ")))
|
(split v " ")))
|
||||||
((and keep-id (= n "id")) nil)
|
((and keep-id (= n "id")) nil)
|
||||||
(true (dom-set-attr el n v)))))
|
(true (dom-set-attr el n v)))))
|
||||||
@@ -2307,7 +2261,8 @@
|
|||||||
((parts (split resolved ":")))
|
((parts (split resolved ":")))
|
||||||
(let
|
(let
|
||||||
((prop (first parts))
|
((prop (first parts))
|
||||||
(val (if (> (len parts) 1) (nth parts 1) nil)))
|
(val
|
||||||
|
(if (> (len parts) 1) (nth parts 1) nil)))
|
||||||
(cond
|
(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))
|
((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
|
(let
|
||||||
@@ -2347,7 +2302,8 @@
|
|||||||
((parts (split resolved ":")))
|
((parts (split resolved ":")))
|
||||||
(let
|
(let
|
||||||
((prop (first parts))
|
((prop (first parts))
|
||||||
(val (if (> (len parts) 1) (nth parts 1) nil)))
|
(val
|
||||||
|
(if (> (len parts) 1) (nth parts 1) nil)))
|
||||||
(cond
|
(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))
|
((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
|
(let
|
||||||
@@ -2452,10 +2408,14 @@
|
|||||||
(if
|
(if
|
||||||
(= depth 1)
|
(= depth 1)
|
||||||
j
|
j
|
||||||
(find-close (+ j 1) (- depth 1)))
|
(find-close
|
||||||
|
(+ j 1)
|
||||||
|
(- depth 1)))
|
||||||
(if
|
(if
|
||||||
(= (nth raw j) "{")
|
(= (nth raw j) "{")
|
||||||
(find-close (+ j 1) (+ depth 1))
|
(find-close
|
||||||
|
(+ j 1)
|
||||||
|
(+ depth 1))
|
||||||
(find-close (+ j 1) depth))))))
|
(find-close (+ j 1) depth))))))
|
||||||
(let
|
(let
|
||||||
((close (find-close start 1)))
|
((close (find-close start 1)))
|
||||||
@@ -2566,7 +2526,10 @@
|
|||||||
(if
|
(if
|
||||||
(= (len lst) 0)
|
(= (len lst) 0)
|
||||||
-1
|
-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)))
|
(idx-loop obj 0)))
|
||||||
(true
|
(true
|
||||||
(let
|
(let
|
||||||
@@ -2658,7 +2621,8 @@
|
|||||||
(cond
|
(cond
|
||||||
((= end "hs-pick-end") n)
|
((= end "hs-pick-end") n)
|
||||||
((= end "hs-pick-start") 0)
|
((= 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))))
|
(true end))))
|
||||||
(cond
|
(cond
|
||||||
((string? col) (slice col s e))
|
((string? col) (slice col s e))
|
||||||
@@ -2838,8 +2802,6 @@
|
|||||||
hs-sorted-by-desc
|
hs-sorted-by-desc
|
||||||
(fn (col key-fn) (reverse (hs-sorted-by col key-fn))))
|
(fn (col key-fn) (reverse (hs-sorted-by col key-fn))))
|
||||||
|
|
||||||
;; ── SourceInfo API ────────────────────────────────────────────────
|
|
||||||
|
|
||||||
(define
|
(define
|
||||||
hs-dom-has-var?
|
hs-dom-has-var?
|
||||||
(fn
|
(fn
|
||||||
@@ -2859,6 +2821,8 @@
|
|||||||
((store (host-get el "__hs_vars")))
|
((store (host-get el "__hs_vars")))
|
||||||
(if (nil? store) nil (host-get store name)))))
|
(if (nil? store) nil (host-get store name)))))
|
||||||
|
|
||||||
|
;; ── SourceInfo API ────────────────────────────────────────────────
|
||||||
|
|
||||||
(define
|
(define
|
||||||
hs-dom-set-var-raw!
|
hs-dom-set-var-raw!
|
||||||
(fn
|
(fn
|
||||||
@@ -2949,12 +2913,7 @@
|
|||||||
|
|
||||||
(define
|
(define
|
||||||
hs-null-error!
|
hs-null-error!
|
||||||
(fn
|
(fn (selector) (raise (str "'" selector "' is null"))))
|
||||||
(selector)
|
|
||||||
(let
|
|
||||||
((msg (str "'" selector "' is null")))
|
|
||||||
(host-set! (host-global "window") "_hs_null_error" msg)
|
|
||||||
(guard (_null-e (true nil)) (raise msg)))))
|
|
||||||
|
|
||||||
(define
|
(define
|
||||||
hs-named-target
|
hs-named-target
|
||||||
@@ -2974,7 +2933,9 @@
|
|||||||
((results (hs-query-all selector)))
|
((results (hs-query-all selector)))
|
||||||
(if
|
(if
|
||||||
(and
|
(and
|
||||||
(or (nil? results) (and (list? results) (= (len results) 0)))
|
(or
|
||||||
|
(nil? results)
|
||||||
|
(and (list? results) (= (len results) 0)))
|
||||||
(string? selector)
|
(string? selector)
|
||||||
(> (len selector) 0)
|
(> (len selector) 0)
|
||||||
(= (substring selector 0 1) "#"))
|
(= (substring selector 0 1) "#"))
|
||||||
|
|||||||
@@ -856,229 +856,3 @@
|
|||||||
(scan-template!)
|
(scan-template!)
|
||||||
(t-emit! "eof" nil)
|
(t-emit! "eof" nil)
|
||||||
tokens)))
|
tokens)))
|
||||||
|
|
||||||
;; ── Stream wrapper for upstream-style stateful tokenizer API ───────────────
|
|
||||||
;;
|
|
||||||
;; Upstream _hyperscript exposes a Tokens object with cursor + follow-set
|
|
||||||
;; semantics on _hyperscript.internals.tokenizer. Our hs-tokenize returns a
|
|
||||||
;; flat list; the stream wrapper adds the stateful operations.
|
|
||||||
;;
|
|
||||||
;; Type names map ours → upstream's (e.g. "ident" → "IDENTIFIER").
|
|
||||||
|
|
||||||
(define
|
|
||||||
hs-stream-type-map
|
|
||||||
(fn
|
|
||||||
(t)
|
|
||||||
(cond
|
|
||||||
((= t "ident") "IDENTIFIER")
|
|
||||||
((= t "number") "NUMBER")
|
|
||||||
((= t "string") "STRING")
|
|
||||||
((= t "class") "CLASS_REF")
|
|
||||||
((= t "id") "ID_REF")
|
|
||||||
((= t "attr") "ATTRIBUTE_REF")
|
|
||||||
((= t "style") "STYLE_REF")
|
|
||||||
((= t "whitespace") "WHITESPACE")
|
|
||||||
((= t "op") "OPERATOR")
|
|
||||||
((= t "eof") "EOF")
|
|
||||||
(true (upcase t)))))
|
|
||||||
|
|
||||||
;; Create a stream from a source string.
|
|
||||||
;; Returns a dict — mutable via dict-set!.
|
|
||||||
(define
|
|
||||||
hs-stream
|
|
||||||
(fn
|
|
||||||
(src)
|
|
||||||
{:tokens (hs-tokenize src) :pos 0 :follows (list) :last-match nil :last-ws nil}))
|
|
||||||
|
|
||||||
;; Skip whitespace tokens, advancing pos to the next non-WS token.
|
|
||||||
;; Captures the last skipped whitespace value into :last-ws.
|
|
||||||
(define
|
|
||||||
hs-stream-skip-ws!
|
|
||||||
(fn
|
|
||||||
(s)
|
|
||||||
(let
|
|
||||||
((tokens (get s :tokens)))
|
|
||||||
(define
|
|
||||||
loop
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(let
|
|
||||||
((p (get s :pos)))
|
|
||||||
(when
|
|
||||||
(and (< p (len tokens))
|
|
||||||
(= (get (nth tokens p) :type) "whitespace"))
|
|
||||||
(do
|
|
||||||
(dict-set! s :last-ws (get (nth tokens p) :value))
|
|
||||||
(dict-set! s :pos (+ p 1))
|
|
||||||
(loop))))))
|
|
||||||
(loop))))
|
|
||||||
|
|
||||||
;; Current token (after skipping whitespace).
|
|
||||||
(define
|
|
||||||
hs-stream-current
|
|
||||||
(fn
|
|
||||||
(s)
|
|
||||||
(do
|
|
||||||
(hs-stream-skip-ws! s)
|
|
||||||
(let
|
|
||||||
((tokens (get s :tokens)) (p (get s :pos)))
|
|
||||||
(if (< p (len tokens)) (nth tokens p) nil)))))
|
|
||||||
|
|
||||||
;; Returns the current token if its value matches; advances and updates
|
|
||||||
;; :last-match. Returns nil otherwise (no advance).
|
|
||||||
;; Honors the follow set: tokens whose value is in :follows do NOT match.
|
|
||||||
(define
|
|
||||||
hs-stream-match
|
|
||||||
(fn
|
|
||||||
(s value)
|
|
||||||
(let
|
|
||||||
((cur (hs-stream-current s)))
|
|
||||||
(cond
|
|
||||||
((nil? cur) nil)
|
|
||||||
((some (fn (f) (= f value)) (get s :follows)) nil)
|
|
||||||
((= (get cur :value) value)
|
|
||||||
(do
|
|
||||||
(dict-set! s :pos (+ (get s :pos) 1))
|
|
||||||
(dict-set! s :last-match cur)
|
|
||||||
cur))
|
|
||||||
(true nil)))))
|
|
||||||
|
|
||||||
;; Match by upstream-style type name. Accepts any number of allowed types.
|
|
||||||
(define
|
|
||||||
hs-stream-match-type
|
|
||||||
(fn
|
|
||||||
(s &rest types)
|
|
||||||
(let
|
|
||||||
((cur (hs-stream-current s)))
|
|
||||||
(cond
|
|
||||||
((nil? cur) nil)
|
|
||||||
((some (fn (t) (= (hs-stream-type-map (get cur :type)) t)) types)
|
|
||||||
(do
|
|
||||||
(dict-set! s :pos (+ (get s :pos) 1))
|
|
||||||
(dict-set! s :last-match cur)
|
|
||||||
cur))
|
|
||||||
(true nil)))))
|
|
||||||
|
|
||||||
;; Match if value is one of the given names.
|
|
||||||
(define
|
|
||||||
hs-stream-match-any
|
|
||||||
(fn
|
|
||||||
(s &rest names)
|
|
||||||
(let
|
|
||||||
((cur (hs-stream-current s)))
|
|
||||||
(cond
|
|
||||||
((nil? cur) nil)
|
|
||||||
((some (fn (n) (= (get cur :value) n)) names)
|
|
||||||
(do
|
|
||||||
(dict-set! s :pos (+ (get s :pos) 1))
|
|
||||||
(dict-set! s :last-match cur)
|
|
||||||
cur))
|
|
||||||
(true nil)))))
|
|
||||||
|
|
||||||
;; Match an op token whose value is in the list.
|
|
||||||
(define
|
|
||||||
hs-stream-match-any-op
|
|
||||||
(fn
|
|
||||||
(s &rest ops)
|
|
||||||
(let
|
|
||||||
((cur (hs-stream-current s)))
|
|
||||||
(cond
|
|
||||||
((nil? cur) nil)
|
|
||||||
((and (= (get cur :type) "op")
|
|
||||||
(some (fn (o) (= (get cur :value) o)) ops))
|
|
||||||
(do
|
|
||||||
(dict-set! s :pos (+ (get s :pos) 1))
|
|
||||||
(dict-set! s :last-match cur)
|
|
||||||
cur))
|
|
||||||
(true nil)))))
|
|
||||||
|
|
||||||
;; Peek N non-WS tokens ahead. Returns the token if its value matches; nil otherwise.
|
|
||||||
(define
|
|
||||||
hs-stream-peek
|
|
||||||
(fn
|
|
||||||
(s value offset)
|
|
||||||
(let
|
|
||||||
((tokens (get s :tokens)))
|
|
||||||
(define
|
|
||||||
skip-n-non-ws
|
|
||||||
(fn
|
|
||||||
(p remaining)
|
|
||||||
(cond
|
|
||||||
((>= p (len tokens)) -1)
|
|
||||||
((= (get (nth tokens p) :type) "whitespace")
|
|
||||||
(skip-n-non-ws (+ p 1) remaining))
|
|
||||||
((= remaining 0) p)
|
|
||||||
(true (skip-n-non-ws (+ p 1) (- remaining 1))))))
|
|
||||||
(let
|
|
||||||
((p (skip-n-non-ws (get s :pos) offset)))
|
|
||||||
(if (and (>= p 0) (< p (len tokens))
|
|
||||||
(= (get (nth tokens p) :value) value))
|
|
||||||
(nth tokens p)
|
|
||||||
nil)))))
|
|
||||||
|
|
||||||
;; Consume tokens until one whose value matches the marker. Returns
|
|
||||||
;; the consumed list (excluding the marker). Marker becomes current.
|
|
||||||
(define
|
|
||||||
hs-stream-consume-until
|
|
||||||
(fn
|
|
||||||
(s marker)
|
|
||||||
(let
|
|
||||||
((tokens (get s :tokens)) (out (list)))
|
|
||||||
(define
|
|
||||||
loop
|
|
||||||
(fn
|
|
||||||
(acc)
|
|
||||||
(let
|
|
||||||
((p (get s :pos)))
|
|
||||||
(cond
|
|
||||||
((>= p (len tokens)) acc)
|
|
||||||
((= (get (nth tokens p) :value) marker) acc)
|
|
||||||
(true
|
|
||||||
(do
|
|
||||||
(dict-set! s :pos (+ p 1))
|
|
||||||
(loop (append acc (list (nth tokens p))))))))))
|
|
||||||
(loop out))))
|
|
||||||
|
|
||||||
;; Consume until the next whitespace token; returns the consumed list.
|
|
||||||
(define
|
|
||||||
hs-stream-consume-until-ws
|
|
||||||
(fn
|
|
||||||
(s)
|
|
||||||
(let
|
|
||||||
((tokens (get s :tokens)))
|
|
||||||
(define
|
|
||||||
loop
|
|
||||||
(fn
|
|
||||||
(acc)
|
|
||||||
(let
|
|
||||||
((p (get s :pos)))
|
|
||||||
(cond
|
|
||||||
((>= p (len tokens)) acc)
|
|
||||||
((= (get (nth tokens p) :type) "whitespace") acc)
|
|
||||||
(true
|
|
||||||
(do
|
|
||||||
(dict-set! s :pos (+ p 1))
|
|
||||||
(loop (append acc (list (nth tokens p))))))))))
|
|
||||||
(loop (list)))))
|
|
||||||
|
|
||||||
;; Follow-set management.
|
|
||||||
(define hs-stream-push-follow! (fn (s v) (dict-set! s :follows (cons v (get s :follows)))))
|
|
||||||
(define
|
|
||||||
hs-stream-pop-follow!
|
|
||||||
(fn (s) (let ((f (get s :follows))) (when (> (len f) 0) (dict-set! s :follows (rest f))))))
|
|
||||||
(define
|
|
||||||
hs-stream-push-follows!
|
|
||||||
(fn (s vs) (for-each (fn (v) (hs-stream-push-follow! s v)) vs)))
|
|
||||||
(define
|
|
||||||
hs-stream-pop-follows!
|
|
||||||
(fn (s n) (when (> n 0) (do (hs-stream-pop-follow! s) (hs-stream-pop-follows! s (- n 1))))))
|
|
||||||
(define
|
|
||||||
hs-stream-clear-follows!
|
|
||||||
(fn (s) (let ((saved (get s :follows))) (do (dict-set! s :follows (list)) saved))))
|
|
||||||
(define
|
|
||||||
hs-stream-restore-follows!
|
|
||||||
(fn (s saved) (dict-set! s :follows saved)))
|
|
||||||
|
|
||||||
;; Last-consumed token / whitespace.
|
|
||||||
(define hs-stream-last-match (fn (s) (get s :last-match)))
|
|
||||||
(define hs-stream-last-ws (fn (s) (get s :last-ws)))
|
|
||||||
23
lib/ocaml/baseline/abundant.ml
Normal file
23
lib/ocaml/baseline/abundant.ml
Normal file
@@ -0,0 +1,23 @@
|
|||||||
|
let div_sum n =
|
||||||
|
let s = ref 1 in
|
||||||
|
let i = ref 2 in
|
||||||
|
while !i * !i <= n do
|
||||||
|
if n mod !i = 0 then begin
|
||||||
|
s := !s + !i;
|
||||||
|
let q = n / !i in
|
||||||
|
if q <> !i then s := !s + q
|
||||||
|
end;
|
||||||
|
i := !i + 1
|
||||||
|
done;
|
||||||
|
if n = 1 then 0 else !s
|
||||||
|
|
||||||
|
let count_abundant n =
|
||||||
|
let c = ref 0 in
|
||||||
|
for i = 12 to n - 1 do
|
||||||
|
if div_sum i > i then c := !c + 1
|
||||||
|
done;
|
||||||
|
!c
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
count_abundant 100
|
||||||
8
lib/ocaml/baseline/ackermann.ml
Normal file
8
lib/ocaml/baseline/ackermann.ml
Normal file
@@ -0,0 +1,8 @@
|
|||||||
|
let rec ack m n =
|
||||||
|
if m = 0 then n + 1
|
||||||
|
else if n = 0 then ack (m - 1) 1
|
||||||
|
else ack (m - 1) (ack m (n - 1))
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
ack 3 4
|
||||||
31
lib/ocaml/baseline/activity_select.ml
Normal file
31
lib/ocaml/baseline/activity_select.ml
Normal file
@@ -0,0 +1,31 @@
|
|||||||
|
let max_nonoverlap intervals =
|
||||||
|
let arr = Array.of_list intervals in
|
||||||
|
let n = Array.length arr in
|
||||||
|
let sorted = Array.make n (0, 0) in
|
||||||
|
for i = 0 to n - 1 do
|
||||||
|
sorted.(i) <- arr.(i)
|
||||||
|
done;
|
||||||
|
for i = 0 to n - 1 do
|
||||||
|
for j = 0 to n - 2 - i do
|
||||||
|
let (_, e1) = sorted.(j) in
|
||||||
|
let (_, e2) = sorted.(j + 1) in
|
||||||
|
if e1 > e2 then begin
|
||||||
|
let t = sorted.(j) in
|
||||||
|
sorted.(j) <- sorted.(j + 1);
|
||||||
|
sorted.(j + 1) <- t
|
||||||
|
end
|
||||||
|
done
|
||||||
|
done;
|
||||||
|
let count = ref 0 in
|
||||||
|
let last_end = ref (-1000000) in
|
||||||
|
for i = 0 to n - 1 do
|
||||||
|
let (s, e) = sorted.(i) in
|
||||||
|
if s >= !last_end then begin
|
||||||
|
count := !count + 1;
|
||||||
|
last_end := e
|
||||||
|
end
|
||||||
|
done;
|
||||||
|
!count
|
||||||
|
;;
|
||||||
|
|
||||||
|
max_nonoverlap [(1, 4); (3, 5); (0, 6); (5, 7); (3, 8); (5, 9); (6, 10); (8, 11); (8, 12); (2, 13); (12, 14)]
|
||||||
13
lib/ocaml/baseline/adler32.ml
Normal file
13
lib/ocaml/baseline/adler32.ml
Normal file
@@ -0,0 +1,13 @@
|
|||||||
|
let adler32 s =
|
||||||
|
let a = ref 1 in
|
||||||
|
let b = ref 0 in
|
||||||
|
let m = 65521 in
|
||||||
|
for i = 0 to String.length s - 1 do
|
||||||
|
a := (!a + Char.code s.[i]) mod m;
|
||||||
|
b := (!b + !a) mod m
|
||||||
|
done;
|
||||||
|
!b * 65536 + !a
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
adler32 "Wikipedia"
|
||||||
23
lib/ocaml/baseline/anagram_check.ml
Normal file
23
lib/ocaml/baseline/anagram_check.ml
Normal file
@@ -0,0 +1,23 @@
|
|||||||
|
let to_counts s =
|
||||||
|
let counts = Array.make 256 0 in
|
||||||
|
for i = 0 to String.length s - 1 do
|
||||||
|
let c = Char.code s.[i] in
|
||||||
|
counts.(c) <- counts.(c) + 1
|
||||||
|
done;
|
||||||
|
counts
|
||||||
|
|
||||||
|
let same_counts a b =
|
||||||
|
let result = ref true in
|
||||||
|
for i = 0 to 255 do
|
||||||
|
if a.(i) <> b.(i) then result := false
|
||||||
|
done;
|
||||||
|
!result
|
||||||
|
|
||||||
|
let is_anagram s t = same_counts (to_counts s) (to_counts t)
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
(if is_anagram "listen" "silent" then 1 else 0) +
|
||||||
|
(if is_anagram "hello" "world" then 1 else 0) +
|
||||||
|
(if is_anagram "anagram" "nagaram" then 1 else 0) +
|
||||||
|
(if is_anagram "abc" "abcd" then 1 else 0)
|
||||||
29
lib/ocaml/baseline/anagram_groups.ml
Normal file
29
lib/ocaml/baseline/anagram_groups.ml
Normal file
@@ -0,0 +1,29 @@
|
|||||||
|
let canonical s =
|
||||||
|
let chars = Array.make 26 0 in
|
||||||
|
for i = 0 to String.length s - 1 do
|
||||||
|
let k = Char.code s.[i] - Char.code 'a' in
|
||||||
|
if k >= 0 && k < 26 then chars.(k) <- chars.(k) + 1
|
||||||
|
done;
|
||||||
|
let buf = Buffer.create 26 in
|
||||||
|
for i = 0 to 25 do
|
||||||
|
for _ = 1 to chars.(i) do
|
||||||
|
Buffer.add_string buf (String.make 1 (Char.chr (i + Char.code 'a')))
|
||||||
|
done
|
||||||
|
done;
|
||||||
|
Buffer.contents buf
|
||||||
|
|
||||||
|
let group_anagrams xs =
|
||||||
|
let h = Hashtbl.create 8 in
|
||||||
|
List.iter (fun s ->
|
||||||
|
let k = canonical s in
|
||||||
|
let cur = match Hashtbl.find_opt h k with
|
||||||
|
| Some xs -> xs
|
||||||
|
| None -> []
|
||||||
|
in
|
||||||
|
Hashtbl.replace h k (s :: cur)
|
||||||
|
) xs;
|
||||||
|
Hashtbl.length h
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
group_anagrams ["eat"; "tea"; "tan"; "ate"; "nat"; "bat"]
|
||||||
26
lib/ocaml/baseline/anagrams.ml
Normal file
26
lib/ocaml/baseline/anagrams.ml
Normal file
@@ -0,0 +1,26 @@
|
|||||||
|
(* Baseline: count anagram groups using Hashtbl + sort *)
|
||||||
|
|
||||||
|
(* Sort the chars in a string to get its anagram-equivalence key *)
|
||||||
|
let canonical s =
|
||||||
|
let n = String.length s in
|
||||||
|
let chars = ref [] in
|
||||||
|
for i = 0 to n - 1 do
|
||||||
|
chars := (String.get s i) :: !chars
|
||||||
|
done ;
|
||||||
|
let sorted = List.sort compare !chars in
|
||||||
|
String.concat "" sorted
|
||||||
|
;;
|
||||||
|
|
||||||
|
let count_groups words =
|
||||||
|
let counts = Hashtbl.create 16 in
|
||||||
|
List.iter
|
||||||
|
(fun w ->
|
||||||
|
let k = canonical w in
|
||||||
|
match Hashtbl.find_opt counts k with
|
||||||
|
| None -> Hashtbl.add counts k 1
|
||||||
|
| Some n -> Hashtbl.replace counts k (n + 1))
|
||||||
|
words ;
|
||||||
|
Hashtbl.length counts
|
||||||
|
;;
|
||||||
|
|
||||||
|
count_groups ["eat"; "tea"; "tan"; "ate"; "nat"; "bat"]
|
||||||
17
lib/ocaml/baseline/atm.ml
Normal file
17
lib/ocaml/baseline/atm.ml
Normal file
@@ -0,0 +1,17 @@
|
|||||||
|
type account = { mutable balance : int }
|
||||||
|
|
||||||
|
exception Insufficient
|
||||||
|
|
||||||
|
let withdraw acct amt =
|
||||||
|
if amt > acct.balance then raise Insufficient
|
||||||
|
else acct.balance <- acct.balance - amt
|
||||||
|
|
||||||
|
let deposit acct amt = acct.balance <- acct.balance + amt
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
let a = { balance = 100 } in
|
||||||
|
deposit a 50;
|
||||||
|
withdraw a 30;
|
||||||
|
try (withdraw a 200; -1)
|
||||||
|
with Insufficient -> a.balance
|
||||||
18
lib/ocaml/baseline/bag.ml
Normal file
18
lib/ocaml/baseline/bag.ml
Normal file
@@ -0,0 +1,18 @@
|
|||||||
|
let count_words text =
|
||||||
|
let words = String.split_on_char ' ' text in
|
||||||
|
let counts = Hashtbl.create 8 in
|
||||||
|
List.iter (fun w ->
|
||||||
|
let n = match Hashtbl.find_opt counts w with
|
||||||
|
| Some n -> n + 1
|
||||||
|
| None -> 1
|
||||||
|
in
|
||||||
|
Hashtbl.replace counts w n
|
||||||
|
) words;
|
||||||
|
counts
|
||||||
|
|
||||||
|
let max_count counts =
|
||||||
|
Hashtbl.fold (fun _ v acc -> if v > acc then v else acc) counts 0
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
max_count (count_words "the quick brown fox jumps over the lazy dog the fox")
|
||||||
25
lib/ocaml/baseline/balance.ml
Normal file
25
lib/ocaml/baseline/balance.ml
Normal file
@@ -0,0 +1,25 @@
|
|||||||
|
let is_balanced s =
|
||||||
|
let stack = Stack.create () in
|
||||||
|
let n = String.length s in
|
||||||
|
let ok = ref true in
|
||||||
|
let i = ref 0 in
|
||||||
|
while !i < n && !ok do
|
||||||
|
let c = s.[!i] in
|
||||||
|
(if c = '(' || c = '[' || c = '{' then Stack.push c stack
|
||||||
|
else if c = ')' then
|
||||||
|
(if Stack.is_empty stack || Stack.pop stack <> '(' then ok := false)
|
||||||
|
else if c = ']' then
|
||||||
|
(if Stack.is_empty stack || Stack.pop stack <> '[' then ok := false)
|
||||||
|
else if c = '}' then
|
||||||
|
(if Stack.is_empty stack || Stack.pop stack <> '{' then ok := false));
|
||||||
|
i := !i + 1
|
||||||
|
done;
|
||||||
|
!ok && Stack.is_empty stack
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
(if is_balanced "({[abc]d}e)" then 1 else 0) +
|
||||||
|
(if is_balanced "(a]" then 1 else 0) +
|
||||||
|
(if is_balanced "{[}]" then 1 else 0) +
|
||||||
|
(if is_balanced "(())" then 1 else 0) +
|
||||||
|
(if is_balanced "" then 1 else 0)
|
||||||
19
lib/ocaml/baseline/base_n.ml
Normal file
19
lib/ocaml/baseline/base_n.ml
Normal file
@@ -0,0 +1,19 @@
|
|||||||
|
let to_base_n n base =
|
||||||
|
let digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" in
|
||||||
|
if n = 0 then "0"
|
||||||
|
else begin
|
||||||
|
let m = ref (abs n) in
|
||||||
|
let acc = ref "" in
|
||||||
|
while !m > 0 do
|
||||||
|
acc := String.make 1 digits.[!m mod base] ^ !acc;
|
||||||
|
m := !m / base
|
||||||
|
done;
|
||||||
|
if n < 0 then "-" ^ !acc else !acc
|
||||||
|
end
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
String.length (to_base_n 255 16) +
|
||||||
|
String.length (to_base_n 1024 2) +
|
||||||
|
String.length (to_base_n 100 10) +
|
||||||
|
String.length (to_base_n 0 16)
|
||||||
42
lib/ocaml/baseline/bf_full.ml
Normal file
42
lib/ocaml/baseline/bf_full.ml
Normal file
@@ -0,0 +1,42 @@
|
|||||||
|
let interpret prog =
|
||||||
|
let mem = Array.make 256 0 in
|
||||||
|
let ptr = ref 0 in
|
||||||
|
let pc = ref 0 in
|
||||||
|
let n = String.length prog in
|
||||||
|
let acc = ref 0 in
|
||||||
|
while !pc < n do
|
||||||
|
let c = prog.[!pc] in
|
||||||
|
(if c = '>' then ptr := !ptr + 1
|
||||||
|
else if c = '<' then ptr := !ptr - 1
|
||||||
|
else if c = '+' then mem.(!ptr) <- mem.(!ptr) + 1
|
||||||
|
else if c = '-' then mem.(!ptr) <- mem.(!ptr) - 1
|
||||||
|
else if c = '.' then acc := !acc + mem.(!ptr)
|
||||||
|
else if c = '[' then begin
|
||||||
|
if mem.(!ptr) = 0 then begin
|
||||||
|
let depth = ref 1 in
|
||||||
|
while !depth > 0 do
|
||||||
|
pc := !pc + 1;
|
||||||
|
let c = prog.[!pc] in
|
||||||
|
if c = '[' then depth := !depth + 1
|
||||||
|
else if c = ']' then depth := !depth - 1
|
||||||
|
done
|
||||||
|
end
|
||||||
|
end
|
||||||
|
else if c = ']' then begin
|
||||||
|
if mem.(!ptr) <> 0 then begin
|
||||||
|
let depth = ref 1 in
|
||||||
|
while !depth > 0 do
|
||||||
|
pc := !pc - 1;
|
||||||
|
let c = prog.[!pc] in
|
||||||
|
if c = ']' then depth := !depth + 1
|
||||||
|
else if c = '[' then depth := !depth - 1
|
||||||
|
done
|
||||||
|
end
|
||||||
|
end);
|
||||||
|
pc := !pc + 1
|
||||||
|
done;
|
||||||
|
!acc
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
interpret "+++[.-]"
|
||||||
43
lib/ocaml/baseline/bfs.ml
Normal file
43
lib/ocaml/baseline/bfs.ml
Normal file
@@ -0,0 +1,43 @@
|
|||||||
|
(* Baseline: graph BFS using Queue + Hashtbl visited set.
|
||||||
|
Returns the count of reachable nodes. *)
|
||||||
|
|
||||||
|
(* Adjacency as an assoc list of (node, neighbors). *)
|
||||||
|
let graph =
|
||||||
|
[ ("A", ["B"; "C"])
|
||||||
|
; ("B", ["D"])
|
||||||
|
; ("C", ["D"; "E"])
|
||||||
|
; ("D", ["F"])
|
||||||
|
; ("E", ["F"])
|
||||||
|
; ("F", [])
|
||||||
|
]
|
||||||
|
;;
|
||||||
|
|
||||||
|
let neighbors n =
|
||||||
|
match List.assoc_opt n graph with
|
||||||
|
| None -> []
|
||||||
|
| Some ns -> ns
|
||||||
|
;;
|
||||||
|
|
||||||
|
let bfs start =
|
||||||
|
let visited = Hashtbl.create 16 in
|
||||||
|
let q = Queue.create () in
|
||||||
|
Queue.push start q ;
|
||||||
|
Hashtbl.add visited start true ;
|
||||||
|
let rec loop () =
|
||||||
|
if Queue.is_empty q then ()
|
||||||
|
else
|
||||||
|
let v = Queue.pop q in
|
||||||
|
List.iter
|
||||||
|
(fun n ->
|
||||||
|
if not (Hashtbl.mem visited n) then begin
|
||||||
|
Hashtbl.add visited n true ;
|
||||||
|
Queue.push n q
|
||||||
|
end)
|
||||||
|
(neighbors v) ;
|
||||||
|
loop ()
|
||||||
|
in
|
||||||
|
loop () ;
|
||||||
|
Hashtbl.length visited
|
||||||
|
;;
|
||||||
|
|
||||||
|
bfs "A"
|
||||||
42
lib/ocaml/baseline/bfs_grid.ml
Normal file
42
lib/ocaml/baseline/bfs_grid.ml
Normal file
@@ -0,0 +1,42 @@
|
|||||||
|
let h = 5
|
||||||
|
let w = 5
|
||||||
|
|
||||||
|
let grid = [|
|
||||||
|
[| 0; 0; 1; 0; 0 |];
|
||||||
|
[| 1; 0; 1; 0; 1 |];
|
||||||
|
[| 0; 0; 0; 0; 0 |];
|
||||||
|
[| 0; 1; 1; 1; 0 |];
|
||||||
|
[| 0; 0; 0; 0; 0 |]
|
||||||
|
|]
|
||||||
|
|
||||||
|
let step dist q r c nr nc =
|
||||||
|
if nr >= 0 && nr < h && nc >= 0 && nc < w
|
||||||
|
&& grid.(nr).(nc) = 0 && dist.(nr).(nc) = -1 then begin
|
||||||
|
dist.(nr).(nc) <- dist.(r).(c) + 1;
|
||||||
|
Queue.push (nr * 10 + nc) q
|
||||||
|
end
|
||||||
|
|
||||||
|
let bfs sr sc tr tc =
|
||||||
|
let dist = Array.init h (fun _ -> Array.make w (-1)) in
|
||||||
|
let q = Queue.create () in
|
||||||
|
dist.(sr).(sc) <- 0;
|
||||||
|
Queue.push (sr * 10 + sc) q;
|
||||||
|
let go = ref true in
|
||||||
|
while !go do
|
||||||
|
if Queue.is_empty q then go := false
|
||||||
|
else if dist.(tr).(tc) <> -1 then go := false
|
||||||
|
else begin
|
||||||
|
let rc = Queue.pop q in
|
||||||
|
let r = rc / 10 in
|
||||||
|
let c = rc mod 10 in
|
||||||
|
step dist q r c (r - 1) c;
|
||||||
|
step dist q r c (r + 1) c;
|
||||||
|
step dist q r c r (c - 1);
|
||||||
|
step dist q r c r (c + 1)
|
||||||
|
end
|
||||||
|
done;
|
||||||
|
dist.(tr).(tc)
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
bfs 0 0 4 4
|
||||||
24
lib/ocaml/baseline/bigint_add.ml
Normal file
24
lib/ocaml/baseline/bigint_add.ml
Normal file
@@ -0,0 +1,24 @@
|
|||||||
|
let bigint_add a b =
|
||||||
|
let rec aux a b carry =
|
||||||
|
match (a, b) with
|
||||||
|
| ([], []) -> if carry = 0 then [] else [carry]
|
||||||
|
| (x :: xs, []) ->
|
||||||
|
let s = x + carry in
|
||||||
|
(s mod 10) :: aux xs [] (s / 10)
|
||||||
|
| ([], y :: ys) ->
|
||||||
|
let s = y + carry in
|
||||||
|
(s mod 10) :: aux [] ys (s / 10)
|
||||||
|
| (x :: xs, y :: ys) ->
|
||||||
|
let s = x + y + carry in
|
||||||
|
(s mod 10) :: aux xs ys (s / 10)
|
||||||
|
in
|
||||||
|
aux a b 0
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
let r1 = bigint_add [9;9;9] [1] in
|
||||||
|
let r2 = bigint_add [5;6;7] [8;9;1] in
|
||||||
|
let r3 = bigint_add [9;9;9;9;9;9;9;9] [1] in
|
||||||
|
List.fold_left (+) 0 r1
|
||||||
|
+ List.fold_left (+) 0 r2
|
||||||
|
+ List.length r3
|
||||||
47
lib/ocaml/baseline/binary_heap.ml
Normal file
47
lib/ocaml/baseline/binary_heap.ml
Normal file
@@ -0,0 +1,47 @@
|
|||||||
|
let parent i = (i - 1) / 2
|
||||||
|
let lchild i = 2 * i + 1
|
||||||
|
let rchild i = 2 * i + 2
|
||||||
|
|
||||||
|
let swap a i j =
|
||||||
|
let t = a.(i) in
|
||||||
|
a.(i) <- a.(j);
|
||||||
|
a.(j) <- t
|
||||||
|
|
||||||
|
let rec sift_up a i =
|
||||||
|
if i > 0 && a.(parent i) > a.(i) then begin
|
||||||
|
swap a i (parent i);
|
||||||
|
sift_up a (parent i)
|
||||||
|
end
|
||||||
|
|
||||||
|
let rec sift_down a n i =
|
||||||
|
let l = lchild i and r = rchild i in
|
||||||
|
let smallest = ref i in
|
||||||
|
if l < n && a.(l) < a.(!smallest) then smallest := l;
|
||||||
|
if r < n && a.(r) < a.(!smallest) then smallest := r;
|
||||||
|
if !smallest <> i then begin
|
||||||
|
swap a i !smallest;
|
||||||
|
sift_down a n !smallest
|
||||||
|
end
|
||||||
|
|
||||||
|
let push a size x =
|
||||||
|
a.(!size) <- x;
|
||||||
|
size := !size + 1;
|
||||||
|
sift_up a (!size - 1)
|
||||||
|
|
||||||
|
let pop a size =
|
||||||
|
let m = a.(0) in
|
||||||
|
size := !size - 1;
|
||||||
|
a.(0) <- a.(!size);
|
||||||
|
sift_down a !size 0;
|
||||||
|
m
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
let a = Array.make 20 0 in
|
||||||
|
let s = ref 0 in
|
||||||
|
List.iter (fun x -> push a s x) [9; 4; 7; 1; 8; 3; 5; 2; 6];
|
||||||
|
let total = ref 0 in
|
||||||
|
for _ = 1 to 9 do
|
||||||
|
total := !total * 10 + pop a s
|
||||||
|
done;
|
||||||
|
!total
|
||||||
39
lib/ocaml/baseline/bipartite.ml
Normal file
39
lib/ocaml/baseline/bipartite.ml
Normal file
@@ -0,0 +1,39 @@
|
|||||||
|
let is_bipartite n adj =
|
||||||
|
let color = Array.make n (-1) in
|
||||||
|
let ok = ref true in
|
||||||
|
let q = Queue.create () in
|
||||||
|
for src = 0 to n - 1 do
|
||||||
|
if color.(src) = -1 then begin
|
||||||
|
color.(src) <- 0;
|
||||||
|
Queue.push src q;
|
||||||
|
while not (Queue.is_empty q) do
|
||||||
|
let u = Queue.pop q in
|
||||||
|
List.iter (fun v ->
|
||||||
|
if color.(v) = -1 then begin
|
||||||
|
color.(v) <- 1 - color.(u);
|
||||||
|
Queue.push v q
|
||||||
|
end else if color.(v) = color.(u) then
|
||||||
|
ok := false
|
||||||
|
) adj.(u)
|
||||||
|
done
|
||||||
|
end
|
||||||
|
done;
|
||||||
|
let zeros = ref 0 in
|
||||||
|
for i = 0 to n - 1 do
|
||||||
|
if color.(i) = 0 then zeros := !zeros + 1
|
||||||
|
done;
|
||||||
|
if !ok then !zeros else -1
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
let n = 7 in
|
||||||
|
let adj = [|
|
||||||
|
[1; 3];
|
||||||
|
[0; 2; 4];
|
||||||
|
[1; 5];
|
||||||
|
[0; 4; 6];
|
||||||
|
[1; 3];
|
||||||
|
[2; 6];
|
||||||
|
[3; 5]
|
||||||
|
|] in
|
||||||
|
is_bipartite n adj
|
||||||
13
lib/ocaml/baseline/bisect.ml
Normal file
13
lib/ocaml/baseline/bisect.ml
Normal file
@@ -0,0 +1,13 @@
|
|||||||
|
let bisect f lo hi =
|
||||||
|
let lo = ref lo and hi = ref hi in
|
||||||
|
for _ = 1 to 50 do
|
||||||
|
let mid = (!lo +. !hi) /. 2.0 in
|
||||||
|
if f mid = 0.0 || f !lo *. f mid < 0.0 then hi := mid
|
||||||
|
else lo := mid
|
||||||
|
done;
|
||||||
|
!lo
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
let r = bisect (fun x -> x *. x -. 2.0) 1.0 2.0 in
|
||||||
|
int_of_float (r *. 100.0)
|
||||||
12
lib/ocaml/baseline/bits.ml
Normal file
12
lib/ocaml/baseline/bits.ml
Normal file
@@ -0,0 +1,12 @@
|
|||||||
|
let popcount n =
|
||||||
|
let count = ref 0 in
|
||||||
|
let m = ref n in
|
||||||
|
while !m > 0 do
|
||||||
|
if !m land 1 = 1 then count := !count + 1;
|
||||||
|
m := !m lsr 1
|
||||||
|
done;
|
||||||
|
!count
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
popcount 1023 + popcount 5 + popcount 1024 + popcount 0xff
|
||||||
24
lib/ocaml/baseline/bowling.ml
Normal file
24
lib/ocaml/baseline/bowling.ml
Normal file
@@ -0,0 +1,24 @@
|
|||||||
|
let bowling_score frames =
|
||||||
|
let arr = Array.of_list frames in
|
||||||
|
let n = Array.length arr in
|
||||||
|
let total = ref 0 in
|
||||||
|
let i = ref 0 in
|
||||||
|
let frame = ref 1 in
|
||||||
|
while !frame <= 10 && !i < n do
|
||||||
|
if arr.(!i) = 10 then begin
|
||||||
|
total := !total + 10 + arr.(!i + 1) + arr.(!i + 2);
|
||||||
|
i := !i + 1
|
||||||
|
end else if !i + 1 < n && arr.(!i) + arr.(!i + 1) = 10 then begin
|
||||||
|
total := !total + 10 + arr.(!i + 2);
|
||||||
|
i := !i + 2
|
||||||
|
end else begin
|
||||||
|
total := !total + arr.(!i) + arr.(!i + 1);
|
||||||
|
i := !i + 2
|
||||||
|
end;
|
||||||
|
frame := !frame + 1
|
||||||
|
done;
|
||||||
|
!total
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
bowling_score [10; 7; 3; 9; 0; 10; 0; 8; 8; 2; 0; 6; 10; 10; 10; 8; 1]
|
||||||
32
lib/ocaml/baseline/bracket_match.ml
Normal file
32
lib/ocaml/baseline/bracket_match.ml
Normal file
@@ -0,0 +1,32 @@
|
|||||||
|
let bracket_match s =
|
||||||
|
let n = String.length s in
|
||||||
|
let stack = ref [] in
|
||||||
|
let ok = ref true in
|
||||||
|
let i = ref 0 in
|
||||||
|
while !ok && !i < n do
|
||||||
|
let c = s.[!i] in
|
||||||
|
if c = '(' || c = '[' || c = '{' then
|
||||||
|
stack := c :: !stack
|
||||||
|
else if c = ')' || c = ']' || c = '}' then begin
|
||||||
|
match !stack with
|
||||||
|
| [] -> ok := false
|
||||||
|
| top :: rest ->
|
||||||
|
let pair =
|
||||||
|
(c = ')' && top = '(') ||
|
||||||
|
(c = ']' && top = '[') ||
|
||||||
|
(c = '}' && top = '{')
|
||||||
|
in
|
||||||
|
if pair then stack := rest else ok := false
|
||||||
|
end;
|
||||||
|
i := !i + 1
|
||||||
|
done;
|
||||||
|
if !ok && !stack = [] then 1 else 0
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
let strings = ["()"; "[{()}]"; "({[}])"; ""; "(("; "()[](){}"; "(a(b)c)"; "(()"; "])"] in
|
||||||
|
let count = ref 0 in
|
||||||
|
List.iter (fun s ->
|
||||||
|
count := !count + bracket_match s
|
||||||
|
) strings;
|
||||||
|
!count
|
||||||
20
lib/ocaml/baseline/brainfuck.ml
Normal file
20
lib/ocaml/baseline/brainfuck.ml
Normal file
@@ -0,0 +1,20 @@
|
|||||||
|
let interpret prog =
|
||||||
|
let mem = Array.make 256 0 in
|
||||||
|
let ptr = ref 0 in
|
||||||
|
let pc = ref 0 in
|
||||||
|
let n = String.length prog in
|
||||||
|
let acc = ref 0 in
|
||||||
|
while !pc < n do
|
||||||
|
let c = prog.[!pc] in
|
||||||
|
(if c = '>' then ptr := !ptr + 1
|
||||||
|
else if c = '<' then ptr := !ptr - 1
|
||||||
|
else if c = '+' then mem.(!ptr) <- mem.(!ptr) + 1
|
||||||
|
else if c = '-' then mem.(!ptr) <- mem.(!ptr) - 1
|
||||||
|
else if c = '.' then acc := !acc + mem.(!ptr));
|
||||||
|
pc := !pc + 1
|
||||||
|
done;
|
||||||
|
!acc
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
interpret "+++++.+++++.+++++.+++++.+++++."
|
||||||
27
lib/ocaml/baseline/bs_bounds.ml
Normal file
27
lib/ocaml/baseline/bs_bounds.ml
Normal file
@@ -0,0 +1,27 @@
|
|||||||
|
let lower_bound arr x =
|
||||||
|
let lo = ref 0 and hi = ref (Array.length arr) in
|
||||||
|
while !lo < !hi do
|
||||||
|
let mid = (!lo + !hi) / 2 in
|
||||||
|
if arr.(mid) < x then lo := mid + 1
|
||||||
|
else hi := mid
|
||||||
|
done;
|
||||||
|
!lo
|
||||||
|
|
||||||
|
let upper_bound arr x =
|
||||||
|
let lo = ref 0 and hi = ref (Array.length arr) in
|
||||||
|
while !lo < !hi do
|
||||||
|
let mid = (!lo + !hi) / 2 in
|
||||||
|
if arr.(mid) <= x then lo := mid + 1
|
||||||
|
else hi := mid
|
||||||
|
done;
|
||||||
|
!lo
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
let a = [| 1; 2; 2; 3; 3; 3; 5; 7; 9 |] in
|
||||||
|
let cnt3 = upper_bound a 3 - lower_bound a 3 in
|
||||||
|
let cnt2 = upper_bound a 2 - lower_bound a 2 in
|
||||||
|
let cnt5 = upper_bound a 5 - lower_bound a 5 in
|
||||||
|
let cnt9 = upper_bound a 9 - lower_bound a 9 in
|
||||||
|
let cnt4 = upper_bound a 4 - lower_bound a 4 in
|
||||||
|
cnt3 * 1000 + cnt2 * 100 + cnt5 * 10 + cnt9 + cnt4
|
||||||
25
lib/ocaml/baseline/bs_rotated.ml
Normal file
25
lib/ocaml/baseline/bs_rotated.ml
Normal file
@@ -0,0 +1,25 @@
|
|||||||
|
let bs_rotated arr target =
|
||||||
|
let lo = ref 0 in
|
||||||
|
let hi = ref (Array.length arr - 1) in
|
||||||
|
let result = ref (-1) in
|
||||||
|
while !lo <= !hi && !result = -1 do
|
||||||
|
let mid = (!lo + !hi) / 2 in
|
||||||
|
if arr.(mid) = target then result := mid
|
||||||
|
else if arr.(!lo) <= arr.(mid) then begin
|
||||||
|
if target >= arr.(!lo) && target < arr.(mid) then
|
||||||
|
hi := mid - 1
|
||||||
|
else
|
||||||
|
lo := mid + 1
|
||||||
|
end else begin
|
||||||
|
if target > arr.(mid) && target <= arr.(!hi) then
|
||||||
|
lo := mid + 1
|
||||||
|
else
|
||||||
|
hi := mid - 1
|
||||||
|
end
|
||||||
|
done;
|
||||||
|
!result
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
let a = [| 4; 5; 6; 7; 0; 1; 2 |] in
|
||||||
|
bs_rotated a 0 + bs_rotated a 7 * 10 + bs_rotated a 3 * 100
|
||||||
16
lib/ocaml/baseline/bsearch.ml
Normal file
16
lib/ocaml/baseline/bsearch.ml
Normal file
@@ -0,0 +1,16 @@
|
|||||||
|
let bsearch arr target =
|
||||||
|
let n = Array.length arr in
|
||||||
|
let lo = ref 0 and hi = ref (n - 1) in
|
||||||
|
let found = ref (-1) in
|
||||||
|
while !lo <= !hi && !found = -1 do
|
||||||
|
let mid = (!lo + !hi) / 2 in
|
||||||
|
if arr.(mid) = target then found := mid
|
||||||
|
else if arr.(mid) < target then lo := mid + 1
|
||||||
|
else hi := mid - 1
|
||||||
|
done;
|
||||||
|
!found
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
let a = Array.of_list [1;3;5;7;9;11;13;15;17;19;21] in
|
||||||
|
bsearch a 13 + bsearch a 5 + bsearch a 100
|
||||||
25
lib/ocaml/baseline/btree.ml
Normal file
25
lib/ocaml/baseline/btree.ml
Normal file
@@ -0,0 +1,25 @@
|
|||||||
|
(* Baseline: binary search tree with insert + in-order traversal *)
|
||||||
|
type 'a tree =
|
||||||
|
| Leaf
|
||||||
|
| Node of 'a * 'a tree * 'a tree
|
||||||
|
;;
|
||||||
|
|
||||||
|
let rec insert x t =
|
||||||
|
match t with
|
||||||
|
| Leaf -> Node (x, Leaf, Leaf)
|
||||||
|
| Node (v, l, r) ->
|
||||||
|
if x < v then Node (v, insert x l, r)
|
||||||
|
else if x > v then Node (v, l, insert x r)
|
||||||
|
else t
|
||||||
|
;;
|
||||||
|
|
||||||
|
let rec inorder t =
|
||||||
|
match t with
|
||||||
|
| Leaf -> []
|
||||||
|
| Node (v, l, r) -> List.append (inorder l) (v :: inorder r)
|
||||||
|
;;
|
||||||
|
|
||||||
|
let from_list xs = List.fold_left (fun t x -> insert x t) Leaf xs ;;
|
||||||
|
|
||||||
|
let t = from_list [5; 3; 8; 1; 4; 7; 9; 2] ;;
|
||||||
|
List.fold_left (fun a b -> a + b) 0 (inorder t)
|
||||||
14
lib/ocaml/baseline/caesar.ml
Normal file
14
lib/ocaml/baseline/caesar.ml
Normal file
@@ -0,0 +1,14 @@
|
|||||||
|
let shift_char c k =
|
||||||
|
let n = Char.code c in
|
||||||
|
if n >= 97 && n <= 122 then
|
||||||
|
Char.chr (((n - 97 + k) mod 26 + 26) mod 26 + 97)
|
||||||
|
else c
|
||||||
|
|
||||||
|
let encode s k =
|
||||||
|
String.init (String.length s) (fun i -> shift_char s.[i] k)
|
||||||
|
;;
|
||||||
|
|
||||||
|
(* ROT13 round-trip: encode (encode "hello" 13) 13 = "hello".
|
||||||
|
Sum the codes of two chars to give a deterministic integer check. *)
|
||||||
|
let r = encode (encode "hello" 13) 13 in
|
||||||
|
Char.code r.[0] + Char.code r.[4]
|
||||||
76
lib/ocaml/baseline/calc.ml
Normal file
76
lib/ocaml/baseline/calc.ml
Normal file
@@ -0,0 +1,76 @@
|
|||||||
|
(* Baseline: recursive-descent calculator for "+", "*", parens, ints. *)
|
||||||
|
type expr =
|
||||||
|
| Lit of int
|
||||||
|
| Add of expr * expr
|
||||||
|
| Mul of expr * expr
|
||||||
|
;;
|
||||||
|
|
||||||
|
let parse_input src =
|
||||||
|
let pos = ref 0 in
|
||||||
|
let peek () = if !pos < String.length src then String.get src !pos else "" in
|
||||||
|
let advance () = pos := !pos + 1 in
|
||||||
|
let skip_ws () =
|
||||||
|
while !pos < String.length src && peek () = " " do advance () done
|
||||||
|
in
|
||||||
|
|
||||||
|
let rec parse_atom () =
|
||||||
|
skip_ws () ;
|
||||||
|
if peek () = "(" then begin
|
||||||
|
advance () ;
|
||||||
|
let e = parse_expr () in
|
||||||
|
skip_ws () ;
|
||||||
|
advance () ; (* consume ')' *)
|
||||||
|
e
|
||||||
|
end
|
||||||
|
else
|
||||||
|
let start = !pos in
|
||||||
|
let rec digits () =
|
||||||
|
if !pos < String.length src then
|
||||||
|
let c = peek () in
|
||||||
|
if c >= "0" && c <= "9" then begin advance () ; digits () end
|
||||||
|
else ()
|
||||||
|
in
|
||||||
|
digits () ;
|
||||||
|
let n = Int.of_string (String.sub src start (!pos - start)) in
|
||||||
|
Lit n
|
||||||
|
|
||||||
|
and parse_term () =
|
||||||
|
skip_ws () ;
|
||||||
|
let lhs = ref (parse_atom ()) in
|
||||||
|
let rec loop () =
|
||||||
|
skip_ws () ;
|
||||||
|
if peek () = "*" then begin
|
||||||
|
advance () ;
|
||||||
|
lhs := Mul (!lhs, parse_atom ()) ;
|
||||||
|
loop ()
|
||||||
|
end
|
||||||
|
in
|
||||||
|
loop () ;
|
||||||
|
!lhs
|
||||||
|
|
||||||
|
and parse_expr () =
|
||||||
|
skip_ws () ;
|
||||||
|
let lhs = ref (parse_term ()) in
|
||||||
|
let rec loop () =
|
||||||
|
skip_ws () ;
|
||||||
|
if peek () = "+" then begin
|
||||||
|
advance () ;
|
||||||
|
lhs := Add (!lhs, parse_term ()) ;
|
||||||
|
loop ()
|
||||||
|
end
|
||||||
|
in
|
||||||
|
loop () ;
|
||||||
|
!lhs
|
||||||
|
in
|
||||||
|
parse_expr ()
|
||||||
|
;;
|
||||||
|
|
||||||
|
let rec eval e =
|
||||||
|
match e with
|
||||||
|
| Lit n -> n
|
||||||
|
| Add (a, b) -> eval a + eval b
|
||||||
|
| Mul (a, b) -> eval a * eval b
|
||||||
|
;;
|
||||||
|
|
||||||
|
(* (1 + 2) * 3 + 4 = 9 + 4 = 13 *)
|
||||||
|
eval (parse_input "(1 + 2) * 3 + 4")
|
||||||
13
lib/ocaml/baseline/catalan.ml
Normal file
13
lib/ocaml/baseline/catalan.ml
Normal file
@@ -0,0 +1,13 @@
|
|||||||
|
let catalan n =
|
||||||
|
let dp = Array.make (n + 1) 0 in
|
||||||
|
dp.(0) <- 1;
|
||||||
|
for i = 1 to n do
|
||||||
|
for j = 0 to i - 1 do
|
||||||
|
dp.(i) <- dp.(i) + dp.(j) * dp.(i - 1 - j)
|
||||||
|
done
|
||||||
|
done;
|
||||||
|
dp.(n)
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
catalan 5
|
||||||
5
lib/ocaml/baseline/closures.ml
Normal file
5
lib/ocaml/baseline/closures.ml
Normal file
@@ -0,0 +1,5 @@
|
|||||||
|
(* Baseline: closures + curried application *)
|
||||||
|
let make_adder n = fun x -> n + x ;;
|
||||||
|
let add5 = make_adder 5 ;;
|
||||||
|
let add10 = make_adder 10 ;;
|
||||||
|
add5 100 + add10 200
|
||||||
15
lib/ocaml/baseline/coin_change.ml
Normal file
15
lib/ocaml/baseline/coin_change.ml
Normal file
@@ -0,0 +1,15 @@
|
|||||||
|
let coin_change coins target =
|
||||||
|
let dp = Array.make (target + 1) (target + 1) in
|
||||||
|
dp.(0) <- 0;
|
||||||
|
for i = 1 to target do
|
||||||
|
List.iter (fun c ->
|
||||||
|
if c <= i && dp.(i - c) + 1 < dp.(i) then
|
||||||
|
dp.(i) <- dp.(i - c) + 1
|
||||||
|
) coins
|
||||||
|
done;
|
||||||
|
if dp.(target) > target then -1
|
||||||
|
else dp.(target)
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
coin_change [1; 5; 10; 25] 67
|
||||||
16
lib/ocaml/baseline/coin_min.ml
Normal file
16
lib/ocaml/baseline/coin_min.ml
Normal file
@@ -0,0 +1,16 @@
|
|||||||
|
let coin_min coins amount =
|
||||||
|
let dp = Array.make (amount + 1) (-1) in
|
||||||
|
dp.(0) <- 0;
|
||||||
|
for i = 1 to amount do
|
||||||
|
List.iter (fun c ->
|
||||||
|
if c <= i && dp.(i - c) >= 0 then begin
|
||||||
|
let cand = dp.(i - c) + 1 in
|
||||||
|
if dp.(i) < 0 || cand < dp.(i) then dp.(i) <- cand
|
||||||
|
end
|
||||||
|
) coins
|
||||||
|
done;
|
||||||
|
dp.(amount)
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
coin_min [1; 5; 10; 25] 67
|
||||||
12
lib/ocaml/baseline/combinations.ml
Normal file
12
lib/ocaml/baseline/combinations.ml
Normal file
@@ -0,0 +1,12 @@
|
|||||||
|
let rec choose k xs =
|
||||||
|
if k = 0 then [[]]
|
||||||
|
else
|
||||||
|
match xs with
|
||||||
|
| [] -> []
|
||||||
|
| h :: rest ->
|
||||||
|
List.map (fun c -> h :: c) (choose (k - 1) rest)
|
||||||
|
@ choose k rest
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
List.length (choose 4 [1; 2; 3; 4; 5; 6; 7; 8; 9])
|
||||||
43
lib/ocaml/baseline/convex_hull.ml
Normal file
43
lib/ocaml/baseline/convex_hull.ml
Normal file
@@ -0,0 +1,43 @@
|
|||||||
|
let cross ox oy ax ay bx by =
|
||||||
|
(ax - ox) * (by - oy) - (ay - oy) * (bx - ox)
|
||||||
|
|
||||||
|
let hull_size pts =
|
||||||
|
let n = List.length pts in
|
||||||
|
if n < 3 then n
|
||||||
|
else begin
|
||||||
|
let sorted = List.sort (fun (a, b) (c, d) ->
|
||||||
|
if a <> c then compare a c else compare b d) pts in
|
||||||
|
let arr = Array.of_list sorted in
|
||||||
|
let h = Array.make (2 * n) (0, 0) in
|
||||||
|
let k = ref 0 in
|
||||||
|
for i = 0 to n - 1 do
|
||||||
|
let (xi, yi) = arr.(i) in
|
||||||
|
let cont = ref true in
|
||||||
|
while !cont && !k >= 2 do
|
||||||
|
let (ox, oy) = h.(!k - 2) in
|
||||||
|
let (ax, ay) = h.(!k - 1) in
|
||||||
|
if cross ox oy ax ay xi yi <= 0 then k := !k - 1
|
||||||
|
else cont := false
|
||||||
|
done;
|
||||||
|
h.(!k) <- (xi, yi);
|
||||||
|
k := !k + 1
|
||||||
|
done;
|
||||||
|
let lo = !k + 1 in
|
||||||
|
for i = n - 2 downto 0 do
|
||||||
|
let (xi, yi) = arr.(i) in
|
||||||
|
let cont = ref true in
|
||||||
|
while !cont && !k >= lo do
|
||||||
|
let (ox, oy) = h.(!k - 2) in
|
||||||
|
let (ax, ay) = h.(!k - 1) in
|
||||||
|
if cross ox oy ax ay xi yi <= 0 then k := !k - 1
|
||||||
|
else cont := false
|
||||||
|
done;
|
||||||
|
h.(!k) <- (xi, yi);
|
||||||
|
k := !k + 1
|
||||||
|
done;
|
||||||
|
!k - 1
|
||||||
|
end
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
hull_size [(0, 0); (1, 1); (2, 0); (2, 2); (0, 2); (1, 0); (3, 3); (5, 1)]
|
||||||
14
lib/ocaml/baseline/count_bits.ml
Normal file
14
lib/ocaml/baseline/count_bits.ml
Normal file
@@ -0,0 +1,14 @@
|
|||||||
|
let count_bits n =
|
||||||
|
let result = Array.make (n + 1) 0 in
|
||||||
|
for i = 1 to n do
|
||||||
|
result.(i) <- result.(i / 2) + (i mod 2)
|
||||||
|
done;
|
||||||
|
let sum = ref 0 in
|
||||||
|
for i = 0 to n do
|
||||||
|
sum := !sum + result.(i)
|
||||||
|
done;
|
||||||
|
!sum
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
count_bits 100
|
||||||
13
lib/ocaml/baseline/count_change.ml
Normal file
13
lib/ocaml/baseline/count_change.ml
Normal file
@@ -0,0 +1,13 @@
|
|||||||
|
let count_ways coins target =
|
||||||
|
let dp = Array.make (target + 1) 0 in
|
||||||
|
dp.(0) <- 1;
|
||||||
|
List.iter (fun c ->
|
||||||
|
for i = c to target do
|
||||||
|
dp.(i) <- dp.(i) + dp.(i - c)
|
||||||
|
done
|
||||||
|
) coins;
|
||||||
|
dp.(target)
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
count_ways [1; 2; 5; 10; 25] 50
|
||||||
42
lib/ocaml/baseline/count_inversions.ml
Normal file
42
lib/ocaml/baseline/count_inversions.ml
Normal file
@@ -0,0 +1,42 @@
|
|||||||
|
let count_inv arr =
|
||||||
|
let n = Array.length arr in
|
||||||
|
let temp = Array.make n 0 in
|
||||||
|
let count = ref 0 in
|
||||||
|
let rec merge lo mid hi =
|
||||||
|
let i = ref lo and j = ref (mid + 1) and k = ref lo in
|
||||||
|
while !i <= mid && !j <= hi do
|
||||||
|
if arr.(!i) <= arr.(!j) then begin
|
||||||
|
temp.(!k) <- arr.(!i);
|
||||||
|
i := !i + 1
|
||||||
|
end else begin
|
||||||
|
temp.(!k) <- arr.(!j);
|
||||||
|
count := !count + (mid - !i + 1);
|
||||||
|
j := !j + 1
|
||||||
|
end;
|
||||||
|
k := !k + 1
|
||||||
|
done;
|
||||||
|
while !i <= mid do
|
||||||
|
temp.(!k) <- arr.(!i);
|
||||||
|
i := !i + 1; k := !k + 1
|
||||||
|
done;
|
||||||
|
while !j <= hi do
|
||||||
|
temp.(!k) <- arr.(!j);
|
||||||
|
j := !j + 1; k := !k + 1
|
||||||
|
done;
|
||||||
|
for x = lo to hi do
|
||||||
|
arr.(x) <- temp.(x)
|
||||||
|
done
|
||||||
|
and sort lo hi =
|
||||||
|
if lo < hi then begin
|
||||||
|
let mid = (lo + hi) / 2 in
|
||||||
|
sort lo mid;
|
||||||
|
sort (mid + 1) hi;
|
||||||
|
merge lo mid hi
|
||||||
|
end
|
||||||
|
in
|
||||||
|
sort 0 (n - 1);
|
||||||
|
!count
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
count_inv [|8; 4; 2; 1; 3; 5; 7; 6|]
|
||||||
17
lib/ocaml/baseline/count_palindromes.ml
Normal file
17
lib/ocaml/baseline/count_palindromes.ml
Normal file
@@ -0,0 +1,17 @@
|
|||||||
|
let count_pal s =
|
||||||
|
let n = String.length s in
|
||||||
|
let count = ref 0 in
|
||||||
|
for c = 0 to 2 * n - 2 do
|
||||||
|
let l = ref (c / 2) in
|
||||||
|
let r = ref ((c + 1) / 2) in
|
||||||
|
while !l >= 0 && !r < n && s.[!l] = s.[!r] do
|
||||||
|
count := !count + 1;
|
||||||
|
l := !l - 1;
|
||||||
|
r := !r + 1
|
||||||
|
done
|
||||||
|
done;
|
||||||
|
!count
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
count_pal "aabaa"
|
||||||
42
lib/ocaml/baseline/count_paths_dag.ml
Normal file
42
lib/ocaml/baseline/count_paths_dag.ml
Normal file
@@ -0,0 +1,42 @@
|
|||||||
|
let n = 6
|
||||||
|
let adj = [|
|
||||||
|
[1; 2];
|
||||||
|
[3];
|
||||||
|
[3; 4];
|
||||||
|
[5];
|
||||||
|
[5];
|
||||||
|
[]
|
||||||
|
|]
|
||||||
|
|
||||||
|
let in_deg = Array.make n 0
|
||||||
|
let paths = Array.make n 0
|
||||||
|
|
||||||
|
let count_paths () =
|
||||||
|
for u = 0 to n - 1 do
|
||||||
|
List.iter (fun v -> in_deg.(v) <- in_deg.(v) + 1) adj.(u)
|
||||||
|
done;
|
||||||
|
let order = ref [] in
|
||||||
|
let q = Queue.create () in
|
||||||
|
for v = 0 to n - 1 do
|
||||||
|
if in_deg.(v) = 0 then Queue.push v q
|
||||||
|
done;
|
||||||
|
while not (Queue.is_empty q) do
|
||||||
|
let u = Queue.pop q in
|
||||||
|
order := u :: !order;
|
||||||
|
List.iter (fun v ->
|
||||||
|
in_deg.(v) <- in_deg.(v) - 1;
|
||||||
|
if in_deg.(v) = 0 then Queue.push v q
|
||||||
|
) adj.(u)
|
||||||
|
done;
|
||||||
|
paths.(0) <- 1;
|
||||||
|
let topo = List.rev !order in
|
||||||
|
List.iter (fun u ->
|
||||||
|
List.iter (fun v ->
|
||||||
|
paths.(v) <- paths.(v) + paths.(u)
|
||||||
|
) adj.(u)
|
||||||
|
) topo;
|
||||||
|
paths.(n - 1)
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
count_paths ()
|
||||||
16
lib/ocaml/baseline/count_subarrays_k.ml
Normal file
16
lib/ocaml/baseline/count_subarrays_k.ml
Normal file
@@ -0,0 +1,16 @@
|
|||||||
|
let count_subarr_sum_k arr k =
|
||||||
|
let n = Array.length arr in
|
||||||
|
let prefix = Array.make (n + 1) 0 in
|
||||||
|
for i = 0 to n - 1 do
|
||||||
|
prefix.(i + 1) <- prefix.(i) + arr.(i)
|
||||||
|
done;
|
||||||
|
let count = ref 0 in
|
||||||
|
for i = 0 to n - 1 do
|
||||||
|
for j = i + 1 to n do
|
||||||
|
if prefix.(j) - prefix.(i) = k then count := !count + 1
|
||||||
|
done
|
||||||
|
done;
|
||||||
|
!count
|
||||||
|
;;
|
||||||
|
|
||||||
|
count_subarr_sum_k [| 1; 1; 1; 2; -1; 3; 1; -2; 4 |] 3
|
||||||
12
lib/ocaml/baseline/csv.ml
Normal file
12
lib/ocaml/baseline/csv.ml
Normal file
@@ -0,0 +1,12 @@
|
|||||||
|
let sum_second_col text =
|
||||||
|
let lines = String.split_on_char '\n' text in
|
||||||
|
List.fold_left (fun acc line ->
|
||||||
|
let fields = String.split_on_char ',' line in
|
||||||
|
if List.length fields >= 2 then
|
||||||
|
acc + int_of_string (List.nth fields 1)
|
||||||
|
else acc
|
||||||
|
) 0 lines
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
sum_second_col "a,1,extra\nb,2,extra\nc,3,extra\nd,4,extra"
|
||||||
24
lib/ocaml/baseline/daily_temperatures.ml
Normal file
24
lib/ocaml/baseline/daily_temperatures.ml
Normal file
@@ -0,0 +1,24 @@
|
|||||||
|
let daily_temperatures temps =
|
||||||
|
let n = Array.length temps in
|
||||||
|
let answer = Array.make n 0 in
|
||||||
|
let stack = ref [] in
|
||||||
|
for i = 0 to n - 1 do
|
||||||
|
let cont = ref true in
|
||||||
|
while !cont do
|
||||||
|
match !stack with
|
||||||
|
| top :: rest when temps.(top) < temps.(i) ->
|
||||||
|
answer.(top) <- i - top;
|
||||||
|
stack := rest
|
||||||
|
| _ -> cont := false
|
||||||
|
done;
|
||||||
|
stack := i :: !stack
|
||||||
|
done;
|
||||||
|
let sum = ref 0 in
|
||||||
|
for i = 0 to n - 1 do
|
||||||
|
sum := !sum + answer.(i)
|
||||||
|
done;
|
||||||
|
!sum
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
daily_temperatures [| 73; 74; 75; 71; 69; 72; 76; 73 |]
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user