├── lib ├── error.ml ├── dune ├── shim.js ├── run.ml ├── operators.ml ├── stdlib.rsc ├── scanner.ml ├── types.ml ├── compile.ml ├── preprocess.ml ├── parser.ml └── eval.ml ├── .gitignore ├── .dockerignore ├── dune-project ├── bin ├── dune └── rustscript_cli.ml ├── assets └── logo.png ├── bench.sh ├── examples ├── comment.rsc ├── euler1.rsc ├── fib.rsc ├── euler1_no_listcomp.rsc ├── strings.rsc ├── capture.rsc ├── fib_tc.rsc ├── ack.rsc ├── tailrec.rsc ├── match_expr.rsc ├── euler5.rsc ├── atom.rsc ├── euler6.rsc ├── pipe.rsc ├── euler2.rsc ├── fizzbuzz.rsc ├── block.rsc ├── map.rsc ├── fmap_tuple.rsc ├── quicksort.rsc ├── run_len_encode.rsc ├── mergesort.rsc ├── two_sum.rsc ├── euler1_tup.rsc ├── caesar.rsc ├── euler3.rsc ├── bst.rsc ├── graph.rsc ├── tictactoe.rsc ├── expr.rsc └── tictactoe_minimax.rsc ├── setup.sh ├── test ├── dune ├── strings.ml ├── fib.ml ├── match_expr.ml ├── pipe.ml ├── run_len_encode.ml ├── tuple.ml ├── two_sum.ml ├── capture.ml ├── tailrec.ml ├── expr.ml ├── comments.ml ├── util.ml ├── sort.ml ├── block.ml ├── map.ml └── euler.ml ├── LICENSE ├── rustscript.opam ├── Dockerfile ├── licenses ├── LICENSE-MIT └── LICENSE-APACHE ├── test.rsc ├── docs └── index.html ├── editor └── rustscript.vim ├── rustscript.install └── README.md /lib/error.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | .vscode/ 3 | .replit -------------------------------------------------------------------------------- /.dockerignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | .vscode/ 3 | .replit 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | (name rustscript) 3 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name rustscript_cli) 3 | (libraries rustscript)) 4 | -------------------------------------------------------------------------------- /assets/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mkhan45/RustScript2/HEAD/assets/logo.png -------------------------------------------------------------------------------- /bench.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | hyperfine --warmup 3 "dune exec ./bin/rustscript_cli.exe examples/fib.rsc" 3 | -------------------------------------------------------------------------------- /examples/comment.rsc: -------------------------------------------------------------------------------- 1 | let a = 5 # set a to 5 2 | # aaaaaa 3 | let b = (5, 10, 15) 4 | a 5 | b 6 | # 7 | -------------------------------------------------------------------------------- /examples/euler1.rsc: -------------------------------------------------------------------------------- 1 | let euler1 = sum([x for x in [1..1000] if x mod 3 == 0 || x mod 5 == 0]) 2 | # inspect(euler1) # 233168 3 | -------------------------------------------------------------------------------- /examples/fib.rsc: -------------------------------------------------------------------------------- 1 | let fib(n) = match n 2 | | 0 | 1 -> 1 3 | | _ -> fib(n - 1) + fib(n - 2) 4 | 5 | inspect(fib(30)) 6 | -------------------------------------------------------------------------------- /examples/euler1_no_listcomp.rsc: -------------------------------------------------------------------------------- 1 | let predicate = fn(n) => (n mod 3 == 0) || (n mod 5 == 0) 2 | # inspect(sum(filter_rev(predicate, range(1, 1000)))) #233168 3 | -------------------------------------------------------------------------------- /examples/strings.rsc: -------------------------------------------------------------------------------- 1 | let a = "abc" 2 | 3 | let b = "123!" 4 | 5 | let result = match (a, b, a + b) 6 | | ("abc", "123!", "abc123!") -> T 7 | | _ -> F 8 | -------------------------------------------------------------------------------- /examples/capture.rsc: -------------------------------------------------------------------------------- 1 | let quadratic(a, b, c, x) = a * x * x + b * x + c 2 | let g = sub(_, 5) 3 | let f = quadratic(_, _, 0, _) 4 | let h = sub(%1, %0) 5 | let j = f(1, 2, _) 6 | -------------------------------------------------------------------------------- /examples/fib_tc.rsc: -------------------------------------------------------------------------------- 1 | let fib = { 2 | let fib_helper = fn(n, a, b) => if n == 0 then b else fib_helper(n - 1, b, a + b) 3 | 4 | fn (n) => fib_helper(n, 1, 1) 5 | } 6 | -------------------------------------------------------------------------------- /examples/ack.rsc: -------------------------------------------------------------------------------- 1 | let ack(m, n) = match (m, n) 2 | | (0, _) -> n + 1 3 | | (_, 0) -> ack(m - 1, 1) 4 | | _ -> ack(m - 1, ack(m, n - 1)) 5 | 6 | inspect(ack(3, 8)) 7 | -------------------------------------------------------------------------------- /examples/tailrec.rsc: -------------------------------------------------------------------------------- 1 | let sum_tailrec(n, acc) = { 2 | if n == 0 3 | then acc 4 | else sum_tailrec(n - 1, acc + n) 5 | } 6 | 7 | inspect(sum_tailrec(500000, 0)) 8 | -------------------------------------------------------------------------------- /setup.sh: -------------------------------------------------------------------------------- 1 | opam init -y 2 | eval $(opam env --switch=default) 3 | opam install dune -y 4 | opam install base stdio -y # Add deps here 5 | eval $(opam config env) 6 | eval $(opam env) -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names fib tuple block comments tailrec euler match_expr map run_len_encode two_sum sort strings expr capture pipe) 3 | (libraries base stdio rustscript)) 4 | -------------------------------------------------------------------------------- /examples/match_expr.rsc: -------------------------------------------------------------------------------- 1 | let fib = fn(n) => match n 2 | | 0 | 1 -> 1 3 | | _ as x -> fib(x - 1) + fib(n - 2) 4 | 5 | let fib2 = fn(n) => if let 0 | 1 = n then 1 else fib2(n - 1) + fib2(n - 2) 6 | -------------------------------------------------------------------------------- /examples/euler5.rsc: -------------------------------------------------------------------------------- 1 | let gcd = fn(a, b) => match (a, b) 2 | | (a, 0) -> a 3 | | (a, b) -> gcd(b, a mod b) 4 | 5 | let lcm = fn(a, b) => (a * b) / gcd(a, b) 6 | 7 | let euler5 = fold(1, lcm, [1..20]) 8 | -------------------------------------------------------------------------------- /examples/atom.rsc: -------------------------------------------------------------------------------- 1 | let x = :a1 2 | let y = :b2 3 | 4 | let m = %{:a: 1, :b: %{:a: 3, :b: 4, :c: 5}} 5 | let %{:a: i, :b: m2} = m 6 | 7 | let %{:a: z, :b: x, :c: y} = m2 8 | 9 | inspect((i, z, x, y)) 10 | -------------------------------------------------------------------------------- /examples/euler6.rsc: -------------------------------------------------------------------------------- 1 | let sum_sqr = { 2 | let s = sum([1..101]) 3 | s * s 4 | } 5 | 6 | let sqr_sum = sum([x * x for x in [1..101]]) 7 | 8 | let euler6 = sum_sqr - sqr_sum 9 | 10 | # inspect(euler6) # 25164150 11 | -------------------------------------------------------------------------------- /examples/pipe.rsc: -------------------------------------------------------------------------------- 1 | let add5 = add(_, 5) 2 | let mul3 = mul(_, 3) 3 | 4 | let x = 10 |> add5 |> mul3 5 | 6 | let g = "asdf" 7 | |> to_charlist 8 | |> reverse 9 | |> enumerate 10 | |> map(fn((i, c)) => c + to_string(i), _) 11 | -------------------------------------------------------------------------------- /examples/euler2.rsc: -------------------------------------------------------------------------------- 1 | let euler2 = { 2 | let aux = fn((a, b), acc) => 3 | if b < 4000000 then 4 | aux((b, a + 4 * b), acc + b) 5 | else 6 | acc 7 | 8 | aux((0, 2), 0) 9 | } 10 | 11 | inspect(euler2) 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | RustScript is dual-licensed under either 2 | 3 | * MIT License (license/LICENSE-MIT or http://opensource.org/licenses/MIT) 4 | * Apache License, Version 2.0 (license/LICENSE-APACHE or http://www.apache.org/licenses/LICENSE-2.0) 5 | 6 | at your option. 7 | -------------------------------------------------------------------------------- /examples/fizzbuzz.rsc: -------------------------------------------------------------------------------- 1 | let fizzbuzz(n) = foreach([1..101], fn(n) => match (n mod 3, n mod 5) 2 | | (0, 0) -> println("FizzBuzz") 3 | | (0, _) -> println("Fizz") 4 | | (_, 0) -> println("Buzz") 5 | | _ -> println(to_string(n)) 6 | ) 7 | 8 | fizzbuzz(100) 9 | -------------------------------------------------------------------------------- /examples/block.rsc: -------------------------------------------------------------------------------- 1 | let (a, b) = { 2 | let a = (4, 2) 3 | let (a, b) = a 4 | (a * b, 12) 5 | } 6 | 7 | let f = fn(a, b, c) => { 8 | let g = fn(a, b) => a * b + c 9 | g(b, c) + a 10 | } 11 | 12 | f(10, 5, 3) 13 | 14 | let c = 5 + { 5 + 10 * 2 } 15 | -------------------------------------------------------------------------------- /examples/map.rsc: -------------------------------------------------------------------------------- 1 | let m = %{ 2 | 1 => 2, 3 | 3 => 4, 4 | (5, 6) => (7, 8) 5 | } 6 | 7 | let %{1 => x, 3 => y, (5, 6) => z, 467 => a} = m 8 | 9 | let m2 = %{ 10 | one: 1, 11 | three: 3, 12 | two: 2 13 | } 14 | 15 | let %{one, two, three} = m2 16 | -------------------------------------------------------------------------------- /examples/fmap_tuple.rsc: -------------------------------------------------------------------------------- 1 | let fmap = fn (f, ls) => { 2 | if ls == () then { 3 | () 4 | } else { 5 | let (hd, tl) = ls 6 | (f(hd), fmap(f, tl)) 7 | } 8 | } 9 | 10 | let f = fn(x) => x * 2 11 | 12 | fmap(f, (5, (10, (20, (30, (1, ())))))) 13 | -------------------------------------------------------------------------------- /test/strings.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | 4 | open Rustscript.Run 5 | open Util 6 | 7 | let () = 8 | let ss, state = 9 | test_state () |> run_file (test_file "strings.rsc") in 10 | assert_equal_expressions "result" "T" ss state; 11 | 12 | printf "Passed\n" 13 | -------------------------------------------------------------------------------- /examples/quicksort.rsc: -------------------------------------------------------------------------------- 1 | let sort = fn(ls) => match ls 2 | | [] -> [] 3 | | [pivot | tail] -> { 4 | let (higher, lower) = partition(tail, fn(x) => x >= pivot) 5 | sort(lower) + [pivot] + sort(higher) 6 | } 7 | 8 | # inspect(sort([5, 3, 7, 9, 10, 4, 6])) # [3, 4, 5, 6, 7, 9, 10] 9 | -------------------------------------------------------------------------------- /test/fib.ml: -------------------------------------------------------------------------------- 1 | open Stdio 2 | 3 | open Rustscript.Run 4 | open Util 5 | 6 | let () = 7 | let ss, state = test_state () in 8 | let (_, state), ss = eval ss state "let fib = fn(n) => if n < 1 then 1 else fib(n - 1) + fib(n - 2)" in 9 | assert_equal_expressions "fib(10)" "144" ss state; 10 | printf "Passed\n" 11 | -------------------------------------------------------------------------------- /test/match_expr.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | 4 | open Rustscript.Run 5 | open Util 6 | 7 | let () = 8 | let ss, state = 9 | test_state () |> run_file (test_file "match_expr.rsc") in 10 | 11 | assert_equal_expressions "fib(20)" "10946" ss state; 12 | assert_equal_expressions "fib2(20)" "10946" ss state; 13 | 14 | printf "Passed\n" 15 | -------------------------------------------------------------------------------- /test/pipe.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | 4 | open Rustscript.Run 5 | open Util 6 | 7 | let () = 8 | let ss, state = 9 | test_state () |> run_file (test_file "pipe.rsc") in 10 | 11 | assert_equal_expressions "x" "45" ss state; 12 | assert_equal_expressions "g" "[\"f0\", \"d1\", \"s2\", \"a3\"]" ss state; 13 | 14 | printf "Passed\n" 15 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name rustscript) 3 | (libraries base stdio lwt cohttp cohttp-lwt-unix safepass) 4 | (modules run types parser scanner eval operators preprocess compile) 5 | (preprocess (pps ppx_blob)) 6 | (preprocessor_deps (file stdlib.rsc) (file shim.js) (file lodash.js))) 7 | 8 | (env 9 | (release 10 | (ocamlopt_flags (:standard -O3)))) 11 | -------------------------------------------------------------------------------- /rustscript.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "0.1.0" 3 | maintainer: "mikail@mikail-khan.com" 4 | authors: ["Mikail Khan" "William Ragstad"] 5 | homepage: "https://github.com/mkhan45/RustScript2" 6 | bug-reports: "https://github.com/mkhan45/RustScript2/issues" 7 | dev-repo: "git+https://github.com/mkhan45/RustScript2.git" 8 | license: "MIT + Apache" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | -------------------------------------------------------------------------------- /test/run_len_encode.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | 4 | open Rustscript.Run 5 | open Util 6 | 7 | let () = 8 | let ss, state = 9 | test_state () |> run_file (test_file "run_len_encode.rsc") in 10 | 11 | assert_equal_expressions 12 | "run_len_encode(test_ls)" 13 | "[(1, 2), (2, 1), (3, 1), (4, 3), (5, 1), (6, 1), (1, 1), (2, 2)]" 14 | ss 15 | state; 16 | 17 | printf "Passed\n" 18 | -------------------------------------------------------------------------------- /test/tuple.ml: -------------------------------------------------------------------------------- 1 | open Stdio 2 | 3 | open Rustscript.Run 4 | open Util 5 | 6 | let () = 7 | let ss, state = test_state () in 8 | let (_, state), ss = eval ss state "let x = (1, 2, (3, 4, 5), (6, 7), 8)" in 9 | let (_, state), ss = eval ss state "let (a, b, c, d, e) = x" in 10 | let (_, state), ss = eval ss state "let (f, g, h) = c" in 11 | assert_equal_expressions "(a, b, e, f, g, h)" "(1, 2, 8, 3, 4, 5)" ss state; 12 | printf "Passed\n" 13 | -------------------------------------------------------------------------------- /test/two_sum.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | 4 | open Rustscript.Run 5 | open Util 6 | 7 | let () = 8 | let ss, state = 9 | test_state () |> run_file (test_file "two_sum.rsc") in 10 | 11 | assert_equal_expressions "two_sum([1,9,13,20,47], 10)" "(0, 1)" ss state; 12 | assert_equal_expressions "two_sum([3,2,4,1,9], 12)" "(0, 4)" ss state; 13 | assert_equal_expressions "two_sum([], 10)" "()" ss state; 14 | 15 | printf "Passed\n" 16 | -------------------------------------------------------------------------------- /examples/run_len_encode.rsc: -------------------------------------------------------------------------------- 1 | let run_len_encode = fn(ls) => match ls 2 | | [] -> [] 3 | | [x | xs] -> { 4 | let next = run_len_encode(xs) 5 | match next 6 | | [(next_x, cnt) | tl] when x == next_x -> [(x, cnt + 1) | tl] 7 | | _ -> [(x, 1) | next] 8 | } 9 | 10 | let test_ls = [1, 1, 2, 3, 4, 4, 4, 5, 6, 1, 2, 2] 11 | 12 | # [(1., 2.), (2., 1.), (3., 1.), (4., 3.), (5., 1.), (6., 1.), (1., 1.), (2., 2.)] 13 | # inspect(run_len_encode(test_ls)) 14 | -------------------------------------------------------------------------------- /test/capture.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | 4 | open Rustscript.Run 5 | open Util 6 | 7 | let () = 8 | let ss, state = 9 | test_state () |> run_file (test_file "capture.rsc") in 10 | 11 | assert_equal_expressions "g(3)" "-2" ss state; 12 | assert_equal_expressions "g(5)" "0" ss state; 13 | assert_equal_expressions "f(1, 2, 4)" "quadratic(1, 2, 0, 4)" ss state; 14 | assert_equal_expressions "j(4)" "f(1, 2, 4)" ss state; 15 | assert_equal_expressions "h(5, 3)" "-2" ss state; 16 | 17 | printf "Passed\n" 18 | -------------------------------------------------------------------------------- /test/tailrec.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | 4 | open Rustscript.Run 5 | open Util 6 | 7 | let () = 8 | let ss, state = 9 | test_state () |> run_file (test_file "tailrec.rsc") in 10 | (* Evaluating this stack overflows when tail recursion isn't optimized*) 11 | assert_equal_expressions "sum_tailrec(300000, 0)" "45000150000" ss state; 12 | 13 | let ss, state = 14 | test_state () |> run_file (test_file "fib_tc.rsc") in 15 | assert_equal_expressions "fib(30)" "2178309" ss state; 16 | 17 | printf "Passed\n" 18 | -------------------------------------------------------------------------------- /examples/mergesort.rsc: -------------------------------------------------------------------------------- 1 | let merge = fn(xs, ys) => match (xs, ys) 2 | | (ls, [])|([], ls) -> ls 3 | | ([x|xs], [y|ys]) when x <= y -> [x | merge(xs, [y|ys])] 4 | | ([x|xs], [y|ys]) -> [y | merge([x|xs], ys)] 5 | 6 | let sort = fn(ls) => { 7 | let pairs = fn(ls) => match ls 8 | | [a, b | tl] -> [merge(a, b) | pairs(tl)] 9 | | _ -> ls 10 | 11 | let loop = fn(ls) => match ls 12 | | [x] -> x 13 | | _ -> loop(pairs(ls)) 14 | 15 | loop([[x] for x in ls]) 16 | } 17 | 18 | # inspect(sort([5, 4, 12, 17, 6, 7, 4, 3, 2, 8, 9])) 19 | -------------------------------------------------------------------------------- /examples/two_sum.rsc: -------------------------------------------------------------------------------- 1 | let two_sum = fn(nums, target) => { 2 | let helper = fn(m, ls, target) => match ls 3 | | [] -> () 4 | | [(i, x) | xs] -> { 5 | let complement = target - x 6 | match m 7 | | %{complement => ()} -> helper(%{x => i | m}, xs, target) 8 | | %{complement => y} -> (y, i) 9 | } 10 | 11 | helper(%{}, enumerate(nums), target) 12 | } 13 | 14 | # inspect(two_sum([1,9,13,20,47], 10)) # (0, 1) 15 | # inspect(two_sum([3,2,4,1,9], 10)) # (0, 4) 16 | # inspect(two_sum([], 10)) # () 17 | -------------------------------------------------------------------------------- /test/expr.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | 4 | open Rustscript.Run 5 | open Util 6 | 7 | let () = 8 | let ss, state = 9 | test_state () |> run_file (test_file "expr.rsc") in 10 | 11 | assert_equal_expressions "eval_str(\"2\")" (Int.to_string 2) ss state; 12 | assert_equal_expressions "eval_str(\"2 * 5 + 4 / 3\")" (Float.to_string (2. *. 5. +. 4. /. 3.)) ss state; 13 | assert_equal_expressions 14 | "eval_str(\"53 / 76 + 4 - 32 / 21\")" 15 | (Float.to_string (53. /. 76. +. 4. -. 32. /. 21.)) 16 | ss state; 17 | 18 | printf "Passed\n" 19 | -------------------------------------------------------------------------------- /test/comments.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | 4 | open Rustscript.Run 5 | open Util 6 | 7 | let () = 8 | let ss, state = 9 | test_state () |> run_file (test_file "block.rsc") in 10 | assert_equal_expressions "a + b" "20" ss state; 11 | assert_equal_expressions "f(10, 5, 3)" "28" ss state; 12 | 13 | let ss, state = 14 | test_state () |> run_file (test_file "comment.rsc") in 15 | let input = "a" in 16 | let output = "5" in 17 | assert_equal_expressions input output ss state; 18 | 19 | let input = "b" in 20 | let output = "(5, 10, 15)" in 21 | assert_equal_expressions input output ss state; 22 | printf "Passed\n" 23 | -------------------------------------------------------------------------------- /test/util.ml: -------------------------------------------------------------------------------- 1 | open Stdio 2 | 3 | open Rustscript.Run 4 | open Rustscript.Types 5 | 6 | let test_file filename = Printf.sprintf "../../../examples/%s" filename 7 | 8 | let assert_equal_expressions lhs rhs ss state = 9 | let (lhs_res, _), ss = eval ss state lhs in 10 | let (rhs_res, _), ss = eval ss state rhs in 11 | match (Rustscript.Operators.val_eq lhs_res rhs_res ss {line_num = 0; filename = "test"}) with 12 | | Boolean true -> assert true 13 | | _ -> 14 | printf "Expected LHS: %s\n" (string_of_val ss lhs_res); 15 | printf "Got RHS: %s\n" (string_of_val ss rhs_res); 16 | printf "\n"; 17 | assert false 18 | -------------------------------------------------------------------------------- /test/sort.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | 4 | open Rustscript.Run 5 | open Util 6 | 7 | let () = 8 | let ss, state = 9 | test_state () |> run_file (test_file "quicksort.rsc") in 10 | assert_equal_expressions "sort([5, 3, 9, 10, 4, 7, 6])" "[3, 4, 5, 6, 7, 9, 10]" ss state; 11 | 12 | let ss, state = 13 | test_state () |> run_file (test_file "mergesort.rsc") in 14 | assert_equal_expressions "sort([5, 3, 9, 10, 4, 7, 6])" "[3, 4, 5, 6, 7, 9, 10]" ss state; 15 | 16 | let ss, state = 17 | test_state () |> run_file (test_file "bst.rsc") in 18 | assert_equal_expressions "sort(ls)" "tree_to_ls_inorder(bst)" ss state; 19 | 20 | printf "Passed\n" 21 | -------------------------------------------------------------------------------- /test/block.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | open Printf 4 | 5 | open Rustscript.Run 6 | open Util 7 | 8 | let () = 9 | let ss, state = 10 | test_state () |> run_file (test_file "block.rsc") in 11 | assert_equal_expressions "a + b" "20" ss state; 12 | assert_equal_expressions "f(10, 5, 3)" "28" ss state; 13 | assert_equal_expressions "c" (Int.to_string (5 + (5 + 10 * 2))) ss state; 14 | 15 | let ss, state = 16 | test_state () |> run_file (test_file "fmap_tuple.rsc") in 17 | let input = "(5, (10, (20, (30, (1, ())))))" in 18 | let output = "(10, (20, (40, (60, (2, ())))))" in 19 | assert_equal_expressions (sprintf "fmap(f, %s)" input) output ss state; 20 | printf "Passed\n" 21 | -------------------------------------------------------------------------------- /examples/euler1_tup.rsc: -------------------------------------------------------------------------------- 1 | let range_tup = { 2 | let helper = fn (l, r, acc) => 3 | if l == r then acc else helper(l, r - 1, (r, acc)) 4 | 5 | fn (l, r) => helper(l - 1, r, ()) 6 | } 7 | 8 | let filter_tup = { 9 | let helper = fn(f, ls, acc) => match ls 10 | | (_, ()) -> acc 11 | | (hd, tl) -> 12 | if f(hd) 13 | then helper(f, tl, (hd, acc)) 14 | else helper(f, tl, acc) 15 | 16 | fn(f, ls) => helper(f, ls, ()) 17 | } 18 | 19 | let sum_tup = { 20 | let helper = fn(ls, acc) => match ls 21 | | (hd, ()) -> hd + acc 22 | | (hd, tl) -> helper(tl, hd + acc) 23 | 24 | fn (ls) => helper(ls, 0) 25 | } 26 | 27 | let predicate = fn(n) => (n mod 3 == 0) || (n mod 5 == 0) 28 | -------------------------------------------------------------------------------- /examples/caesar.rsc: -------------------------------------------------------------------------------- 1 | let (to_number, to_letter) = { 2 | let enumerated = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" |> to_charlist |> enumerate 3 | let to_number = fold(%{}, fn(m, (i, l)) => %{l => i | m}, enumerated) 4 | let to_letter = fold(%{}, fn(m, (i, l)) => %{i => l | m}, enumerated) 5 | (to_number, to_letter) 6 | } 7 | 8 | let encode = fn(text, shift) => { 9 | let shift = shift mod 26 10 | 11 | let loop = fn(char_ls, acc) => match char_ls 12 | | [] -> concat(reverse(acc)) 13 | | [c | xs] when to_number(c) == () -> loop(xs, [c | acc]) 14 | | [c | xs] -> { 15 | let new_letter = c 16 | |> to_number 17 | |> add(shift, _) 18 | |> fn(c) => if c < 0 then 26 + c else c 19 | |> fn(c) => to_letter(c mod 26) 20 | loop(xs, [new_letter | acc]) 21 | } 22 | 23 | loop(to_charlist(text), []) 24 | } 25 | 26 | let decode = fn(text, n) => encode(text, -n) 27 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:alpine AS build 2 | 3 | RUN sudo apk add pkgconf libgmpxx gmp-dev binutils 4 | RUN opam install dune base cohttp cohttp-lwt-unix js_of_ocaml js_of_ocaml-ppx lwt ppx_blob stdio safepass 5 | # RUN eval $(opam env) 6 | ENV OPAM_SWITCH_PREFIX '/home/opam/.opam/4.13' 7 | ENV CAML_LD_LIBRARY_PATH '/home/opam/.opam/4.13/lib/stublibs:/home/opam/.opam/4.13/lib/ocaml/stublibs:/home/opam/.opam/4.13/lib/ocaml' 8 | ENV OCAML_TOPLEVEL_PATH '/home/opam/.opam/4.13/lib/toplevel' 9 | ENV PATH '/home/opam/.opam/4.13/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin' 10 | 11 | # Cloning RustScript 12 | COPY . RustScript2 13 | WORKDIR RustScript2 14 | RUN sudo chown -R opam . 15 | 16 | # Build RustScript 17 | RUN dune build 18 | RUN sudo strip _build/default/bin/rustscript_cli.exe 19 | 20 | FROM alpine 21 | COPY --from=build /home/opam/RustScript2/_build/default/bin/rustscript_cli.exe /bin/rustscript 22 | -------------------------------------------------------------------------------- /licenses/LICENSE-MIT: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | -------------------------------------------------------------------------------- /examples/euler3.rsc: -------------------------------------------------------------------------------- 1 | let gcd = fn(a, b) => match (a, b) 2 | | (x, 0) | (0, x) -> x 3 | | (a, b) when a > b -> gcd(b, a) 4 | | (a, b) -> { 5 | let remainder = b mod a 6 | if remainder != 0 then (gcd(a, remainder)) else a 7 | } 8 | 9 | let pollard = fn(n) => match n 10 | | 1 -> () 11 | | n when n mod 2 == 0 -> 2 12 | | n -> { 13 | let g = fn(x, n) => (x * x + 1) mod n 14 | let iter = fn(x, y, d) => match (x, y, d) 15 | | (x, y, 1) -> { 16 | let x = g(x, n) 17 | let y = g(g(y, n), n) 18 | let d = gcd(abs(x - y), n) 19 | iter(x, y, d) 20 | } 21 | | (_, _, d) -> if d == n then () else d 22 | 23 | iter(2, 2, 1) 24 | } 25 | 26 | let factor = fn(n) => { 27 | let d = pollard(n) 28 | if d == () then () else n / d 29 | } 30 | 31 | let euler3 = { 32 | # repeatedly factors until largest is found 33 | let aux = fn(n) => match factor(n) 34 | | () -> n 35 | | f when n == f -> f 36 | | f -> aux(f) 37 | 38 | let n = 600851475143 39 | aux(n) 40 | } 41 | 42 | # inspect(euler3) # should be 6857 43 | -------------------------------------------------------------------------------- /examples/bst.rsc: -------------------------------------------------------------------------------- 1 | let sort = fn(ls) => match ls 2 | | [] -> [] 3 | | [pivot | tail] -> { 4 | let higher = filter (fn(x) => x >= pivot, tail) 5 | let lower = filter(fn(x) => x < pivot, tail) 6 | 7 | sort(lower) + [pivot] + sort(higher) 8 | } 9 | 10 | let insert = fn(root, key) => match root 11 | | () -> %{val: key} 12 | | %{right, val} when val < key -> %{right: insert(right, key) | root} 13 | | %{left} -> %{left: insert(left, key) | root} 14 | 15 | let tree_to_ls_inorder = { 16 | let loop = fn(root, acc) => match root 17 | | () -> acc 18 | | %{val, left, right} -> { 19 | let acc = loop(left, acc) 20 | let acc = [val | acc] 21 | loop(right, acc) 22 | } 23 | 24 | fn(bst) => reverse(loop(bst, [])) 25 | } 26 | 27 | let tree_to_ls_preorder = { 28 | let loop = fn(root, acc) => match root 29 | | () -> acc 30 | | %{val, left, right} -> { 31 | let acc = [val | acc] 32 | let acc = loop(left, acc) 33 | loop(right, acc) 34 | } 35 | 36 | fn(bst) => reverse(loop(bst, [])) 37 | } 38 | 39 | let construct_from_list = fn(ls) => 40 | fold((), fn(t, v) => insert(t, v), ls) 41 | 42 | let ls = to_charlist("khan348kha") 43 | let bst = construct_from_list(ls) 44 | -------------------------------------------------------------------------------- /examples/graph.rsc: -------------------------------------------------------------------------------- 1 | let y_bin() = 1 2 | 3 | let distance_sqr((x1, y1), (x2, y2)) = { 4 | let x = x1 - x2 5 | let y = y1 - y2 6 | x * x + y * y 7 | } 8 | 9 | let draw_graph(points, scale) = { 10 | let height = 20 11 | let width = 40 12 | 13 | let col_loop = fn(row, col, row_arr) => { 14 | if col == width then { 15 | ["\n" | row_arr] 16 | } else { 17 | let current_point = ((col - width / 2) / scale, (row - height / 2) / scale) 18 | let is_filled = points 19 | |> map(distance_sqr(current_point, _), _) 20 | |> map(fn(dist) => dist < 0.001, _) 21 | |> any 22 | 23 | let point_char = if is_filled then "." else " " 24 | col_loop(row, col + 1, [point_char | row_arr]) 25 | } 26 | } 27 | 28 | let row_loop = fn(row, table) => { 29 | if row == height then { 30 | table 31 | |> map(reverse, _) 32 | |> map(concat, _) 33 | |> concat 34 | } else { 35 | let table = [col_loop(row, 0, []) | table] 36 | row_loop(row + 1, table) 37 | } 38 | } 39 | 40 | let graph_str = row_loop(0, []) 41 | println(graph_str) 42 | } 43 | 44 | let f(x) = x * x * x 45 | 46 | let points = [-15..16] 47 | |> map(div(_, 20), _) 48 | |> map(fn(x) => (x, f(x)), _) 49 | 50 | draw_graph(points, 20) 51 | -------------------------------------------------------------------------------- /bin/rustscript_cli.ml: -------------------------------------------------------------------------------- 1 | open Rustscript 2 | open Rustscript.Types 3 | open Base 4 | open Stdio 5 | 6 | let rec repl state ss = 7 | printf "> "; 8 | Out_channel.flush stdout; 9 | match In_channel.input_line ~fix_win_eol:true stdin with 10 | | Some "\n" -> () 11 | | None -> () 12 | | Some line -> 13 | match Rustscript.Run.eval ss state line with 14 | | (Tuple [], new_state), ss -> repl new_state ss 15 | | (evaled, new_state), ss -> 16 | printf "%s\n" (Rustscript.Types.string_of_val ss evaled); 17 | Out_channel.flush stdout; 18 | repl new_state ss 19 | 20 | let () = 21 | let args = Sys.get_argv () in 22 | let ss, state = Run.default_state () in 23 | match args |> Array.to_list with 24 | | [_] -> 25 | repl state ss 26 | | _::"compile"::filenames -> 27 | let compiled = List.fold_left ~init:"" ~f:(fun s f -> s ^ "\n" ^ Compile.compile_file f) filenames 28 | in 29 | printf "%s" compiled 30 | | _::filenames -> 31 | let _ = List.fold_left ~init:(ss, state) ~f:(fun s f -> Run.run_file f s) filenames 32 | in 33 | () 34 | | _ -> 35 | printf "Usage: 'rustscript ' or just 'rustscript' for REPL\n" 36 | -------------------------------------------------------------------------------- /test.rsc: -------------------------------------------------------------------------------- 1 | let range(a, b) = range_step(a, b, 1) 2 | 3 | let f = fn(x, y) => { 4 | let c = x * y 5 | c + x + y 6 | } 7 | 8 | let t = (f(10, 5), f(5, 10)) 9 | let (a, b) = t 10 | 11 | let f = fn((a, b), c) => a * b + c 12 | inspect(f((5, 10), 15)) 13 | 14 | let g(x) = x * 2 15 | inspect(g(5)) 16 | 17 | let fib(x) = if x < 2 then x else fib(x - 1) + fib(x - 2) 18 | inspect(fib(10)) 19 | 20 | let range_tup(l, r) = if l == r then () else (l, range_tup(l + 1, r)) 21 | inspect(range_tup(5, 15)) 22 | 23 | let map(f, ls) = if ls == () then () else { 24 | inspect(ls) 25 | let (hd, tl) = ls 26 | (hd, map(f, tl)) 27 | } 28 | inspect(map(fib, range_tup(1, 10))) 29 | 30 | let fib2(n) = match n 31 | | 0 -> 1 32 | | 1 -> 1 33 | | _ -> fib(n - 1) + fib(n - 2) 34 | inspect(fib2(10)) 35 | 36 | fib2(10) |> inspect 37 | 38 | 10 39 | |> fn(a) => a + 50 40 | |> fn(a) => a * 20 41 | |> fn(a) => a - 20 42 | |> fn(a) => a / 2 43 | |> inspect 44 | inspect((((10 + 50) * 20) - 20) / 2) 45 | 46 | let (a, b, c) = (1, 2, 3) 47 | let f = fn(x) => x * b 48 | 2 |> f |> inspect 49 | 50 | let ls = [1, 4, 5] 51 | ls |> inspect 52 | 53 | let [a, b, c] = ls 54 | (a, b, c) |> inspect 55 | 56 | let ls = [1, 2, 3, 4, 5, 6] 57 | let [a, b, c | tl] = ls 58 | (a, b, c, tl) |> inspect 59 | [1..10] |> inspect 60 | 61 | let m = %{"one" => 1, "two" => 2, 3 => "three"} 62 | m |> inspect 63 | m(3) |> inspect 64 | -------------------------------------------------------------------------------- /test/map.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | 4 | open Rustscript.Run 5 | open Util 6 | 7 | let () = 8 | let ss, state = 9 | test_state () |> run_file (test_file "map.rsc") in 10 | 11 | assert_equal_expressions "get(m, 1)" "2" ss state; 12 | assert_equal_expressions "get(m, 3)" "4" ss state; 13 | assert_equal_expressions "get(m, (5, 6))" "(7, 8)" ss state; 14 | assert_equal_expressions "get(m, 467))" "()" ss state; 15 | 16 | assert_equal_expressions "get(m, 1)" "x" ss state; 17 | assert_equal_expressions "get(m, 3)" "y" ss state; 18 | assert_equal_expressions "get(m, (5, 6))" "z" ss state; 19 | assert_equal_expressions "get(m, 467))" "a" ss state; 20 | 21 | assert_equal_expressions "m(1)" "x" ss state; 22 | assert_equal_expressions "m(3)" "y" ss state; 23 | assert_equal_expressions "m((5, 6))" "z" ss state; 24 | assert_equal_expressions "m(467)" "a" ss state; 25 | 26 | assert_equal_expressions "one" "1" ss state; 27 | assert_equal_expressions "two" "2" ss state; 28 | assert_equal_expressions "three" "3" ss state; 29 | 30 | let ss, state = 31 | test_state () |> run_file (test_file "caesar.rsc") in 32 | 33 | assert_equal_expressions "encode(\"HELLO WORLD\", 5)" "\"MJQQT BTWQI\"" ss state; 34 | assert_equal_expressions "decode(encode(\"HELLO WORLD\", 5), 5)" "\"HELLO WORLD\"" ss state; 35 | 36 | printf "Passed\n" 37 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | RustScript 4 | 5 | 6 |

7 | Web RustScript 8 |

9 |

10 | Don't abuse 11 |

12 |
13 | 14 |
15 | 16 | 

17 |     
18 | 
19 |     
42 | 
43 | 


--------------------------------------------------------------------------------
/test/euler.ml:
--------------------------------------------------------------------------------
 1 | open Base
 2 | open Stdio
 3 | 
 4 | open Rustscript.Run
 5 | open Util
 6 | 
 7 | let () =
 8 |     let ss, state = 
 9 |         test_state () |> run_file (test_file "euler1.rsc") in
10 |     assert_equal_expressions "euler1" "233168" ss state;
11 | 
12 |     let ss, state = 
13 |         test_state () |> run_file (test_file "euler1_no_listcomp.rsc") in
14 |     assert_equal_expressions "sum(filter_rev(predicate, range(1, 1000)))" "233168" ss state;
15 | 
16 |     let ss, state = 
17 |         test_state () |> run_file (test_file "euler1_tup.rsc") in
18 |     assert_equal_expressions "sum_tup(filter_tup(predicate, range_tup(1, 1000)))" "233168" ss state;
19 | 
20 |     let ss, state = 
21 |         test_state () |> run_file (test_file "euler1_tup.rsc") in
22 |     assert_equal_expressions "sum(filter(predicate, range(1, 1000)))" "233168" ss state;
23 | 
24 |     let ss, state = 
25 |         test_state () |> run_file (test_file "euler2.rsc") in
26 |     assert_equal_expressions "euler2" "4613732" ss state;
27 | 
28 |     let ss, state = 
29 |         test_state () |> run_file (test_file "euler3.rsc") in
30 |     assert_equal_expressions "euler3" "6857" ss state;
31 | 
32 |     let ss, state = 
33 |         test_state () |> run_file (test_file "euler5.rsc") in
34 |     assert_equal_expressions "euler5" "232792560" ss state;
35 | 
36 |     let ss, state = 
37 |         test_state () |> run_file (test_file "euler6.rsc") in
38 |     assert_equal_expressions "euler6" "25164150" ss state;
39 | 
40 |     printf "Passed\n"
41 | 


--------------------------------------------------------------------------------
/editor/rustscript.vim:
--------------------------------------------------------------------------------
 1 | " adapted from
 2 | " https://github.com/thesephist/ink/blob/7d47f9f39c539381085ff2dd07ce5b356916daa9/utils/ink.vim, 
 3 | " https://vim.fandom.com/wiki/Creating_your_own_syntax_files
 4 | 
 5 | if exists("b:rustscript_syntax")
 6 |     finish
 7 | endif
 8 | 
 9 | syntax sync fromstart
10 | 
11 | " prefer hard tabs
12 | set noexpandtab
13 | 
14 | " keywords
15 | syn keyword rscKeyword match let when
16 | syn keyword rscKeyword if then else
17 | syn keyword rscKeyword for in
18 | highlight link rscKeyword Keyword
19 | 
20 | " operators
21 | syntax match rscOp "+"
22 | syntax match rscOp "-"
23 | syntax match rscOp "*"
24 | syntax match rscOp "/"
25 | syntax match rscOp "^"
26 | syntax match rscOp "$"
27 | syntax match rscOp "%"
28 | syntax match rscOp "&&"
29 | syntax match rscOp "||"
30 | syntax match rscOp "<="
31 | syntax match rscOp "<"
32 | syntax match rscOp ">"
33 | syntax match rscOp ">="
34 | syntax match rscOp "mod"
35 | highlight link rscOp Operator
36 | 
37 | syntax match rscMatchArrow "->" 
38 | highlight link rscMatchArrow Label
39 | 
40 | syntax match rscFnArrow "\v\=\>" 
41 | syn keyword rscFnKeyword fn
42 | highlight link rscFnArrow Function
43 | highlight link rscFnKeyword Function
44 | 
45 | syntax match rscNumber "\v\d+"
46 | syntax match rscNumber "\v\d+\.\d+"
47 | highlight link rscNumber Number
48 | 
49 | syntax match rscBool "T"
50 | syntax match rscBool "F"
51 | highlight link rscBool Boolean
52 | 
53 | syntax match rscAtom "\v:\[A-za-z][A-za-z0-9_]+"
54 | highlight link rscAtom Constant
55 | 
56 | syntax match rscIdentifier "\v[A-Za-z@!?][A-Za-z0-9@!?]*"
57 | syntax match rscIdentifier "\v_"
58 | highlight link rscIdentifier Identifier
59 | 
60 | syntax region rscString start=/\v"/ skip=/\v\\./ end=/\v"/
61 | highlight link rscString String
62 | 
63 | " comments
64 | syntax match rscComment "#.*"
65 | highlight link rscComment Comment
66 | 


--------------------------------------------------------------------------------
/examples/tictactoe.rsc:
--------------------------------------------------------------------------------
 1 | let empty_board() = repeat(:empty, 9)
 2 | 
 3 | let square_to_string(square) = match square
 4 |     | :empty -> " "
 5 |     | :x     -> "X"
 6 |     | :o     -> "O"
 7 | 
 8 | let print_board(board) = {
 9 |     foreach([0..3], fn(i) => {
10 | 	let [a, b, c] = slice(board, 3 * i, 3 * i + 3)
11 | 	let (a, b, c) = (square_to_string(a), square_to_string(b), square_to_string(c))
12 | 	println(" " + a + " | " + b + " | " + c)
13 | 	if i != 2 then println("-----------") else ()
14 |     })
15 | }
16 | 
17 | let switch_turn(turn) = match turn
18 |     | :x -> :o
19 |     | :o -> :x
20 | 
21 | let is_winner(board, turn) = {
22 |     let flatten(ls) = fold([], fn(a, b) => a + b, ls)
23 | 
24 |     let rows = ([slice(board, 3 * i, 3 * i + 3) for i in [0..3]])
25 |     let cols = ([[nth(board, 3 * i + j) for i in [0..3]] for j in [0..3]])
26 |     let diags = [[nth(board, i) for i in [0, 4, 8]], [nth(board, i) for i in [2, 4, 6]]]
27 | 
28 |     let sets = flatten([rows, cols, diags])
29 | 
30 |     any([
31 | 	all([sq == turn for sq in set])
32 | 	for set in sets
33 |     ])
34 | }
35 | 
36 | let game_loop(board, turn) = {
37 |     println("===========\n")
38 |     print_board(board)
39 |     print("\nChoose a position for " + square_to_string(turn) + ": ")
40 | 
41 |     let get_position = fn() => match string_to_int(scanln())
42 | 	| (:ok, n) when nth(board, n) != :empty -> {
43 | 	    print("That position is already taken, enter another: ")
44 | 	    get_position()
45 | 	}
46 | 	| (:ok, n) when (0 <= n) && (n <= 8) -> n
47 | 	| _ -> {
48 | 	    print("Error: position must be a number from 0 to 9: ")
49 | 	    get_position()
50 | 	}
51 | 
52 |     let position = get_position()
53 |     let new_board = set_nth(board, position, turn)
54 | 
55 |     if is_winner(new_board, turn) then {
56 | 	println(square_to_string(turn) + " Wins!")
57 | 	print_board(new_board)
58 |     } else {
59 | 	game_loop(set_nth(board, position, turn), switch_turn(turn))
60 |     }
61 | }
62 | 
63 | game_loop(empty_board(), :x)
64 | 


--------------------------------------------------------------------------------
/rustscript.install:
--------------------------------------------------------------------------------
 1 | lib: [
 2 |   "_build/install/default/lib/rustscript/META"
 3 |   "_build/install/default/lib/rustscript/dune-package"
 4 |   "_build/install/default/lib/rustscript/eval.ml"
 5 |   "_build/install/default/lib/rustscript/opam"
 6 |   "_build/install/default/lib/rustscript/operators.ml"
 7 |   "_build/install/default/lib/rustscript/parser.ml"
 8 |   "_build/install/default/lib/rustscript/preprocess.ml"
 9 |   "_build/install/default/lib/rustscript/run.ml"
10 |   "_build/install/default/lib/rustscript/rustscript.a"
11 |   "_build/install/default/lib/rustscript/rustscript.cma"
12 |   "_build/install/default/lib/rustscript/rustscript.cmi"
13 |   "_build/install/default/lib/rustscript/rustscript.cmt"
14 |   "_build/install/default/lib/rustscript/rustscript.cmx"
15 |   "_build/install/default/lib/rustscript/rustscript.cmxa"
16 |   "_build/install/default/lib/rustscript/rustscript.ml"
17 |   "_build/install/default/lib/rustscript/rustscript__Eval.cmi"
18 |   "_build/install/default/lib/rustscript/rustscript__Eval.cmt"
19 |   "_build/install/default/lib/rustscript/rustscript__Eval.cmx"
20 |   "_build/install/default/lib/rustscript/rustscript__Operators.cmi"
21 |   "_build/install/default/lib/rustscript/rustscript__Operators.cmt"
22 |   "_build/install/default/lib/rustscript/rustscript__Operators.cmx"
23 |   "_build/install/default/lib/rustscript/rustscript__Parser.cmi"
24 |   "_build/install/default/lib/rustscript/rustscript__Parser.cmt"
25 |   "_build/install/default/lib/rustscript/rustscript__Parser.cmx"
26 |   "_build/install/default/lib/rustscript/rustscript__Preprocess.cmi"
27 |   "_build/install/default/lib/rustscript/rustscript__Preprocess.cmt"
28 |   "_build/install/default/lib/rustscript/rustscript__Preprocess.cmx"
29 |   "_build/install/default/lib/rustscript/rustscript__Run.cmi"
30 |   "_build/install/default/lib/rustscript/rustscript__Run.cmt"
31 |   "_build/install/default/lib/rustscript/rustscript__Run.cmx"
32 |   "_build/install/default/lib/rustscript/rustscript__Scanner.cmi"
33 |   "_build/install/default/lib/rustscript/rustscript__Scanner.cmt"
34 |   "_build/install/default/lib/rustscript/rustscript__Scanner.cmx"
35 |   "_build/install/default/lib/rustscript/rustscript__Types.cmi"
36 |   "_build/install/default/lib/rustscript/rustscript__Types.cmt"
37 |   "_build/install/default/lib/rustscript/rustscript__Types.cmx"
38 |   "_build/install/default/lib/rustscript/scanner.ml"
39 |   "_build/install/default/lib/rustscript/types.ml"
40 | ]
41 | libexec: [
42 |   "_build/install/default/lib/rustscript/rustscript.cmxs"
43 | ]
44 | doc: [
45 |   "_build/install/default/doc/rustscript/LICENSE"
46 |   "_build/install/default/doc/rustscript/README.md"
47 | ]
48 | 


--------------------------------------------------------------------------------
/examples/expr.rsc:
--------------------------------------------------------------------------------
 1 | let contains(ls, el) = match ls
 2 |     | [] -> F
 3 |     | [x | xs] when x == el -> T
 4 |     | [_ | xs] -> contains(xs, el)
 5 | 
 6 | let digits() = to_charlist("0123456789")
 7 | 
 8 | let is_digit(c) = contains(digits(), c)
 9 | 
10 | let chars_to_number(chars) = {
11 |     let digit_map = {
12 | 	let enumerated = enumerate(digits())
13 | 	fold(%{}, fn(m, (i, d)) => %{d => i | m}, enumerated)
14 |     }
15 | 
16 |     let loop = fn(ls, acc, multiplier) => match ls
17 | 	| [] -> acc
18 | 	| [c | cs] -> {
19 | 	    let number = digit_map(c) * multiplier
20 | 	    loop(cs, acc + number, multiplier * 10)
21 | 	}
22 | 
23 |     let chars = reverse(chars)
24 |     loop(chars, 0, 1)
25 | }
26 | 
27 | let scan(str) = {
28 |     let char_ls = to_charlist(str)
29 |     
30 |     let loop_number = fn(ls, acc) => match ls
31 | 	| [c | xs] when is_digit(c) -> loop_number(xs, [c | acc])
32 | 	| _ -> (reverse(acc), ls)
33 | 
34 | 
35 |     let loop = fn(ls, acc) => match ls
36 | 	| [] -> reverse(acc)
37 | 	| [" " | xs] -> loop(xs, acc)
38 | 	| ["+" | xs] -> loop(xs, [:add | acc])
39 | 	| ["-" | xs] -> loop(xs, [:sub | acc])
40 | 	| ["*" | xs] -> loop(xs, [:mul | acc])
41 | 	| ["/" | xs] -> loop(xs, [:div | acc])
42 | 	| [c | _]  -> {
43 | 	    let (digit_chars, xs) = loop_number(ls, [])
44 | 	    let number = chars_to_number(digit_chars)
45 | 	    loop(xs, [(:number, number) | acc])
46 | 	}
47 | 
48 |     loop(to_charlist(str), [])
49 | }
50 | 
51 | let op_bp(op) = match op
52 |     | :add | :sub -> (1, 2)
53 |     | :mul | :div -> (3, 4)
54 | 
55 | let complete_expr(lhs, ls, min_bp) = match ls
56 |     | [(:number, _) | _] | [] -> (lhs, ls)
57 |     | [op | xs] -> {
58 | 	let (l_bp, r_bp) = op_bp(op)
59 | 	if l_bp < min_bp then {
60 | 	    (lhs, ls)
61 | 	} else {
62 | 	    let (rhs, rest) = expr_bp(xs, r_bp)
63 | 	    let complete = %{op: op, lhs: lhs, rhs: rhs}
64 | 	    complete_expr(complete, rest, min_bp)
65 | 	}
66 |     }
67 | 
68 | let expr_bp(toks, min_bp) = match toks
69 | 	| [(:number, _) as n | xs] -> complete_expr(n, xs, min_bp)
70 | 	| _ -> let () = 1
71 | 
72 | let eval(expr) = match expr
73 |     | %{op: :add, lhs: l, rhs: r} -> eval(l) + eval(r)
74 |     | %{op: :sub, lhs: l, rhs: r} -> eval(l) - eval(r)
75 |     | %{op: :mul, lhs: l, rhs: r} -> eval(l) * eval(r)
76 |     | %{op: :div, lhs: l, rhs: r} -> eval(l) / eval(r)
77 |     | (:number, n) -> n
78 |     | _ -> expr
79 | 
80 | let eval_str(s) = {
81 |     let tokens = scan(s)
82 |     let (expr, _) = expr_bp(tokens, 0)
83 |     eval(expr)
84 | }
85 | 
86 | let input_loop() = {
87 |     print("Enter an expression to evaluate: ")
88 | 
89 |     match scanln ()
90 | 	| () -> println("\nNo line scanned, exiting")
91 | 	| "exit" -> println("exiting")
92 | 	| line -> {
93 | 	    let res = eval_str(line)
94 | 	    println(to_string(res))
95 | 	    input_loop()
96 | 	}
97 | }
98 | #loop()
99 | 


--------------------------------------------------------------------------------
/lib/shim.js:
--------------------------------------------------------------------------------
  1 | const _ = this._;
  2 | const assert = console.assert;
  3 | 
  4 | const ll_bind_n = (ls, n) => {
  5 |     let result = [];
  6 |     let current = ls;
  7 |     for (let i = 0; i < n; i += 1) {
  8 |         result.push(current.val);
  9 |         current = current.next;
 10 |     }
 11 | 
 12 |     assert(current === null);
 13 |     return result;
 14 | }
 15 | 
 16 | const ll_bind_head_tail = (ls, n) => {
 17 |     let result = [];
 18 |     let current = ls;
 19 |     for (let i = 0; i < n; i += 1) {
 20 |         result.push(current.val);
 21 |         current = current.next;
 22 |     }
 23 | 
 24 |     result.push(current);
 25 |     return result;
 26 | }
 27 | 
 28 | const ll_to_string = ls => {
 29 |     let result = [];
 30 | 
 31 |     while (ls !== undefined && ls !== null) {
 32 |         result.push(ls.val);
 33 |         ls = ls.next;
 34 |     }
 35 | 
 36 |     return `[${result}]`;
 37 | }
 38 | 
 39 | const ll_from_ls = ls => {
 40 |     let res = null;
 41 |     for (let i = ls.length - 1; i >= 0; i -= 1)
 42 |         res = {val: ls[i], next: res}
 43 |     
 44 |     return res;
 45 | }
 46 | 
 47 | const prepend_arr = (arr, ll) => {
 48 |     assert(ll === null || ll.val !== null);
 49 | 
 50 |     let new_ll = ll;
 51 |     for (let i = arr.length - 1; i >= 0; i -= 1)
 52 |         new_ll = {val: arr[i], next: new_ll};
 53 | 
 54 |     return new_ll;
 55 | }
 56 | 
 57 | const to_string__builtin = v => {
 58 |     if (typeof v === "string") {
 59 |         return `"${v}"`
 60 |     } else if (Array.isArray(v)) {
 61 |         return `(${v.map(to_string__builtin).join()})`
 62 |     } else if (v.__is_rsc_map) {
 63 |         let res = [];
 64 |         for (const [key, val] of v.map.entries()) {
 65 |             res.push(`${to_string__builtin(key)} => ${to_string__builtin(val)}`);
 66 |         }
 67 |         return `%{\n\t${res.join("\n\t")}\n}`
 68 |     }else if (v === undefined) {
 69 |         return "undefined";
 70 |     } else if (v !== null && v.val) {
 71 |         return ll_to_string(v);
 72 |     } else {
 73 |         return JSON.stringify(v);
 74 |     }
 75 | }
 76 | 
 77 | const rustscript_equal = (a, b) => {
 78 |     if (a === b) {
 79 |         return true;
 80 |     } else if (Array.isArray(a) && Array.isArray(b)) {
 81 |         return (a.length === b.length) && (a.every((v, i) => v == b[i]));
 82 |     }
 83 | }
 84 | 
 85 | const rsc_matches = (val, pat) => {
 86 |     if (pat === null || val === pat) {
 87 |         return true;
 88 |     }
 89 | 
 90 |     if (Array.isArray(val) && Array.isArray(pat)) {
 91 |         return _(val).zip(pat).every(([v, p]) => rsc_matches(v, p));
 92 |     }
 93 | 
 94 |     // or pattern
 95 |     if (pat.__rsc_pat_type === 0) {
 96 |         return rsc_matches(val, pat.l) || rsc_matches(val, pat.r);
 97 |     }
 98 | 
 99 |     return false;
100 | }
101 | 
102 | const inspect__builtin = val => console.log(to_string__builtin(val));
103 | const print__builtin = val => process.stdout.write(val);
104 | const println__builtin = val => console.log(val);
105 | const string_to_num__builtin = parseFloat;
106 | const string_to_int__builtin = parseInt
107 | 
108 | const range_step__builtin = (start, end, step) => {
109 |     if (start >= end) {
110 |         return null;
111 |     } else {
112 |         return {val: start, next: range_step__builtin(start + step, end, step)};
113 |     }
114 | }
115 | 
116 | const mk_thunk = (fn, args) => {
117 |     return {
118 |         __rsc_is_thunk: true,
119 |         fn: fn,
120 |         args: args,
121 |     }
122 | }
123 | 
124 | const unwrap_thunk = thunk => {
125 |     let res = thunk;
126 |     while (res !== undefined && res.__rsc_is_thunk) {
127 |         res = res.fn(...res.args)
128 |     }
129 | 
130 |     return res;
131 | }
132 | 
133 | const __rsc_mk_map = m => {
134 |     let f = x => m.get(x);
135 |     f.map = m;
136 |     f.__is_rsc_map = true;
137 |     return f;
138 | }
139 | 


--------------------------------------------------------------------------------
/examples/tictactoe_minimax.rsc:
--------------------------------------------------------------------------------
  1 | let empty_board() = repeat(:empty, 9)
  2 | 
  3 | let square_to_string(square) = match square
  4 |     | :empty -> " "
  5 |     | :x     -> "X"
  6 |     | :o     -> "O"
  7 | 
  8 | let print_board(board) = {
  9 |     foreach([0..3], fn(i) => {
 10 | 	let [a, b, c] = slice(board, 3 * i, 3 * i + 3)
 11 | 	let (a, b, c) = (square_to_string(a), square_to_string(b), square_to_string(c))
 12 | 	println(" " + a + " | " + b + " | " + c)
 13 | 	if i != 2 then println("-----------") else ()
 14 |     })
 15 | }
 16 | 
 17 | let switch_turn(turn) = match turn
 18 |     | :x -> :o
 19 |     | :o -> :x
 20 | 
 21 | let flatten(ls) = fold([], fn(a, b) => a + b, ls)
 22 | let get_rows(board) = [slice(board, 3 * i, 3 * i + 3) for i in [0..3]]
 23 | let get_cols(board) = [[nth(board, 3 * i + j) for i in [0..3]] for j in [0..3]]
 24 | let get_diags(board) = [[nth(board, i) for i in [0, 4, 8]], [nth(board, i) for i in [2, 4, 6]]]
 25 | let get_sets(board) = flatten([get_set(board) for get_set in [get_rows, get_cols, get_diags]])
 26 | 
 27 | let is_winner(board, turn) = {
 28 |     let sets = get_sets(board)
 29 | 
 30 |     any([
 31 | 	all([sq == turn for sq in set])
 32 | 	for set in sets
 33 |     ])
 34 | }
 35 | 
 36 | let is_tied(board) = !any([sq == :empty for sq in board])
 37 | 
 38 | let minimax(board, turn, alpha, beta) = {
 39 |     if is_winner(board, turn) then {
 40 | 	(1, board)
 41 |     } else if is_winner(board, switch_turn(turn)) then {
 42 | 	(-1, board)
 43 |     } else if !any([sq == :empty for sq in board]) then {
 44 | 	(0, board)
 45 |     } else {
 46 | 	let possible_moves = [set_nth(board, i, turn) for (i, p) in enumerate(board) if p == :empty]
 47 | 	let opposite_turn = switch_turn(turn)
 48 | 
 49 | 	let loop = fn(possible_moves, best_move, alpha, beta) => match possible_moves
 50 | 	    | [] -> (alpha, best_move)
 51 | 	    | [nboard | possible_moves] -> {
 52 | 		let score = alpha
 53 | 		
 54 | 		let (score, nmove) = minimax(nboard, opposite_turn, -beta, -alpha)
 55 | 		let (score, nmove) = if (alpha < score) && (score < beta) then {
 56 | 		    minimax(nboard, opposite_turn, -beta, -score)
 57 | 		} else {
 58 | 		    (score, nmove)
 59 | 		}
 60 | 
 61 | 		let score = -score
 62 | 
 63 | 		if score > alpha then
 64 | 		    loop(possible_moves, nboard, score, beta)
 65 | 		else if alpha >= beta then
 66 | 		    (score, nboard)
 67 | 		else
 68 | 		    loop(possible_moves, best_move, alpha, beta)
 69 | 	    }
 70 | 	
 71 | 	loop(possible_moves, ^possible_moves, -999, 999)
 72 |     }
 73 | }
 74 | 
 75 | let ai_move(board, turn) = {
 76 |     let num_filled = length([sq for sq in board if sq != :empty])
 77 |     if (num_filled == 0) || ((num_filled == 1) && (nth(board, 4) == :empty)) then {
 78 | 	set_nth(board, 4, turn)
 79 |     } else if num_filled < 4 then {
 80 | 	let sets = get_sets(board)
 81 | 	let set_indices = get_sets([0..9])
 82 | 	let zip_inner = fn(xs, ys) => match (xs, ys)
 83 | 	    | ([], []) -> []
 84 | 	    | ([x | xs], [y | ys]) -> [zip_rev(x, y) | zip_inner(xs, ys)]
 85 | 
 86 | 	let indexed_sets = zip_inner(set_indices, sets)
 87 | 
 88 | 	let opposite_turn = switch_turn(turn)
 89 | 
 90 | 	# find the missing position if a set is missing only one
 91 | 	let loop = fn(sets) => match sets
 92 | 	    | [] -> ()
 93 | 	    | [set | sets] -> {
 94 | 		if length([i for (i, sq) in set if sq == opposite_turn]) == 2 then {
 95 | 		    let (missing_i, missing_sq) = ^[(i, sq) for (i, sq) in set if sq != opposite_turn]
 96 | 		    if missing_sq == :empty then
 97 | 			missing_i
 98 | 		    else
 99 | 			loop(sets)
100 | 		} else {
101 | 		    loop(sets)
102 | 		}
103 | 	    }
104 | 	
105 | 	let block_move = loop(indexed_sets)
106 | 	if block_move != () then {
107 | 	    set_nth(board, block_move, turn)
108 | 	} else {
109 | 	    let corners = [0, 2, 6, 8]
110 | 	    let corner_move = find(fn(sq) => nth(board, sq) == :empty, corners)
111 | 	    set_nth(board, corner_move, turn)
112 | 	}
113 | 
114 |     } else {
115 | 	let (_, new_board) = minimax(board, turn, -999999, 999999)
116 | 	new_board
117 |     }
118 | }
119 | 
120 | let game_loop(board, turn, player) = {
121 |     println("===========\n")
122 |     print_board(board)
123 | 
124 |     let get_position = fn() => match string_to_int(scanln())
125 | 	| (:ok, n) when nth(board, n) != :empty -> {
126 | 	    print("That position is already taken, enter another: ")
127 | 	    get_position()
128 | 	}
129 | 	| (:ok, n) when (0 <= n) && (n <= 8) -> n
130 | 	| _ -> {
131 | 	    print("Error: position must be a number from 0 to 9: ")
132 | 	    get_position()
133 | 	}
134 | 
135 |     let new_board = if turn == player then {
136 | 	print("\nChoose a position for " + square_to_string(turn) + ": ")
137 | 	let position = get_position()
138 | 	set_nth(board, position, player)
139 |     } else {
140 | 	ai_move(board, turn)
141 |     }
142 | 	
143 |     if is_winner(new_board, turn) then {
144 | 	println(square_to_string(turn) + " Wins!")
145 | 	print_board(new_board)
146 |     } else if is_tied(new_board) then {
147 | 	println("You tied!")
148 | 	print_board(new_board)
149 |     } else {
150 | 	game_loop(new_board, switch_turn(turn), player)
151 |     }
152 | }
153 | 
154 | let board = empty_board()
155 | game_loop(board, :x, :x)
156 | 


--------------------------------------------------------------------------------
/lib/run.ml:
--------------------------------------------------------------------------------
  1 | open Base
  2 | open Stdio
  3 | open Types
  4 | open Scanner
  5 | 
  6 | 
  7 | let eval: static_state -> state -> string -> (value * state) * static_state = fun ss state s ->
  8 |     let (parsed, _remaining) = Parser.parse_str s "repl" in
  9 |     let static_atoms =
 10 |         Preprocess.find_atoms (ExprNode parsed) ss.static_atoms
 11 |     in
 12 |     let static_idents =
 13 |         Preprocess.find_idents (ExprNode parsed) ss.static_idents
 14 |     in
 15 |     let ss = { ss with static_atoms; static_idents } in
 16 |     let parsed = parsed 
 17 |         |> fun e -> Preprocess.ExprNode e
 18 |         |> fun e -> Preprocess.resolve_atoms e ss.static_atoms
 19 |         |> fun e -> Preprocess.resolve_idents e ss.static_idents
 20 |         |> Preprocess.unwrap_expr_node
 21 |     in
 22 |     let eval_closure = Eval.eval_expr parsed ss in
 23 |     (eval_closure state), ss
 24 | 
 25 | let run_line ss state line =
 26 |     match eval ss state line with
 27 |         | (Tuple [], new_state), _ -> new_state
 28 |         | (evaled, new_state), _ ->
 29 |             printf "%s\n" (string_of_val ss evaled);
 30 |             Out_channel.flush Stdio.stdout;
 31 |             new_state
 32 | 
 33 | let run_string in_string filename (ss, state) =
 34 |     let locate = Located.locate {line_num = 0; filename = filename} in
 35 |     let tokens = in_string |> Scanner.scan ~filename:filename |> skip_newlines in
 36 |     (* print_toks (List.map ~f:Located.extract tokens); *)
 37 |     let expr_ls =
 38 |         let rec aux remaining acc = match (skip_newlines remaining) with
 39 |             | [] -> acc
 40 |             | remaining ->
 41 |                   let (parsed, remaining) = Parser.parse remaining 0 in
 42 |                   aux remaining (parsed::acc)
 43 |         in
 44 |         let (parsed, remaining) = Parser.parse tokens 0 in
 45 |         List.rev (aux remaining [parsed])
 46 |     in
 47 |     let block = BlockExpr expr_ls in
 48 |     let static_atoms =
 49 |         Preprocess.find_atoms (ExprNode (locate block)) ss.static_atoms
 50 |     in
 51 |     let static_idents =
 52 |         Preprocess.find_idents (ExprNode (locate block)) ss.static_idents
 53 |     in
 54 |     (* List.iter static_idents ~f:(fun (k, v) -> printf "%s: %d\n" k v); *)
 55 |     let ss = { ss with static_atoms; static_idents } in
 56 |     let expr_ls = expr_ls
 57 |         |> List.map ~f:(fun e -> Preprocess.ExprNode e)
 58 |         |> List.map ~f:(fun e -> Preprocess.resolve_atoms e ss.static_atoms)
 59 |         |> List.map ~f:(fun e -> Preprocess.resolve_idents e ss.static_idents)
 60 |         |> List.map ~f:Preprocess.unwrap_expr_node
 61 |     in
 62 |     let static_block_funcs = 
 63 |         Preprocess.find_block_funcs ss (expr_ls |> List.map ~f:Located.extract) ss.static_block_funcs 
 64 |     in
 65 |     let ss = { ss with static_block_funcs } in
 66 |     let block = BlockExpr expr_ls |> Located.locate {line_num = 0; filename = filename} in
 67 |     (* List.iter *) 
 68 |     (*     static_block_funcs *) 
 69 |     (*     ~f:(fun (k, f) -> *) 
 70 |     (*             let fn_name = List.Assoc.find_exn (List.Assoc.inverse ss.static_idents) ~equal:Int.equal k in *)
 71 |     (*             let is_inlinable = Preprocess.is_function_inlinable k ss f.fn_expr.data in *)
 72 |     (*             printf "%s is inlinable: %b\n" fn_name is_inlinable); *)
 73 |     (* TODO: If statement syntax errors here? *)
 74 |     let block = match (Preprocess.clobbers_declared_fn_test (ExprNode block) ss.static_block_funcs) with
 75 |         | false -> block
 76 |         | true ->
 77 |             printf "Tried to clobber function with variable binding\n";
 78 |             Caml.exit 0
 79 |     in
 80 |     let block = block
 81 |         |> fun b -> Preprocess.inline_functions (ExprNode b) ss.static_block_funcs
 82 |         |> Preprocess.unwrap_expr_node
 83 |     in
 84 |     (* printf "%s\n" (string_of_expr ss block.data); *)
 85 |     let expr_ls = match block with
 86 |     | {data = BlockExpr expr_ls; _} -> expr_ls
 87 |     | _ -> assert false
 88 |     in
 89 |     let fold_step = fun state e -> let _, s = (Eval.eval_expr e ss) state in s in
 90 |     ss, List.fold_left ~init:state ~f:fold_step expr_ls
 91 | 
 92 | let run_file filename (ss, state) =
 93 |     let in_stream = In_channel.create filename in
 94 |     let in_string = In_channel.input_all in_stream in
 95 |     run_string in_string filename (ss, state)
 96 | 
 97 | let base_static_atoms () = [
 98 |     ("ok", 0); 
 99 |     ("err", 1);
100 |     ("number", 2);
101 |     ("integer", 3);
102 |     ("boolean", 4);
103 |     ("tuple", 5);
104 |     ("list", 6);
105 |     ("function", 7);
106 |     ("dictionary", 8);
107 |     ("atom", 9);
108 |     ("string", 10);
109 | ]
110 | 
111 | let base_static_idents () = 
112 |     let builtin_idents = [
113 |         "inspect__builtin";
114 |         "print__builtin";
115 |         "println__builtin";
116 |         "scanln__builtin";
117 |         "to_string__builtin";
118 |         "string_to_num__builtin";
119 |         "string_to_int__builtin";
120 |         "range_step__builtin";
121 |         "fold__builtin";
122 |         "to_charlist__builtin";
123 |         "get__builtin";
124 |         "read_file__builtin";
125 |         "write_file__builtin";
126 |         "list_dir__builtin";
127 |         "mkdir__builtin";
128 |         "map_keys__builtin";
129 |         "map_to_list__builtin";
130 |         "typeof__builtin";
131 |         "serve__builtin";
132 |         "serve_ssl__builtin";
133 |         "crypto_hash__builtin";
134 |         "validate_pass__builtin";
135 |         "truncate__builtin";
136 |     ] in
137 |     List.zip_exn builtin_idents (List.range 0 (List.length builtin_idents))
138 | 
139 | let default_state () = 
140 |     let static_atoms = base_static_atoms () in
141 |     let static_idents = base_static_idents () in
142 |     let static_block_funcs = [] in
143 |     let call_stack = [] in
144 |     let code_string = [%blob "stdlib.rsc"] in
145 |     let ss = {static_atoms; static_idents; static_block_funcs; call_stack} in
146 |     run_string code_string "stdlib.rsc" (ss, (Map.empty (module Int)))
147 | 
148 | let test_state = default_state
149 | 


--------------------------------------------------------------------------------
/lib/operators.ml:
--------------------------------------------------------------------------------
  1 | open Types
  2 | open Stdio
  3 | open Base
  4 | 
  5 | let val_add lhs rhs ss loc = match lhs, rhs with
  6 |     | Integer lhs, Integer rhs -> Integer (lhs + rhs)
  7 |     | Number lhs, Number rhs -> Number (lhs +. rhs)
  8 |     | Integer lhs, Number rhs -> Number ((Int.to_float lhs) +. rhs)
  9 |     | Number lhs, Integer rhs -> Number (lhs +. (Int.to_float rhs))
 10 |     | ValList lhs, ValList rhs ->  ValList (lhs @ rhs)
 11 |     | StringVal lhs, StringVal rhs ->  StringVal (lhs ^ rhs)
 12 |     | _ -> 
 13 |             printf "Invalid Add at %s: lhs = %s, rhs = %s\n" 
 14 |                 (location_to_string loc)
 15 |                 (string_of_val ss lhs) (string_of_val ss rhs);
 16 |             print_traceback ss;
 17 |             Caml.exit 0
 18 | 
 19 | let val_sub lhs rhs ss loc = match lhs, rhs with
 20 |     | Integer lhs, Integer rhs -> Integer (lhs - rhs)
 21 |     | Number lhs, Number rhs -> Number (lhs -. rhs)
 22 |     | Integer lhs, Number rhs -> Number ((Int.to_float lhs) -. rhs)
 23 |     | Number lhs, Integer rhs -> Number (lhs -. (Int.to_float rhs))
 24 |     | _ ->
 25 |         printf "Invalid sub at %s: lhs = %s, rhs = %s\n" 
 26 |             (location_to_string loc) (string_of_val ss lhs) (string_of_val ss rhs);
 27 |         print_traceback ss;
 28 |         Caml.exit 0
 29 | 
 30 | let val_mul lhs rhs ss _loc = match lhs, rhs with
 31 |     | Integer lhs, Integer rhs -> Integer (lhs * rhs)
 32 |     | Number lhs, Number rhs -> Number (lhs *. rhs)
 33 |     | Integer lhs, Number rhs -> Number ((Int.to_float lhs) *. rhs)
 34 |     | Number lhs, Integer rhs -> Number (lhs *. (Int.to_float rhs))
 35 |     | _ -> 
 36 |             printf "Invalid Mul: lhs = %s, rhs = %s\n" (string_of_val ss lhs) (string_of_val ss rhs);
 37 |             assert false
 38 | 
 39 | let val_div lhs rhs _ss _loc = match lhs, rhs with
 40 |     | Integer lhs, Integer rhs when Int.equal (lhs % rhs) 0 -> Integer (lhs / rhs)
 41 |     | Integer lhs, Integer rhs -> Number ((Float.of_int lhs) /. (Float.of_int rhs))
 42 |     | Number lhs, Number rhs -> Number (lhs /. rhs)
 43 |     | Integer lhs, Number rhs -> Number ((Int.to_float lhs) /. rhs)
 44 |     | Number lhs, Integer rhs -> Number (lhs /. (Int.to_float rhs))
 45 |     | _ -> assert false
 46 | 
 47 | let val_is_true v _ss _loc = match v with
 48 |     | Boolean true -> true
 49 |     | _ -> false
 50 | 
 51 | let rec val_eq lhs rhs ss loc = match lhs, rhs with
 52 |     | Integer lhs, Integer rhs -> Boolean (Int.equal lhs rhs)
 53 |     | Number lhs, Number rhs -> Boolean (Float.equal lhs rhs)
 54 |     | Integer lhs, Number rhs -> Boolean (Float.equal (Int.to_float lhs) rhs)
 55 |     | Number lhs, Integer rhs -> Boolean (Float.equal lhs (Int.to_float rhs))
 56 |     | Boolean lhs, Boolean rhs -> Boolean (Bool.equal lhs rhs)
 57 |     | (Tuple lhs, Tuple rhs)|(ValList lhs, ValList rhs) -> begin
 58 |         match List.zip lhs rhs with
 59 |             | Ok zipped ->  
 60 |                 let res = List.for_all zipped ~f:(fun (a, b) -> val_is_true (val_eq a b ss loc) ss loc)
 61 |                 in Boolean res
 62 |             | _ -> Boolean false
 63 |     end
 64 |     | Atom lhs, Atom rhs -> Boolean (Int.equal lhs rhs)
 65 |     | StringVal lhs, StringVal rhs -> Boolean (String.equal (escape_string lhs) (escape_string rhs))
 66 |     | _ -> Boolean false
 67 | 
 68 | let val_eq_bool l r ss loc = val_is_true (val_eq l r ss loc) ss loc
 69 | 
 70 | let val_neq lhs rhs ss loc = Boolean (not (val_is_true (val_eq lhs rhs ss loc) ss loc))
 71 | 
 72 | let val_lt lhs rhs ss loc = match lhs, rhs with
 73 |     | Integer lhs, Integer rhs -> Boolean (Int.compare lhs rhs < 0)
 74 |     | Number lhs, Number rhs -> Boolean (Float.compare lhs rhs < 0)
 75 |     | Integer lhs, Number rhs -> Boolean (Float.compare (Int.to_float lhs) rhs < 0)
 76 |     | Number lhs, Integer rhs -> Boolean (Float.compare lhs (Int.to_float rhs) < 0)
 77 |     | StringVal lhs, StringVal rhs -> Boolean (String.compare lhs rhs < 0)
 78 |     | _ ->
 79 |         printf "Invalid <: lhs = %s, rhs = %s, at %s\n" 
 80 |             (string_of_val ss lhs)
 81 |             (string_of_val ss rhs)
 82 |             (location_to_string loc);
 83 |         Caml.exit 0
 84 | 
 85 | let val_gt lhs rhs _ss _loc = match lhs, rhs with
 86 |     | Integer lhs, Integer rhs -> Boolean (Int.compare lhs rhs > 0)
 87 |     | Number lhs, Number rhs -> Boolean (Float.compare lhs rhs > 0)
 88 |     | Integer lhs, Number rhs -> Boolean (Float.compare (Int.to_float lhs) rhs > 0)
 89 |     | Number lhs, Integer rhs -> Boolean (Float.compare lhs (Int.to_float rhs) > 0)
 90 |     | StringVal lhs, StringVal rhs -> Boolean (String.compare lhs rhs > 0)
 91 |     | _ -> assert false
 92 | 
 93 | let val_leq lhs rhs _ss _loc = match lhs, rhs with
 94 |     | Integer lhs, Integer rhs -> Boolean (Int.compare lhs rhs <= 0)
 95 |     | Number lhs, Number rhs -> Boolean (Float.compare lhs rhs <= 0)
 96 |     | Integer lhs, Number rhs -> Boolean (Float.compare (Int.to_float lhs) rhs <= 0)
 97 |     | Number lhs, Integer rhs -> Boolean (Float.compare lhs (Int.to_float rhs) <= 0)
 98 |     | StringVal lhs, StringVal rhs -> Boolean (String.compare lhs rhs <= 0)
 99 |     | _ -> assert false
100 | 
101 | let val_geq lhs rhs _ss _loc = match lhs, rhs with
102 |     | Integer lhs, Integer rhs -> Boolean (Int.compare lhs rhs >= 0)
103 |     | Number lhs, Number rhs -> Boolean (Float.compare lhs rhs >= 0)
104 |     | Integer lhs, Number rhs -> Boolean (Float.compare (Int.to_float lhs) rhs >= 0)
105 |     | Number lhs, Integer rhs -> Boolean (Float.compare lhs (Int.to_float rhs) >= 0)
106 |     | StringVal lhs, StringVal rhs -> Boolean (String.compare lhs rhs >= 0)
107 |     | _ -> assert false
108 | 
109 | let val_and lhs rhs _ss _loc = match lhs, rhs with
110 |     | Boolean lhs, Boolean rhs -> Boolean (lhs && rhs)
111 |     | _ -> assert false
112 | 
113 | let val_or lhs rhs _ss _loc = match lhs, rhs with
114 |     | Boolean lhs, Boolean rhs -> Boolean (lhs || rhs)
115 |     | _ -> assert false
116 | 
117 | let val_mod lhs rhs _ss _loc = match lhs, rhs with
118 |     | Integer lhs, Integer rhs -> Integer (lhs % rhs)
119 |     | Number lhs, Number rhs -> Number (Float.mod_float lhs rhs)
120 |     | _ -> assert false
121 | 
122 | let val_negate rhs _ss _loc = match rhs with
123 |     | Integer rhs -> Integer (~-rhs)
124 |     | Number rhs -> Number (~-.rhs)
125 |     | _ -> assert false
126 | 
127 | let val_negate_bool rhs _ss _loc = match rhs with
128 |     | Boolean rhs -> Boolean (not rhs)
129 |     | _ -> assert false
130 | 
131 | let val_list_head rhs ss _loc = match rhs with
132 |     | ValList (head::_) -> head
133 |     | _ ->
134 |         printf "Invalid Head: rhs = %s\n" (string_of_val ss rhs);
135 |         assert false
136 | 
137 | let val_list_tail rhs ss loc = match rhs with
138 |     | ValList (_::tail) -> ValList tail
139 |     | _ ->
140 |         printf "Invalid Tail at %s: rhs = %s\n" (location_to_string loc) (string_of_val ss rhs);
141 |         print_traceback ss;
142 |         Caml.exit 0
143 | 


--------------------------------------------------------------------------------
/lib/stdlib.rsc:
--------------------------------------------------------------------------------
  1 | let starts_with(ls, prefix) = take(length(prefix), ls) == prefix
  2 | 
  3 | let replace_substr(str, substr, replacement) = {
  4 |     let substr_chars = to_charlist(substr)
  5 |     let substr_len = length(substr_chars)
  6 |     let replacement_chars = to_charlist(replacement)
  7 | 
  8 |     let loop = fn(chars, acc) => match chars
  9 | 	| [] -> 
 10 | 	    reverse(acc)
 11 | 
 12 | 	| _ when starts_with(chars, substr_chars) -> {
 13 | 	    let remaining = drop(length(substr_chars), chars)
 14 | 	    loop(remaining, reverse(replacement_chars) + acc)
 15 | 	}
 16 | 
 17 | 	| [c | xs] ->
 18 | 	    loop(xs, [c | acc])
 19 | 
 20 |     let string_chars = to_charlist(str)
 21 |     loop(string_chars, []) |> concat
 22 | }
 23 | 
 24 | let merge_maps(m1, m2) = {
 25 |     let m1_list = map_to_list(m1)
 26 |     fold(m2, fn(acc, (k, v)) => %{k => v | acc}, m1_list)
 27 | }
 28 | 
 29 | let count(ls) = {
 30 |     let loop(ls, counter) = match ls
 31 | 	| [] -> counter
 32 | 	| [x | xs] when counter(x) == () -> loop(xs, %{x => 1 | counter})
 33 | 	| [x | xs] -> loop(xs, %{x => counter(x) + 1 | counter})
 34 | 
 35 |     loop(ls, %{})
 36 | }
 37 | 
 38 | let reverse(ls) = {
 39 |     let fold_step = fn(ls, x) => [x|ls]
 40 |     fold([], fold_step, ls)
 41 | }
 42 | 
 43 | let filter_rev(f, ls) = {
 44 |     let fold_step = fn(ls, x) => if f(x) then [x|ls] else ls
 45 |     fold([], fold_step, ls)
 46 | }
 47 | 
 48 | let filter(f, ls) = reverse(filter_rev(f, ls))
 49 | 
 50 | let find(f, ls) = match ls
 51 |     | [] -> ()
 52 |     | [x | xs] -> if f(x) then x else find(f, xs)
 53 | 
 54 | let map_rev(f, ls) = fold([], fn(ls, x) => [f(x)|ls], ls)
 55 | let map(f, ls) = reverse(map_rev(f, ls))
 56 | let range(a, b) = range_step(a, b, 1)
 57 | 
 58 | let zip_rev(l1, l2) = {
 59 |     let helper = fn(acc, l1, l2) => match (l1, l2)
 60 | 	| ([], _) -> acc
 61 | 	| (_, []) -> acc
 62 | 	| ([x|xs], [y|ys]) -> helper([(x, y)|acc], xs, ys)
 63 | 
 64 |     helper([], l1, l2)
 65 | }
 66 | 
 67 | let zip(l1, l2) = reverse(zip_rev(l1, l2))
 68 | 
 69 | let length(ls) = fold(0, fn(l, _) => l + 1, ls)
 70 | 
 71 | let enumerate_rev(ls) = {
 72 |     let len = length(ls)
 73 |     zip_rev([0..len], ls)
 74 | }
 75 | 
 76 | let enumerate(ls) = reverse(enumerate_rev(ls))
 77 | 
 78 | let concat(ls) = fold("", fn(a, b) => a + b, ls)
 79 | 
 80 | let intersperse_rev(ls, sep) = {
 81 |     let loop(ls, sep, acc) = match ls
 82 | 	| [] -> acc
 83 | 	| [x] -> [x | acc]
 84 | 	| [x | xs] -> loop(xs, sep, [sep, x | acc])
 85 | 
 86 |     loop(ls, sep, [])
 87 | }
 88 | 
 89 | let intersperse(ls, sep) = reverse(intersperse_rev(ls, sep))
 90 | 
 91 | let concat_sep(ls, sep) = concat(intersperse(ls, sep))
 92 | 
 93 | let is_sorted_by(ls, f) = match ls
 94 |     | [] | [_] -> T
 95 |     | [a | [b | _] as xs] when f(a, b) == :less || f(a, b) == :equal -> is_sorted_by(xs, f)
 96 |     | _ -> F
 97 | 
 98 | let op_cmp(a, b) = match T
 99 |     | _ when a < b  -> :less
100 |     | _ when a == b -> :equal
101 |     | _             -> :more
102 | 
103 | let is_sorted(ls) = is_sorted_by(ls, op_cmp)
104 | 
105 | let sum(ls) = fold(0, fn(a, b) => a + b, ls)
106 | let any(ls) = fold(F, fn(a, b) => a || b, ls)
107 | let all(ls) = fold(T, fn(a, b) => a && b, ls)
108 | 
109 | let foreach(ls, f) = match ls
110 |     | [] -> ()
111 |     | [x | xs] -> {
112 | 	f(x)
113 | 	foreach(xs, f)
114 |     }
115 | 
116 | let group_by(ls, f) = {
117 |     let fold_step = fn(acc, el) => match acc
118 | 	| [] when f(el) -> [[]]
119 | 	| [] -> [[el]]
120 | 	| [current | _] when f(el) -> [[] | acc]
121 | 	| [current | rest] -> [[el | current] | rest]
122 | 
123 |     fold([], fold_step, ls) |> reverse |> map(reverse, _)
124 | }
125 | 
126 | let split(ls, el) = group_by(ls, eq(_, el))
127 | 
128 | # copied from https://github.com/janestreet/base/blob/0f626a86991b020348eac9aa0244d59da43ae02c/src/list.ml#L1060
129 | let split_at(n, ls) = 
130 |     if n <= 0 then {
131 | 	([], ls)
132 |     } else {
133 | 	let loop(n, ls, acc) =
134 | 	    if n == 0 then 
135 | 		(reverse(acc), ls)
136 | 	    else match ls
137 | 		| [] -> (ls, acc)
138 | 		| [x | xs] -> loop(n - 1, xs, [x | acc])
139 | 	
140 | 	loop(n, ls, [])
141 |     }
142 | 
143 | let take(n, ls) = {
144 |     let (res, _) = split_at(n, ls)
145 |     res
146 | }
147 | 
148 | let drop(n, ls) =
149 |     if n <= 0 || ls == [] then
150 | 	ls
151 |     else
152 | 	drop(n - 1, $ls)
153 | 
154 | let slice(ls, start, end) = take(end - start, drop(start, ls))
155 | 
156 | let take_while(ls, f) = {
157 |     let loop(ls, f, acc) = match ls
158 | 	| [x | xs] when f(x) -> loop(xs, f, [x | acc])
159 | 	| _ -> reverse(acc)
160 | 
161 |     loop(ls, f, [])
162 | }
163 | 
164 | let skip_while(ls, f) = match ls
165 |     | [x | xs] when f(x) -> skip_while(xs, f)
166 |     | _ -> ls
167 | 
168 | let max(a, b) = if a > b then a else b
169 | let min(a, b) = if a < b then a else b
170 | 
171 | let partition_rev(ls, f) = {
172 |     let loop(ls, f, (l1, l2)) = match ls
173 | 	| [] -> (l1, l2)
174 | 	| [x | xs] when f(x) -> loop(xs, f, ([x | l1], l2))
175 | 	| [x | xs] -> loop(xs, f, (l1, [x | l2]))
176 | 
177 |     loop(ls, f, ([], []))
178 | }
179 | 
180 | let partition(ls, f) = {
181 |     let (l1, l2) = partition_rev(ls, f)
182 |     (reverse(l1), reverse(l2))
183 | }
184 | 
185 | let step_by(ls, n) = {
186 |     let loop(ls, n, i, acc) = match (ls, i)
187 | 	| ([], _) -> reverse(acc)
188 | 	| ([x | xs], 0) -> loop(xs, n, n, [x | acc])
189 | 	| ([_ | xs], i) -> loop(xs, n, i - 1, acc)
190 | 
191 |     loop(ls, n - 1, 0, [])
192 | }
193 | 
194 | let repeat(x, n) = {
195 |     let helper(x, n, acc) = match n
196 | 	| 0 -> acc
197 | 	| n -> helper(x, n - 1, [x | acc])
198 | 
199 |     helper(x, n, [])
200 | }
201 | 
202 | let nth(ls, i) = match i
203 |     | 0 -> ^ls
204 |     | i -> nth($ls, i - 1)
205 | 
206 | let set_nth(ls, i, x) = match i
207 |     | 0 -> [x | $ls]
208 |     | i -> [^ls | set_nth($ls, i - 1, x)]
209 | 
210 | let merge = fn(xs, ys, cmp) => match (xs, ys)
211 |     | (ls, [])|([], ls) -> ls
212 |     | ([x|xs], [y|ys]) when cmp(x, y) <= 0 -> [x | merge(xs, [y|ys], cmp)]
213 |     | ([x|xs], [y|ys]) -> [y | merge([x|xs], ys, cmp)]
214 | 
215 | let sort = fn(ls, cmp) => {
216 |     let pairs = fn(ls) => match ls
217 |         | [a, b | tl] -> [merge(a, b, cmp) | pairs(tl)]
218 |         | _ -> ls
219 | 
220 |     let loop = fn(ls) => match ls
221 |         | [x] -> x
222 |         | _ -> loop(pairs(ls))
223 | 
224 |     loop([[x] for x in ls])
225 | }
226 | 
227 | let abs(x) = if x >= 0 then x else -x
228 | 
229 | let replace(ls, pairs) = {
230 |     let loop = fn(ls, acc) => match ls
231 | 	| [] -> reverse(acc)
232 | 	| [x | xs] when pairs(x) != () -> loop(xs, [pairs(x) | acc])
233 | 	| [x | xs] -> loop(xs, [x | acc])
234 | 
235 |     loop(ls, [])
236 | }
237 | 
238 | let add(a, b) = a + b
239 | let sub(a, b) = a - b
240 | let mul(a, b) = a * b
241 | let div(a, b) = a / b
242 | let eq(a, b) = a == b
243 | let geq(a, b) = a >= b
244 | let leq(a, b) = a <= b
245 | let lt(a, b) = a < b
246 | let gt(a, b) = a > b
247 | 
248 | let fst((a, _)) = a
249 | let snd((_, b)) = b
250 | 
251 | let inspect(n) = inspect__builtin(n)
252 | let print(n) = print__builtin(n)
253 | let println(n) = println__builtin(n)
254 | let scanln() = scanln__builtin()
255 | let to_string(n) = to_string__builtin(n)
256 | let string_to_num(n) = string_to_num__builtin(n)
257 | let string_to_int(n) = string_to_int__builtin(n)
258 | let range_step(start, end, step) = range_step__builtin(start, end, step)
259 | let fold(acc, f, ls) = fold__builtin(acc, f, ls)
260 | let to_charlist(n) = to_charlist__builtin(n)
261 | let get(m, k) = get__builtin(m, k)
262 | let read_file(file) = read_file__builtin(file)
263 | let write_file(file, data) = write_file__builtin(file, data)
264 | let list_dir(dir) = list_dir__builtin(dir)
265 | let mkdir(dir) = mkdir__builtin(dir)
266 | let map_keys(m) = map_keys__builtin(m)
267 | let map_to_list(m) = map_to_list__builtin(m)
268 | let typeof(m) = typeof__builtin(m)
269 | let start_server(port, callback, server_state) = serve__builtin(port, callback, server_state)
270 | let start_server_ssl(cert_path, key_path, port, callback) = serve_ssl__builtin(cert_path, key_path, port, callback)
271 | let crypto_hash(val) = crypto_hash__builtin(val)
272 | let validate_pass(pass, hash) = validate_pass__builtin(pass, hash)
273 | let truncate(val) = truncate__builtin(val)
274 | 


--------------------------------------------------------------------------------
/lib/scanner.ml:
--------------------------------------------------------------------------------
  1 | open Base
  2 | open Stdio
  3 | open Printf
  4 | open Types
  5 | 
  6 | type token =
  7 |     | True
  8 |     | False
  9 |     | Number of float
 10 |     | Integer of int
 11 |     | Ident of string
 12 |     | StringTok of string
 13 |     | Operator of Types.operator
 14 |     | Match
 15 |     | Let
 16 |     | Equal
 17 |     | LParen
 18 |     | RParen
 19 |     | LBrace
 20 |     | RBrace
 21 |     | LBracket
 22 |     | RBracket
 23 |     | Fn
 24 |     | When
 25 |     | If
 26 |     | Then
 27 |     | Else
 28 |     | Arrow
 29 |     | MatchArrow
 30 |     | Newline
 31 |     | Hashtag
 32 |     | Comma
 33 |     | Pipe
 34 |     | Underscore
 35 |     | Colon
 36 |     | Percent
 37 |     | DotDot
 38 |     | For
 39 |     | In
 40 |     | As
 41 | 
 42 | let is_numeric d = Base.Char.is_digit d
 43 | let is_identic c = Base.Char.is_alphanum c || phys_equal c '_'
 44 | 
 45 | let rec scan_digit ls line_num filename =
 46 |     let rec aux ls acc saw_dot = match ls with
 47 |         | '.'::_ when saw_dot -> begin match acc with
 48 |             | '.'::chars -> chars, scan_ls ('.'::ls) line_num filename, false
 49 |             | _ -> acc, scan_ls ls line_num filename, true
 50 |         end
 51 |         | '.'::xs -> aux xs ('.'::acc) true
 52 |         | d::xs when (is_numeric d) -> aux xs (d::acc) saw_dot
 53 |         | _ -> acc, scan_ls ls line_num filename, saw_dot
 54 |     in 
 55 |     let chars, scanned, saw_dot = aux ls [] false in
 56 |     if saw_dot then
 57 |         let f = chars |> List.rev |> String.of_char_list |> Float.of_string in
 58 |         (Number f |> Located.locate {line_num; filename})::scanned
 59 |     else
 60 |         let i = chars |> List.rev |> String.of_char_list |> Int.of_string in
 61 |         (Integer i |> Located.locate {line_num; filename})::scanned
 62 | 
 63 | and scan_ident ls line_num filename =
 64 |     let rec aux ls acc = match ls with
 65 |         | c::xs when is_identic c -> aux xs (c::acc)
 66 |         | _ -> let n = (acc |> List.rev |> String.of_char_list) in
 67 |                let tok = match n with
 68 |                    | "let" -> Let
 69 |                    | "fn" -> Fn
 70 |                    | "if" -> If
 71 |                    | "then" -> Then
 72 |                    | "else" -> Else
 73 |                    | "match" -> Match
 74 |                    | "when" -> When
 75 |                    | "for" -> For
 76 |                    | "in" -> In
 77 |                    | "as" -> As
 78 |                    | "mod" -> Operator Mod
 79 |                    | _ -> Ident n
 80 |                 in
 81 |                 (tok |> Located.locate {line_num; filename})::(scan_ls ls line_num filename)
 82 |     in aux ls []
 83 | 
 84 | and scan_string ls line_num filename =
 85 |     let rec aux ls line_num acc = match ls with
 86 |         | '"'::xs -> 
 87 |             (StringTok (String.of_char_list (List.rev acc)) 
 88 |             |> Located.locate {line_num; filename})::(scan_ls xs line_num filename)
 89 |         | '\\'::'"'::xs -> aux xs line_num ('"'::acc)
 90 |         | '\n'::xs -> aux xs (line_num + 1) ('\n'::acc)
 91 |         | c::xs -> aux xs line_num (c::acc)
 92 |         | [] ->
 93 |             printf "Unmatched quote";
 94 |             assert false
 95 |     in aux ls line_num []
 96 | 
 97 | and skip_until_newline = function
 98 |     | [] -> []
 99 |     | '\n'::xs -> xs
100 |     | _::xs -> skip_until_newline xs
101 | 
102 | and scan_ls ls line filename =
103 |     let locate = Located.locate {line_num = line; filename = filename} in
104 |     match ls with
105 |     | [] -> []
106 |     | (' '|'\t')::xs -> scan_ls xs line filename
107 |     | '\n'::xs -> 
108 |         (Newline |> locate) :: scan_ls xs (line + 1) filename
109 |     | '='::'>'::xs -> 
110 |         (Arrow |> locate):: scan_ls xs line filename
111 |     | '-'::'>'::xs -> 
112 |         (MatchArrow |> locate) :: scan_ls xs line filename
113 |     | '+'::xs -> 
114 |         (Operator Add |> locate) :: scan_ls xs line filename
115 |     | '-'::xs -> 
116 |         (Operator Neg |> locate) :: scan_ls xs line filename
117 |     | '*'::xs -> 
118 |         (Operator Mul |> locate) :: scan_ls xs line filename
119 |     | '/'::xs -> 
120 |         (Operator Div |> locate) :: scan_ls xs line filename
121 |     | '<'::'='::xs -> 
122 |         (Operator LEQ |> locate) :: scan_ls xs line filename
123 |     | '<'::xs -> 
124 |         (Operator LT |> locate) :: scan_ls xs line filename
125 |     | '>'::'='::xs -> 
126 |         (Operator GEQ |> locate) :: scan_ls xs line filename
127 |     | '>'::xs -> 
128 |         (Operator GT |> locate) :: scan_ls xs line filename
129 |     | '&'::'&'::xs -> 
130 |         (Operator And |> locate) :: scan_ls xs line filename
131 |     | '|'::'|'::xs -> 
132 |         (Operator Or |> locate) :: scan_ls xs line filename
133 |     | '='::'='::xs -> 
134 |         (Operator EQ |> locate) :: scan_ls xs line filename
135 |     | '!'::'='::xs -> 
136 |         (Operator NEQ |> locate) :: scan_ls xs line filename
137 |     | '%'::xs -> 
138 |         (Percent |> locate) :: scan_ls xs line filename
139 |     | '^'::xs -> 
140 |         (Operator Head |> locate) :: scan_ls xs line filename
141 |     | '$'::xs -> 
142 |         (Operator Tail |> locate) :: scan_ls xs line filename
143 |     | '!'::xs -> 
144 |         (Operator Not |> locate) :: scan_ls xs line filename
145 |     | '.'::'.'::xs -> 
146 |         (DotDot |> locate) :: scan_ls xs line filename
147 |     | '('::xs -> 
148 |         (LParen |> locate) :: scan_ls xs line filename
149 |     | ')'::xs -> 
150 |         (RParen |> locate) :: scan_ls xs line filename
151 |     | '{'::xs -> 
152 |         (LBrace |> locate) :: scan_ls xs line filename
153 |     | '}'::xs -> 
154 |         (RBrace |> locate) :: scan_ls xs line filename
155 |     | '['::xs -> 
156 |         (LBracket |> locate) :: scan_ls xs line filename
157 |     | ']'::xs -> 
158 |         (RBracket |> locate) :: scan_ls xs line filename
159 |     | '='::xs -> 
160 |         (Equal |> locate) :: scan_ls xs line filename
161 |     | '_'::xs -> 
162 |         (Underscore |> locate) :: scan_ls xs line filename
163 |     | ','::xs -> 
164 |         (Comma |> locate) :: scan_ls xs line filename
165 |     | '#'::xs -> 
166 |         scan_ls (skip_until_newline xs) (line + 1) filename
167 |     | '|'::'>'::xs -> 
168 |         ((Operator PipeOp) |> locate) :: scan_ls xs line filename
169 |     | '|'::xs -> 
170 |         (Pipe |> locate) :: scan_ls xs line filename
171 |     | 'T'::xs -> 
172 |         (True |> locate) :: scan_ls xs line filename
173 |     | 'F'::xs -> 
174 |         (False |> locate) :: scan_ls xs line filename
175 |     | ':'::xs -> 
176 |         (Colon |> locate) :: scan_ls xs line filename
177 |     | '"'::xs -> scan_string xs line filename
178 |     | d::_ as ls when Char.is_digit d -> scan_digit ls line filename
179 |     | i::_ as ls when Char.is_alpha i -> scan_ident ls line filename
180 |     | ls -> 
181 |             printf "Scan Error: %s\n" (String.of_char_list ls); 
182 |             assert false
183 | 
184 | let scan s ~filename = s |> String.to_list |> (fun s -> scan_ls s 1 filename)
185 | 
186 | let string_of_tok = function
187 |     | Number f -> Float.to_string f
188 |     | Integer i -> Int.to_string i
189 |     | Ident s -> "(Ident " ^ s ^ ")"
190 |     | StringTok s -> sprintf "String (\"%s\")" s
191 |     | Operator _ -> "Operator"
192 |     | Let -> "Let"
193 |     | Equal -> "Equal"
194 |     | LParen -> "LParen"
195 |     | RParen -> "RParen"
196 |     | LBrace -> "LBrace"
197 |     | RBrace -> "RBrace"
198 |     | LBracket -> "LBracket"
199 |     | RBracket -> "RBracket"
200 |     | Comma -> "Comma"
201 |     | Fn -> "Fn"
202 |     | Arrow -> "Arrow"
203 |     | True -> "True"
204 |     | False -> "False"
205 |     | When -> "When"
206 |     | If -> "If"
207 |     | Then -> "Then"
208 |     | Else -> "Else"
209 |     | Newline -> "Newline"
210 |     | Hashtag -> "Hashtag"
211 |     | Pipe -> "Pipe"
212 |     | Match -> "Match"
213 |     | MatchArrow -> "MatchArrow"
214 |     | Underscore -> "Underscore"
215 |     | Colon -> "Colon"
216 |     | Percent -> "Percent"
217 |     | DotDot -> "DotDot"
218 |     | For -> "For"
219 |     | In -> "In"
220 |     | As -> "As"
221 | 
222 | let string_of_toks ls = String.concat ~sep:" " (List.map ~f:string_of_tok ls)
223 | let print_toks ls = ls |> string_of_toks |> printf "%s\n"
224 | 
225 | let toks_empty toks = List.for_all toks ~f:(fun tok -> phys_equal tok Newline)
226 | let rec skip_newlines = function
227 |     | {Located.data = Newline; _} :: xs -> skip_newlines xs
228 |     | ls -> ls
229 | 


--------------------------------------------------------------------------------
/lib/types.ml:
--------------------------------------------------------------------------------
  1 | open Base
  2 | open Printf
  3 | open Stdio
  4 | 
  5 | type location = { line_num: int; filename: string }
  6 | let location_to_string location = sprintf "line %s of %s" (Int.to_string location.line_num) location.filename
  7 | 
  8 | module Located = struct
  9 |     type 'a t = { location: location; data: 'a }
 10 | 
 11 |     let locate location a = { location; data = a }
 12 |     let extract {data; _} = data
 13 | end
 14 | 
 15 | type operator =
 16 |     | Add
 17 |     | Neg
 18 |     | Mul
 19 |     | Div
 20 |     | LT
 21 |     | GT
 22 |     | LEQ
 23 |     | GEQ
 24 |     | EQ
 25 |     | NEQ
 26 |     | And
 27 |     | Or
 28 |     | Mod
 29 |     | Head
 30 |     | Tail
 31 |     | Not
 32 |     | PipeOp
 33 | 
 34 | type value =
 35 |     | Number of float
 36 |     | Integer of int
 37 |     | Boolean of bool
 38 |     | Tuple of value list
 39 |     | ValList of value list
 40 |     | Lambda of lambda
 41 |     | LambdaCapture of {capture_val: value; capture_args: capture_arg list}
 42 |     | Fn of func
 43 |     | Thunk of {thunk_fn: lambda; thunk_args: value; thunk_fn_name: ident}
 44 |     | Dictionary of (int, (value * value) list, Int.comparator_witness) Map.t
 45 |     | Atom of int
 46 |     | StringVal of string
 47 | 
 48 | and pattern =
 49 |     | SinglePat of ident
 50 |     | NumberPat of float
 51 |     | IntegerPat of int
 52 |     | StringPat of string
 53 |     | UnresolvedAtomPat of string
 54 |     | AtomPat of int
 55 |     | TuplePat of pattern list
 56 |     | ListPat of list_pattern
 57 |     | MapPat of ((expr Located.t) * pattern) list
 58 |     | OrPat of pattern * pattern
 59 |     | AsPat of pattern * string
 60 |     | WildcardPat
 61 | 
 62 | and list_pattern =
 63 |     | FullPat of pattern list
 64 |     | HeadTailPat of (pattern list) * pattern
 65 | 
 66 | (* TODO: Make static_block_funcs a map *)
 67 | and static_state = { 
 68 |         static_atoms: (string * int) list; 
 69 |         static_idents: (string * int) list;
 70 |         static_block_funcs: (int * func) list;
 71 |         call_stack: ((int * location) * int) list;
 72 |     }
 73 | 
 74 | and state = (int, value, Int.comparator_witness) Map.t
 75 | 
 76 | (* Used to evaluate captures *)
 77 | and used_hole =
 78 |     | BlankHole
 79 |     | LabeledHole
 80 | 
 81 | and capture_arg =
 82 |     | ValArg of value
 83 |     | BlankCaptureHole
 84 |     | LabeledCaptureHole of int
 85 | 
 86 | and capture_expr_arg =
 87 |     | CaptureExprArg of expr Located.t
 88 |     | BlankCaptureExprHole
 89 |     | LabeledCaptureExprHole of int
 90 | 
 91 | and lambda = {lambda_expr: expr Located.t; lambda_args: pattern; enclosed_state: state;}
 92 | and lambda_call = {callee: ident; call_args: expr Located.t}
 93 | and lambda_capture_expr = {capture_expr_fn: ident; capture_expr_args: capture_expr_arg list}
 94 | and func = {fn_expr: expr Located.t; fn_args: pattern}
 95 | and if_expr = {cond: expr Located.t; then_expr: expr Located.t; else_expr: expr Located.t}
 96 | and if_let_expr = 
 97 |     {pat: pattern; assigned_expr: expr Located.t; let_then_expr: expr Located.t; let_else_expr: expr Located.t}
 98 | and ident =
 99 |     | UnresolvedIdent of string
100 |     | ResolvedIdent of int
101 | 
102 | and expr =
103 |     | Atomic of value
104 |     | IdentExpr of ident
105 |     | Binary of {lhs: expr Located.t; op: operator; rhs: expr Located.t}
106 |     | Prefix of {op: operator; rhs: expr Located.t}
107 |     | Let of {assignee: pattern; assigned_expr: expr Located.t}
108 |     | LambdaDef of {lambda_def_expr: expr Located.t; lambda_def_args: pattern}
109 |     | LambdaCall of lambda_call
110 |     | LambdaCaptureExpr of lambda_capture_expr
111 |     | FnDef of {fn_name: ident; fn_def_func: func}
112 |     | IfExpr of if_expr
113 |     | IfLetExpr of if_let_expr
114 |     | TupleExpr of (expr Located.t) list
115 |     | BlockExpr of (expr Located.t) list
116 |     | MatchExpr of {match_val: expr Located.t; match_arms: (pattern * (expr Located.t) * (expr Located.t) option) list}
117 |     | MapExpr of (((expr Located.t) * (expr Located.t)) list) * ((expr Located.t) option)
118 |     | ListExpr of ((expr Located.t) list) * ((expr Located.t) option)
119 |     | UnresolvedAtom of string
120 | 
121 | let escape_string s = s 
122 |     |> String.substr_replace_all ~pattern:"\\n" ~with_:"\n"
123 |     |> String.substr_replace_all ~pattern:"\\t" ~with_:"\t"
124 | 
125 | let rec string_of_val ss v = 
126 |     let string_of_val = string_of_val ss in
127 |     match v with
128 |     | Number n -> Float.to_string n
129 |     | Integer n -> Int.to_string n
130 |     | Boolean true -> "T"
131 |     | Boolean false -> "F"
132 |     | Tuple ls -> "(" ^ String.concat ~sep:", " (List.map ~f:string_of_val ls) ^ ")"
133 |     | ValList ls -> "[" ^ String.concat ~sep:", " (List.map ~f:string_of_val ls) ^ "]"
134 |     | Lambda _ -> "Lambda"
135 |     | LambdaCapture _ -> "LambdaCapture"
136 |     | Fn _ -> "Fn"
137 |     | Thunk _ -> "Thunk"
138 |     | Dictionary d ->
139 |         let string_of_pair = fun (k, v) -> sprintf "%s: %s" (string_of_val k) (string_of_val v) in
140 |         let map_fn = fun ls -> String.concat ~sep:", " (List.map ~f:string_of_pair ls) in
141 |         let map_pairs = (List.map ~f:map_fn (Map.data d)) in
142 |         sprintf "{%s}" (String.concat ~sep:", " map_pairs)
143 |     | Atom n -> 
144 |         let reverse_map = List.Assoc.inverse ss.static_atoms in
145 |         sprintf ":%s" (List.Assoc.find_exn reverse_map ~equal:Int.equal n)
146 |     | StringVal s -> s |> escape_string |> sprintf "\"%s\"" 
147 | 
148 | let rec string_of_expr ss e = 
149 |     let string_of_pat = string_of_pat ss in
150 |     let string_of_expr = string_of_expr ss in
151 |     let string_of_val  = string_of_val ss in
152 |     match e with
153 |     | Atomic v -> string_of_val v
154 |     | IdentExpr (UnresolvedIdent s) -> s
155 |     | IdentExpr (ResolvedIdent i) -> List.Assoc.find_exn (ss.static_idents |> List.Assoc.inverse) ~equal:Int.equal i
156 |     | Prefix p -> sprintf "{rhs: %s}" (string_of_expr p.rhs.data)
157 |     | Binary b -> sprintf "{lhs: %s, rhs: %s}" (string_of_expr b.lhs.data) (string_of_expr b.rhs.data)
158 |     | Let l -> sprintf "Let %s = %s" (string_of_pat l.assignee) (string_of_expr l.assigned_expr.data)
159 |     | LambdaDef _ -> "Lambda"
160 |     | FnDef d -> sprintf "FnDef %s%s = %s" 
161 |         (string_of_pat (SinglePat d.fn_name)) 
162 |         (string_of_pat d.fn_def_func.fn_args)
163 |         (string_of_expr d.fn_def_func.fn_expr.data)
164 |     | LambdaCall ({callee = UnresolvedIdent name; _} as call) -> 
165 |             sprintf "{Call: %s, args: %s}" name (string_of_expr call.call_args.data)
166 |     | LambdaCall ({callee = ResolvedIdent i; _} as call) -> 
167 |             let name = List.Assoc.find_exn (ss.static_idents |> List.Assoc.inverse) ~equal:Int.equal i in
168 |             sprintf "{Call: %s, args: %s}" name (string_of_expr call.call_args.data)
169 |     | LambdaCaptureExpr _ -> "LambdaCaptureExpr"
170 |     | TupleExpr ls -> 
171 |             sprintf "(%s)" (String.concat ~sep:", " (ls |> List.map ~f:Located.extract |> List.map ~f:string_of_expr))
172 |     | ListExpr (ls, tail) -> 
173 |         sprintf "[%s|%s]"
174 |         (String.concat ~sep:", " (ls |> List.map ~f:Located.extract |> List.map ~f:string_of_expr))
175 |         (if Option.is_none tail then "None" else "Tail")
176 |     | IfExpr _ -> "IfExpr"
177 |     | IfLetExpr _ -> "IfLetExpr"
178 |     | BlockExpr ls -> 
179 |         sprintf "{\n\t%s\n}" 
180 |         (String.concat ~sep:"\n\t" (ls |> List.map ~f:Located.extract |> List.map ~f:string_of_expr))
181 |     | MatchExpr _ -> "MatchExpr"
182 |     | MapExpr _ -> "Map"
183 |     | UnresolvedAtom _ -> "UnresolvedAtom"
184 | 
185 | and string_of_list_pat ss pat = match pat with
186 |     | FullPat ls -> "[" ^ (String.concat ~sep:", " (List.map ~f:(string_of_pat ss) ls)) ^ "]"
187 |     | HeadTailPat (_hd, _tl) -> assert false (* TODO *)
188 | 
189 | and string_of_pat ss pat = match pat with
190 |     | SinglePat (UnresolvedIdent s) -> s
191 |     | SinglePat (ResolvedIdent i) ->
192 |         List.Assoc.find_exn (List.Assoc.inverse ss.static_idents) ~equal:Int.equal i
193 |     | StringPat s -> sprintf "StringPat (\"%s\")" s
194 |     | ListPat lp -> (string_of_list_pat ss lp)
195 |     | MapPat _ -> "MapPat"
196 |     | NumberPat f -> Float.to_string f
197 |     | IntegerPat i -> Int.to_string i
198 |     | TuplePat ls -> sprintf "(%s)" (String.concat ~sep:", " (List.map ~f:(string_of_pat ss) ls))
199 |     | WildcardPat -> "_"
200 |     | OrPat _ -> "OrPat"
201 |     | AsPat _ -> "AsPat"
202 |     | UnresolvedAtomPat _ -> "UnresolvedAtomPat"
203 |     | AtomPat _ -> "AtomPat"
204 | 
205 | let rec hash_value = function
206 |     | Number f -> Hashtbl.hash (0, f)
207 |     | Boolean b -> Hashtbl.hash (1, b)
208 |     | Tuple ls -> Hashtbl.hash (2, List.map ~f:hash_value ls)
209 |     | Atom i -> Hashtbl.hash (3, i)
210 |     | StringVal s -> Hashtbl.hash (4, (escape_string s))
211 |     | Integer i -> Hashtbl.hash (5, i)
212 |     | _ ->
213 |         printf "Tried to hash an unhashable type";
214 |         assert false
215 | 
216 | let rec print_traceback ss = match ss.call_stack with
217 |     | [] -> ()
218 |     | ((call_id, call_loc), count)::xs ->
219 |         match List.Assoc.find (List.Assoc.inverse ss.static_idents) ~equal:Int.equal call_id with
220 |             | Some fn_name ->
221 |                 printf "%s at %s, called %d times\n" fn_name (location_to_string call_loc) count;
222 |                 print_traceback {ss with call_stack = xs}
223 |             | None ->
224 |                 match call_id with
225 |                 | -1 -> 
226 |                     printf "Anonymous fn at %s, called %d times\n" (location_to_string call_loc) count;
227 |                 | _ ->
228 |                     printf "Unresolved Ident %d at %s, called %d times\n" call_id (location_to_string call_loc) count;
229 |                 print_traceback {ss with call_stack = xs}
230 | 


--------------------------------------------------------------------------------
/lib/compile.ml:
--------------------------------------------------------------------------------
  1 | open Base
  2 | open Types
  3 | open Located
  4 | 
  5 | let ident_id = ref 0
  6 | let new_id () = 
  7 |     ident_id := !ident_id + 1;
  8 |     !ident_id
  9 | 
 10 | let idents = ref (Hashtbl.create (module String))
 11 | 
 12 | let new_ident name = 
 13 |     match Hashtbl.find !idents name with
 14 |     | Some id -> 
 15 |             Printf.sprintf "__ident_%d_%s" id name
 16 |     | None ->
 17 |         let id = new_id () in
 18 |         let s = Printf.sprintf "__ident_%d_%s" id name in
 19 |         Hashtbl.set ~key:name ~data:id !idents;
 20 |         s
 21 | 
 22 | and get_ident name = match name with
 23 |     | "inspect" -> "inspect__builtin"
 24 |     | "range_step" -> "range_step__builtin"
 25 |     | "println" -> "println__builtin"
 26 |     | _ ->
 27 |         let id = Hashtbl.find_exn !idents name in
 28 |         Printf.sprintf "__ident_%d_%s" id name
 29 | 
 30 | let compile_val v = match v with
 31 |     | Number f -> Printf.sprintf "%f" f
 32 |     | Integer i -> Printf.sprintf "%d" i
 33 |     | Boolean true -> "true"
 34 |     | Boolean false -> "false"
 35 |     | StringVal s -> Printf.sprintf "\"%s\"" s
 36 |     | _ -> assert false
 37 | 
 38 | let rec bind pat expr ss = 
 39 |     let _bind lhs rhs = bind lhs rhs ss in
 40 |     let _ident = List.Assoc.find_exn (List.Assoc.inverse ss.static_idents) ~equal:Int.equal in
 41 |     match pat with
 42 |     | SinglePat (UnresolvedIdent s) ->
 43 |             let var_ident = new_ident s in
 44 |             Printf.sprintf "var %s = %s" var_ident (compile_expr expr ss)
 45 |     | WildcardPat | NumberPat _ | IntegerPat _ | StringPat _ | UnresolvedAtomPat _ -> 
 46 |             compile_expr expr ss
 47 |     | TuplePat ls ->
 48 |             let bind_ls = String.concat ~sep:", " (List.map ~f:compile_bind_pat ls) in
 49 |             Printf.sprintf "var [%s] = %s" bind_ls (compile_expr expr ss)
 50 |     | ListPat FullPat ls ->
 51 |             let bind_ls = String.concat ~sep:", " (List.map ~f:compile_bind_pat ls) in
 52 |             Printf.sprintf "var [%s] = ll_bind_n(%s, %d)" bind_ls (compile_expr expr ss) (List.length ls)
 53 |     | ListPat HeadTailPat (ls, tail) ->
 54 |             let bind_ls = String.concat ~sep:", " (List.map ~f:compile_bind_pat ls) in
 55 |             Printf.sprintf "var [%s,%s] = ll_bind_head_tail(%s, %d)" 
 56 |                 bind_ls (compile_bind_pat tail) (compile_expr expr ss) (List.length ls)
 57 |     | OrPat (l, r) ->
 58 |             Printf.sprintf "if (%s) { %s } else if (%s) { %s }" 
 59 |                 (pat_cond expr l ~ss) (bind l expr ss)
 60 |                 (pat_cond expr r ~ss) (bind r expr ss)
 61 |     | _ -> 
 62 |             Stdio.printf "%s" (string_of_pat ss pat);
 63 |             assert false
 64 | 
 65 | and pat_cond expr pat ~ss = match pat with
 66 |     | WildcardPat | SinglePat _ -> "true"
 67 |     | NumberPat lhs  -> Printf.sprintf "%s === %f" (compile_expr expr ss) lhs
 68 |     | IntegerPat lhs -> Printf.sprintf "%s === %d" (compile_expr expr ss) lhs
 69 |     | _ -> Printf.sprintf "rsc_matches(%s, %s)" (compile_expr expr ss) (compile_pat pat)
 70 | 
 71 | and check_match pat expr ~ss =
 72 |     let cond = pat_cond expr pat ~ss in
 73 |     Printf.sprintf "if (!(%s)) throw 'Invalid Binding'" cond
 74 | 
 75 | and compile_pat pat = match pat with
 76 |     | SinglePat (UnresolvedIdent s) -> new_ident s
 77 |     | TuplePat ls -> Printf.sprintf "[%s]" (String.concat ~sep:", " (List.map ~f:compile_pat ls))
 78 |     | IntegerPat i -> Printf.sprintf "%d" i
 79 |     | NumberPat f -> Printf.sprintf "%f" f
 80 |     | OrPat (l, r) -> Printf.sprintf "{__rsc_pat_type: 0, l: (%s), r: (%s)}" (compile_pat l) (compile_pat r)
 81 |     | WildcardPat -> "null"
 82 |     | _ -> assert false
 83 | 
 84 | and compile_bind_pat pat = match pat with
 85 |     | SinglePat (UnresolvedIdent s) -> new_ident s
 86 |     | TuplePat ls -> Printf.sprintf "[%s]" (String.concat ~sep:", " (List.map ~f:compile_pat ls))
 87 |     | IntegerPat _ | NumberPat _ | WildcardPat -> new_ident "unused"
 88 |     | _ -> assert false
 89 | 
 90 | and compile_map ls tail ss =
 91 |     let rec loop ls acc = match ls with
 92 |     | [] -> List.rev acc
 93 |     | ((k, v)::rest) -> 
 94 |             let pair = Printf.sprintf "[(%s), (%s)]" (compile_expr k ss) (compile_expr v ss) in
 95 |             loop rest (pair::acc)
 96 |     in
 97 |     let args = String.concat ~sep:"," (loop ls []) in
 98 |     match tail with
 99 |     | Some tail -> Printf.sprintf "__rsc_mk_map(new Map([%s, ...(%s).map]))" args (compile_expr tail ss)
100 |     | None -> Printf.sprintf "__rsc_mk_map(new Map([%s]))" args
101 | 
102 | and compile_expr expr ?tc:(tc=false) ss =
103 |     let compile ?tc:(tc=false) expr = compile_expr ~tc expr ss in
104 |     match expr with
105 |     | {data = Atomic v; _} ->
106 |             compile_val v
107 |     | {data = BlockExpr ls; _} ->
108 |             let (expr_ls, last) = List.split_n ls ((List.length ls) - 1) in
109 |             let last = List.hd_exn last in
110 |             let fold_step = fun acc expr -> acc ^ (compile expr) ^ ";\n" in
111 |             let items = List.fold_left ~init:"" ~f:fold_step expr_ls in
112 |             Printf.sprintf "(_ => {\n%s\nreturn %s\n})()" items (compile ~tc last)
113 |     | {data = IdentExpr (UnresolvedIdent n); _} -> 
114 |             get_ident n
115 |     | {data = Prefix({op = Neg; rhs}); _} -> 
116 |             Printf.sprintf "-%s" (compile rhs)
117 |     | {data = Prefix({op = Not; rhs}); _} -> 
118 |             Printf.sprintf "!%s" (compile rhs)
119 |     | {data = Binary({op = Add; lhs; rhs}); _} -> 
120 |             Printf.sprintf "(%s + %s)" (compile lhs) (compile rhs)
121 |     | {data = Binary({op = Neg; lhs; rhs}); _} -> 
122 |             Printf.sprintf "(%s - %s)" (compile lhs) (compile rhs)
123 |     | {data = Binary({op = Mul; lhs; rhs}); _} -> 
124 |             Printf.sprintf "(%s * %s)" (compile lhs) (compile rhs)
125 |     | {data = Binary({op = Div; lhs; rhs}); _} -> 
126 |             Printf.sprintf "(%s / %s)" (compile lhs) (compile rhs)
127 |     | {data = Binary({op = EQ; lhs; rhs}); _} -> 
128 |             Printf.sprintf "rustscript_equal(%s, %s)" (compile lhs) (compile rhs)
129 |     | {data = Binary({op = NEQ; lhs; rhs}); _} -> 
130 |             Printf.sprintf "(%s !== %s)" (compile lhs) (compile rhs)
131 |     | {data = Binary({op = LEQ; lhs; rhs}); _} -> 
132 |             Printf.sprintf "(%s <= %s)" (compile lhs) (compile rhs)
133 |     | {data = Binary({op = GEQ; lhs; rhs}); _} -> 
134 |             Printf.sprintf "(%s >= %s)" (compile lhs) (compile rhs)
135 |     | {data = Binary({op = LT; lhs; rhs}); _} -> 
136 |             Printf.sprintf "(%s < %s)" (compile lhs) (compile rhs)
137 |     | {data = Binary({op = GT; lhs; rhs}); _} -> 
138 |             Printf.sprintf "(%s > %s)" (compile lhs) (compile rhs)
139 |     | {data = Binary({op = And; lhs; rhs}); _} -> 
140 |             Printf.sprintf "(%s && %s)" (compile lhs) (compile rhs)
141 |     | {data = Binary({op = Or; lhs; rhs}); _} -> 
142 |             Printf.sprintf "(%s || %s)" (compile lhs) (compile rhs)
143 |     | {data = Binary({op = Mod; lhs; rhs}); _} -> 
144 |             Printf.sprintf "(%s %% %s)" (compile lhs) (compile rhs)
145 |     | {data = Binary({op = PipeOp; lhs; rhs}); _} -> 
146 |             if tc then
147 |                 Printf.sprintf "mk_thunk(%s, [%s])" (compile rhs) (compile lhs)
148 |             else
149 |                 Printf.sprintf "unwrap_thunk(%s(%s))" (compile rhs) (compile lhs)
150 |     | {data = Let l; _} -> 
151 |             bind l.assignee l.assigned_expr ss
152 |     | {data = TupleExpr ls; _} ->
153 |         Printf.sprintf "[%s]" (String.concat ~sep:", " (List.map ~f:compile ls))
154 |     | {data = ListExpr (ls, Some tail); _} ->
155 |         Printf.sprintf "prepend_arr([%s], %s)" (String.concat ~sep:", " (List.map ~f:compile ls)) (compile tail)
156 |     | {data = ListExpr (ls, None); _} ->
157 |         Printf.sprintf "ll_from_ls([%s])" (String.concat ~sep:", " (List.map ~f:compile ls))
158 |     | {data = MapExpr (ls, tail); _} ->
159 |             compile_map ls tail ss
160 |     | {data = LambdaCall {callee = UnresolvedIdent fn; call_args = {data = TupleExpr call_args; _}; _}; _} -> 
161 |             let args = String.concat ~sep:", " (List.map ~f:compile call_args) in
162 |             if tc then
163 |                 Printf.sprintf "mk_thunk(%s, [%s])" (get_ident fn) args
164 |             else
165 |                 Printf.sprintf "unwrap_thunk(%s(%s))" (get_ident fn) args
166 |     | {data = LambdaDef d; _} -> 
167 |             let args = match d.lambda_def_args with
168 |             | TuplePat args -> args
169 |             | _ -> assert false
170 |             in
171 |             let args = String.concat ~sep:", " (List.map ~f:compile_pat args) in
172 |             Printf.sprintf "((%s) => %s)" args (compile d.lambda_def_expr)
173 |     | {data = FnDef {fn_name = UnresolvedIdent name; fn_def_func}; _} ->
174 |             let fn_ident = new_ident name in
175 |             let args = match fn_def_func.fn_args with
176 |             | TuplePat args -> args
177 |             | _ -> assert false
178 |             in
179 |             let args = String.concat ~sep:", " (List.map ~f:compile_pat args) in
180 |             let body = compile_expr ~tc:true fn_def_func.fn_expr ss in
181 |             Printf.sprintf "const %s = (%s) => %s" fn_ident args body
182 |     | {data = IfExpr {cond; then_expr; else_expr}; _} ->
183 |             Printf.sprintf "(_ => {if (%s) { return (_ => %s)() } else { return (_ => %s)() }})()" 
184 |                             (compile cond) (compile ~tc then_expr) (compile ~tc else_expr)
185 |     | {data = MatchExpr {match_val; match_arms}; location} ->
186 |             let match_val_ident = new_ident "match_val" in
187 |             Printf.sprintf "
188 |             (() => {
189 |                 const %s = %s;
190 |                 if (false) {}
191 |                 %s
192 |             })()
193 |             "
194 |             match_val_ident
195 |             (compile match_val)
196 |             (List.fold_left match_arms ~init:"" ~f:(fun acc (pat, arm_body, arm_guard) -> begin
197 |                 Printf.sprintf "
198 |                 %s
199 |                 else if ((%s) && (%s)) {
200 |                     %s
201 |                     return %s
202 |                 }
203 |                 "
204 |                 acc
205 |                 (pat_cond (locate location (IdentExpr (UnresolvedIdent "match_val"))) pat ~ss)
206 |                 (Option.value ~default:"true" (Option.map ~f:compile arm_guard))
207 |                 (bind pat (locate location (IdentExpr (UnresolvedIdent "match_val"))) ss)
208 |                 (compile arm_body)
209 |             end))
210 |     | _ -> 
211 |             Stdio.printf "%s\n" (string_of_expr ss expr.data);
212 |             assert false
213 | 
214 | let compile_str ?ss:(ss=let ss, _ = Run.default_state () in ss) ?name:(name="compile") s =
215 |     let tokens = s |> Scanner.scan ~filename:name |> Scanner.skip_newlines in
216 |     let expr_ls =
217 |         let rec loop remaining acc = match (Scanner.skip_newlines remaining) with
218 |         | [] -> 
219 |                 List.rev acc
220 |         | _ ->
221 |                 let parsed, remaining = Parser.parse remaining 0 in
222 |                 loop remaining (parsed::acc)
223 |         in
224 |         loop tokens []
225 |     in
226 |     let fold_step = fun acc expr -> acc ^ (compile_expr expr ss) ^ ";\n" in
227 |     let shim = [%blob "shim.js"] in
228 |     let lodash = [%blob "lodash.js"] in
229 |     lodash ^ "\n" ^ shim ^ "\n" ^ List.fold_left ~init:"" ~f:fold_step expr_ls
230 | 
231 | let compile_file filename =
232 |     let in_stream = Stdio.In_channel.create filename in
233 |     let in_string = Stdio.In_channel.input_all in_stream in
234 |     compile_str ~name:filename in_string
235 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | 

  2 |     
  3 |     

  4 |         RustScript V2
  5 |     

  6 | 

  7 | 
  8 | 
  9 | V2 of 
 10 | 
 11 | I originally wrote RustScript in Java because it was part of a school project,
 12 | ignoring performance/code quality because I only had one night to do it.
 13 | 
 14 | This is an improved version of RustScript with improved performance and more features
 15 | written to learn OCaml. It also served as a testbed for features, and a demonstration
 16 | of the 80/20 rule; the language's design was largely based on ease of implementation.
 17 | 
 18 | ### Examples:
 19 | 
 20 | The most impressive examples are:
 21 | - The tic-tac-toe AI: 
 22 | - The TOML parser library: 
 23 | - A simple static site generator/HTML template engine: 
 24 | - My personal website served using the previous two libraries: , hosted at 
 25 | - More examples below
 26 | 
 27 | ### Language Tour
 28 | 
 29 | #### Basic types:
 30 | 
 31 | RustScript has 5 basic types
 32 | ```ex
 33 | let x = 5 # integer
 34 | let f = 5.0 # float
 35 | let s = "Hello" # string
 36 | let b = T # boolean
 37 | let a = :atom # atom
 38 | ```
 39 | 
 40 | #### Compound types:
 41 | 
 42 | There are also a few compound types
 43 | ```ex
 44 | let t = (1, "hello", :aaa) # tuples
 45 | let ls = [1, 2, 3, 4, 5] # lists
 46 | let m = %{one: 2, "three" => 3} # maps
 47 | let f1 = fn(x) => x * 2 # closures
 48 | let f2(x) = x * 2 # functions
 49 | ```
 50 | 
 51 | #### Patterns:
 52 | 
 53 | All bindings in RustScript are done through pattern matching. Aside from the primitives, there
 54 | are:
 55 | 
 56 | ```ex
 57 | let (a, (b, c), d) = (1, (2, 3), 4) # tuple patterns
 58 | inspect((a, b, c, d)) # (1, 2, 3, 4)
 59 | 
 60 | let [a, b, c] = [1, 2, 3] # list patterns
 61 | inspect((a, b, c)) # (1, 2, 3)
 62 | 
 63 | let [a, b | tl] = [1, 2, 3, 4] # list head/tail patterns
 64 | inspect((a, b, tl)) # (1, 2, [3, 4])
 65 | 
 66 | let %{one, "two" => two} = %{one: 1, "two" => 2, unused: 0} # map patterns
 67 | inspect((one, two)) # (1, 2)
 68 | 
 69 | let _ = :something # wildcard pattern
 70 | # no bindings are created
 71 | 
 72 | let [x | xs] as ls = [1, 2, 3] # as patterns
 73 | inspect((x, xs, ls)) # (1, [2, 3], [1, 2, 3])
 74 | ```
 75 | 
 76 | While pattern matching is most frequently used in let bindings, it is also used in `if let` expressions, `match` expressions,
 77 | and function arguments.
 78 | 
 79 | `if let` expressions are used for refutable patterns:
 80 | 
 81 | ```ex
 82 | let result = (:ok, 5)
 83 | if let (:ok, n) = result then
 84 |     inspect(n)
 85 | else
 86 |     println("Error")
 87 | ```
 88 | 
 89 | `match` expressions:
 90 | 
 91 | ```ex
 92 | let ls = [1, 2, 3, 4]
 93 | match ls
 94 |     | [1 | xs] -> println("Starts with 1")
 95 |     | [_ | xs] -> println("Starts with something other than 1")
 96 | ```
 97 | 
 98 | #### Closures:
 99 | 
100 | ```ex
101 | let a = 5
102 | let f = fn(x) => x * a # f captures a
103 | 
104 | inspect(f(2)) # 10
105 | 
106 | let g = fn(a, [x | xs]) = (a * x, xs) # pattern matching works in function arguments
107 | inspect(g(1, [2, 3, 4])) # (2, [3, 4])
108 | ```
109 | 
110 | #### Named functions:
111 | 
112 | Named functions do not capture their environment. As a result, they run
113 | slightly faster and can be made mutually recursive
114 | 
115 | ```
116 | let f(x) = x * 2
117 | inspect(f(2)) # 4
118 | ```
119 | 
120 | #### Maps:
121 | 
122 | ```ex
123 | # pairs with non-atom keys use "=>" arrows
124 | let x = %{"one" => 1, "two" => 2, "three" => 3}
125 | 
126 | # pairs with atom keys use colons
127 | let y = %{one: 1, two: 2, three: 3}
128 | 
129 | # the following are equivalent:
130 | %{one: 1, two: 2}
131 | %{:one => 1, :two, 2}
132 | 
133 | # Maps are accessed via function call syntax
134 | inspect(x("one")) # 1
135 | inspect(y(:one)) # 1
136 | 
137 | # However it's often more convenient to pattern match over them,
138 | # especially with atoms as keys
139 | 
140 | let %{"one" => one, "two" => two} = x
141 | inspect((one, two)) # the three does not get bound
142 | 
143 | let %{one, two} = y # key punning, equivalent to the next line
144 | let %{:one => one, :two => two} = y
145 | 
146 | # Maps can be updated using update syntax
147 | let m = %{one: 1, two: 2}
148 | let g = %{three: 3 | m}
149 | inspect(g) # %{:one: 1, :three: 3, :two: 2}
150 | ```
151 | 
152 | #### Lists
153 | 
154 | ```ex
155 | # Lists are heterogenous linkedlists.
156 | let ls = [1, 2, 5, 7]
157 | 
158 | # Generally, lists are accessed via pattern matching
159 | let [a, b | tl] = ls
160 | inspect((a, b, tl)) # (1, 2, [5, 7])
161 | 
162 | # They can also be accessed by index in O(n) time via the nth function
163 | inspect(nth(ls, 2)) # 5
164 | 
165 | # Range expressions
166 | inspect([1..10]) # [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
167 | inspect([1,5..25]) # [1, 5, 9, 13, 17, 21]
168 | 
169 | # List comprehensions
170 | inspect([n * n for n in [1..100] if n mod 12 == 0]) # [144, 576, 1296, 2304, 3600, 5184, 7056, 9216]
171 | ```
172 | 
173 | #### Captures and Pipes
174 | 
175 | ```ex
176 | # Currying is emulated via function captures
177 | 
178 | let polynomial = fn(a, b, c, x) => a * x * x + b * x + c
179 | let f = polynomial(2, 3, 4, _)
180 | let g = polynomial(_, _, _, 10)
181 | 
182 | inspect(f(10)) # 234
183 | inspect(g(2, 3, 4)) # 234
184 | 
185 | # Captures are especially useful in combination with the pipe operator.
186 | # The following code takes advantage of the standard add, sub, mul, and div functions
187 | # as well as the fact that inspect returns its arguments unchanged after printing them
188 | 
189 | let f = polynomial(2, 3, 4)
190 | 
191 | 10
192 | |> f
193 | |> inspect # 234
194 | |> add(_, 10)
195 | |> inspect # 244
196 | |> div(_, 100)
197 | |> inspect # 2.44
198 | |> sub(1000, _)
199 | |> inspect # 997.56
200 | |> mul(_, 10)
201 | |> inspect # -9975.599
202 | ```
203 | 
204 | ### Build
205 | 
206 | ```bash
207 | dune build
208 | ```
209 | 
210 | Run a file using:
211 | 
212 | ```bash
213 | dune exec ./bin/rustscript_cli.exe 
214 | ```
215 | 
216 | Start a REPL using:
217 | 
218 | ```bash
219 | dune exec ./bin/rustscript_cli.exe
220 | ```
221 | 
222 | # Further examples
223 | 
224 | #### FizzBuzz
225 | ```ex
226 | # ideally, for ... in will become a macro over foreach
227 | let fizzbuzz(n) = foreach([1..101], fn(n) => match (n % 3, n % 5)
228 |     | (0, 0) -> println("FizzBuzz")
229 |     | (0, _) -> println("Fizz")
230 |     | (_, 0) -> println("Buzz")
231 |     | _ -> println(to_string(n))
232 | )
233 | 
234 | fizzbuzz(100)
235 | ```
236 | 
237 | #### Quicksort
238 | 
239 | ```ex
240 | let sort = fn(ls) => match ls
241 |     | [] -> []
242 |     | [pivot | tail] -> {
243 | 	let (higher, lower) = partition(tail, fn(x) => x >= pivot)
244 |         sort(lower) + [pivot] + sort(higher)
245 |     }
246 | 
247 | inspect(sort([5, 3, 7, 9, 10, 4, 6])) # [3, 4, 5, 6, 7, 9, 10]
248 | ```
249 | 
250 | #### Run Length Encode
251 | ```ex
252 | let run_len_encode = fn(ls) => match ls
253 |     | [] -> []
254 |     | [x | xs] -> {
255 |         let next = run_len_encode(xs)
256 |         match next
257 |             | [(next_x, cnt) | tl] when x == next_x -> [(x, cnt + 1) | tl]
258 |             | _ -> [(x, 1) | next]
259 |     }
260 | 
261 | let test_ls = [1, 1, 2, 3, 4, 4, 4, 5, 6, 1, 2, 2]
262 | 
263 | # [(1., 2.), (2., 1.), (3., 1.), (4., 3.), (5., 1.), (6., 1.), (1., 1.), (2., 2.)]
264 | inspect(run_len_encode(test_ls))
265 | ```
266 | 
267 | #### Binary Search Tree
268 | ```ex
269 | let insert = fn(root, key) => match root
270 |     | () -> %{val: key}
271 |     | %{right, val} when val < key -> %{right: insert(right, key) | root}
272 |     | %{left} -> %{left: insert(left, key) | root}
273 | 
274 | let tree_to_ls_inorder = {
275 |     let loop = fn(root, acc) => match root
276 | 	| () -> acc
277 | 	| %{val, left, right} -> {
278 | 	    let acc = loop(left, acc)
279 | 	    let acc = [val | acc]
280 | 	    loop(right, acc)
281 | 	}
282 | 
283 |     fn(bst) => reverse(loop(bst, []))
284 | }
285 | 
286 | let construct_from_list = fn(ls) =>
287 |     fold((), fn(t, v) => insert(t, v), ls)
288 | 
289 | let ls = [50, 30, 20, 65, 42, 20, 40, 70, 60, 80]
290 | let bst = construct_from_list(ls)
291 | inspect(tree_to_ls_inorder(bst)) # [20, 20, 30, 40, 42, 50, 60, 65, 70, 80]
292 | ```
293 | 
294 | #### Two Sum
295 | ```ex
296 | let two_sum = fn(nums, target) => {
297 |     let helper = fn(m, ls, target) => match ls
298 |         | [] -> ()
299 |         | [(i, x) | xs] -> {
300 |             let complement = target - x
301 |             match m
302 |                 | %{complement => ()} -> helper(%{x: i | m}, xs, target)
303 |                 | %{complement => y} -> (y, i)
304 |         }
305 | 
306 |     helper(%{}, enumerate(nums), target)
307 | }
308 | 
309 | inspect(two_sum([1,9,13,20,47], 10)) # (0, 1)
310 | inspect(two_sum([3,2,4,1,9], 10)) # (0, 4)
311 | inspect(two_sum([], 10)) # ()
312 | ```
313 | 
314 | ##### Caesar Cipher
315 | ```ex
316 | let (to_number, to_letter) = {
317 |     let enumerated = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" |> to_charlist |> enumerate
318 |     let to_number = fold(%{}, fn(m, (i, l)) => %{l => i | m}, enumerated)
319 |     let to_letter = fold(%{}, fn(m, (i, l)) => %{i => l | m}, enumerated)
320 |     (to_number, to_letter)
321 | }
322 | 
323 | let encode = fn(text, n) => {
324 |     let shift = shift % 26
325 | 
326 |     let loop = fn(char_ls, acc) => match char_ls
327 | 	| [] -> concat(reverse(acc))
328 | 	| [c | xs] when to_number(c) == () -> loop(xs, [c | acc])
329 | 	| [c | xs] -> {
330 | 	    let new_letter = c
331 | 		|> to_number
332 | 		|> add(shift, _)
333 | 		|> fn(c) => if c < 0 then 26 + c else c
334 | 		|> fn(c) => to_letter(c % 26)
335 | 	    loop(xs, [new_letter | acc])
336 | 	}
337 | 
338 |     loop(to_charlist(text), [])
339 | }
340 | 
341 | let decode = fn(text, n) => encode(text, -n)
342 | 
343 | inspect(encode("HELLO WORLD", 5)) # "MJQQT BTWQI"
344 | inspect(decode(encode("HELLO WORLD", 5), 5)) # "HELLO WORLD"
345 | ```
346 | 
347 | ##### Project Euler #1
348 | ```ex
349 | euler1 = sum([x for x in [1..1000] if x % 3 == 0 || x % 5 == 0])
350 | inspect(euler1) # 233168
351 | ```
352 | 
353 | ##### Project Euler #2
354 | ```ex
355 | let euler2 = {
356 |     let aux = fn((a, b), acc) =>
357 |         if b < 4000000 then 
358 |             aux((b, a + 4 * b), acc + b)
359 |        else 
360 |             acc
361 | 
362 |     aux((0, 2), 0)
363 | }
364 | 
365 | inspect(euler2) # 4613732
366 | ```
367 | 
368 | #### Euler 3
369 | ```ex
370 | let gcd = fn(a, b) => match (a, b)
371 |     | (0, x)|(x, 0) -> x
372 |     | (a, b) when a > b -> gcd(b, a)
373 |     | (a, b) -> {
374 |         let remainder = b % a
375 |         if remainder != 0 then (gcd(a, remainder)) else a
376 |     }
377 | 
378 | let abs = fn(x) => if x < 0 then -x else x
379 | 
380 | let pollard = fn(n) => match n
381 |     | 1 -> ()
382 |     | n when n % 2 == 0 -> 2
383 |     | n -> {
384 |         let g = fn(x, n) => (x * x + 1) % n
385 |         let iter = fn(x, y, d) => match (x, y, d)
386 |             | (x, y, 1) -> {
387 |                 let x = g(x, n)
388 |                 let y = g(g(y, n), n)
389 |                 let d = gcd(abs(x - y), n)
390 |                 iter(x, y, d)
391 |             }
392 |             | (_, _, d) -> if d == n then () else d
393 | 
394 |         iter(2, 2, 1)
395 |     }
396 | 
397 | let factor = fn(n) => {
398 |     let d = pollard(n)
399 |     if d == () then () else n / d
400 | }
401 | 
402 | let euler3 = {
403 |     # repeatedly factors until largest is found
404 |     let aux = fn(n) => match factor(n)
405 |         | () -> n
406 |         | f when n == f -> f
407 |         | f -> aux(f)
408 | 
409 |     let n = 600851475143
410 |     aux(n)
411 | }
412 | 
413 | inspect(euler3) # 6857
414 | ```
415 | 
416 | More project euler problems can be found in the [examples folder](https://github.com/mkhan45/RustScript2/tree/main/examples).
417 | 


--------------------------------------------------------------------------------
/licenses/LICENSE-APACHE:
--------------------------------------------------------------------------------
  1 |                                  Apache License
  2 |                            Version 2.0, January 2004
  3 |                         http://www.apache.org/licenses/
  4 | 
  5 |    TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
  6 | 
  7 |    1. Definitions.
  8 | 
  9 |       "License" shall mean the terms and conditions for use, reproduction,
 10 |       and distribution as defined by Sections 1 through 9 of this document.
 11 | 
 12 |       "Licensor" shall mean the copyright owner or entity authorized by
 13 |       the copyright owner that is granting the License.
 14 | 
 15 |       "Legal Entity" shall mean the union of the acting entity and all
 16 |       other entities that control, are controlled by, or are under common
 17 |       control with that entity. For the purposes of this definition,
 18 |       "control" means (i) the power, direct or indirect, to cause the
 19 |       direction or management of such entity, whether by contract or
 20 |       otherwise, or (ii) ownership of fifty percent (50%) or more of the
 21 |       outstanding shares, or (iii) beneficial ownership of such entity.
 22 | 
 23 |       "You" (or "Your") shall mean an individual or Legal Entity
 24 |       exercising permissions granted by this License.
 25 | 
 26 |       "Source" form shall mean the preferred form for making modifications,
 27 |       including but not limited to software source code, documentation
 28 |       source, and configuration files.
 29 | 
 30 |       "Object" form shall mean any form resulting from mechanical
 31 |       transformation or translation of a Source form, including but
 32 |       not limited to compiled object code, generated documentation,
 33 |       and conversions to other media types.
 34 | 
 35 |       "Work" shall mean the work of authorship, whether in Source or
 36 |       Object form, made available under the License, as indicated by a
 37 |       copyright notice that is included in or attached to the work
 38 |       (an example is provided in the Appendix below).
 39 | 
 40 |       "Derivative Works" shall mean any work, whether in Source or Object
 41 |       form, that is based on (or derived from) the Work and for which the
 42 |       editorial revisions, annotations, elaborations, or other modifications
 43 |       represent, as a whole, an original work of authorship. For the purposes
 44 |       of this License, Derivative Works shall not include works that remain
 45 |       separable from, or merely link (or bind by name) to the interfaces of,
 46 |       the Work and Derivative Works thereof.
 47 | 
 48 |       "Contribution" shall mean any work of authorship, including
 49 |       the original version of the Work and any modifications or additions
 50 |       to that Work or Derivative Works thereof, that is intentionally
 51 |       submitted to Licensor for inclusion in the Work by the copyright owner
 52 |       or by an individual or Legal Entity authorized to submit on behalf of
 53 |       the copyright owner. For the purposes of this definition, "submitted"
 54 |       means any form of electronic, verbal, or written communication sent
 55 |       to the Licensor or its representatives, including but not limited to
 56 |       communication on electronic mailing lists, source code control systems,
 57 |       and issue tracking systems that are managed by, or on behalf of, the
 58 |       Licensor for the purpose of discussing and improving the Work, but
 59 |       excluding communication that is conspicuously marked or otherwise
 60 |       designated in writing by the copyright owner as "Not a Contribution."
 61 | 
 62 |       "Contributor" shall mean Licensor and any individual or Legal Entity
 63 |       on behalf of whom a Contribution has been received by Licensor and
 64 |       subsequently incorporated within the Work.
 65 | 
 66 |    2. Grant of Copyright License. Subject to the terms and conditions of
 67 |       this License, each Contributor hereby grants to You a perpetual,
 68 |       worldwide, non-exclusive, no-charge, royalty-free, irrevocable
 69 |       copyright license to reproduce, prepare Derivative Works of,
 70 |       publicly display, publicly perform, sublicense, and distribute the
 71 |       Work and such Derivative Works in Source or Object form.
 72 | 
 73 |    3. Grant of Patent License. Subject to the terms and conditions of
 74 |       this License, each Contributor hereby grants to You a perpetual,
 75 |       worldwide, non-exclusive, no-charge, royalty-free, irrevocable
 76 |       (except as stated in this section) patent license to make, have made,
 77 |       use, offer to sell, sell, import, and otherwise transfer the Work,
 78 |       where such license applies only to those patent claims licensable
 79 |       by such Contributor that are necessarily infringed by their
 80 |       Contribution(s) alone or by combination of their Contribution(s)
 81 |       with the Work to which such Contribution(s) was submitted. If You
 82 |       institute patent litigation against any entity (including a
 83 |       cross-claim or counterclaim in a lawsuit) alleging that the Work
 84 |       or a Contribution incorporated within the Work constitutes direct
 85 |       or contributory patent infringement, then any patent licenses
 86 |       granted to You under this License for that Work shall terminate
 87 |       as of the date such litigation is filed.
 88 | 
 89 |    4. Redistribution. You may reproduce and distribute copies of the
 90 |       Work or Derivative Works thereof in any medium, with or without
 91 |       modifications, and in Source or Object form, provided that You
 92 |       meet the following conditions:
 93 | 
 94 |       (a) You must give any other recipients of the Work or
 95 |           Derivative Works a copy of this License; and
 96 | 
 97 |       (b) You must cause any modified files to carry prominent notices
 98 |           stating that You changed the files; and
 99 | 
100 |       (c) You must retain, in the Source form of any Derivative Works
101 |           that You distribute, all copyright, patent, trademark, and
102 |           attribution notices from the Source form of the Work,
103 |           excluding those notices that do not pertain to any part of
104 |           the Derivative Works; and
105 | 
106 |       (d) If the Work includes a "NOTICE" text file as part of its
107 |           distribution, then any Derivative Works that You distribute must
108 |           include a readable copy of the attribution notices contained
109 |           within such NOTICE file, excluding those notices that do not
110 |           pertain to any part of the Derivative Works, in at least one
111 |           of the following places: within a NOTICE text file distributed
112 |           as part of the Derivative Works; within the Source form or
113 |           documentation, if provided along with the Derivative Works; or,
114 |           within a display generated by the Derivative Works, if and
115 |           wherever such third-party notices normally appear. The contents
116 |           of the NOTICE file are for informational purposes only and
117 |           do not modify the License. You may add Your own attribution
118 |           notices within Derivative Works that You distribute, alongside
119 |           or as an addendum to the NOTICE text from the Work, provided
120 |           that such additional attribution notices cannot be construed
121 |           as modifying the License.
122 | 
123 |       You may add Your own copyright statement to Your modifications and
124 |       may provide additional or different license terms and conditions
125 |       for use, reproduction, or distribution of Your modifications, or
126 |       for any such Derivative Works as a whole, provided Your use,
127 |       reproduction, and distribution of the Work otherwise complies with
128 |       the conditions stated in this License.
129 | 
130 |    5. Submission of Contributions. Unless You explicitly state otherwise,
131 |       any Contribution intentionally submitted for inclusion in the Work
132 |       by You to the Licensor shall be under the terms and conditions of
133 |       this License, without any additional terms or conditions.
134 |       Notwithstanding the above, nothing herein shall supersede or modify
135 |       the terms of any separate license agreement you may have executed
136 |       with Licensor regarding such Contributions.
137 | 
138 |    6. Trademarks. This License does not grant permission to use the trade
139 |       names, trademarks, service marks, or product names of the Licensor,
140 |       except as required for reasonable and customary use in describing the
141 |       origin of the Work and reproducing the content of the NOTICE file.
142 | 
143 |    7. Disclaimer of Warranty. Unless required by applicable law or
144 |       agreed to in writing, Licensor provides the Work (and each
145 |       Contributor provides its Contributions) on an "AS IS" BASIS,
146 |       WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
147 |       implied, including, without limitation, any warranties or conditions
148 |       of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
149 |       PARTICULAR PURPOSE. You are solely responsible for determining the
150 |       appropriateness of using or redistributing the Work and assume any
151 |       risks associated with Your exercise of permissions under this License.
152 | 
153 |    8. Limitation of Liability. In no event and under no legal theory,
154 |       whether in tort (including negligence), contract, or otherwise,
155 |       unless required by applicable law (such as deliberate and grossly
156 |       negligent acts) or agreed to in writing, shall any Contributor be
157 |       liable to You for damages, including any direct, indirect, special,
158 |       incidental, or consequential damages of any character arising as a
159 |       result of this License or out of the use or inability to use the
160 |       Work (including but not limited to damages for loss of goodwill,
161 |       work stoppage, computer failure or malfunction, or any and all
162 |       other commercial damages or losses), even if such Contributor
163 |       has been advised of the possibility of such damages.
164 | 
165 |    9. Accepting Warranty or Additional Liability. While redistributing
166 |       the Work or Derivative Works thereof, You may choose to offer,
167 |       and charge a fee for, acceptance of support, warranty, indemnity,
168 |       or other liability obligations and/or rights consistent with this
169 |       License. However, in accepting such obligations, You may act only
170 |       on Your own behalf and on Your sole responsibility, not on behalf
171 |       of any other Contributor, and only if You agree to indemnify,
172 |       defend, and hold each Contributor harmless for any liability
173 |       incurred by, or claims asserted against, such Contributor by reason
174 |       of your accepting any such warranty or additional liability.
175 | 
176 |    END OF TERMS AND CONDITIONS
177 | 
178 |    APPENDIX: How to apply the Apache License to your work.
179 | 
180 |       To apply the Apache License to your work, attach the following
181 |       boilerplate notice, with the fields enclosed by brackets "[]"
182 |       replaced with your own identifying information. (Don't include
183 |       the brackets!)  The text should be enclosed in the appropriate
184 |       comment syntax for the file format. We also recommend that a
185 |       file or class name and description of purpose be included on the
186 |       same "printed page" as the copyright notice for easier
187 |       identification within third-party archives.
188 | 
189 |    Copyright [yyyy] [name of copyright owner]
190 | 
191 |    Licensed under the Apache License, Version 2.0 (the "License");
192 |    you may not use this file except in compliance with the License.
193 |    You may obtain a copy of the License at
194 | 
195 |        http://www.apache.org/licenses/LICENSE-2.0
196 | 
197 |    Unless required by applicable law or agreed to in writing, software
198 |    distributed under the License is distributed on an "AS IS" BASIS,
199 |    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
200 |    See the License for the specific language governing permissions and
201 |    limitations under the License.
202 | 
203 | 


--------------------------------------------------------------------------------
/lib/preprocess.ml:
--------------------------------------------------------------------------------
  1 | open Base
  2 | open Types
  3 | 
  4 | let inline_threshold = 3
  5 | 
  6 | let assoc_add ls x = 
  7 |     if List.Assoc.mem ls ~equal:String.equal x then
  8 |         ls
  9 |     else
 10 |         (x, List.length ls)::ls
 11 | 
 12 | type tree_node =
 13 |     | ExprNode of (expr Located.t)
 14 |     | PatNode of pattern
 15 | 
 16 | let unwrap_expr_node = function
 17 |     | ExprNode n -> n
 18 |     | _ -> assert false
 19 | 
 20 | let unwrap_pat_node = function
 21 |     | PatNode n -> n
 22 |     | _ -> assert false
 23 | 
 24 | let rec tree_fold_map: tree_node -> accumulator:'a -> f:('a -> tree_node -> (tree_node * 'a)) -> (tree_node * 'a) = 
 25 |     fun node ~accumulator ~f -> match node with
 26 |     | ExprNode ({data = Atomic _ | IdentExpr _ | UnresolvedAtom _; _}) ->
 27 |         f accumulator node
 28 |     | ExprNode (({data = Binary ({lhs; rhs; _} as b); _}) as located) ->
 29 |         let lhs, accumulator = tree_fold_map (ExprNode lhs) ~accumulator:accumulator ~f:f in
 30 |         let rhs, accumulator = tree_fold_map (ExprNode rhs) ~accumulator:accumulator ~f:f in
 31 |         let (lhs, rhs) = (unwrap_expr_node lhs), (unwrap_expr_node rhs) in
 32 |         f accumulator (ExprNode {located with data = Binary {b with lhs; rhs}})
 33 |     | ExprNode ({data = Prefix ({rhs; _} as p); _} as located) ->
 34 |         let rhs, accumulator = tree_fold_map (ExprNode rhs) ~accumulator:accumulator ~f:f in
 35 |         let rhs = unwrap_expr_node rhs in
 36 |         f accumulator (ExprNode {located with data = Prefix {p with rhs}})
 37 |     | ExprNode ({data = Let {assignee; assigned_expr}; location}) ->
 38 |         let assignee, accumulator = tree_fold_map (PatNode assignee) ~accumulator:accumulator ~f:f in
 39 |         let assigned_expr, accumulator = tree_fold_map (ExprNode assigned_expr) ~accumulator:accumulator ~f:f in
 40 |         let (assignee, assigned_expr) = unwrap_pat_node assignee, unwrap_expr_node assigned_expr in
 41 |         f accumulator (ExprNode {data = Let {assignee; assigned_expr}; location})
 42 |     | ExprNode ({data = LambdaDef {lambda_def_expr; lambda_def_args}; _} as located) ->
 43 |         let lambda_def_expr, accumulator = 
 44 |             tree_fold_map (ExprNode lambda_def_expr) ~accumulator:accumulator ~f:f 
 45 |         in
 46 |         let lambda_def_args, accumulator = 
 47 |             tree_fold_map (PatNode lambda_def_args) ~accumulator:accumulator ~f:f 
 48 |         in
 49 |         let (lambda_def_expr, lambda_def_args) = 
 50 |             (unwrap_expr_node lambda_def_expr, unwrap_pat_node lambda_def_args)
 51 |         in
 52 |         f accumulator (ExprNode {located with data = LambdaDef {lambda_def_expr; lambda_def_args}})
 53 |     | ExprNode ({data = LambdaCall ({call_args; _} as c); _} as located) ->
 54 |         let call_args, accumulator = tree_fold_map (ExprNode call_args) ~accumulator:accumulator ~f:f in
 55 |         let call_args = unwrap_expr_node call_args in
 56 |         f accumulator (ExprNode ({located with data = LambdaCall {c with call_args}}))
 57 |     | ExprNode ({data = LambdaCaptureExpr {capture_expr_args; capture_expr_fn}; _} as located) ->
 58 |         let step accumulator capture_arg = match capture_arg with
 59 |             | CaptureExprArg e ->
 60 |                 let e, accumulator = tree_fold_map (ExprNode e) ~accumulator:accumulator ~f:f in
 61 |                 accumulator, CaptureExprArg (unwrap_expr_node e)
 62 |             | _ -> accumulator, capture_arg
 63 |         in
 64 |         let accumulator, capture_expr_args = List.fold_map ~init:accumulator ~f:step capture_expr_args in
 65 |         f accumulator (ExprNode {located with data = LambdaCaptureExpr {capture_expr_args; capture_expr_fn}})
 66 |     | ExprNode ({data = FnDef ({fn_def_func = {fn_expr; fn_args}; _} as def); _} as located) ->
 67 |         let fn_expr, accumulator = tree_fold_map (ExprNode fn_expr) ~accumulator:accumulator ~f:f in
 68 |         let fn_args, accumulator = tree_fold_map (PatNode fn_args) ~accumulator:accumulator ~f:f in
 69 |         let (fn_expr, fn_args) = unwrap_expr_node fn_expr, unwrap_pat_node fn_args in
 70 |         let fn_def_func = {fn_expr; fn_args} in
 71 |         f accumulator (ExprNode ({located with data = FnDef {def with fn_def_func}}))
 72 |     | ExprNode ({data = IfExpr {cond; then_expr; else_expr}; _} as located) ->
 73 |         let cond, accumulator = tree_fold_map (ExprNode cond) ~accumulator:accumulator ~f:f in
 74 |         let then_expr, accumulator = tree_fold_map (ExprNode then_expr) ~accumulator:accumulator ~f:f in
 75 |         let else_expr, accumulator = tree_fold_map (ExprNode else_expr) ~accumulator:accumulator ~f:f in
 76 |         let (cond, then_expr, else_expr) = 
 77 |             (unwrap_expr_node cond, unwrap_expr_node then_expr, unwrap_expr_node else_expr) 
 78 |         in
 79 |         f accumulator (ExprNode ({located with data = IfExpr {cond; then_expr; else_expr}}))
 80 |     | ExprNode ({data = IfLetExpr {pat; assigned_expr; let_then_expr; let_else_expr}; _} as located) ->
 81 |         let pat, accumulator = tree_fold_map (PatNode pat) ~accumulator ~f in
 82 |         let assigned_expr, accumulator = tree_fold_map (ExprNode assigned_expr) ~accumulator ~f in
 83 |         let let_then_expr, accumulator = tree_fold_map (ExprNode let_then_expr) ~accumulator ~f in
 84 |         let let_else_expr, accumulator = tree_fold_map (ExprNode let_else_expr) ~accumulator ~f in
 85 |         let (pat, assigned_expr, let_then_expr, let_else_expr) = (
 86 |             unwrap_pat_node pat, 
 87 |             unwrap_expr_node assigned_expr, 
 88 |             unwrap_expr_node let_then_expr, 
 89 |             unwrap_expr_node let_else_expr
 90 |         ) 
 91 |         in
 92 |         f accumulator (ExprNode ({located with data = IfLetExpr {pat; assigned_expr; let_then_expr; let_else_expr}}))
 93 |     | ExprNode ({data = TupleExpr ls; _} as located) ->
 94 |         let step accumulator node =
 95 |             let mapped_node, accumulator = tree_fold_map (ExprNode node) ~accumulator:accumulator ~f:f in
 96 |             accumulator, unwrap_expr_node mapped_node
 97 |         in
 98 |         let accumulator, ls = List.fold_map ~init:accumulator ~f:step ls in
 99 |         f accumulator (ExprNode ({located with data = TupleExpr ls}))
100 |     | ExprNode ({data = BlockExpr ls; _} as located) ->
101 |         let step accumulator node =
102 |             let mapped_node, accumulator = tree_fold_map (ExprNode node) ~accumulator:accumulator ~f:f in
103 |             accumulator, unwrap_expr_node mapped_node
104 |         in
105 |         let accumulator, ls = List.fold_map ~init:accumulator ~f:step ls in
106 |         f accumulator (ExprNode {located with data = BlockExpr ls})
107 |     | ExprNode ({data = MatchExpr {match_val; match_arms}; _} as located) ->
108 |         let match_val, accumulator = tree_fold_map (ExprNode match_val) ~accumulator:accumulator ~f:f in
109 |         let match_val = unwrap_expr_node match_val in
110 |         let step accumulator (match_pat, match_expr, match_cond_opt) =
111 |             let match_pat, accumulator = tree_fold_map (PatNode match_pat) ~accumulator:accumulator ~f:f in
112 |             let match_expr, accumulator = tree_fold_map (ExprNode match_expr) ~accumulator:accumulator ~f:f in
113 |             let match_cond_opt, accumulator = match match_cond_opt with
114 |                 | Some c -> 
115 |                     let match_cond, accumulator = tree_fold_map (ExprNode c) ~accumulator:accumulator ~f:f in
116 |                     Some (unwrap_expr_node match_cond), accumulator
117 |                 | None -> None, accumulator
118 |             in
119 |             accumulator, (unwrap_pat_node match_pat, unwrap_expr_node match_expr, match_cond_opt)
120 |         in
121 |         let accumulator, match_arms = List.fold_map ~init:accumulator ~f:step match_arms in
122 |         f accumulator (ExprNode {located with data = MatchExpr {match_val; match_arms}})
123 |     | ExprNode ({data = MapExpr (pairs, tail_opt); _} as located) ->
124 |         let step accumulator (k, v) =
125 |             let k, accumulator = tree_fold_map (ExprNode k) ~accumulator:accumulator ~f:f in
126 |             let v, accumulator = tree_fold_map (ExprNode v) ~accumulator:accumulator ~f:f in
127 |             accumulator, (unwrap_expr_node k, unwrap_expr_node v)
128 |         in
129 |         let accumulator, pairs = List.fold_map ~init:accumulator ~f:step pairs in
130 |         let tail_opt, accumulator = match tail_opt with
131 |             | Some t -> 
132 |                 let tail, accumulator = tree_fold_map (ExprNode t) ~accumulator:accumulator ~f:f in
133 |                 Some (unwrap_expr_node tail), accumulator
134 |             | None -> None, accumulator
135 |         in
136 |         f accumulator (ExprNode {located with data = MapExpr (pairs, tail_opt)})
137 |     | ExprNode ({data = ListExpr (ls, tail_opt); _} as located) ->
138 |         let step accumulator node =
139 |             let mapped_node, accumulator = tree_fold_map (ExprNode node) ~accumulator:accumulator ~f:f in
140 |             accumulator, (unwrap_expr_node mapped_node)
141 |         in
142 |         let accumulator, ls = List.fold_map ~init:accumulator ~f:step ls in
143 |         let tail_opt, accumulator = match tail_opt with
144 |             | Some t -> 
145 |                 let tail, accumulator = tree_fold_map (ExprNode t) ~accumulator:accumulator ~f:f in
146 |                 Some (unwrap_expr_node tail), accumulator
147 |             | None -> None, accumulator
148 |         in
149 |         f accumulator (ExprNode {located with data = ListExpr (ls, tail_opt)})
150 |     | PatNode (SinglePat _ | NumberPat _ | IntegerPat _ | StringPat _ | UnresolvedAtomPat _ | AtomPat _ | WildcardPat) ->
151 |         f accumulator node
152 |     | PatNode (TuplePat ls) ->
153 |         let step accumulator node =
154 |             let mapped_node, accumulator = tree_fold_map (PatNode node) ~accumulator:accumulator ~f:f in
155 |             accumulator, (unwrap_pat_node mapped_node)
156 |         in
157 |         let accumulator, ls = List.fold_map ~init:accumulator ~f:step ls in
158 |         f accumulator (PatNode (TuplePat ls))
159 |     | PatNode (ListPat (FullPat ls)) ->
160 |         let step accumulator node =
161 |             let mapped_node, accumulator = tree_fold_map (PatNode node) ~accumulator:accumulator ~f:f in
162 |             accumulator, (unwrap_pat_node mapped_node)
163 |         in
164 |         let accumulator, ls = List.fold_map ~init:accumulator ~f:step ls in
165 |         f accumulator (PatNode (ListPat (FullPat ls)))
166 |     | PatNode (ListPat (HeadTailPat (ls, tail))) ->
167 |         let step accumulator node =
168 |             let mapped_node, accumulator = tree_fold_map (PatNode node) ~accumulator:accumulator ~f:f in
169 |             accumulator, (unwrap_pat_node mapped_node)
170 |         in
171 |         let accumulator, ls = List.fold_map ~init:accumulator ~f:step ls in
172 |         let tail, accumulator = tree_fold_map (PatNode tail) ~accumulator:accumulator ~f:f in
173 |         let tail = unwrap_pat_node tail in
174 |         f accumulator (PatNode (ListPat (HeadTailPat (ls, tail))))
175 |     | PatNode (MapPat pairs) ->
176 |         let step accumulator (k, v) =
177 |             let k, accumulator = tree_fold_map (ExprNode k) ~accumulator:accumulator ~f:f in
178 |             let v, accumulator = tree_fold_map (PatNode v) ~accumulator:accumulator ~f:f in
179 |             let (k, v) = unwrap_expr_node k, unwrap_pat_node v in
180 |             accumulator, (k, v) 
181 |         in
182 |         let accumulator, pairs = List.fold_map ~init:accumulator ~f:step pairs in
183 |         f accumulator (PatNode (MapPat pairs))
184 |     | PatNode (OrPat (l, r)) ->
185 |         let l, accumulator = tree_fold_map (PatNode l) ~accumulator:accumulator ~f:f in
186 |         let r, accumulator = tree_fold_map (PatNode r) ~accumulator:accumulator ~f:f in
187 |         let (l, r) = (unwrap_pat_node l), (unwrap_pat_node r) in
188 |         f accumulator (PatNode (OrPat (l, r)))
189 |     | PatNode (AsPat (p, s)) ->
190 |         let p, accumulator = tree_fold_map (PatNode p) ~accumulator:accumulator ~f:f in
191 |         let p = unwrap_pat_node p in
192 |         f accumulator (PatNode (AsPat (p, s)))
193 | 
194 | let find_expr_atoms_step expr atoms = match (Located.extract expr) with
195 |     | UnresolvedAtom s -> expr, assoc_add atoms s
196 |     | _ -> expr, atoms
197 | 
198 | let find_pat_atoms_step pat atoms = match pat with
199 |     | UnresolvedAtomPat s -> pat, assoc_add atoms s
200 |     | _ -> pat, atoms
201 | 
202 | let find_atoms tree atoms =
203 |     let fold_step atoms tree = match tree with
204 |         | ExprNode e ->
205 |             let e, atoms = find_expr_atoms_step e atoms in
206 |             (ExprNode e), atoms
207 |         | PatNode p -> 
208 |             let p, atoms = find_pat_atoms_step p atoms in
209 |             (PatNode p), atoms
210 |     in
211 |     let _, atoms = tree_fold_map tree ~accumulator:atoms ~f:fold_step in
212 |     atoms
213 | 
214 | let resolve_atoms_step atoms node = match node with
215 |     | ExprNode {data = UnresolvedAtom s; location} -> begin
216 |         match List.Assoc.find atoms ~equal:String.equal s with
217 |             | Some i -> ExprNode {data = Atomic (Atom i); location}, atoms
218 |             | None ->
219 |                 Stdio.printf "Could not resolve atom :%s\n" s;
220 |                 Caml.exit 0
221 |     end
222 |     | PatNode (UnresolvedAtomPat s) -> begin
223 |         match List.Assoc.find atoms ~equal:String.equal s with
224 |             | Some i -> PatNode (AtomPat i), atoms
225 |             | None ->
226 |                 Stdio.printf "Could not resolve atom :%s\n" s;
227 |                 Caml.exit 0
228 |     end
229 |     | _ -> node, atoms
230 | 
231 | let resolve_atoms tree atoms =
232 |     let tree, _ = tree_fold_map tree ~accumulator:atoms ~f:resolve_atoms_step in
233 |     tree
234 | 
235 | let find_idents_step idents node = match node with
236 |     | ExprNode {data = IdentExpr (UnresolvedIdent s); _} ->
237 |         node, assoc_add idents s
238 |     | ExprNode {data = LambdaCall {callee = UnresolvedIdent s; _}; _} ->
239 |         node, assoc_add idents s
240 |     | ExprNode {data = FnDef {fn_name = UnresolvedIdent s; _}; _} ->
241 |         node, assoc_add idents s
242 |     | ExprNode {data = LambdaCaptureExpr {capture_expr_fn = UnresolvedIdent s; _}; _} ->
243 |         node, assoc_add idents s
244 |     | PatNode (SinglePat (UnresolvedIdent s)) ->
245 |         node, assoc_add idents s
246 |     | _ -> node, idents
247 | 
248 | let find_idents tree idents =
249 |     let _, idents = tree_fold_map tree ~accumulator:idents ~f:find_idents_step in
250 |     idents
251 | 
252 | let resolve_idents_step idents node = 
253 |     let find = List.Assoc.find_exn idents ~equal:String.equal in
254 |     match node with
255 |     | ExprNode {data = IdentExpr (UnresolvedIdent s); location} ->
256 |         let ident = ResolvedIdent (find s) in
257 |         ExprNode {data = IdentExpr ident; location}, idents
258 |     | ExprNode {data = LambdaCall ({callee = UnresolvedIdent s; _} as c); location} ->
259 |         let ident = ResolvedIdent (find s) in
260 |         ExprNode {data = LambdaCall {c with callee = ident}; location}, idents
261 |     | ExprNode {data = FnDef ({fn_name = UnresolvedIdent s; _} as def); location} ->
262 |         let ident = ResolvedIdent (find s) in
263 |         ExprNode {data = FnDef {def with fn_name = ident}; location}, idents
264 |     | ExprNode {data = LambdaCaptureExpr ({capture_expr_fn = UnresolvedIdent s; _} as capture); location} ->
265 |         let ident = ResolvedIdent (find s) in
266 |         ExprNode {data = LambdaCaptureExpr {capture with capture_expr_fn = ident}; location}, idents
267 |     | PatNode (SinglePat (UnresolvedIdent s)) ->
268 |         let ident = ResolvedIdent (find s) in
269 |         PatNode (SinglePat ident), idents
270 |     | _ -> node, idents
271 | 
272 | let resolve_idents tree idents =
273 |     let tree, _ = tree_fold_map tree ~accumulator:idents ~f:resolve_idents_step in
274 |     tree
275 | 
276 | let find_expr_functions ss acc e = match e with
277 |     | FnDef {fn_name = UnresolvedIdent fn_name; fn_def_func} -> 
278 |         (fn_name |> List.Assoc.find_exn ss.static_idents ~equal:String.equal, fn_def_func)::acc
279 |     | FnDef {fn_name = ResolvedIdent i; fn_def_func} ->
280 |         (i, fn_def_func)::acc
281 |     | _ -> acc
282 | 
283 | let find_block_funcs ss expr_ls acc =
284 |     List.fold_left ~init:acc ~f:(find_expr_functions ss) expr_ls
285 | 
286 | let inline_functions_step static_funcs node = match node with
287 |     | ExprNode {data = LambdaCall {callee = ResolvedIdent id; call_args}; location} ->
288 |         let fn = List.Assoc.find static_funcs ~equal:Int.equal id in
289 |         begin match fn with
290 |             | None -> 
291 |                 node, static_funcs
292 |             | Some {fn_expr = {data = BlockExpr ls; _}; _} when List.length ls > inline_threshold ->
293 |                 node, static_funcs
294 |             | Some {fn_expr; fn_args} ->
295 |                 let e = BlockExpr [
296 |                     Let {assignee = fn_args; assigned_expr = call_args} |> Located.locate location;
297 |                     fn_expr
298 |                 ] |> Located.locate fn_expr.location
299 |                 in ExprNode e, static_funcs
300 |         end
301 |     | _ -> node, static_funcs
302 | 
303 | let inline_functions tree static_funcs = 
304 |     let tree, _ = tree_fold_map tree ~accumulator:static_funcs ~f:inline_functions_step in
305 |     tree
306 | 
307 | let clobbers_declared_fn_step (acc, static_funcs) node = match node with
308 |     | PatNode (SinglePat (ResolvedIdent id)) ->
309 |         let clobbers = List.Assoc.mem static_funcs ~equal:Int.equal id in
310 |         node, (clobbers || acc, static_funcs)
311 |     | _ ->
312 |         node, (false || acc, static_funcs)
313 | 
314 | let clobbers_declared_fn_test tree static_funcs =
315 |     let _, (result, _) = tree_fold_map tree ~accumulator:(false, static_funcs) ~f:clobbers_declared_fn_step in
316 |     result
317 | 


--------------------------------------------------------------------------------
/lib/parser.ml:
--------------------------------------------------------------------------------
  1 | open Types
  2 | open Types.Located
  3 | open Scanner
  4 | open Printf
  5 | open Base
  6 | 
  7 | let binary_op_bp = function
  8 |     | PipeOp    -> (1, 2)
  9 |     | Or        -> (3, 4)
 10 |     | And       -> (5, 6)
 11 |     | EQ | NEQ | GEQ | LEQ  -> (7, 8)
 12 |     | LT | GT   -> (9, 10)
 13 |     | Add | Neg -> (11, 12)
 14 |     | Mul | Div | Mod -> (13, 14)
 15 |     | Head | Tail -> (15, 16)
 16 |     | Not -> assert false
 17 | 
 18 | let prefix_op_bp = 13
 19 | 
 20 | let rec complete_expr: expr t -> (token t) list -> int -> (expr t * (token t) list) = 
 21 |     fun lhs ls min_bp -> match (skip_newlines ls) with
 22 |     | ({data = Operator op; location})::xs ->
 23 |             let (l_bp, r_bp) = binary_op_bp op in
 24 |             if l_bp < min_bp then 
 25 |                 (lhs, ls)
 26 |             else 
 27 |                 let (rhs, rem) = parse xs r_bp in 
 28 |                 let complete = Binary {op = op; lhs = lhs; rhs = rhs} |> locate location in 
 29 |                 complete_expr complete rem min_bp
 30 |     | _ -> (lhs, ls)
 31 | 
 32 | and parse_prefix_expr op xs min_bp =
 33 |     let (rhs, rem) = parse xs min_bp in 
 34 |     let complete = Prefix {op = op; rhs = rhs} |> locate rhs.location in
 35 |     complete_expr complete rem min_bp
 36 | 
 37 | and parse_paren_expr xs min_bp =
 38 |     let rec aux toks saw_comma acc = match toks with
 39 |         | {data = RParen; location}::rest -> acc, rest, saw_comma, location
 40 |         | _ -> 
 41 |             let nx, rest = parse toks 0 in
 42 |             let rest = skip_newlines rest in
 43 |             match rest with
 44 |                 | {data = Comma; _}::rest -> aux rest true (nx::acc)
 45 |                 | {data = RParen; location}::rest -> (nx::acc), rest, saw_comma, location
 46 |                 | {location; data}::_ ->
 47 |                     printf "Error parsing parenthesised expression at %s: Expected comma or newline, got %s \n" 
 48 |                         (location_to_string location)
 49 |                         (string_of_tok data);
 50 |                     assert false
 51 |                 | [] ->
 52 |                     printf "Error parsing parenthesised expression at end of file\n";
 53 |                     assert false
 54 |     in 
 55 |     let expr_list, rest, saw_comma, location = aux xs false [] in
 56 |     let locate = locate location in
 57 |     match expr_list, saw_comma with
 58 |         | _, true -> complete_expr (TupleExpr (List.rev expr_list) |> locate) rest min_bp
 59 |         | [], false -> complete_expr (TupleExpr [] |> locate) rest min_bp
 60 |         | [paren_expr], false -> complete_expr paren_expr rest min_bp
 61 |         | _, false -> assert false
 62 | 
 63 | 
 64 | and parse_list_expr xs min_bp =
 65 |     let rec parse_tail ls expr_list =
 66 |         let tail, more = parse ls 0 in
 67 |         match more with
 68 |             | {data = RBracket; location}::rest ->
 69 |                 let parsed_list = ListExpr((List.rev expr_list), Some tail) in
 70 |                 complete_expr (parsed_list |> locate location) rest min_bp
 71 |             | {location; _}::_ -> 
 72 |                 printf "Error parsing list expression at %s\n" (location_to_string location);
 73 |                 assert false
 74 |             | [] ->
 75 |                 printf "Error parsing list expression at end of file\n";
 76 |                 assert false
 77 | 
 78 |     and parse_range ls expr_list =
 79 |         let (end_, rest) = parse ls 0 in
 80 |         match expr_list, rest with
 81 |             | [snd; fst], {data = RBracket; location}::rest ->
 82 |                 let step = (Binary {lhs = snd; rhs = fst; op = Neg}) |> locate location in
 83 |                 let call =
 84 |                     LambdaCall {
 85 |                         callee = UnresolvedIdent "range_step"; 
 86 |                         call_args = TupleExpr [fst;end_;step] |> locate location
 87 |                     }
 88 |                 in
 89 |                 complete_expr (call |> locate location) rest min_bp
 90 |             | [start], {data = RBracket; location}::rest ->
 91 |                 let call =
 92 |                     LambdaCall {
 93 |                         callee = UnresolvedIdent "range"; 
 94 |                         call_args = TupleExpr [start;end_] |> locate location
 95 |                     }
 96 |                 in
 97 |                 complete_expr (call |> locate location) rest min_bp
 98 |             | _, {location; _}::_ ->
 99 |                 printf "Invalid range expression at %s\n" (location_to_string location);
100 |                 assert false
101 |             | _, [] ->
102 |                 printf "Invalid range expression at end of file\n";
103 |                 assert false
104 | 
105 |     and parse_filter_clause ls = 
106 |         let ls = skip_newlines ls in
107 |         match ls with
108 |         | {data = RBracket; _}::xs -> None, xs
109 |         | {data = If; _}::rest -> begin match parse rest 0 with
110 |             | e, {data = RBracket; _}::more ->
111 |                 Some e, more
112 |             | _, {location; _}::_ ->
113 |                 printf "Invalid filter clause in list comprehension at %s\n" (location_to_string location);
114 |                 assert false
115 |             | _, [] ->
116 |                 printf "Invalid filter clause in list comprehension at end of file\n";
117 |                 assert false
118 |         end
119 |         | {location; _}::_ ->
120 |             printf "Invalid list comprehension at %s\n" (location_to_string location);
121 |             Caml.exit 0
122 |         | [] ->
123 |             printf "Invalid list comprehension at end of file\n";
124 |             Caml.exit 0
125 | 
126 |     and parse_listcomp ls expr_list =
127 |         let arg_pat, rest = parse_pat ls in
128 |         let arg_pat = TuplePat [arg_pat] in
129 |         let rest = skip_newlines rest in
130 |         match expr_list, rest with
131 |             | [map_expr], {data = In; location}::rest ->
132 |                 let ls_expr, rest = parse rest 0 in
133 |                 let map_fn = LambdaDef {lambda_def_expr = map_expr; lambda_def_args = arg_pat} in
134 |                 let filter_expr, more = parse_filter_clause rest in
135 |                 let locate = locate location in
136 |                 begin match filter_expr with
137 |                     | Some e ->
138 |                         let filter_fn = LambdaDef {lambda_def_expr = e; lambda_def_args = arg_pat} in
139 |                         let filter_args = TupleExpr [filter_fn |> locate; ls_expr] in
140 |                         let filtered_ls = LambdaCall {
141 |                             callee = UnresolvedIdent "filter_rev"; 
142 |                             call_args = filter_args |> locate
143 |                         } 
144 |                         in
145 |                         let map_args = TupleExpr [map_fn |> locate; filtered_ls |> locate] in
146 |                         LambdaCall {
147 |                             callee = UnresolvedIdent "map_rev"; 
148 |                             call_args = map_args |> locate
149 |                         } |> locate, more
150 |                     | None ->
151 |                         let map_args = TupleExpr [map_fn |> locate; ls_expr] in
152 |                         LambdaCall {
153 |                             callee = UnresolvedIdent "map"; 
154 |                             call_args = map_args |> locate
155 |                         } |> locate, more
156 |                 end
157 |             | _, {location; _}::_ ->
158 |                 printf "Invalid list comprehension at %s\n" (location_to_string location);
159 |                 Caml.exit 0
160 |             | _ ->
161 |                 printf "Invalid list comprehension end of file\n";
162 |                 Caml.exit 0
163 | 
164 |     and aux toks acc = match toks with
165 |         | {data = RBracket; location}::rest -> 
166 |             let expr_list, tail = (acc, None) in
167 |             let parsed_list = ListExpr ((List.rev expr_list), tail) in
168 |             complete_expr (parsed_list |> locate location) rest min_bp
169 |         | _ -> let nx, rest = parse toks 0 in
170 |             let rest = skip_newlines rest in
171 |             match rest with
172 |                 | {data = Comma; _}::rest -> aux rest (nx::acc)
173 |                 | {data = RBracket; location}::rest -> 
174 |                     let expr_list, tail = (nx::acc, None) in
175 |                     let parsed_list = ListExpr ((List.rev expr_list), tail) in
176 |                     complete_expr (parsed_list |> locate location) rest min_bp
177 |                 | {data = Pipe; _}::rest -> parse_tail rest (nx::acc)
178 |                 | {data = DotDot; _}::rest -> parse_range rest (nx::acc)
179 |                 | {data = For; _}::rest -> parse_listcomp rest (nx::acc)
180 |                 | {location; _}::_ -> 
181 |                     printf "Invalid list expression at %s\n" (location_to_string location);
182 |                     Caml.exit 0
183 |                 | [] ->
184 |                     printf "Invalid list expression at end of file\n";
185 |                     Caml.exit 0
186 |     in 
187 |     aux xs []
188 | 
189 | and expr_bp ls min_bp = 
190 |     let ls = skip_newlines ls in
191 |     match ls with
192 |     | ({data = LParen; _}::xs) -> parse_paren_expr xs min_bp
193 |     | ({data = LBracket; _}::xs) -> parse_list_expr xs min_bp
194 |     | ({data = Number f; location})::xs -> complete_expr (Atomic (Number f) |> locate location) xs min_bp
195 |     | ({data = Integer i; location})::xs -> complete_expr (Atomic (Integer i) |> locate location) xs min_bp
196 |     | ({data = Ident n; location})::xs -> complete_expr (IdentExpr (UnresolvedIdent n) |> locate location) xs min_bp
197 |     | ({data = StringTok s; location})::xs -> complete_expr (Atomic (StringVal s) |> locate location) xs min_bp
198 |     | ({data = Operator op; _})::xs -> parse_prefix_expr op xs min_bp
199 |     | {data = True; location}::xs -> complete_expr (Atomic (Boolean true) |> locate location) xs min_bp
200 |     | {data = False; location}::xs -> complete_expr (Atomic (Boolean false) |> locate location) xs min_bp
201 |     | _ -> assert false
202 | 
203 | and complete_pat lhs ls in_list = match ls with
204 |     | {data = Pipe; _}::xs when not in_list ->
205 |         let rhs, rest = parse_pat xs in
206 |         OrPat (lhs, rhs), rest
207 |     | {data = As; _}::({data = Ident n; _})::xs ->
208 |         AsPat (lhs, n), xs
209 |     | {data = As; location}::_ ->
210 |         printf "Expected a name at %s\n" (location_to_string location);
211 |         assert false
212 |     | _ -> lhs, ls
213 | 
214 | and parse_pat ?in_list:(in_list=false) ls = match ls with
215 |     | {data = LParen; _}::xs ->
216 |             let rec aux toks acc = match toks with
217 |                 | {data = RParen; _}::rest -> (acc, rest)
218 |                 | _ ->  let (nx, rest) = parse_pat toks in
219 |                         match rest with
220 |                             | ({data = Comma; _}::rest) -> aux rest (nx::acc)
221 |                             | ({data = RParen; _}::rest) -> (nx::acc, rest)
222 |                             | ({data; _}::_) ->
223 |                                 Stdio.printf "Expected Comma or RParen in parsing of tuple pattern, got %s\n"
224 |                                     (string_of_tok data);
225 |                                 Caml.exit 0
226 |                             | [] -> 
227 |                                 Stdio.printf "Expected Comma or RParen in parsing of tuple pattern at end of file\n";
228 |                                 Caml.exit 0
229 |             in 
230 |             let (parsed, remaining) = aux xs [] 
231 |             in complete_pat (TuplePat (List.rev parsed)) remaining in_list
232 |     | {data = LBracket; _}::xs ->
233 |             let rec aux toks acc = match toks with
234 |                 | {data = RBracket; _}::rest -> (acc, None), rest
235 |                 | _ -> let (nx, rest) = parse_pat ~in_list:true toks in
236 |                     match rest with
237 |                         | {data = Comma; _}::rest -> aux rest (nx::acc)
238 |                         | {data = RBracket; _}::rest -> (nx::acc, None), rest
239 |                         | {data = Pipe; _}::rest ->
240 |                             let tail_pat, more = parse_pat rest in begin
241 |                                 match more with
242 |                                     | {data = RBracket; _}::rest -> (nx::acc, Some tail_pat), rest
243 |                                     | _ -> assert false
244 |                             end
245 |                         | _ -> assert false
246 |             in
247 |             let (pat_list, tail), rest = aux xs [] in
248 |             let parsed_list_pat = match tail with
249 |                 | None -> FullPat (List.rev pat_list)
250 |                 | Some tail_pat -> HeadTailPat (List.rev pat_list, tail_pat)
251 |             in
252 |             complete_pat (ListPat parsed_list_pat) rest in_list
253 |     | {data = Percent; _}::{data = LBrace; _}::xs ->
254 |         let parse_pair: (token t) list -> (expr t * pattern) * ((token t) list) = fun toks ->
255 |             let key, rest = parse toks 0 in
256 |             match rest with
257 |                 | {data = Comma | RBrace; _}::_ ->
258 |                     (* Field punning *)
259 |                     let key, val_pat = match key with
260 |                         | ({data = IdentExpr (UnresolvedIdent n); location}) -> 
261 |                             let key = UnresolvedAtom n |> locate location in
262 |                             let val_pat = SinglePat (UnresolvedIdent n) in
263 |                             key, val_pat
264 |                         | _ -> assert false
265 |                     in
266 |                     (key, val_pat), rest
267 |                 | {data = Colon; _}::more ->
268 |                     let val_pat, more = parse_pat more in
269 |                     let key = match key with
270 |                         | ({data = IdentExpr (UnresolvedIdent n); location}) -> UnresolvedAtom n |> locate location
271 |                         | _ -> assert false
272 |                     in
273 |                     (key, val_pat), more
274 |                 | {data = Arrow; _}::more ->
275 |                     let val_pat, more = parse_pat more in
276 |                     (key, val_pat), more
277 |                 | {data; location}::_ -> 
278 |                     printf "Expected a colon in map at %s, got %s\n" 
279 |                         (location_to_string location)
280 |                         (string_of_tok data);
281 |                     Caml.exit 0
282 |                 | [] ->
283 |                     printf "Expected a colon in map at end of file\n";
284 |                     Caml.exit 0
285 |         in
286 |         let rec aux toks acc = match (skip_newlines toks) with
287 |             | {data = RBrace; _}::rest -> acc, rest
288 |             | {data = Comma; _}::rest ->
289 |                 let pair, more = parse_pair rest in
290 |                 aux more (pair::acc)
291 |             | {data; location}::_ ->
292 |                 printf "Expected RBrace or Comma at %s, got %s"
293 |                     (location_to_string location)
294 |                     (string_of_tok data);
295 |                 Caml.exit 0
296 |             | _ -> assert false
297 |         in begin match xs with
298 |             | {data = RBrace; _}::rest -> complete_pat (MapPat []) rest in_list
299 |             | _ ->
300 |                 let first_pair, rest = parse_pair xs in
301 |                 let pair_ls, more = aux rest [first_pair] in
302 |                 complete_pat (MapPat (List.rev pair_ls)) more in_list
303 |         end
304 |     | {data = Percent; _}::_ -> 
305 |         printf "Expected LBrace\n";
306 |         assert false
307 |     | {data = Colon; _}::({data = Ident s; _})::xs -> complete_pat (UnresolvedAtomPat s) xs in_list
308 |     | ({data = Ident s; _})::xs -> complete_pat (SinglePat (UnresolvedIdent s)) xs in_list
309 |     | ({data = Number f; _})::xs -> complete_pat (NumberPat f) xs in_list
310 |     | ({data = Integer i; _})::xs -> complete_pat (IntegerPat i) xs in_list
311 |     | ({data = StringTok f; _})::xs -> complete_pat (StringPat f) xs in_list
312 |     | {data = Underscore; _}::xs -> complete_pat WildcardPat xs in_list
313 |     | {data; location}::_ ->
314 |             printf "Expected pattern at %s, got %s" (location_to_string location) (string_of_tok data);
315 |             Caml.exit 0
316 |     | [] ->
317 |             printf "Expected pattern at end of file";
318 |             Caml.exit 0
319 | 
320 | and parse_let ls =
321 |     let (pat, xs) = parse_pat ls in
322 |     match xs with
323 |         | {data = Equal; _}::xs ->
324 |                 let (rhs, rest) = parse xs 0 in
325 |                 let let_expr: expr = Let {assignee = pat; assigned_expr = rhs}
326 |                 in (let_expr, rest)
327 |         | {data = LParen; _}::_ -> begin match pat with
328 |             | SinglePat fn_name ->
329 |                 let (fn_args, xs) = parse_pat xs in begin
330 |                 match xs with
331 |                     | {data = Equal; _}::xs ->
332 |                         let (fn_expr, rest) = parse xs 0 in
333 |                         let def = FnDef {fn_name; fn_def_func = {fn_args; fn_expr = fn_expr}} in
334 |                         (def, rest)
335 |                     | _ -> assert false
336 |                 end
337 |             | _ -> assert false
338 |         end
339 |         | _ -> assert false
340 | 
341 | and parse_args toks =
342 |     match toks with
343 |     | {data = LParen; _}::xs ->
344 |             let rec aux toks acc = match toks with
345 |                 | {data = RParen; _}::rest -> (acc, rest)
346 |                 | _ -> 
347 |                     let nx, rest = match toks with
348 |                         | {data = Underscore; _}::rest ->
349 |                             BlankCaptureExprHole, rest
350 |                         | {data = Percent; _}::{data = Integer n; _}::rest ->
351 |                             LabeledCaptureExprHole n, rest
352 |                         | _ ->
353 |                             let (nx, rest) = parse toks 0 in
354 |                             CaptureExprArg nx, rest
355 |                     in
356 |                     let acc = nx::acc in
357 |                     let rest = skip_newlines rest in
358 |                     match rest with
359 |                         | {data = Comma; _}::rest -> aux rest acc
360 |                         | {data = RParen; _}::rest -> acc, rest
361 |                         | {data; location}::_ ->
362 |                             printf "Error: expected a ), got %s at %s"
363 |                                 (string_of_tok data)
364 |                                 (location_to_string location);
365 |                             Caml.exit 0
366 |                         | [] ->
367 |                             printf "Error: missing parentheses in argument list at end of file";
368 |                             Caml.exit 0
369 |             in
370 |             let (parsed, remaining) = aux xs []
371 |             in
372 |             (List.rev parsed, remaining)
373 |     | _ ->
374 |             printf "Error parsing args";
375 |             assert false
376 | 
377 | and parse_lambda = function
378 |     | {data = Fn; _}::xs -> 
379 |         begin
380 |             let (args, rest) = parse_pat xs in
381 |             match rest with
382 |                 | {data = Arrow; _}::xs ->
383 |                         let (lambda_expr, rest) = parse xs (-1) in
384 |                         let lambda = 
385 |                             LambdaDef {lambda_def_expr = lambda_expr; lambda_def_args = args} 
386 |                         in (lambda, rest)
387 |                 | {location; _}::_ ->
388 |                         printf "Expected an arrow at %s\n" (location_to_string location);
389 |                         Caml.exit 0
390 |                 | [] -> 
391 |                         printf "Expected an arrow at end of file\n";
392 |                         Caml.exit 0
393 |         end
394 |     | _ -> assert false
395 | 
396 | and parse_lambda_call = function
397 |     | ({data = Ident lambda_name; location})::xs -> 
398 |         begin match parse_args xs with
399 |             | args, rest when List.for_all args ~f:(function | CaptureExprArg _ -> true | _ -> false) ->
400 |                 let args = List.map args ~f:(function | CaptureExprArg e -> e | _ -> assert false) in
401 |                 let call_args = TupleExpr args |> locate location in
402 |                 (LambdaCall {callee = UnresolvedIdent lambda_name; call_args = call_args}, rest)
403 |             | args, rest ->
404 |                 LambdaCaptureExpr {capture_expr_fn = UnresolvedIdent lambda_name; capture_expr_args = args}, rest
405 |         end
406 |     | _ -> assert false
407 | 
408 | 
409 | and parse_if_expr = function
410 |     | {data = If; _}::{data = Let; _}::xs -> begin
411 |         let pat, xs = parse_pat xs in
412 |         let xs = match skip_newlines xs with
413 |             | {data = Equal; _}::xs -> skip_newlines xs
414 |             | _ -> assert false
415 |         in
416 |         let assigned_expr, xs = parse xs 0 in
417 |         match (skip_newlines xs) with
418 |             | {data = Then; _}::xs -> begin
419 |                 let (let_then_expr, xs) = parse xs 0 in
420 |                 match (skip_newlines xs) with
421 |                     | {data = Else; _}::xs ->
422 |                         let (let_else_expr, rest) = parse xs 0 in
423 |                         (IfLetExpr {pat; assigned_expr; let_then_expr; let_else_expr}), rest
424 |                     | _ -> assert false
425 |             end
426 |             | _ -> assert false
427 |     end
428 |     | {data = If; _}::xs -> begin
429 |         let (cond, xs) = parse xs 0 in
430 |         match skip_newlines xs with
431 |             | {data = Then; _}::xs -> begin
432 |                 let (then_expr, xs) = parse xs 0 in
433 |                 match (skip_newlines xs) with
434 |                     | {data = Else; _}::xs ->
435 |                         let (else_expr, rest) = parse xs 0 in
436 |                         (IfExpr {cond = cond; then_expr = then_expr; else_expr = else_expr}, rest)
437 |                     | _ -> 
438 |                         printf "Error parsing as else: ";
439 |                         assert false
440 |                 end
441 |             | {data; location}::_ ->
442 |                 printf "Error parsing if expression at %s: expected Then, got %s\n" 
443 |                     (location_to_string location)
444 |                     (string_of_tok data);
445 |                 Caml.exit 0
446 |             | [] ->
447 |                 printf "Error parsing if expression at end of file";
448 |                 Caml.exit 0
449 |     end
450 |     | _ -> assert false
451 | 
452 | and parse_block_expr ls =
453 |     let rec aux ls acc = match skip_newlines ls with
454 |         | {data = RBrace; _}::rest -> (BlockExpr (List.rev acc), rest)
455 |         | rest ->
456 |                 let (next_expr, rest) = parse rest 0 in
457 |                 aux rest (next_expr::acc)
458 |     in aux ls []
459 | 
460 | and parse_map = function
461 |     | {data = LBrace; _}::rest ->
462 |         let rest = skip_newlines rest in
463 |         let parse_key_val ls =
464 |             let ls = skip_newlines ls in
465 |             let key_expr, xs = parse ls 0 in
466 |             let xs = skip_newlines xs in
467 |             match xs with
468 |                 | {data = Colon; _}::xs ->
469 |                     let xs = skip_newlines xs in
470 |                     let key = match key_expr with
471 |                         | {data = IdentExpr (UnresolvedIdent n); _} -> UnresolvedAtom n
472 |                         | _ ->
473 |                             printf "Only use colon in maps with atom keys";
474 |                             assert false
475 |                     in
476 |                     let (val_expr, more) = parse xs 0 in
477 |                     (key, val_expr, more)
478 |                 | {data = Arrow; _}::xs ->
479 |                     let xs = skip_newlines xs in
480 |                     let (val_expr, more) = parse xs 0 in
481 |                     (key_expr.data, val_expr, more)
482 |                 | _ ->
483 |                     printf "Expected comma";
484 |                     assert false
485 |         in
486 |         let rec aux ls acc = match (skip_newlines ls) with
487 |             | {data = RBrace; _}::more -> ((acc, None), more)
488 |             | {data = Comma; _}::xs ->
489 |                 let xs = skip_newlines xs in
490 |                 let (key_expr, val_expr, rest) = parse_key_val xs in
491 |                 let rest = skip_newlines rest in
492 |                 aux rest ((key_expr, val_expr)::acc)
493 |             | {data = Pipe; _}::xs ->
494 |                 let xs = skip_newlines xs in
495 |                 let tail, rest = parse xs 0 in
496 |                 let rest = skip_newlines rest in begin
497 |                 match rest with
498 |                     | {data = RBrace; _}::more -> ((acc, Some tail), more)
499 |                     | _ ->
500 |                         printf "Invalid map expression\n";
501 |                         assert false
502 |                 end
503 |             | {data; location}::_ -> 
504 |                 printf "Expected Pipe, Comma, or RBrace at %s, got %s" 
505 |                     (location_to_string location) 
506 |                     (string_of_tok data);
507 |                 Caml.exit 0
508 |             | [] -> 
509 |                 printf "Expected Pipe, Comma, or RBrace at end of file" ;
510 |                 Caml.exit 0
511 |         in begin match rest with
512 |             | {data = RBrace; _}::xs ->
513 |                 (MapExpr ([], None), xs)
514 |             | _ ->
515 |                 let k0, v0, rest = parse_key_val rest in
516 |                 let rest = skip_newlines rest in
517 |                 let (res, tail), more = aux rest [(k0, v0)] in
518 |                 let res = List.map ~f:(fun (a, b) -> a |> locate b.location, b) res in
519 |                 (MapExpr (List.rev res, tail), more)
520 |         end
521 | 
522 |     | _ ->
523 |         printf "Expected LBrace\n";
524 |         assert false
525 | 
526 | and parse_match_expr ls loc =
527 |     let (match_val, rest) = parse ls 0 in
528 |     let rest = skip_newlines rest in
529 |     let rec parse_match_arms toks acc =
530 |         let toks = skip_newlines toks in
531 |         match toks with
532 |         | {data = Pipe; _}::xs ->
533 |             let arm_pat, rest = parse_pat xs in begin
534 |             let cond, rest = match rest with
535 |                 | {data = MatchArrow; _}::_ -> None, rest
536 |                 | {data = When; _}::rest ->
537 |                         let cond, rest = parse rest 0 in
538 |                         Some cond, rest
539 |                 | _ ->
540 |                     printf "Expected When or MatchArrow";
541 |                     assert false
542 |             in
543 |             match rest with
544 |                 | {data = MatchArrow; _}::rest ->
545 |                     let rest = skip_newlines rest in
546 |                     let arm_expr, rest = parse rest 0 in begin
547 |                         match rest with
548 |                             | {data = Newline; _}::xs -> 
549 |                                 parse_match_arms xs ((arm_pat, arm_expr, cond)::acc)
550 |                             | {data = Pipe; _}::_ -> 
551 |                                 printf "Must break line after each match arm\n";
552 |                                 assert false
553 |                             | _ ->
554 |                                 printf "Error parsing expression in match arm\n";
555 |                                 assert false
556 |                     end
557 |                 | _ ->
558 |                     printf "Expected an arrow\n";
559 |                     assert false
560 |             end
561 |         | more -> List.rev acc, more
562 |     in
563 |     let (match_arms, rest) = parse_match_arms rest [] in
564 |     if (not (phys_equal match_arms [])) then
565 |         MatchExpr {match_val = match_val; match_arms = match_arms}, rest
566 |     else begin
567 |         printf "No match arms in match expression at %s\n" (location_to_string loc);
568 |         Caml.exit 0
569 |     end
570 | 
571 | and parse: (token Located.t) list -> int -> (expr Located.t) * ((token Located.t) list) = fun s min_bp ->
572 |     let s = skip_newlines s in
573 |     match s with
574 |         | {data = LBrace; location}::xs -> 
575 |             let (block, xs) = parse_block_expr xs in
576 |             complete_expr (block |> locate location) xs min_bp
577 |         | {data = Percent; location}::xs -> 
578 |             let (map, xs) = parse_map xs in
579 |             complete_expr (map |> locate location) xs min_bp
580 |         | {data = Colon; location}::({data = Ident n; _})::xs -> 
581 |             complete_expr ((UnresolvedAtom n) |> locate location) xs min_bp
582 |         | ({data = Ident _; location})::{data = LParen; _}::_ -> 
583 |             let (call, xs) = parse_lambda_call s in
584 |             complete_expr (call |> locate location) xs min_bp
585 |         | {data = LParen; _}::_ -> expr_bp s 0
586 |         | {data = LBracket; _}::_ -> expr_bp s 0
587 |         | ({data = Operator _; _})::_ -> expr_bp s 0
588 |         | {data = (True|False|Number _|Integer _| Ident _| StringTok _); _}::_ -> expr_bp s min_bp
589 |         | {data = Let; location}::xs -> 
590 |             let l, remaining = parse_let xs in
591 |             l |> locate location, remaining
592 |         | {data = Fn; location}::_ -> 
593 |             let (lambda_parsed, xs) = parse_lambda s in
594 |             complete_expr (lambda_parsed |> locate location) xs min_bp
595 |         | {data = If; location}::_ -> 
596 |             let (if_parsed, xs) = parse_if_expr s in
597 |             complete_expr (if_parsed |> locate location) xs min_bp
598 |         | {data = Match; location}::xs -> 
599 |             let (match_parsed, xs) = parse_match_expr xs location in
600 |             complete_expr (match_parsed |> locate location) xs min_bp
601 |         | {location; data = Pipe}::_ -> 
602 |             printf "Expected expression at %s, got %s. Did you forget a %%?\n" 
603 |                 (location_to_string location) (string_of_tok Pipe);
604 |             Caml.exit 0
605 |         | {location; data}::_ -> 
606 |             printf "Expected expression at %s, got %s\n" (location_to_string location) (string_of_tok data);
607 |             Caml.exit 0
608 |         | [] -> 
609 |             printf "Expected expression at end of file\n";
610 |             assert false
611 | 
612 | let parse_str s filename = parse (Scanner.scan s ~filename:filename) 0
613 | 


--------------------------------------------------------------------------------
/lib/eval.ml:
--------------------------------------------------------------------------------
  1 | open Types
  2 | open Stdio
  3 | open Base
  4 | open Operators
  5 | 
  6 | (* Throughout, static state is abbreviated as ss *)
  7 | 
  8 | let rec bind: pattern -> value -> static_state -> location -> state -> state = fun lhs rhs ss loc ->
  9 |     let bind lhs rhs = bind lhs rhs ss loc in
 10 |     let pattern_matches lhs rhs = pattern_matches lhs rhs ss loc in
 11 |     (* printf "Binding %s to %s\n" (string_of_pat lhs) (string_of_val rhs); *)
 12 |     match lhs, rhs with
 13 |     | SinglePat (UnresolvedIdent s), _ -> fun _ ->
 14 |             printf "Error: found unresolved SinglePat %s at %s\n" s (location_to_string loc);
 15 |             print_traceback ss;
 16 |             Caml.exit 0;
 17 |     | SinglePat (ResolvedIdent i), _ -> fun state ->
 18 |             Map.set state ~key:i ~data:rhs
 19 |     | NumberPat lhs, Number rhs when Float.equal lhs rhs -> 
 20 |             fun state -> state
 21 |     | IntegerPat lhs, Integer rhs when Int.equal lhs rhs -> 
 22 |             fun state -> state
 23 |     | StringPat lhs, StringVal rhs when String.equal (escape_string lhs) (escape_string rhs) ->
 24 |             fun state -> state
 25 |     | AtomPat lhs, Atom rhs when Int.equal lhs rhs ->
 26 |             fun state -> state
 27 |     | OrPat (l, r), _ -> fun state ->
 28 |             if (pattern_matches l rhs state) then (bind l rhs) state else (bind r rhs) state
 29 |     | AsPat (pat, n), _ -> fun state ->
 30 |             let ident_id = List.Assoc.find_exn ss.static_idents ~equal:String.equal n in
 31 |             let state = bind (SinglePat (ResolvedIdent ident_id)) rhs state in
 32 |             bind pat rhs state
 33 |     | ((TuplePat lhs_ls) as lhs, ((Tuple rhs_ls) as rhs))|
 34 |       ((ListPat (FullPat lhs_ls)) as lhs, ((ValList rhs_ls) as rhs)) -> begin
 35 |           match List.zip lhs_ls rhs_ls with
 36 |             | Ok zipped ->
 37 |                 fun state -> List.fold_left ~init:state ~f:(fun state (k, v) -> (bind k v) state) zipped
 38 |             | _ ->
 39 |                 printf "\n";
 40 |                 printf "Error at %s, Tried to bind %s of len %d to %s of len %d\n"
 41 |                     (location_to_string loc)
 42 |                     (string_of_pat ss lhs) (List.length lhs_ls)
 43 |                     (string_of_val ss rhs) (List.length rhs_ls);
 44 |                 print_traceback ss;
 45 |                 Caml.exit 0
 46 |       end
 47 |     | (ListPat (HeadTailPat (head_pat_ls, tail_pat))), ValList rhs_ls -> fun s ->
 48 |             let (head_ls, tail_ls) = List.split_n rhs_ls (List.length head_pat_ls) in
 49 |             let s = (bind (ListPat (FullPat head_pat_ls)) (ValList head_ls)) s in
 50 |             let s = (bind tail_pat (ValList tail_ls)) s in
 51 |             s
 52 |     | MapPat kv_pairs, Dictionary rhs -> fun s ->
 53 |         let fetched_pairs = kv_pairs
 54 |             |> List.map ~f:(fun (k, v) -> let ev_k, _ = (eval_expr k ss) s in ev_k, v)
 55 |             |> List.map ~f:(fun (k, v) -> dict_get rhs k ss loc, v)
 56 |         in
 57 |         let fold_step state (k, v) = (bind v k) state in
 58 |         List.fold_left ~init:s ~f:fold_step fetched_pairs
 59 |     | WildcardPat, _ -> fun state -> state
 60 |     | _ -> 
 61 |         printf "Error at %s, Tried to bind %s to %s\n"
 62 |             (location_to_string loc)
 63 |             (string_of_pat ss lhs)
 64 |             (string_of_val ss rhs);
 65 |         print_traceback ss;
 66 |         Caml.exit 0
 67 | 
 68 | and dict_get dict key ss loc =
 69 |     (* Can probably be replaced by Base.Option functions *)
 70 |     match Map.find dict (hash_value key) with
 71 |         | Some found_values ->
 72 |             let res = List.Assoc.find found_values ~equal:(fun a b -> val_eq_bool a b ss loc) key in
 73 |             Option.value ~default:(Tuple []) res
 74 |         | _ -> Tuple []
 75 | 
 76 | and list_equal_len lhs rhs = match lhs, rhs with
 77 |     | [], [] -> true
 78 |     | [], _ | _, [] -> false
 79 |     | _::xs, _::ys -> list_equal_len xs ys
 80 | 
 81 | and pattern_matches: pattern -> value -> static_state -> location -> state -> bool = fun pat value ss loc state ->
 82 |     let pattern_matches pat value = pattern_matches pat value ss loc in
 83 |     let eval_expr expr ?tc:(tc=false) = eval_expr expr ss ~tc:tc in
 84 |     match pat, value with
 85 |         | WildcardPat, _ -> true
 86 |         | SinglePat _, _ -> true
 87 |         | AsPat (pat, _), _ -> pattern_matches pat value state
 88 |         | OrPat (lhs, rhs), value -> (pattern_matches lhs value state) || (pattern_matches rhs value state)
 89 |         | NumberPat lhs, Number rhs -> Float.equal lhs rhs
 90 |         | IntegerPat lhs, Integer rhs -> Int.equal lhs rhs
 91 |         | StringPat lhs, StringVal rhs -> String.equal (escape_string lhs) (escape_string rhs)
 92 |         | AtomPat lhs, Atom rhs -> Int.equal lhs rhs
 93 |         | ((TuplePat lhs_ls), (Tuple rhs_ls))|(ListPat (FullPat lhs_ls), ValList rhs_ls) ->
 94 |             if list_equal_len lhs_ls rhs_ls then
 95 |                 let zipped = List.zip_exn lhs_ls rhs_ls in
 96 |                 List.for_all ~f:(fun (p, v) -> pattern_matches p v state) zipped
 97 |             else false
 98 |         | (ListPat (HeadTailPat (head_pat_ls, tail_pat)), ValList rhs_ls) ->
 99 |             let (head_ls, tail_ls) = List.split_n rhs_ls (List.length head_pat_ls) in
100 |             let head_matches = pattern_matches (ListPat (FullPat head_pat_ls)) (ValList head_ls) state in
101 |             let tail_matches = pattern_matches tail_pat (ValList tail_ls) state in
102 |             head_matches && tail_matches
103 |         | (MapPat kv_pairs, Dictionary rhs) ->
104 |             let fetched_pairs = kv_pairs
105 |                 |> List.map ~f:(fun (k, v) -> let ev_k, _ = (eval_expr k) state in ev_k, v)
106 |                 |> List.map ~f:(fun (k, v) -> dict_get rhs k ss loc, v)
107 |             in
108 |             List.for_all ~f:(fun (k, v) -> pattern_matches v k state) fetched_pairs
109 |         | _ -> false
110 | 
111 | and inspect_builtin (args, state) ss =
112 |     match args with
113 |         | Tuple [v] ->
114 |             printf "%s\n" (string_of_val ss v);
115 |             Stdio.Out_channel.flush Stdio.stdout;
116 |             v, state
117 |         | _ ->
118 |             printf "Expected only one argument to inspect";
119 |             assert false
120 | 
121 | and print_builtin (args, state) ss loc =
122 |     match args with
123 |         | Tuple [StringVal s] ->
124 |             s |> escape_string |> printf "%s";
125 |             Stdio.Out_channel.flush Stdio.stdout;
126 |             (Tuple [], state)
127 |         | _ ->
128 |             printf "Expected one string argument to print at %s\n" (location_to_string loc);
129 |             print_traceback ss;
130 |             Caml.exit 0
131 | 
132 | (* Better as a builtin since concatenating strings is expensive *)
133 | and println_builtin (args, state) ss loc =
134 |     match args with
135 |         | Tuple [StringVal s] ->
136 |             s |> escape_string |> printf "%s\n";
137 |             Stdio.Out_channel.flush Stdio.stdout;
138 |             (Tuple [], state)
139 |         | _ ->
140 |             printf "Expected one string argument to println at %s\n" (location_to_string loc);
141 |             print_traceback ss;
142 |             Caml.exit 0
143 | 
144 | and to_string_builtin (args, state) ss loc =
145 |     match args with
146 |         | Tuple [v] ->
147 |             (StringVal (string_of_val ss v)), state
148 |         | _ ->
149 |             printf "Expected only one argument to to_string at %s\n" (location_to_string loc);
150 |             print_traceback ss;
151 |             Caml.exit 0
152 | 
153 | and string_to_num_builtin (args, state) ss loc = 
154 |     match args with
155 |         | Tuple [StringVal s] -> begin
156 |             try
157 |                 Tuple [Atom 0; Number (Float.of_string s)], state
158 |             with
159 |                 | _ -> Atom 1, state
160 |         end
161 |         | _ ->
162 |             printf "Expected one string argument to string_to_num at %s\n" (location_to_string loc);
163 |             print_traceback ss;
164 |             Caml.exit 0
165 | 
166 | and string_to_int_builtin (args, state) ss loc = 
167 |     match args with
168 |         | Tuple [StringVal s] -> begin
169 |             try
170 |                 Tuple [Atom 0; Integer (Int.of_string s)], state
171 |             with
172 |                 | _ -> Atom 1, state
173 |         end
174 |         | _ ->
175 |             printf "Expected one string argument to string_to_num at %s\n" (location_to_string loc);
176 |             print_traceback ss;
177 |             Caml.exit 0
178 | 
179 | and scanln_builtin (args, state) ss loc =
180 |     match args with
181 |         | Tuple [] -> begin
182 |             match Stdio.In_channel.input_line ~fix_win_eol:true Stdio.stdin with
183 |             | Some line -> (StringVal line), state
184 |             | None -> Tuple [], state
185 |         end
186 |         | _ ->
187 |             printf "Expected () as an argument to scan_line at %s\n" (location_to_string loc);
188 |             print_traceback ss;
189 |             Caml.exit 0
190 | 
191 | and range_builtin (args, state) ss loc =
192 |     match args with
193 |         | Tuple [Integer start; Integer end_; Integer step] ->
194 |             let caml_ls = List.range start end_ ~stride:step in
195 |             let val_ls = List.map ~f:(fun n -> Integer n) caml_ls in
196 |             ValList val_ls, state
197 |         | _ ->
198 |             printf "Expected three integer arguments to range_step at %s, got %s\n" 
199 |                 (location_to_string loc)
200 |                 (string_of_val ss args);
201 |             print_traceback ss;
202 |             Caml.exit 0
203 | 
204 | and fold_builtin (args, state) ss loc =
205 |     match args with
206 |         | Tuple [init; Lambda fn; ValList ls] ->
207 |             let call_fn = fun args ->
208 |                 let lambda_call = Thunk {thunk_fn = fn; thunk_args= args; thunk_fn_name = ResolvedIdent 0} in
209 |                 let res, _ = unwrap_thunk lambda_call state ss loc in
210 |                 res
211 |             in
212 |             let fold_result = 
213 |                 List.fold 
214 |                 ~init:init
215 |                 ~f:(fun acc v -> call_fn (Tuple [acc; v]))
216 |                 ls
217 |             in
218 |             fold_result, state
219 |         | Tuple [init; Fn fn; ValList ls] ->
220 |             let call_fn = fun args ->
221 |                 let block_funcs = List.Assoc.map ss.static_block_funcs ~f:(fun f -> Fn f) in
222 |                 let enclosed_state = Map.of_alist_reduce (module Int) block_funcs ~f:(fun a _ -> a) in
223 |                 let pseudo_lambda = {lambda_expr = fn.fn_expr; lambda_args = fn.fn_args; enclosed_state } in
224 |                 let lambda_call = Thunk {thunk_fn = pseudo_lambda; thunk_args= args; thunk_fn_name = ResolvedIdent 0} in
225 |                 let res, _ = unwrap_thunk lambda_call state ss loc in
226 |                 res
227 |             in
228 |             let fold_result = 
229 |                 List.fold 
230 |                 ~init:init
231 |                 ~f:(fun acc v -> call_fn (Tuple [acc; v]))
232 |                 ls
233 |             in
234 |             fold_result, state
235 |         | _ ->
236 |             printf "Expected (init, fn, ls) as arguments to fold at %s, got %s\n" 
237 |                 (location_to_string loc)
238 |                 (string_of_val ss args);
239 |             print_traceback ss;
240 |             Caml.exit 0
241 | 
242 | and to_charlist_builtin (args, state) _ss =
243 |     match args with
244 |         | Tuple [StringVal s] ->
245 |             let chars = String.to_list s in
246 |             let char_strs = List.map ~f:String.of_char chars in
247 |             let val_ls = List.map ~f:(fun c -> StringVal c) char_strs in
248 |             ValList val_ls, state
249 |         | _ ->
250 |             printf "Expected a single string argument to to_charlist";
251 |             assert false
252 | 
253 | and get_builtin (args, state) ss loc = 
254 |     match args with
255 |         | Tuple [Dictionary m; key] -> begin
256 |             match Map.find m (hash_value key) with
257 |                 | Some found_values -> 
258 |                     let res = 
259 |                         List.Assoc.find found_values ~equal:(fun a b -> val_eq_bool a b ss loc) key 
260 |                     in
261 |                     let v = Option.value ~default:(Tuple []) res in
262 |                     v, state
263 |                 | None -> (Tuple [], state)
264 |             end
265 |         | _ ->
266 |             printf "get requires two arguments, a list, and a value";
267 |             assert false
268 | 
269 | and read_file_builtin (args, state) _ss _loc =
270 |     match args with
271 |         | Tuple [StringVal filename] -> begin
272 |             try
273 |                 let in_stream = In_channel.create filename in
274 |                 let file_string = In_channel.input_all in_stream in
275 |                 In_channel.close in_stream;
276 |                 StringVal file_string, state
277 |             with Sys_error err_str ->
278 |                 Tuple [Atom 1; StringVal err_str], state
279 |         end
280 |         | _ -> assert false
281 | 
282 | and write_file_builtin (args, state) ss loc =
283 |     match args with
284 |         | Tuple [StringVal filename; StringVal data] -> begin
285 |             try
286 |                 let out_stream = Out_channel.create filename in
287 |                 Out_channel.output_string out_stream (escape_string data);
288 |                 Out_channel.close out_stream;
289 |                 Tuple [], state
290 |             with Sys_error err_str ->
291 |                 printf "Error at %s: %s\n" (location_to_string loc) err_str;
292 |                 print_traceback ss;
293 |                 Caml.exit 0
294 |         end
295 |         | _ -> assert false
296 | 
297 | and list_dir_builtin (args, state) ss loc =
298 |     match args with
299 |         | Tuple [StringVal dirname] -> begin
300 |             try
301 |                 let filenames = Caml.Sys.readdir dirname
302 |                     |> Array.to_list
303 |                     |> List.map ~f:(fun n -> StringVal n)
304 |                 in
305 |                 ValList filenames, state
306 |             with Sys_error err_str ->
307 |                 printf "Error at %s: %s\n" (location_to_string loc) err_str;
308 |                 print_traceback ss;
309 |                 Caml.exit 0
310 |         end
311 |         | _ -> assert false
312 | 
313 | and mkdir_builtin (args, state) _ss _loc =
314 |     match args with
315 |         | Tuple [StringVal dirname] -> begin
316 |             try
317 |                 match Caml.Sys.command (Printf.sprintf "mkdir %s" dirname) with
318 |                     | 0 -> Atom 0, state
319 |                     | _ -> Tuple [Atom 1; StringVal "Nonzero exit code"], state
320 |             with Sys_error err_str ->
321 |                 Tuple [Atom 1; StringVal err_str], state
322 |         end
323 |         | _ -> assert false
324 | 
325 | and map_keys_builtin (args, state) _ss _loc =
326 |     match args with
327 |         | Tuple [Dictionary dict] ->
328 |             let keys = dict 
329 |                 |> Map.data 
330 |                 |> List.map ~f:(fun assoc_list -> List.map ~f:(fun (k, _) -> k) assoc_list)
331 |                 |> List.concat_no_order
332 |             in
333 |             ValList keys, state
334 |         | _ -> assert false
335 | 
336 | and map_to_list_builtin (args, state) _ss _loc =
337 |     match args with
338 |         | Tuple [Dictionary dict] ->
339 |             let ls = dict 
340 |                 |> Map.data 
341 |                 |> List.concat
342 |                 |> List.rev
343 |                 |> List.map ~f:(fun (k, v) -> Tuple [k; v])
344 |             in
345 |             ValList ls, state
346 |         | _ -> assert false
347 | 
348 | and typeof_builtin (args, state) _ss _loc =
349 |     match args with
350 |         | Tuple [Number _] -> Atom 2, state
351 |         | Tuple [Integer _] -> Atom 3, state
352 |         | Tuple [Boolean _] -> Atom 4, state
353 |         | Tuple [Tuple _] -> Atom 5, state
354 |         | Tuple [ValList _] -> Atom 6, state
355 |         | Tuple [(Lambda _) | (LambdaCapture _) | (Fn _)] -> Atom 7, state
356 |         | Tuple [Dictionary _] -> Atom 8, state
357 |         | Tuple [Atom _] -> Atom 9, state
358 |         | Tuple [StringVal _] -> Atom 10, state
359 |         | _ -> assert false
360 | 
361 | and serve_builtin (args, interpreter_state) ss loc =
362 |     match args with
363 |         | Tuple [Integer port; Lambda lambda; server_state] ->
364 |             let open Lwt in
365 |             let open Cohttp in
366 |             let open Cohttp_lwt_unix in
367 |             
368 |             let server_ref = ref server_state in
369 | 
370 |             let callback _conn req body =
371 |             let uri = req |> Request.uri |> Uri.to_string in
372 |             let meth = req |> Request.meth |> Code.string_of_method in
373 |             let headers = req |> Request.headers |> Header.to_string in
374 |             ( body |> Cohttp_lwt.Body.to_string >|= fun body -> body )
375 |             >>= fun body -> 
376 |                     let args = Tuple [StringVal uri; StringVal meth; StringVal headers; StringVal body; !server_ref] in
377 |                     let thunk = Thunk {thunk_fn = lambda; thunk_args = args; thunk_fn_name = ResolvedIdent ~-1} in
378 |                     let res, headers, status = match unwrap_thunk thunk interpreter_state ss loc with
379 |                         | Tuple [StringVal s; server_state; Dictionary headers; Integer status], _ -> 
380 |                             server_ref := server_state;
381 |                             let header_pairs = List.concat (Map.data headers) in
382 |                             let header_pairs = List.map header_pairs ~f:(fun (k, v) -> match k, v with
383 |                                 | StringVal k, StringVal v -> k, v
384 |                                 | _ -> assert false
385 |                             )
386 |                             in
387 |                             let headers = Header.add_list (Header.init ()) header_pairs in
388 |                             s, headers, `Code status
389 |                         | StringVal s, _ -> 
390 |                             s, Header.init (), `OK
391 |                         | _ -> assert false
392 |                     in
393 |                     Server.respond_string ~status ~headers ~body:res ()
394 |             in
395 |             Server.create ~mode:(`TCP (`Port port)) (Server.make ~callback ())
396 |         | _ ->
397 |             assert false
398 | 
399 | and serve_ssl_builtin (args, interpreter_state) ss loc =
400 |     match args with
401 |         | Tuple [StringVal cert_path; StringVal key_path; Integer port; Lambda lambda; server_state] ->
402 |             let open Lwt in
403 |             let open Cohttp in
404 |             let open Cohttp_lwt_unix in
405 | 
406 |             let server_ref = ref server_state in
407 | 
408 |             let callback _conn req body =
409 |             let uri = req |> Request.uri |> Uri.to_string in
410 |             let meth = req |> Request.meth |> Code.string_of_method in
411 |             let headers = req |> Request.headers |> Header.to_string in
412 |             ( body |> Cohttp_lwt.Body.to_string >|= fun body -> body )
413 |             >>= fun body -> 
414 |                     let args = Tuple [StringVal uri; StringVal meth; StringVal headers; StringVal body; !server_ref] in
415 |                     let thunk = Thunk {thunk_fn = lambda; thunk_args = args; thunk_fn_name = ResolvedIdent ~-1} in
416 |                     let res = match unwrap_thunk thunk interpreter_state ss loc with
417 |                         | Tuple [StringVal s; server_state], _ ->
418 |                             server_ref := server_state;
419 |                             s
420 |                         | StringVal s, _ -> 
421 |                             s
422 |                         | _ -> assert false
423 |                     in
424 |                     Server.respond_string ~status:`OK ~body:res ()
425 |             in
426 |             let tls_config = `Crt_file_path cert_path, `Key_file_path key_path, `No_password, `Port port in
427 |             Server.create ~mode:(`TLS tls_config) (Server.make ~callback ())
428 |         | _ ->
429 |             assert false
430 | 
431 | and crypto_hash_builtin (args, state) _ss _loc =
432 |     match args with
433 |         | Tuple [StringVal s] -> StringVal (Bcrypt.string_of_hash (Bcrypt.hash s)), state
434 |         | _ -> assert false
435 | 
436 | and validate_pass_builtin (args, state) _ss _loc =
437 |     match args with
438 |         | Tuple [StringVal a; StringVal b] -> Boolean (Bcrypt.verify a (Bcrypt.hash_of_string b)), state
439 |         | _ -> assert false
440 | 
441 | and truncate_builtin (args, state) _ss _loc =
442 |     match args with
443 |         | Tuple [Number n] -> Integer (Int.of_float n), state
444 |         | _ -> assert false
445 | 
446 | and eval_pipe ~tc lhs rhs ss loc = fun s ->
447 |     let {Located.location = args_loc; _} = lhs in
448 |     let {Located.location = fn_loc; _} = rhs in
449 |     let (lhs, s) = (eval_expr lhs ss) s in
450 |     let (rhs, s) = (eval_expr rhs ss) s in
451 |     match rhs with
452 |     | Lambda _ | Fn _ | LambdaCapture _ | Dictionary _ ->
453 |         let call_args =
454 |             (TupleExpr ([Atomic lhs |> Located.locate args_loc])) |> Located.locate args_loc
455 |         in
456 |         let call =
457 |             {callee = ResolvedIdent ~-1; call_args}
458 |         in
459 |         eval_lambda ~tc:tc rhs call ss fn_loc s
460 |     | _ ->
461 |         printf "Tried to pipe to a non function %s at %s\n"
462 |             (string_of_val ss rhs)
463 |             (location_to_string loc);
464 |         Caml.exit 0
465 | 
466 | and eval_op op lhs rhs ss loc = fun s ->
467 |     let (lhs, s) = (eval_expr lhs ss) s in
468 |     let (rhs, s) = (eval_expr rhs ss) s in
469 |     op lhs rhs ss loc, s
470 |     
471 | and eval_prefix_op op rhs ss loc = fun s ->
472 |     let (rhs, s) = (eval_expr rhs ss) s in
473 |     op rhs ss loc, s
474 | 
475 | and eval_ident ss name loc = fun state ->
476 |     match Map.find state name with
477 |         | Some value -> value, state
478 |         | None ->
479 |             printf "Error at %s: variable not found: %s\n" 
480 |                 (location_to_string loc) 
481 |                 (name |> List.Assoc.find_exn (List.Assoc.inverse ss.static_idents) ~equal:Int.equal);
482 |             print_traceback ss;
483 |             Caml.exit 0
484 | 
485 | and eval_let lhs rhs ss loc = fun state ->
486 |     let (evaled, new_state) = (eval_expr rhs ss) state in
487 |     let new_state = (bind lhs evaled ss loc) new_state in
488 |     (Tuple [], new_state)
489 | 
490 | and eval_fn_def name {fn_expr; fn_args} ss loc = fun state ->
491 |     let fn = Fn {fn_expr; fn_args} in
492 |     let new_state = (bind (SinglePat name) fn ss loc) state in
493 |     (Tuple [], new_state)
494 | 
495 | and eval_lambda_def e args =
496 |     fun s -> (Lambda {lambda_expr = e; lambda_args = args; enclosed_state = s}), s
497 | 
498 | and eval_lambda_capture capture ss loc state =
499 |     let capture_callee_id = match capture.capture_expr_fn with
500 |         | UnresolvedIdent s ->
501 |             printf "Found unresolved ident %s at %s" s (location_to_string loc);
502 |             Caml.exit 0
503 |         | ResolvedIdent id -> id
504 |     in
505 |     let capture_val = match Map.find state capture_callee_id with
506 |         | None ->
507 |             begin match List.Assoc.find ss.static_block_funcs capture_callee_id ~equal:Int.equal with
508 |             | Some f -> Fn f
509 |             | None ->
510 |                 printf "Tried to make function capture out of nonexistent %s at %s\n"
511 |                     (List.Assoc.find_exn (List.Assoc.inverse ss.static_idents) ~equal:Int.equal capture_callee_id)
512 |                     (location_to_string loc);
513 |                 Caml.exit 0
514 |             end
515 |         | Some v -> v
516 |     in
517 |     let fold_step state arg = match arg with
518 |         | CaptureExprArg e ->
519 |             let evaled, state = (eval_expr e ss) state in
520 |             state, ValArg evaled
521 |         | BlankCaptureExprHole ->
522 |             state, BlankCaptureHole
523 |         | LabeledCaptureExprHole i ->
524 |             state, LabeledCaptureHole i
525 |     in
526 |     let state, capture_args = List.fold_map capture.capture_expr_args ~init:state ~f:fold_step in
527 |     let capture = LambdaCapture {capture_val; capture_args} in
528 |     (capture, state)
529 |                 
530 | and unwrap_thunk thunk state ss loc = match thunk with
531 |     | Thunk {thunk_fn; thunk_args; thunk_fn_name = ResolvedIdent thunk_fn_name_id} ->
532 |             let inner_state = (bind thunk_fn.lambda_args thunk_args ss loc) thunk_fn.enclosed_state in
533 |             let inner_state = Map.set inner_state ~key:thunk_fn_name_id ~data:(Lambda thunk_fn) in
534 |             let call_stack = match ss.call_stack with
535 |                 | ((id, loc), n)::xs when Int.equal id thunk_fn_name_id -> ((id, loc), n + 1)::xs
536 |                 | _ -> ((thunk_fn_name_id, loc), 1)::ss.call_stack
537 |             in
538 |             let ss = { ss with call_stack } in
539 |             let (new_thunk, _) = (eval_expr ~tc:true thunk_fn.lambda_expr ss) inner_state in
540 |             unwrap_thunk new_thunk state ss loc
541 |     | Thunk {thunk_fn_name = UnresolvedIdent n; _} ->
542 |             printf "Error: found unresolved ident %s at %s\n" n (location_to_string loc);
543 |             print_traceback ss;
544 |             Caml.exit 0
545 |     | value -> value, state
546 | 
547 | and eval_lambda ~tc lambda call ss loc state = match lambda with
548 |     | Lambda lambda_val ->
549 |         let (evaled, _) = (eval_expr call.call_args ss) state in
550 |         let thunk = Thunk {thunk_fn = lambda_val; thunk_args = evaled; thunk_fn_name = call.callee} in
551 |         if tc then 
552 |             (thunk, state)
553 |         else 
554 |             let res, _ = unwrap_thunk thunk state ss loc in
555 |             (res, state)
556 |     | Fn fn_val ->
557 |         let (evaled, _) = (eval_expr call.call_args ss) state in
558 |         let block_funcs = List.Assoc.map ss.static_block_funcs ~f:(fun f -> Fn f) in
559 |         let enclosed_state = Map.of_alist_reduce (module Int) block_funcs ~f:(fun a _ -> a) in
560 |         let pseudo_lambda = 
561 |             {lambda_expr = fn_val.fn_expr; lambda_args = fn_val.fn_args; enclosed_state }
562 |         in
563 |         let thunk = Thunk {thunk_fn = pseudo_lambda; thunk_args = evaled; thunk_fn_name = call.callee } in
564 |         if tc then
565 |             (thunk, state)
566 |         else
567 |             let res, _ = unwrap_thunk thunk state ss loc in
568 |             (res, state)
569 |     | LambdaCapture capture ->
570 |         let rec construct_arglist captured arglist call_args used_hole = match captured, call_args, used_hole with
571 |             | [], [], _ | [], _, (Some LabeledHole) | [], _::_, None -> 
572 |                 List.rev arglist
573 | 
574 |             | [], _, (Some BlankHole) -> 
575 |                 printf "Called captured fn with too many arguments at %s\n" (location_to_string loc);
576 |                 Caml.exit 0
577 | 
578 |             | BlankCaptureHole::_, [], ((Some BlankHole)|None) -> 
579 |                 printf "Called captured fn with too few arguments at %s\n" (location_to_string loc);
580 |                 Caml.exit 0
581 | 
582 |             | (ValArg v)::xs, _, _ -> 
583 |                 let arg = (Atomic v) |> Located.locate loc in
584 |                 construct_arglist xs (arg::arglist) call_args used_hole
585 | 
586 |             | BlankCaptureHole::xs, arg::call_args, ((Some BlankHole)|None) -> 
587 |                 construct_arglist xs (arg::arglist) call_args (Some BlankHole)
588 | 
589 |             | (LabeledCaptureHole i)::xs, _, ((Some LabeledHole)|None) ->
590 |                 construct_arglist xs ((List.nth_exn call_args i)::arglist) call_args (Some LabeledHole)
591 | 
592 |             | BlankCaptureHole::_, _, (Some LabeledHole) 
593 |             | (LabeledCaptureHole _)::_, _, (Some BlankHole) -> 
594 |                 printf "Tried to mix labeled and blank capture holes in call at %s\n"
595 |                     (location_to_string loc);
596 |                 Caml.exit 0
597 |         in
598 |         let call_args = match call.call_args.data with
599 |             | TupleExpr ls -> ls
600 |             | _ -> assert false
601 |         in
602 |         let arglist = construct_arglist capture.capture_args [] call_args None in
603 |         let call = {call with call_args = (TupleExpr arglist) |> Located.locate loc} in
604 |         let call_stack = match ss.call_stack with
605 |             | ((id, loc), n)::xs when Int.equal id ~-1 -> ((-1, loc), n + 1)::xs
606 |             | _ -> ((-1, loc), 1)::ss.call_stack
607 |         in
608 |         let ss = { ss with call_stack } in
609 |         eval_lambda ~tc:tc capture.capture_val call ss loc state
610 |     | Dictionary dict ->
611 |         let (evaled, state) = (eval_expr call.call_args ss) state in begin
612 |             match evaled with
613 |                 | Tuple [key] -> dict_get dict key ss loc, state
614 |                 | _ ->
615 |                     printf "Expected a single key\n";
616 |                     assert false
617 |         end
618 |     | _ -> assert false
619 | 
620 | and eval_lambda_call ?tc:(tail_call=false) call ss loc =
621 |     let callee_id = match call.callee with
622 |         | UnresolvedIdent n -> List.Assoc.find_exn ss.static_idents ~equal:String.equal n
623 |         | ResolvedIdent i -> i
624 |     in
625 |     fun (state: state) -> match Map.find state callee_id with
626 |         | Some((Lambda _ | Fn _ | LambdaCapture _ | Dictionary _) as l) ->
627 |             eval_lambda ~tc:tail_call l call ss loc state
628 |         | None -> begin
629 |             match call.callee with
630 |                 | ResolvedIdent 0 -> inspect_builtin ((eval_expr call.call_args ss) state) ss
631 |                 | ResolvedIdent 1 -> print_builtin ((eval_expr call.call_args ss) state) ss loc
632 |                 | ResolvedIdent 2 -> println_builtin ((eval_expr call.call_args ss) state) ss loc
633 |                 | ResolvedIdent 3 -> scanln_builtin ((eval_expr call.call_args ss) state) ss loc
634 |                 | ResolvedIdent 4 -> to_string_builtin ((eval_expr call.call_args ss) state) ss loc
635 |                 | ResolvedIdent 5 -> string_to_num_builtin ((eval_expr call.call_args ss) state) ss loc
636 |                 | ResolvedIdent 6 -> string_to_int_builtin ((eval_expr call.call_args ss) state) ss loc
637 |                 | ResolvedIdent 7 -> range_builtin ((eval_expr call.call_args ss) state) ss loc
638 |                 | ResolvedIdent 8 -> fold_builtin ((eval_expr call.call_args ss) state) ss loc
639 |                 | ResolvedIdent 9 -> to_charlist_builtin ((eval_expr call.call_args ss) state) ss
640 |                 | ResolvedIdent 10 -> get_builtin ((eval_expr call.call_args ss) state) ss loc
641 |                 | ResolvedIdent 11 -> read_file_builtin ((eval_expr call.call_args ss) state) ss loc
642 |                 | ResolvedIdent 12 -> write_file_builtin ((eval_expr call.call_args ss) state) ss loc
643 |                 | ResolvedIdent 13 -> list_dir_builtin ((eval_expr call.call_args ss) state) ss loc
644 |                 | ResolvedIdent 14 -> mkdir_builtin ((eval_expr call.call_args ss) state) ss loc
645 |                 | ResolvedIdent 15 -> map_keys_builtin ((eval_expr call.call_args ss) state) ss loc
646 |                 | ResolvedIdent 16 -> map_to_list_builtin ((eval_expr call.call_args ss) state) ss loc
647 |                 | ResolvedIdent 17 -> typeof_builtin ((eval_expr call.call_args ss) state) ss loc
648 |                 | ResolvedIdent 18 -> 
649 |                         Lwt_main.run (serve_builtin ((eval_expr call.call_args ss) state) ss loc);
650 |                         Tuple [], state
651 |                 | ResolvedIdent 19 -> 
652 |                         Lwt_main.run (serve_ssl_builtin ((eval_expr call.call_args ss) state) ss loc);
653 |                         Tuple [], state
654 |                 | ResolvedIdent 20 -> crypto_hash_builtin ((eval_expr call.call_args ss) state) ss loc
655 |                 | ResolvedIdent 21 -> validate_pass_builtin ((eval_expr call.call_args ss) state) ss loc
656 |                 | ResolvedIdent 22 -> truncate_builtin ((eval_expr call.call_args ss) state) ss loc
657 |                 | UnresolvedIdent s ->
658 |                     printf "Error: unresolved function %s not found at %s\n" s (location_to_string loc);
659 |                     print_traceback ss;
660 |                     Caml.exit 0
661 |                 | ResolvedIdent i ->
662 |                     let name = List.Assoc.find_exn (List.Assoc.inverse ss.static_idents) ~equal:Int.equal i in
663 |                     printf "Error: resolved function %s (id %d) not found at %s\n" name i (location_to_string loc);
664 |                     print_traceback ss;
665 |                     Caml.exit 0
666 |         end
667 |         | _ -> match call.callee with
668 |             | UnresolvedIdent s ->
669 |                 printf "Error: tried to call %s not found at %s\n" s (location_to_string loc);
670 |                 print_traceback ss;
671 |                 Caml.exit 0
672 |             | ResolvedIdent i ->
673 |                 let name = List.Assoc.find_exn (List.Assoc.inverse ss.static_idents) ~equal:Int.equal i in
674 |                 printf "Error: tried to call %s not found at %s\n" name (location_to_string loc);
675 |                 print_traceback ss;
676 |                 Caml.exit 0
677 | 
678 | and eval_tuple_expr ls ss state =
679 |     let (eval_ls, state) =
680 |         List.fold_left 
681 |             ~init:([], state) 
682 |             ~f:(fun (acc, s) e -> let (ev, s) = (eval_expr e ss) s in (ev::acc, s))
683 |             ls
684 |     in
685 |     Tuple (List.rev eval_ls), state
686 | 
687 | and eval_if_expr ?tc:(tail_call=false) if_expr ss = fun state ->
688 |     match (eval_expr if_expr.cond ss) state with
689 |         | Boolean true, state -> (eval_expr ~tc:tail_call if_expr.then_expr ss) state
690 |         | Boolean false, state -> 
691 |                 (eval_expr ~tc:tail_call if_expr.else_expr ss) state
692 |         | _ -> assert false
693 | 
694 | and eval_if_let_expr ?tc:(tail_call=false) if_let_expr ss loc = fun state ->
695 |     let assigned_val, state = (eval_expr if_let_expr.assigned_expr ss) state in
696 |     if (pattern_matches if_let_expr.pat assigned_val ss loc state) then
697 |         let state = (bind if_let_expr.pat assigned_val ss loc) state in
698 |         (eval_expr ~tc:tail_call if_let_expr.let_then_expr ss) state
699 |     else
700 |         (eval_expr ~tc:tail_call if_let_expr.let_else_expr ss) state
701 | 
702 | and eval_block_expr ?tc:(tail_call=false) ls ss =
703 |     let static_block_funcs = 
704 |         Preprocess.find_block_funcs ss (ls |> List.map ~f:Located.extract) ss.static_block_funcs 
705 |     in
706 |     let ss = { ss with static_block_funcs } in
707 |     fun state ->
708 |         let (res, _) =
709 |             let len = List.length ls in
710 |             match List.split_n ls (len - 1) with
711 |                 | exprs, [last_expr] ->
712 |                     let block_state =
713 |                         List.fold_left 
714 |                             ~init:state 
715 |                             ~f:(fun line_state e -> let _, s = (eval_expr e ss) line_state in s) 
716 |                             exprs
717 |                     in
718 |                     (eval_expr ~tc:tail_call last_expr ss) block_state
719 |                 | _ -> assert false (* Unreachable *)
720 |         in (res, state)
721 |     
722 | and eval_match_expr ?tc:(tail_call=false) match_val match_arms ss loc state =
723 |     let (match_val, state) = (eval_expr match_val ss) state in
724 |     let eval_expr expr ?tc:(tc=false) = eval_expr expr ss ~tc:tc in
725 |     let bind lhs rhs = bind lhs rhs ss in
726 |     let result_state_opt = List.find_map ~f:(
727 |         fun (pat, arm_expr, cond) -> 
728 |             if pattern_matches pat match_val ss loc state then
729 |                 match cond with
730 |                     | Some cond ->
731 |                         let inner_state = (bind pat match_val loc) state in
732 |                         let cond_eval, inner_state = (eval_expr cond) inner_state in
733 |                         if val_is_true cond_eval ss loc then
734 |                             let (result, _) = (eval_expr ~tc:tail_call arm_expr) inner_state in
735 |                             Some (result, state)
736 |                         else
737 |                             None
738 |                     | None ->
739 |                         let inner_state = (bind pat match_val loc) state in
740 |                         let (result, _) = (eval_expr ~tc:tail_call arm_expr) inner_state in
741 |                         Some(result, state)
742 |             else
743 |                 None
744 |     ) match_arms
745 |     in
746 |     match result_state_opt with
747 |         | Some((result, state)) -> 
748 |             result, state
749 |         | None ->
750 |             printf "No patterns matched %s in match expression at %s\n" 
751 |                 (string_of_val ss match_val)
752 |                 (location_to_string loc);
753 |             print_traceback ss;
754 |             Caml.exit 0
755 | 
756 | and eval_map_expr ?tc:(_tail_call=false) map_pairs tail_map ss loc state =
757 |     let fold_fn = fun (map_acc, state) (key_expr, val_expr) ->
758 |         let key_val, state = (eval_expr key_expr ss) state in
759 |         let data_val, state = (eval_expr val_expr ss) state in
760 |         let key_hash = hash_value key_val in
761 |         let new_data = match Map.find map_acc key_hash with
762 |             | Some assoc_list -> List.Assoc.add assoc_list ~equal:(fun l r -> val_eq_bool l r ss loc) key_val data_val
763 |             | None -> [(key_val, data_val)]
764 |         in
765 |         (Map.set map_acc ~key:key_hash ~data:new_data, state)
766 |     in
767 |     let tail_map, state = match tail_map with
768 |         | Some e ->
769 |             let m, state = (eval_expr e ss) state in
770 |             Some m, state
771 |         | None -> None, state
772 |     in
773 |     let start_map = match tail_map with
774 |         | Some (Dictionary m) -> m
775 |         | None -> Map.empty (module Int)
776 |         | Some m ->
777 |             printf "Expected a map for the tail in map expr at %s, got %s\n"
778 |                 (location_to_string loc)
779 |                 (string_of_val ss m);
780 |             print_traceback ss;
781 |             Caml.exit 0
782 |     in
783 |     let (val_map, state) = 
784 |         List.fold_left ~init:(start_map, state) ~f:fold_fn map_pairs
785 |     in (Dictionary val_map, state)
786 | 
787 | and eval_list_expr ?tc:(_tail_call=false) ls tail ss = fun s ->
788 |     let eval_expr_list ~init =
789 |         List.fold_left
790 |         ~init:init
791 |         ~f:(fun (acc, s) e -> let (ev, s) = (eval_expr e ss) s in (ev::acc, s))
792 |     in
793 |     let eval_prepend ls tail =
794 |         let (tail_eval, s) = (eval_expr tail ss) s in
795 |         match tail_eval with
796 |             | ValList tail_ls ->
797 |                 let (eval_ls, state) = eval_expr_list ~init:(tail_ls, s) (List.rev ls) in
798 |                 ValList eval_ls, state
799 |             | _ ->
800 |                 printf "tried to prepend to non-list %s at %s\n"
801 |                     (string_of_val ss tail_eval)
802 |                     (location_to_string tail.location);
803 |                 print_traceback ss;
804 |                 Caml.exit 0;
805 |     in
806 |     match tail with
807 |         | Some tail -> eval_prepend ls tail
808 |         | None ->
809 |             let (eval_ls, state) = eval_expr_list ~init:([], s) ls in
810 |             ValList (List.rev eval_ls), state
811 | 
812 | and eval_expr: (expr Located.t) -> static_state -> ?tc:bool -> state -> value * state = 
813 |     let open Located in
814 |     fun expr ss ?tc:(tail_call=false) -> 
815 |         let eval_prefix_op op e = eval_prefix_op op e ss in
816 |         let eval_op op lhs rhs = eval_op op lhs rhs ss in
817 |         (* printf "Evaluating: %s\n" (string_of_expr expr); *)
818 |         match expr with
819 |         | {data = Atomic v; _} -> fun s -> v, s
820 |         | {data = IdentExpr (UnresolvedIdent name); location} ->
821 |             printf "Error: Found unresolved ident %s at %s\n"
822 |                 name
823 |                 (location_to_string location);
824 |             print_traceback ss;
825 |             Caml.exit 0
826 |         | {data = IdentExpr (ResolvedIdent i); location} -> eval_ident ss i location
827 |         | {data = Prefix ({op = Head; _} as e); location} -> eval_prefix_op val_list_head e.rhs location
828 |         | {data = Prefix ({op = Tail; _} as e); location} -> eval_prefix_op val_list_tail e.rhs location
829 |         | {data = Prefix ({op = Neg; _} as e); location} -> eval_prefix_op val_negate e.rhs location
830 |         | {data = Prefix ({op = Not; _} as e); location} -> eval_prefix_op val_negate_bool e.rhs location
831 |         | {data = Prefix ({op = _op; _}); location} -> 
832 |             printf "Invalid prefix op at %s\n" (location_to_string location);
833 |             print_traceback ss;
834 |             Caml.exit 0
835 |         | {data = Binary ({op = Add; _} as e); location} -> eval_op val_add e.lhs e.rhs location
836 |         | {data = Binary ({op = Neg; _} as e); location} -> eval_op val_sub e.lhs e.rhs location
837 |         | {data = Binary ({op = Mul; _} as e); location} -> eval_op val_mul e.lhs e.rhs location
838 |         | {data = Binary ({op = Div; _} as e); location} -> eval_op val_div e.lhs e.rhs location
839 |         | {data = Binary ({op = EQ; _} as e); location} -> eval_op val_eq e.lhs e.rhs location
840 |         | {data = Binary ({op = NEQ; _} as e); location} -> eval_op val_neq e.lhs e.rhs location
841 |         | {data = Binary ({op = LEQ; _} as e); location} -> eval_op val_leq e.lhs e.rhs location
842 |         | {data = Binary ({op = GEQ; _} as e); location} -> eval_op val_geq e.lhs e.rhs location
843 |         | {data = Binary ({op = LT; _} as e); location} -> eval_op val_lt e.lhs e.rhs location
844 |         | {data = Binary ({op = GT; _} as e); location} -> eval_op val_gt e.lhs e.rhs location
845 |         | {data = Binary ({op = And; _} as e); location} -> eval_op val_and e.lhs e.rhs location
846 |         | {data = Binary ({op = Or; _} as e); location} -> eval_op val_or e.lhs e.rhs location
847 |         | {data = Binary ({op = Mod; _} as e); location} -> eval_op val_mod e.lhs e.rhs location
848 |         | {data = Binary ({op = PipeOp; _} as e); location} -> eval_pipe ~tc:tail_call e.lhs e.rhs ss location
849 |         | {data = Binary ({op = _op; _}); _} -> assert false (* Invalid binary op *)
850 |         | {data = LambdaDef d; _} -> eval_lambda_def d.lambda_def_expr d.lambda_def_args
851 |         | {data = Let l; location} -> fun s -> (eval_let l.assignee l.assigned_expr ss location) s
852 |         | {data = FnDef d; location} -> fun s -> (eval_fn_def d.fn_name d.fn_def_func ss location) s
853 |         | {data = TupleExpr ls; _} -> fun s -> (eval_tuple_expr ls ss) s
854 |         | {data = LambdaCall l; location} -> fun s -> (eval_lambda_call ~tc:tail_call l ss) location s
855 |         | {data = LambdaCaptureExpr c; location} -> fun s -> (eval_lambda_capture c ss) location s
856 |         | {data = IfExpr i; _} -> eval_if_expr ~tc:tail_call i ss
857 |         | {data = IfLetExpr i; location} -> eval_if_let_expr ~tc:tail_call i ss location
858 |         | {data = BlockExpr ls; _} -> fun s -> (eval_block_expr ~tc:tail_call ls ss) s
859 |         | {data = MatchExpr m; location} -> 
860 |             fun s -> (eval_match_expr ~tc:tail_call m.match_val m.match_arms ss location) s
861 |         | {data = MapExpr (ls, tail); location} -> fun s -> (eval_map_expr ~tc:tail_call ls tail ss location) s
862 |         | {data = ListExpr (ls, tail); _} -> eval_list_expr ls tail ss
863 |         | {data = UnresolvedAtom n; _} ->
864 |             printf "Found unresolved atom :%s\n" n;
865 |             assert false
866 | 


--------------------------------------------------------------------------------