Compare commits
No commits in common. "940fc8ec31f86952dc1810420e87dbe80c032171" and "4a1e509fc4c4946efc49cc3b6d80ea38cf995a67" have entirely different histories.
940fc8ec31
...
4a1e509fc4
4
.gitignore
vendored
4
.gitignore
vendored
|
|
@ -29,7 +29,3 @@ node_modules/
|
|||
.cljs_node_repl/
|
||||
.helix/
|
||||
target/repl-port
|
||||
.repl-buffer
|
||||
.repl-buffer.janet
|
||||
.env
|
||||
src/jpm_tree
|
||||
|
|
|
|||
24
CHANGELOG.md
Normal file
24
CHANGELOG.md
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
# Change Log
|
||||
All notable changes to this project will be documented in this file. This change log follows the conventions of [keepachangelog.com](http://keepachangelog.com/).
|
||||
|
||||
## [Unreleased]
|
||||
### Changed
|
||||
- Add a new arity to `make-widget-async` to provide a different widget shape.
|
||||
|
||||
## [0.1.1] - 2021-10-23
|
||||
### Changed
|
||||
- Documentation on how to make the widgets.
|
||||
|
||||
### Removed
|
||||
- `make-widget-sync` - we're all async, all the time.
|
||||
|
||||
### Fixed
|
||||
- Fixed widget maker to keep working when daylight savings switches over.
|
||||
|
||||
## 0.1.0 - 2021-10-23
|
||||
### Added
|
||||
- Files from the new template.
|
||||
- Widget maker public API - `make-widget-sync`.
|
||||
|
||||
[Unreleased]: https://sourcehost.site/your-name/cludus/compare/0.1.1...HEAD
|
||||
[0.1.1]: https://sourcehost.site/your-name/cludus/compare/0.1.0...0.1.1
|
||||
55
TODO.xit
Normal file
55
TODO.xit
Normal file
|
|
@ -0,0 +1,55 @@
|
|||
|
||||
[x] Fix recursive definition problems in grammar.clj
|
||||
|
||||
TODOS for parser
|
||||
[ ] Make parser errors pretty
|
||||
[ ] Use synchronization to make parsing more robust
|
||||
[ ] Decide on synchronization tokens: [then else ] ) } , ; \n]
|
||||
|
||||
TODOS from interpreter
|
||||
[x] implement tuple splat patterns
|
||||
[x] update match-list to use new AST representation
|
||||
[x] fix length comparison when pattern includes splats
|
||||
[x] update match-dict to use new AST representation
|
||||
[x] update match-struct to use new AST representation
|
||||
[ ] update interpret-receive to use new AST representation
|
||||
[ ] Check interpret-fn-inner ctx for cycles/bugs
|
||||
|
||||
Re-add processes to the language
|
||||
[ ] Write send as function
|
||||
[ ] update interpret-spawn to use new AST representation
|
||||
[ ] ---- Investigate weird timing issue in current send implementation
|
||||
[ ] Investigate `with-bindings` and virtual threads
|
||||
|
||||
Finish interpreter
|
||||
[x] Wire up new interpreter to repl, script situation
|
||||
[x] Merge new interpreter
|
||||
|
||||
Conditionals
|
||||
[ ] Fix let bindings/scope in `if` expressions
|
||||
[ ] Make `and` and `or` special forms
|
||||
[ ] ---- `if and (let x ...)` pattern
|
||||
[ ] ---- arguments are lazily, not eagerly, executed
|
||||
|
||||
Write a compiler: desugaring
|
||||
[~] `...` to `..._` in tuple & list patterns
|
||||
[ ] placeholder partial application to anonymous lambda
|
||||
[ ] word -> :[word] word in pairs (patterns & expressions)
|
||||
|
||||
Write a compiler: correctness
|
||||
[ ] check for unbound names
|
||||
[ ] check for re-binding names
|
||||
[ ] check that recur is in tail position
|
||||
[ ] check that recur is only called inside loop or fn forms
|
||||
[ ] check ns accesses
|
||||
[ ] prevent import cycles
|
||||
[ ] splattern is last member in a pattern
|
||||
[ ] -----List/Tuple
|
||||
[ ] -----Dict/Struct/Set
|
||||
|
||||
Write a compiler: optimization
|
||||
[ ] devise tail call optimization
|
||||
|
||||
Next steps
|
||||
[ ] Get drawing working?
|
||||
[ ] Add stack traces for panics
|
||||
8
assets/index.html
Normal file
8
assets/index.html
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
<html>
|
||||
<head>
|
||||
<title>Hello, world!</title>
|
||||
</head>
|
||||
<body>
|
||||
<script src="main.js"></script>
|
||||
</body>
|
||||
</html>
|
||||
143
build/driver.cpp
143
build/driver.cpp
|
|
@ -1,143 +0,0 @@
|
|||
#include <cstdint>
|
||||
#include <emscripten.h>
|
||||
#include <emscripten/bind.h>
|
||||
#include <string>
|
||||
#include <stdio.h>
|
||||
#include "janet.h"
|
||||
|
||||
using std::string;
|
||||
|
||||
// set all our exported Janet functions as null pointers
|
||||
static JanetFunction *janet_ludus = NULL;
|
||||
static JanetFunction *janet_hello = NULL;
|
||||
|
||||
// these let us look up functions
|
||||
Janet env_lookup(JanetTable *env, const char *name) {
|
||||
Janet out;
|
||||
janet_resolve(env, janet_csymbol(name), &out);
|
||||
return out;
|
||||
}
|
||||
|
||||
JanetFunction *env_lookup_function(JanetTable *env, const char *name) {
|
||||
Janet value = env_lookup(env, name);
|
||||
if (!janet_checktype(value, JANET_FUNCTION)) {
|
||||
janet_panicf("expected %s to be a function, got %q\n", name, value);
|
||||
}
|
||||
return janet_unwrap_function(value);
|
||||
}
|
||||
|
||||
// this lets us call a function
|
||||
bool call_fn(JanetFunction *fn, int argc, const Janet *argv, Janet *out) {
|
||||
JanetFiber *fiber = NULL;
|
||||
if (janet_pcall(fn, argc, argv, out, &fiber) == JANET_SIGNAL_OK) {
|
||||
return true;
|
||||
} else {
|
||||
janet_stacktrace(fiber, *out);
|
||||
return false;
|
||||
}
|
||||
}
|
||||
|
||||
// this is darkish magic, reads an embedded file
|
||||
// do not fuck with this, fellas
|
||||
unsigned char *read_file(const char *filename, size_t *length) {
|
||||
size_t capacity = 2 << 17;
|
||||
unsigned char *src = (unsigned char *)malloc(capacity * sizeof(unsigned char));
|
||||
assert(src);
|
||||
size_t total_bytes_read = 0;
|
||||
FILE *file = fopen(filename, "r");
|
||||
assert(file);
|
||||
size_t bytes_read;
|
||||
do {
|
||||
size_t remaining_capacity = capacity - total_bytes_read;
|
||||
if (remaining_capacity == 0) {
|
||||
capacity <<= 1;
|
||||
src = (unsigned char*)realloc(src, capacity * sizeof(unsigned char));
|
||||
assert(src);
|
||||
remaining_capacity = capacity - total_bytes_read;
|
||||
}
|
||||
|
||||
bytes_read = fread(&src[total_bytes_read], sizeof(unsigned char), remaining_capacity, file);
|
||||
total_bytes_read += bytes_read;
|
||||
} while (bytes_read > 0);
|
||||
|
||||
fclose(file);
|
||||
*length = total_bytes_read;
|
||||
return src;
|
||||
}
|
||||
|
||||
// these are the C++ functions that wrap our Janet functions
|
||||
// simplest case: takes nothing, returns nothing
|
||||
void hello() {
|
||||
Janet result; // we need a place to put the result
|
||||
// args are: fn ptr, argc, argv, result
|
||||
call_fn(janet_hello, 0, {}, &result);
|
||||
}
|
||||
|
||||
// finally, getting a string back
|
||||
// this is our result type
|
||||
struct StringResult {
|
||||
string value;
|
||||
};
|
||||
|
||||
// this is our result constructor
|
||||
// Janet's getcstring resturns const char*
|
||||
StringResult string_result(const char* cstr) {
|
||||
// ...which we have to cast to a std::string
|
||||
return (StringResult) {.value = (string) cstr };
|
||||
}
|
||||
|
||||
// and this is a function that takes and returns a string
|
||||
// it returns a StringResult, tho
|
||||
StringResult ludus(string source) {
|
||||
Janet result;
|
||||
const Janet args[1] = {janet_cstringv(source.c_str())};
|
||||
call_fn(janet_ludus, 1, args, &result);
|
||||
// get the cstring in the result
|
||||
// the 0 passed here is the index in the result of the string
|
||||
const char* cstr = janet_getcstring(&result, 0);
|
||||
// return a constructed StringResult
|
||||
return string_result(cstr);
|
||||
}
|
||||
|
||||
// This function sets up our Janet interpreter, and fixes the null pointers
|
||||
EMSCRIPTEN_KEEPALIVE
|
||||
int main() {
|
||||
janet_init(); // start the interpreter
|
||||
JanetTable *core_env = janet_core_env(NULL); // get a core env
|
||||
JanetTable *lookup = janet_env_lookup(core_env); // and get an env table
|
||||
|
||||
// load the janet image into memory
|
||||
// note that the image is hardcoded here
|
||||
size_t image_length;
|
||||
unsigned char *image = read_file("ludus.jimage", &image_length);
|
||||
|
||||
// load the image into the Janet environment
|
||||
Janet env = janet_unmarshal(image, image_length, 0, lookup, NULL);
|
||||
|
||||
if(!janet_checktype(env, JANET_TABLE)) {
|
||||
janet_panicf("invalid image %q", env);
|
||||
}
|
||||
|
||||
// fix the null pointers, as above
|
||||
// note that the bound symbols are just the normal fn names
|
||||
// no namespacing
|
||||
janet_ludus = env_lookup_function(janet_unwrap_table(env), "ludus");
|
||||
janet_gcroot(janet_wrap_function(janet_ludus));
|
||||
|
||||
janet_hello = env_lookup_function(janet_unwrap_table(env), "hello");
|
||||
janet_gcroot(janet_wrap_function(janet_hello));
|
||||
}
|
||||
|
||||
// these bindings are exported into javascript
|
||||
EMSCRIPTEN_BINDINGS(module) {
|
||||
using namespace emscripten;
|
||||
|
||||
// these are the functions that will be available
|
||||
function("ludus", &ludus, allow_raw_pointers());
|
||||
function("hello", &hello, allow_raw_pointers());
|
||||
|
||||
// we also want a wrapper for our StringResult
|
||||
// we won't access it directly, but emcc makes it nice
|
||||
value_object<StringResult>("StringResult")
|
||||
.field("value", &StringResult::value);
|
||||
}
|
||||
51563
build/janet.c
51563
build/janet.c
File diff suppressed because it is too large
Load Diff
2277
build/janet.h
2277
build/janet.h
File diff suppressed because it is too large
Load Diff
|
|
@ -1,15 +0,0 @@
|
|||
build:
|
||||
# compile the janet into an image
|
||||
# janet -c src/ludus.janet build/ludus.jimage
|
||||
# the complex emscripten invocation
|
||||
# note we have the stack size set to 1024*1024 (1 MB)
|
||||
emcc \
|
||||
-o out.mjs \
|
||||
janet.c driver.cpp \
|
||||
--embed-file ludus.jimage \
|
||||
-lembind \
|
||||
-s "EXPORTED_FUNCTIONS=['_main']" \
|
||||
-s EXPORT_ES6 \
|
||||
-s ALLOW_MEMORY_GROWTH=1 \
|
||||
-s STACK_SIZE=1048576 \
|
||||
-s MODULARIZE
|
||||
Binary file not shown.
|
|
@ -1,8 +0,0 @@
|
|||
import init from "./out.mjs"
|
||||
|
||||
const mod = await init()
|
||||
|
||||
export function run (source) {
|
||||
const result = mod.ludus(source).value
|
||||
return JSON.parse(result)
|
||||
}
|
||||
7170
build/out.mjs
7170
build/out.mjs
File diff suppressed because it is too large
Load Diff
BIN
build/out.wasm
BIN
build/out.wasm
Binary file not shown.
|
|
@ -1,11 +0,0 @@
|
|||
console.log("Starting wasm test run.")
|
||||
|
||||
import init from "./out.mjs"
|
||||
|
||||
console.log("Imported module")
|
||||
|
||||
const mod = await init()
|
||||
|
||||
console.log("Initted module")
|
||||
|
||||
console.log(mod.ludus(":hello_from_ludus").value)
|
||||
17
deps.edn
Normal file
17
deps.edn
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
{:deps
|
||||
{org.clojure/clojurescript {:mvn/version "1.11.121"}
|
||||
thheller/shadow-cljs {:mvn/version "2.26.0"}
|
||||
babashka/fs {:mvn/version "0.4.19"}
|
||||
}
|
||||
|
||||
:source-paths ["src/ludus"]
|
||||
|
||||
:aliases
|
||||
{:main
|
||||
{:exec-fn ludus.core/main!}
|
||||
:repl
|
||||
{:exec-fn clojure.core.server/start-server
|
||||
:exec-args {:name "repl"
|
||||
:port 5555
|
||||
:accept clojure.core.server/repl
|
||||
:server-daemon false}}}}
|
||||
7
graal-compile.sh
Executable file
7
graal-compile.sh
Executable file
|
|
@ -0,0 +1,7 @@
|
|||
#!/opt/homebrew/bin/fish
|
||||
|
||||
jenv shell graalvm64-19.0.2
|
||||
|
||||
lein uberjar
|
||||
|
||||
native-image --enable-preview --report-unsupported-elements-at-runtime --initialize-at-build-time -jar ./target/ludus-0.1.0-SNAPSHOT-standalone.jar -H:Name=./target/ludus
|
||||
22
justfile
22
justfile
|
|
@ -1,20 +1,6 @@
|
|||
# open a janet repl in a different os window
|
||||
# start a repl
|
||||
repl:
|
||||
kitten @ launch --type=os-window --allow-remote-control --cwd=current --title=hx_repl:ludus --keep-focus
|
||||
kitten @ send-text -m "title:hx_repl:ludus" "janet -s\n"
|
||||
clj -X:repl
|
||||
|
||||
restart:
|
||||
kitten @ send-text -m "title:hx_repl:ludus" "\04"
|
||||
kitten @ send-text -m "title:hx_repl:ludus" "janet -s\n"
|
||||
|
||||
# send what's selected to the repl and evaluate it
|
||||
eval:
|
||||
sd "$" "\n" | sd "\n\n" "\n" | kitten @ send-text -m "title:hx_repl:ludus" --stdin
|
||||
|
||||
# send what's selected to a buffer, and then evaluate what's in the buffer
|
||||
buffer:
|
||||
sd "$" "\n" | sd "\n\n" "\n" > .repl-buffer.janet
|
||||
kitten @ send-text -m "title:hx_repl:ludus" "(import ./.repl-buffer :prefix \"\")"
|
||||
|
||||
doc:
|
||||
sd "$" "\n" | sd "\n\n" "\n" | xargs -I _ echo "(doc " _ ")" | kitten @ send-text -m "title:hx_repl:ludus" --stdin
|
||||
build:
|
||||
shadow-cljs release module
|
||||
|
|
|
|||
19
ludus.sublime-project
Normal file
19
ludus.sublime-project
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
{
|
||||
"folders":
|
||||
[
|
||||
{
|
||||
"path": "."
|
||||
}
|
||||
],
|
||||
"settings": {
|
||||
"on_post_save_project": [
|
||||
{
|
||||
"command": "exec",
|
||||
"args": {
|
||||
"shell_cmd": "lein cljfmt fix"
|
||||
},
|
||||
"scope": "window"
|
||||
}
|
||||
]
|
||||
}
|
||||
}
|
||||
14
package.json
14
package.json
|
|
@ -1,16 +1,18 @@
|
|||
{
|
||||
"name": "@ludus/ludus-js-pure",
|
||||
"version": "0.1.0-alpha.10",
|
||||
"version": "0.1.3",
|
||||
"description": "A Ludus interpreter in a pure JS function.",
|
||||
"main": "target/js/ludus.js",
|
||||
"type": "module",
|
||||
"main": "build/ludus.mjs",
|
||||
"directories": {},
|
||||
"keywords": [],
|
||||
"author": "Scott Richmond",
|
||||
"license": "GPL-3.0",
|
||||
"files": [
|
||||
"build/out.wasm",
|
||||
"build/out.mjs",
|
||||
"build/ludus.mjs"],
|
||||
"devDependencies": {}
|
||||
"target/js/*"
|
||||
],
|
||||
"devDependencies": {
|
||||
"shadow-cljs": "^2.26.0",
|
||||
"tap": "^18.6.1"
|
||||
}
|
||||
}
|
||||
|
|
|
|||
14
project.clj
Normal file
14
project.clj
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
(defproject ludus "0.1.0-SNAPSHOT"
|
||||
:description "FIXME: write description"
|
||||
:url "http://ludus.dev"
|
||||
:license {:name "EPL-2.0 OR GPL-2.0-or-later WITH Classpath-exception-2.0"
|
||||
:url "https://www.eclipse.org/legal/epl-2.0/"}
|
||||
:dependencies [[org.clojure/clojure "1.11.1"]
|
||||
[babashka/fs "0.4.19"]
|
||||
]
|
||||
:plugins [[lein-cljfmt "0.8.0"]]
|
||||
:repl-options {:init-ns ludus.core}
|
||||
:main ludus.core
|
||||
:profiles {:uberjar {:aot :all}}
|
||||
:jvm-opts ["--enable-preview"]
|
||||
)
|
||||
111
sandbox.ld
Normal file
111
sandbox.ld
Normal file
|
|
@ -0,0 +1,111 @@
|
|||
fn fib {
|
||||
"Tells you a fib number."
|
||||
(0) -> 0
|
||||
(1) -> 1
|
||||
(n) -> add (
|
||||
fib (dec (n))
|
||||
fib (sub (n, 2))
|
||||
)
|
||||
}
|
||||
|
||||
fn unwrap {
|
||||
((:some, value)) -> value
|
||||
((:ok, value)) -> value
|
||||
}
|
||||
|
||||
fn default (default_value) -> fn (maybe) -> when maybe is {
|
||||
(:ok, value) -> value
|
||||
(:err, _) -> default_value
|
||||
nil -> default_value
|
||||
value -> value
|
||||
}
|
||||
|
||||
fn some (value) -> (:some, value)
|
||||
|
||||
fn ok (value) -> (:ok, value)
|
||||
|
||||
let foo = unwrap ((:ok, 42))
|
||||
|
||||
print (:foo, foo)
|
||||
|
||||
let bar = unwrap ((:some, 23))
|
||||
|
||||
print (:bar, bar)
|
||||
|
||||
let baz = do 69 > default (12) > print (:baz, _)
|
||||
|
||||
let quux = do nil > default (12) > print (:quux, _)
|
||||
|
||||
& unwrap ((:err, "message"))
|
||||
|
||||
fn map {
|
||||
(f) -> fn mapper (xs) -> map (f, xs)
|
||||
(f, xs) -> {
|
||||
let n = count (xs)
|
||||
loop (0, []) with (i, ys) -> if eq (i, n)
|
||||
then ys
|
||||
else recur (
|
||||
inc (i)
|
||||
conj (ys, f (nth (i, xs))))
|
||||
}
|
||||
}
|
||||
|
||||
fn reduce {
|
||||
(f) -> fn reducer {
|
||||
(xs) -> reduce (f, xs)
|
||||
(xs, init) -> reduce (f, xs, init)
|
||||
}
|
||||
(f, xs) -> {
|
||||
let first_x = first (xs)
|
||||
let more_xs = rest (xs)
|
||||
reduce (f, more_xs, first_x)
|
||||
}
|
||||
(f, xs, init) -> {
|
||||
let n = count (xs)
|
||||
loop (0, init) with (i, acc) -> if eq (i, n)
|
||||
then acc
|
||||
else {
|
||||
let curr = nth (i, xs)
|
||||
let next = f (acc, curr)
|
||||
recur (inc (i), next)
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
fn filter {
|
||||
(f) -> fn filterer (xs) -> filter (f, xs)
|
||||
(f, xs) -> {
|
||||
let n = count (xs)
|
||||
loop (0, []) with (i, ys) -> when {
|
||||
eq (i, n) -> ys
|
||||
f (nth (i, xs)) -> recur (inc (i), conj (ys, nth (i, xs)))
|
||||
else -> recur (inc (i), ys)
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
& fn shuffle
|
||||
|
||||
ref x = 4
|
||||
|
||||
set! (x, "foo")
|
||||
|
||||
set! (x, :foo)
|
||||
|
||||
deref (x)
|
||||
|
||||
let greater_than_two? = gt (_, 2)
|
||||
|
||||
fn square (x) -> mult (x, x)
|
||||
|
||||
let xs = [1, 2, 3]
|
||||
|
||||
let ys = #{:a 1, :b 2}
|
||||
|
||||
ys :a
|
||||
|
||||
:a (ys)
|
||||
|
||||
let y = 1
|
||||
|
||||
do y > inc > square > sub (_, 3)
|
||||
18
shadow-cljs.edn
Normal file
18
shadow-cljs.edn
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
;; shadow-cljs configuration
|
||||
{:deps true
|
||||
|
||||
:dev-http {8234 "target"}
|
||||
|
||||
:builds
|
||||
{:node {:target :node-library
|
||||
:output-to "target/js/ludus.js"
|
||||
:exports {:run ludus.node/run}
|
||||
:modules {:main {:entries [ludus.node]}}}
|
||||
:module {:target :esm
|
||||
:output-dir "target/js"
|
||||
:modules {:ludus {:exports {run ludus.node/run test ludus.node/doug}}}
|
||||
}
|
||||
:browser {:target :browser
|
||||
:output-dir "target/js"
|
||||
:asset-path "target"
|
||||
:modules {:main {:init-fn ludus.web/init}}}}}
|
||||
269
src/base.janet
269
src/base.janet
|
|
@ -1,269 +0,0 @@
|
|||
# A base library for Ludus
|
||||
# Only loaded in the prelude
|
||||
|
||||
(defn bool [x] (if (= :^nil x) nil x))
|
||||
|
||||
(defn ludus/and [& args] (every? (map bool args)))
|
||||
|
||||
(defn ludus/or [& args] (some bool args))
|
||||
|
||||
(defn ludus/type [value]
|
||||
(def typed? (when (dictionary? value) (value :^type)))
|
||||
(def the-type (if typed? typed? (type value)))
|
||||
(case the-type
|
||||
:buffer :string
|
||||
:boolean :bool
|
||||
:array :list
|
||||
:table :dict
|
||||
:cfunction :function
|
||||
the-type))
|
||||
|
||||
(var stringify nil)
|
||||
|
||||
(defn- dict-str [dict]
|
||||
(string/join
|
||||
(map
|
||||
(fn [[k v]] (string (stringify k) " " (stringify v)))
|
||||
(pairs dict))
|
||||
", "))
|
||||
|
||||
(defn- stringish? [x] (or (string? x) (buffer? x)))
|
||||
|
||||
(defn- stringify* [value]
|
||||
(when (stringish? value) (break value))
|
||||
(def type (ludus/type value))
|
||||
(case type
|
||||
:nil ""
|
||||
:number (string value)
|
||||
:bool (string value)
|
||||
:keyword (string ":" value)
|
||||
:tuple
|
||||
(string/join (map stringify value) ", ")
|
||||
:list
|
||||
(string/join (map stringify value) ", ")
|
||||
:dict (dict-str value)
|
||||
:set
|
||||
(string/join (map stringify (keys value)) ", ")
|
||||
:box (stringify (value :^value))
|
||||
:fn (string "fn " (value :name))
|
||||
:function (string "builtin " (string value))
|
||||
:pkg (dict-str value)
|
||||
))
|
||||
|
||||
(set stringify stringify*)
|
||||
|
||||
(defn- show-pkg [x]
|
||||
(def tab (struct/to-table x))
|
||||
(set (tab :^name) nil)
|
||||
(set (tab :^type) nil)
|
||||
(string "pkg " (x :^name) " {" (stringify tab) "}")
|
||||
)
|
||||
|
||||
(defn show [x]
|
||||
(case (ludus/type x)
|
||||
:nil "nil"
|
||||
:string (string "\"" x "\"")
|
||||
:tuple (string "(" (stringify x) ")")
|
||||
:list (string "[" (stringify x) "]")
|
||||
:dict (string "#{" (stringify x) "}")
|
||||
:set (string "${" (stringify x) "}")
|
||||
:box (string "box " (x :name) " [ " (stringify x) " ]")
|
||||
:pkg (show-pkg x)
|
||||
(stringify x)))
|
||||
|
||||
(var json nil)
|
||||
|
||||
(defn- dict-json [dict]
|
||||
(string/join
|
||||
(map
|
||||
(fn [[k v]] (string (json k) ": " (json v)))
|
||||
(pairs dict))
|
||||
", "))
|
||||
|
||||
(defn- json* [x]
|
||||
(case (ludus/type x)
|
||||
:nil "null"
|
||||
:number (string x)
|
||||
:bool (if true "true" "false")
|
||||
:string (string "\"" x "\"")
|
||||
:keyword (string "\"" x "\"")
|
||||
:tuple (string "[" (string/join (map json x) ", ") "]")
|
||||
:list (string "[" (string/join (map json x) ", ")"]")
|
||||
:dict (string "{" (dict-json x) "}")
|
||||
:set (string "[" (string/join (map json (keys x)) ", ") "]")
|
||||
(show x)))
|
||||
|
||||
(set json json*)
|
||||
|
||||
(defn show-patt [x]
|
||||
(case (x :type)
|
||||
:nil "nil"
|
||||
:bool (string (x :data))
|
||||
:number (string (x :data))
|
||||
:keyword (string ":" (x :data))
|
||||
:word (x :data)
|
||||
:placeholder (get-in x [:token :lexeme])
|
||||
:tuple (string "(" (string/join (map show-patt (x :data)) ", ") ")")
|
||||
:list (string "[" (string/join (map show-patt (x :data)) ", ")"]")
|
||||
:dict (string "#{" (string/join (map show-patt (x :data)) ", ") "}")
|
||||
:pair (string (show-patt (get-in x [:data 0])) " " (show-patt (get-in x [:data 1])))
|
||||
:typed (string (show-patt (get-in x [:data 1])) " as " (show-patt (get-in x [:data 0])))
|
||||
:interpolated (get-in x [:token :lexeme])
|
||||
:string (get-in x [:token :lexeme])
|
||||
:splat (string "..." (when (x :splatted) (show-patt (x :splatted))))
|
||||
(error (string "cannot show pattern of unknown type " (x :type)))))
|
||||
|
||||
(defn pretty-patterns [fnn]
|
||||
(def {:body clauses} fnn)
|
||||
(string/join (map (fn [x] (-> x first show-patt)) clauses) " "))
|
||||
|
||||
(defn doc [fnn]
|
||||
(def {:name name :doc doc} fnn)
|
||||
(string/join [name (pretty-patterns fnn) doc] "\n"))
|
||||
|
||||
(defn- conj!-set [sett value]
|
||||
(set (sett value) true)
|
||||
sett)
|
||||
|
||||
(defn- conj-set [sett value]
|
||||
(def new (merge sett))
|
||||
(conj!-set new value))
|
||||
|
||||
(defn- conj!-list [list value]
|
||||
(array/push list value))
|
||||
|
||||
(defn- conj-list [list value]
|
||||
(def new (array/slice list))
|
||||
(conj!-list new value))
|
||||
|
||||
(defn conj! [x value]
|
||||
(case (ludus/type x)
|
||||
:list (conj!-list x value)
|
||||
:set (conj!-set x value)))
|
||||
|
||||
(defn conj [x value]
|
||||
(case (ludus/type x)
|
||||
:list (conj-list x value)
|
||||
:set (conj-set x value)
|
||||
(error (string "cannot conj onto " (show x)))))
|
||||
|
||||
(defn disj! [sett value]
|
||||
(set (sett value) nil)
|
||||
sett)
|
||||
|
||||
(defn disj [sett value]
|
||||
(def new (merge sett))
|
||||
(set (new value) nil)
|
||||
new)
|
||||
|
||||
(defn assoc! [dict key value]
|
||||
(set (dict key) value)
|
||||
dict)
|
||||
|
||||
(defn assoc [dict key value]
|
||||
(merge dict {key value}))
|
||||
|
||||
(defn dissoc! [dict key]
|
||||
(set (dict key) nil)
|
||||
dict)
|
||||
|
||||
(defn dissoc [dict key]
|
||||
(def new (merge dict))
|
||||
(set (new key) nil)
|
||||
new)
|
||||
|
||||
(defn ludus/get [key dict &opt def]
|
||||
(default def :^nil)
|
||||
(get dict key def))
|
||||
|
||||
(defn rest [indexed]
|
||||
(array/slice indexed 1))
|
||||
|
||||
(defn to_list [x]
|
||||
(case (ludus/type x)
|
||||
:list x
|
||||
:tuple @[;x]
|
||||
:dict (pairs x)
|
||||
:set (-> x (dissoc :^type) keys)
|
||||
@[x]))
|
||||
|
||||
(defn print! [args]
|
||||
(print ;(map show args)))
|
||||
|
||||
(defn prn [x]
|
||||
(pp x)
|
||||
x)
|
||||
|
||||
(defn concat [x y & zs]
|
||||
(case (ludus/type x)
|
||||
:string (string x y ;zs)
|
||||
:list (array/concat @[] x y ;zs)
|
||||
:set (merge x y ;zs)))
|
||||
|
||||
(defn unbox [b] (get b :^value))
|
||||
|
||||
(defn store! [b x] (set (b :^value) x))
|
||||
|
||||
(def ctx {
|
||||
"print!" print!
|
||||
"prn" prn
|
||||
"eq?" deep=
|
||||
"bool" bool
|
||||
"and" ludus/and
|
||||
"or" ludus/or
|
||||
"add" +
|
||||
"sub" -
|
||||
"mult" *
|
||||
"div" /
|
||||
"mod" %
|
||||
"gt" >
|
||||
"gte" >=
|
||||
"lt" <
|
||||
"lte" <=
|
||||
"inc" inc
|
||||
"dec" dec
|
||||
"not" not
|
||||
"type" ludus/type
|
||||
"stringify" stringify
|
||||
"show" show
|
||||
"doc" doc
|
||||
"concat" concat
|
||||
"conj" conj
|
||||
"conj!" conj!
|
||||
"disj" disj
|
||||
"disj!" disj!
|
||||
"push" array/push
|
||||
"assoc" assoc
|
||||
"assoc!" assoc!
|
||||
"dissoc" dissoc
|
||||
"dissoc!" dissoc!
|
||||
"get" ludus/get
|
||||
"nth" ludus/get
|
||||
"first" first
|
||||
"rest" rest
|
||||
"last" last
|
||||
"slice" slice
|
||||
"to_list" to_list
|
||||
"count" length
|
||||
"pi" math/pi
|
||||
"sin" math/sin
|
||||
"cos" math/cos
|
||||
"tan" math/tan
|
||||
"atan_2" math/atan2
|
||||
"sqrt" math/sqrt
|
||||
"random" math/random
|
||||
"floor" math/floor
|
||||
"ceil" math/ceil
|
||||
"round" math/round
|
||||
"range" range
|
||||
"unbox" unbox
|
||||
"store!" store!
|
||||
})
|
||||
|
||||
(def base (let [b @{}]
|
||||
(each [k v] (pairs ctx)
|
||||
(set (b (keyword k)) v))
|
||||
b))
|
||||
|
||||
(set (base :^type) :dict)
|
||||
|
||||
|
|
@ -1,80 +0,0 @@
|
|||
(import /src/base :as b)
|
||||
|
||||
(defn- get-line [source line]
|
||||
((string/split "\n" source) (dec line)))
|
||||
|
||||
(defn scan-error [e] (pp e) e)
|
||||
|
||||
(defn parse-error [e]
|
||||
(def msg (e :msg))
|
||||
(def {:line line-num :input input :soure source} (e :token))
|
||||
(def source-line (get-line source line-num))
|
||||
(print "Parsing error: " msg)
|
||||
(print "On line " line-num " in " input)
|
||||
(print source-line)
|
||||
e)
|
||||
|
||||
|
||||
(defn validation-error [e]
|
||||
(def msg (e :msg))
|
||||
(def {:line line-num :input input :source source} (get-in e [:node :token]))
|
||||
(def source-line (get-line source line-num))
|
||||
(case msg
|
||||
"unbound name"
|
||||
(do
|
||||
(print "Validation error: " msg " " (get-in e [:node :data]))
|
||||
(print "on line " line-num " in " input)
|
||||
(print source-line))
|
||||
(do
|
||||
(print "Validation error: " msg)
|
||||
(print "on line " line-num)
|
||||
(print source-line)))
|
||||
e)
|
||||
|
||||
(defn- fn-no-match [e]
|
||||
(print "Ludus panicked! no match")
|
||||
(def {:line line-num :source source :input input} (get-in e [:node :token]))
|
||||
(def source-line (get-line source line-num))
|
||||
(print "on line " line-num " in " input)
|
||||
(def called (e :called))
|
||||
(print "calling " (b/show called))
|
||||
(def value (e :value))
|
||||
(print "with " (b/show value))
|
||||
(print "expecting to match one of")
|
||||
(print (b/pretty-patterns called))
|
||||
(print source-line))
|
||||
|
||||
(defn- let-no-match [e]
|
||||
(print "Ludus panicked! no match")
|
||||
(def {:line line-num :source source :input input} (get-in e [:node :token]))
|
||||
(def source-line (get-line source line-num))
|
||||
(print "on line " line-num " in " input)
|
||||
(print "binding " (b/show (e :value)))
|
||||
(def pattern (get-in e [:node :data 0]))
|
||||
(print "to " (b/show-patt pattern))
|
||||
(print source-line))
|
||||
|
||||
(defn- generic-panic [e]
|
||||
(def msg (e :msg))
|
||||
(def {:line line-num :source source :input input} (get-in e [:node :token]))
|
||||
(def source-line (get-line source line-num))
|
||||
(print "Ludus panicked! " msg)
|
||||
(print "on line " line-num " in " input)
|
||||
(print source-line))
|
||||
|
||||
(defn- unbound-name [e]
|
||||
(def {:line line-num :source source :lexeme name :input input} (get-in e [:node :token]))
|
||||
(def source-line (get-line source line-num))
|
||||
(print "Ludus panicked! unbound name " name)
|
||||
(print "on line " line-num " in " input)
|
||||
(print source-line))
|
||||
|
||||
(defn runtime-error [e]
|
||||
(when (= :string (type e)) (print e) (break e))
|
||||
(def msg (e :msg))
|
||||
(case msg
|
||||
"no match: function call" (fn-no-match e)
|
||||
"no match: let binding" (let-no-match e)
|
||||
"unbound name" (unbound-name e)
|
||||
(generic-panic e))
|
||||
e)
|
||||
|
|
@ -1,651 +0,0 @@
|
|||
# A tree walk interpreter for ludus
|
||||
|
||||
(import /src/base :as b)
|
||||
|
||||
(var interpret nil)
|
||||
(var match-pattern nil)
|
||||
|
||||
(defn- todo [msg] (error (string "not yet implemented: " msg)))
|
||||
|
||||
(defn- resolve-name [name ctx]
|
||||
# # (print "resolving " name " in:")
|
||||
# # (pp ctx)
|
||||
(when (not ctx) (break :^not-found))
|
||||
(if (has-key? ctx name)
|
||||
(ctx name)
|
||||
(resolve-name name (ctx :^parent))))
|
||||
|
||||
(defn- match-word [word value ctx]
|
||||
(def name (word :data))
|
||||
# # (print "matched " (b/show value) " to " name)
|
||||
(set (ctx name) value)
|
||||
{:success true :ctx ctx})
|
||||
|
||||
(defn- typed [pattern value ctx]
|
||||
(def [type-ast word] (pattern :data))
|
||||
(def type (type-ast :data))
|
||||
(if (= type (b/ludus/type value))
|
||||
(match-word word value ctx)
|
||||
{:success false :miss [pattern value]}))
|
||||
|
||||
(defn- match-tuple [pattern value ctx]
|
||||
(when (not (tuple? value))
|
||||
(break {:success false :miss [pattern value]}))
|
||||
(def val-len (length value))
|
||||
(var members (pattern :data))
|
||||
(when (empty? members)
|
||||
(break (if (empty? value)
|
||||
{:success true :ctx ctx}
|
||||
{:success false :miss [pattern value]})))
|
||||
(def patt-len (length members))
|
||||
(var splat nil)
|
||||
(def splat? (= :splat ((last members) :type)))
|
||||
(when splat?
|
||||
(when (< val-len patt-len)
|
||||
# (print "mismatched splatted tuple lengths")
|
||||
(break {:success false :miss [pattern value]}))
|
||||
# (print "splat!")
|
||||
(set splat (last members))
|
||||
(set members (slice members 0 (dec patt-len))))
|
||||
(when (and (not splat?) (not= val-len patt-len))
|
||||
# (print "mismatched tuple lengths")
|
||||
(break {:success false :miss [pattern value]}))
|
||||
(var curr-mem :^nothing)
|
||||
(var curr-val :^nothing)
|
||||
(var success true)
|
||||
(for i 0 (length members)
|
||||
(set curr-mem (get members i))
|
||||
(set curr-val (get value i))
|
||||
# (print "in tuple, matching " curr-val " with ")
|
||||
# (pp curr-mem)
|
||||
(def match? (match-pattern curr-mem curr-val ctx))
|
||||
# (pp match?)
|
||||
(when (not (match? :success))
|
||||
(set success false)
|
||||
(break)))
|
||||
(when (and splat? (splat :data))
|
||||
(def rest (array/slice value (length members)))
|
||||
(match-word (splat :data) rest ctx))
|
||||
(if success
|
||||
{:success true :ctx ctx}
|
||||
{:success false :miss [pattern value]}))
|
||||
|
||||
(defn- match-list [pattern value ctx]
|
||||
(when (not (array? value))
|
||||
(break {:success false :miss [pattern value]}))
|
||||
(def val-len (length value))
|
||||
(var members (pattern :data))
|
||||
(when (empty? members)
|
||||
(break (if (empty? value)
|
||||
{:success true :ctx ctx}
|
||||
{:success false :miss [pattern value]})))
|
||||
(def patt-len (length members))
|
||||
(var splat nil)
|
||||
(def splat? (= :splat ((last members) :type)))
|
||||
(when splat?
|
||||
(when (< val-len patt-len)
|
||||
# (print "mismatched splatted list lengths")
|
||||
(break {:success false :miss [pattern value]}))
|
||||
# (print "splat!")
|
||||
(set splat (last members))
|
||||
(set members (slice members 0 (dec patt-len))))
|
||||
(when (and (not splat?) (not= val-len patt-len))
|
||||
# (print "mismatched list lengths")
|
||||
(break {:success false :miss [pattern value]}))
|
||||
(var curr-mem :^nothing)
|
||||
(var curr-val :^nothing)
|
||||
(var success true)
|
||||
(for i 0 (length members)
|
||||
(set curr-mem (get members i))
|
||||
(set curr-val (get value i))
|
||||
# (print "in list, matching " curr-val " with ")
|
||||
# (pp curr-mem)
|
||||
(def match? (match-pattern curr-mem curr-val ctx))
|
||||
# (pp match?)
|
||||
(when (not (match? :success))
|
||||
(set success false)
|
||||
(break)))
|
||||
(when (and splat? (splat :data))
|
||||
(def rest (array/slice value (length members)))
|
||||
(match-word (splat :data) rest ctx))
|
||||
(if success
|
||||
{:success true :ctx ctx}
|
||||
{:success false :miss [pattern value]}))
|
||||
|
||||
(defn- match-string [pattern value ctx]
|
||||
(when (not (string? value))
|
||||
(break {:success false :miss [pattern value]}))
|
||||
(def {:compiled compiled :bindings bindings} pattern)
|
||||
# (print "matching " value " with")
|
||||
# (pp (pattern :grammar))
|
||||
(def matches (peg/match compiled value))
|
||||
(when (not matches)
|
||||
(break {:success false :miss [pattern value]}))
|
||||
(when (not= (length matches) (length bindings))
|
||||
(error "oops: different number of matches and bindings"))
|
||||
(for i 0 (length matches)
|
||||
(set (ctx (bindings i)) (matches i)))
|
||||
{:success true :ctx ctx})
|
||||
|
||||
(defn- match-dict [pattern value ctx]
|
||||
(when (not (table? value))
|
||||
(break {:success false :miss [pattern value]}))
|
||||
(def val-size (length value))
|
||||
(var members (pattern :data))
|
||||
(def patt-len (length members))
|
||||
(when (empty? members)
|
||||
(break (if (empty? value)
|
||||
{:success true :ctx ctx}
|
||||
{:success false :miss [pattern value]})))
|
||||
(var splat nil)
|
||||
(def splat? (= :splat ((last members) :type)))
|
||||
(when splat?
|
||||
(when (< val-size patt-len)
|
||||
# (print "mismatched splatted dict lengths")
|
||||
(break {:success false :miss [pattern value]}))
|
||||
# (print "splat!")
|
||||
(set splat (last members))
|
||||
(set members (slice members 0 (dec patt-len))))
|
||||
(when (and (not splat?) (not= val-size patt-len))
|
||||
# (print "mismatched dict lengths")
|
||||
(break {:success false :miss [pattern value]}))
|
||||
(var success true)
|
||||
(def matched-keys @[])
|
||||
(for i 0 (length members)
|
||||
(def curr-pair (get members i))
|
||||
(def [curr-key curr-patt] (curr-pair :data))
|
||||
(def key (interpret curr-key ctx))
|
||||
(def curr-val (value key))
|
||||
(def match? (match-pattern curr-patt curr-val ctx))
|
||||
(array/push matched-keys key)
|
||||
(when (not (match? :success))
|
||||
(set success false)
|
||||
(break)))
|
||||
(when (and splat? (splat :data) success)
|
||||
(def rest (merge value))
|
||||
(each key matched-keys
|
||||
(set (rest key) nil))
|
||||
(match-word (splat :data) rest ctx))
|
||||
(if success
|
||||
{:success true :ctx ctx}
|
||||
{:success false :miss [pattern value]}))
|
||||
|
||||
|
||||
(defn- match-pattern* [pattern value &opt ctx]
|
||||
# (print "in match-pattern, matching " value " with:")
|
||||
# (pp pattern)
|
||||
(default ctx @{})
|
||||
(def data (pattern :data))
|
||||
(case (pattern :type)
|
||||
# always match
|
||||
:placeholder {:success true :ctx ctx}
|
||||
:ignored {:success true :ctx ctx}
|
||||
:word (match-word pattern value ctx)
|
||||
|
||||
# match on equality
|
||||
:nil {:success (nil? value) :ctx ctx}
|
||||
:bool {:success (= data value) :ctx ctx}
|
||||
:number {:success (= data value) :ctx ctx}
|
||||
:string {:success (= data value) :ctx ctx}
|
||||
:keyword {:success (= data value) :ctx ctx}
|
||||
|
||||
# TODO: lists, dicts
|
||||
:tuple (match-tuple pattern value ctx)
|
||||
:list (match-list pattern value ctx)
|
||||
:dict (match-dict pattern value ctx)
|
||||
|
||||
:interpolated (match-string pattern value ctx)
|
||||
|
||||
:typed (typed pattern value ctx)
|
||||
))
|
||||
|
||||
(set match-pattern match-pattern*)
|
||||
|
||||
(defn- lett [ast ctx]
|
||||
# (print "lett!")
|
||||
# (pp ast)
|
||||
(def [patt expr] (ast :data))
|
||||
(def value (interpret expr ctx))
|
||||
(def match? (match-pattern patt value))
|
||||
(if (match? :success)
|
||||
(do
|
||||
(merge-into ctx (match? :ctx))
|
||||
value)
|
||||
(error {:node ast :value value :msg "no match: let binding"})))
|
||||
|
||||
(defn- matchh [ast ctx]
|
||||
(def [to-match clauses] (ast :data))
|
||||
(def value (interpret to-match ctx))
|
||||
(def len (length clauses))
|
||||
(when (ast :match) (break ((ast :match) 0 value ctx)))
|
||||
(defn match-fn [i value ctx]
|
||||
(when (= len i)
|
||||
(error {:node ast :value value :msg "no match: match form"}))
|
||||
(def clause (clauses i))
|
||||
(def [patt guard expr] clause)
|
||||
(def match? (match-pattern patt value @{:^parent ctx}))
|
||||
(when (not (match? :success))
|
||||
(break (match-fn (inc i) value ctx)))
|
||||
(def body-ctx (match? :ctx))
|
||||
(def guard? (if guard
|
||||
(b/bool (interpret guard body-ctx)) true))
|
||||
(when (not guard?)
|
||||
(break (match-fn (inc i) value ctx)))
|
||||
(interpret expr body-ctx))
|
||||
(set (ast :match) match-fn)
|
||||
(match-fn 0 value ctx))
|
||||
|
||||
(defn- script [ast ctx]
|
||||
(def lines (ast :data))
|
||||
(def last-line (last lines))
|
||||
(for i 0 (-> lines length dec)
|
||||
(interpret (lines i) ctx))
|
||||
(interpret last-line ctx))
|
||||
|
||||
(defn- block [ast parent]
|
||||
(def lines (ast :data))
|
||||
(def last-line (last lines))
|
||||
(def ctx @{:^parent parent})
|
||||
(for i 0 (-> lines length dec)
|
||||
(interpret (lines i) ctx))
|
||||
(interpret last-line ctx))
|
||||
|
||||
(defn- to_string [ctx] (fn [x]
|
||||
(b/stringify (interpret x ctx))))
|
||||
|
||||
(defn- interpolated [ast ctx]
|
||||
(def terms (ast :data))
|
||||
(def interpolations (map (to_string ctx) terms))
|
||||
(string/join interpolations))
|
||||
|
||||
(defn- iff [ast ctx]
|
||||
(def [condition then else] (ast :data))
|
||||
(if (b/bool (interpret condition ctx))
|
||||
(interpret then ctx)
|
||||
(interpret else ctx)))
|
||||
|
||||
# TODO: use a tail call here
|
||||
(defn- whenn [ast ctx]
|
||||
(def clauses (ast :data))
|
||||
(var result :^nothing)
|
||||
(each clause clauses
|
||||
(def [lhs rhs] clause)
|
||||
(when (b/bool (interpret lhs ctx))
|
||||
(set result (interpret rhs ctx))
|
||||
(break)))
|
||||
(when (= result :^nothing)
|
||||
(error {:node ast :msg "no match: when form"}))
|
||||
result)
|
||||
|
||||
(defn- word [ast ctx]
|
||||
(def resolved (resolve-name (ast :data) ctx))
|
||||
(if (= :^not-found resolved)
|
||||
(error {:node ast :msg "unbound name"})
|
||||
resolved))
|
||||
|
||||
(defn- tup [ast ctx]
|
||||
(def members (ast :data))
|
||||
(def the-tup @[])
|
||||
(each member members
|
||||
(array/push the-tup (interpret member ctx)))
|
||||
[;the-tup])
|
||||
|
||||
(defn- args [ast ctx]
|
||||
(def members (ast :data))
|
||||
(def the-args @[])
|
||||
(each member members
|
||||
(array/push the-args (interpret member ctx)))
|
||||
(if (ast :partial)
|
||||
{:^type :partial :args the-args}
|
||||
[;the-args]))
|
||||
|
||||
(defn- sett [ast ctx]
|
||||
(def members (ast :data))
|
||||
(def the-set @{:^type :set})
|
||||
(each member members
|
||||
(def value (interpret member ctx))
|
||||
(set (the-set value) true))
|
||||
the-set)
|
||||
|
||||
(defn- list [ast ctx]
|
||||
(def members (ast :data))
|
||||
(def the-list @[])
|
||||
(each member members
|
||||
(if (= :splat (member :type))
|
||||
(do
|
||||
(def splatted (interpret (member :data) ctx))
|
||||
(when (not= :array (type splatted))
|
||||
(error {:node member :msg "cannot splat non-list into list"}))
|
||||
(array/concat the-list splatted))
|
||||
(array/push the-list (interpret member ctx))))
|
||||
the-list)
|
||||
|
||||
(defn- dict [ast ctx]
|
||||
(def members (ast :data))
|
||||
(def the-dict @{})
|
||||
(each member members
|
||||
(if (= :splat (member :type))
|
||||
(do
|
||||
(def splatted (interpret (member :data) ctx))
|
||||
(when (or
|
||||
(not= :table (type splatted))
|
||||
(:^type splatted))
|
||||
(error {:node member :msg "cannot splat non-dict into dict"}))
|
||||
(merge-into the-dict splatted))
|
||||
(do
|
||||
(def [key-ast value-ast] (member :data))
|
||||
# (print "dict key")
|
||||
# (pp key-ast)
|
||||
# (print "dict value")
|
||||
# (pp value-ast)
|
||||
(def key (interpret key-ast ctx))
|
||||
(def value (interpret value-ast ctx))
|
||||
(set (the-dict key) value))))
|
||||
the-dict)
|
||||
|
||||
(defn- ref [ast ctx]
|
||||
(def {:data value-ast :name name} ast)
|
||||
(def value (interpret value-ast ctx))
|
||||
(def box @{:^type :box :^value value :name name})
|
||||
(set (ctx name) box)
|
||||
box)
|
||||
|
||||
(defn- repeatt [ast ctx]
|
||||
(def [times-ast body] (ast :data))
|
||||
(def times (interpret times-ast ctx))
|
||||
(when (not (number? times))
|
||||
(error {:node times-ast :msg (string "repeat needs a `number` of times; you gave me a " (type times))}))
|
||||
(repeat times (interpret body ctx)))
|
||||
|
||||
(defn- panic [ast ctx]
|
||||
(def info (interpret (ast :data) ctx))
|
||||
(error {:node ast :msg info}))
|
||||
|
||||
# TODO: add docstrings & pattern docs to fns
|
||||
# Depends on: good string representation of patterns
|
||||
# For now, this should be enough to tall the thing
|
||||
(defn- fnn [ast ctx]
|
||||
(def {:name name :data clauses :doc doc} ast)
|
||||
# (print "defining fn " name)
|
||||
(def closure (merge ctx))
|
||||
(def the-fn @{:name name :^type :fn :body clauses :ctx closure :doc doc})
|
||||
(when (not= :^not-found (resolve-name name ctx))
|
||||
# (print "fn "name" was forward declared")
|
||||
(def fwd (resolve-name name ctx))
|
||||
(set (fwd :body) clauses)
|
||||
(set (fwd :ctx) closure)
|
||||
(set (fwd :doc) doc)
|
||||
# (print "fn " name " has been defined")
|
||||
# (pp fwd)
|
||||
(break fwd))
|
||||
# (pp the-fn)
|
||||
(set (closure name) the-fn)
|
||||
(set (ctx name) the-fn)
|
||||
the-fn)
|
||||
|
||||
(defn- is_placeholder [x] (= x :_))
|
||||
|
||||
(var call-fn nil)
|
||||
|
||||
(defn- partial [root-ast the-fn partial-args]
|
||||
(when (the-fn :applied)
|
||||
(error {:msg "cannot partially apply a partially applied function"
|
||||
:node root-ast :called the-fn :args partial-args}))
|
||||
# (print "calling partially applied function")
|
||||
(def args (partial-args :args))
|
||||
# (pp args)
|
||||
(def pos (find-index is_placeholder args))
|
||||
(def name (string (the-fn :name) " *partial*"))
|
||||
(defn partial-fn [root-ast missing]
|
||||
# (print "calling function with arg " (b/show missing))
|
||||
# (pp partial-args)
|
||||
(def full-args (array/slice args))
|
||||
(set (full-args pos) missing)
|
||||
# (print "all args: " (b/show full-args))
|
||||
(call-fn root-ast the-fn [;full-args]))
|
||||
{:^type :fn :applied true :name name :body partial-fn})
|
||||
|
||||
(defn- call-fn* [root-ast the-fn args]
|
||||
# (print "on line " (get-in root-ast [:token :line]))
|
||||
# (print "calling " (b/show the-fn))
|
||||
# (print "with args " (b/show args))
|
||||
# (pp args)
|
||||
(when (or
|
||||
(= :function (type the-fn))
|
||||
(= :cfunction (type the-fn)))
|
||||
# (print "Janet function")
|
||||
(break (the-fn ;args)))
|
||||
(def clauses (the-fn :body))
|
||||
(when (= :nothing clauses)
|
||||
(error {:node root-ast :called the-fn :value args :msg "cannot call function before it is defined"}))
|
||||
(when (= :function (type clauses))
|
||||
(break (clauses root-ast ;args)))
|
||||
(def len (length clauses))
|
||||
(when (the-fn :match) (break ((the-fn :match) 0 args)))
|
||||
(defn match-fn [i args]
|
||||
(when (= len i)
|
||||
(error {:node root-ast :called the-fn :value args :msg "no match: function call"}))
|
||||
(def clause (clauses i))
|
||||
(def [patt guard expr] clause)
|
||||
(def match?
|
||||
(match-pattern patt args @{:^parent (the-fn :ctx)}))
|
||||
(when (not (match? :success))
|
||||
(break (match-fn (inc i) args)))
|
||||
# (print "matched!")
|
||||
(def body-ctx (match? :ctx))
|
||||
(def guard? (if guard
|
||||
(b/bool (interpret guard body-ctx)) true))
|
||||
# (print "passed guard")
|
||||
(when (not guard?)
|
||||
(break (match-fn (inc i) args)))
|
||||
(interpret expr body-ctx))
|
||||
(set (the-fn :match) match-fn)
|
||||
(match-fn 0 args))
|
||||
|
||||
(set call-fn call-fn*)
|
||||
|
||||
(defn- call-partial [root-ast the-fn arg] ((the-fn :body) root-ast ;arg))
|
||||
|
||||
(defn- apply-synth-term [root-ast prev curr]
|
||||
# (print "applying " (b/show prev))
|
||||
# (print "to" (b/show curr))
|
||||
(def types [(b/ludus/type prev) (b/ludus/type curr)])
|
||||
# (print "typle:")
|
||||
# (pp types)
|
||||
(match types
|
||||
[:fn :tuple] (call-fn root-ast prev curr)
|
||||
[:fn :partial] (partial root-ast prev curr)
|
||||
[:function :tuple] (call-fn root-ast prev curr)
|
||||
# [:applied :tuple] (call-partial root-ast prev curr)
|
||||
[:keyword :args] (get (first curr) prev :^nil)
|
||||
[:dict :keyword] (get prev curr :^nil)
|
||||
[:nil :keyword] :^nil
|
||||
[:pkg :keyword] (get prev curr :^nil)
|
||||
[:pkg :pkg-kw] (get prev curr :^nil)))
|
||||
|
||||
(defn- synthetic [ast ctx]
|
||||
(def terms (ast :data))
|
||||
# (print "interpreting synthetic")
|
||||
# (pp ast)
|
||||
# (pp terms)
|
||||
(def first-term (first terms))
|
||||
(def last-term (last terms))
|
||||
(var prev (interpret first-term ctx))
|
||||
# (print "root term: ")
|
||||
# (pp prev)
|
||||
(for i 1 (-> terms length dec)
|
||||
(def curr (interpret (terms i) ctx))
|
||||
# (print "term " i ": " curr)
|
||||
(set prev (apply-synth-term first-term prev curr)))
|
||||
# (print "done with inner terms, applying last term")
|
||||
(apply-synth-term first-term prev (interpret last-term ctx)))
|
||||
|
||||
(defn- doo [ast ctx]
|
||||
(def terms (ast :data))
|
||||
(var prev (interpret (first terms) ctx))
|
||||
(def last-term (last terms))
|
||||
(for i 1 (-> terms length dec)
|
||||
(def curr (interpret (terms i) ctx))
|
||||
(set prev (call-fn (first terms) curr [prev])))
|
||||
(def last-fn (interpret last-term ctx))
|
||||
(call-fn (first terms) last-fn [prev]))
|
||||
|
||||
(defn- pkg [ast ctx]
|
||||
(def members (ast :data))
|
||||
(def the-pkg @{:^name (ast :name) :^type :pkg})
|
||||
(each member members
|
||||
(def [key-ast value-ast] (member :data))
|
||||
(def key (interpret key-ast ctx))
|
||||
(def value (interpret value-ast ctx))
|
||||
(set (the-pkg key) value))
|
||||
# (pp the-pkg)
|
||||
(def out (table/to-struct the-pkg))
|
||||
(set (ctx (ast :name)) out)
|
||||
out)
|
||||
|
||||
(defn- loopp [ast ctx]
|
||||
# (print "looping!")
|
||||
(def data (ast :data))
|
||||
(def args (interpret (data 0) ctx))
|
||||
# this doesn't work: context persists between different interpretations
|
||||
# we want functions to work this way, but not loops (I think)
|
||||
# (when (ast :match) (break ((ast :match) 0 args)))
|
||||
(def clauses (data 1))
|
||||
(def len (length clauses))
|
||||
(var loop-ctx @{:^parent ctx})
|
||||
(defn match-fn [i args]
|
||||
(when (= len i)
|
||||
(error {:node ast :value args :msg "no match: loop"}))
|
||||
(def clause (clauses i))
|
||||
(def [patt guard expr] clause)
|
||||
(def match?
|
||||
(match-pattern patt args loop-ctx))
|
||||
(when (not (match? :success))
|
||||
# (print "no match")
|
||||
(break (match-fn (inc i) args)))
|
||||
# (print "matched!")
|
||||
(def body-ctx (match? :ctx))
|
||||
(def guard? (if guard
|
||||
(b/bool (interpret guard body-ctx)) true))
|
||||
# (print "passed guard")
|
||||
(when (not guard?)
|
||||
(break (match-fn (inc i) args)))
|
||||
(interpret expr body-ctx))
|
||||
(set (ast :match) match-fn)
|
||||
(set (loop-ctx :^recur) match-fn)
|
||||
# (print "ATTACHED MATCH-FN")
|
||||
(match-fn 0 args))
|
||||
|
||||
(defn- recur [ast ctx]
|
||||
# (print "recurring!")
|
||||
(def passed (ast :data))
|
||||
(def args (interpret passed ctx))
|
||||
(def match-fn (resolve-name :^recur ctx))
|
||||
# (print "match fn in ctx:")
|
||||
# (pp (ctx :^recur))
|
||||
# (pp match-fn)
|
||||
# (pp ctx)
|
||||
(match-fn 0 args))
|
||||
|
||||
# TODO for 0.1.0
|
||||
(defn- testt [ast ctx] (todo "test"))
|
||||
|
||||
(defn- ns [ast ctx] (todo "nses"))
|
||||
|
||||
(defn- importt [ast ctx] (todo "imports"))
|
||||
|
||||
(defn- withh [ast ctx] (todo "with"))
|
||||
|
||||
(defn- usee [ast ctx] (todo "use"))
|
||||
|
||||
(defn- interpret* [ast ctx]
|
||||
# (print "interpreting node " (ast :type))
|
||||
(case (ast :type)
|
||||
# literals
|
||||
:nil :^nil
|
||||
:number (ast :data)
|
||||
:bool (ast :data)
|
||||
:string (ast :data)
|
||||
:keyword (ast :data)
|
||||
:placeholder :_
|
||||
|
||||
# collections
|
||||
:tuple (tup ast ctx)
|
||||
:args (args ast ctx)
|
||||
:list (list ast ctx)
|
||||
:set (sett ast ctx)
|
||||
:dict (dict ast ctx)
|
||||
|
||||
# composite forms
|
||||
:if (iff ast ctx)
|
||||
:block (block ast ctx)
|
||||
:when (whenn ast ctx)
|
||||
:script (script ast ctx)
|
||||
:panic (panic ast ctx)
|
||||
|
||||
# looping forms
|
||||
:loop (loopp ast ctx)
|
||||
:recur (recur ast ctx)
|
||||
:repeat (repeatt ast ctx)
|
||||
|
||||
# named/naming forms
|
||||
:word (word ast ctx)
|
||||
:interpolated (interpolated ast ctx)
|
||||
:ref (ref ast ctx)
|
||||
:pkg (pkg ast ctx)
|
||||
:pkg-name (word ast ctx)
|
||||
|
||||
# patterned forms
|
||||
:let (lett ast ctx)
|
||||
:match (matchh ast ctx)
|
||||
|
||||
# functions
|
||||
:fn (fnn ast ctx)
|
||||
|
||||
# synthetic
|
||||
:synthetic (synthetic ast ctx)
|
||||
|
||||
# do
|
||||
:do (doo ast ctx)
|
||||
|
||||
# deferred until after computer class
|
||||
# :with (withh ast ctx)
|
||||
# :import (importt ast ctx)
|
||||
# :ns (ns ast ctx)
|
||||
# :use (usee ast ctx)
|
||||
# :test (testt ast ctx)
|
||||
|
||||
))
|
||||
|
||||
(set interpret interpret*)
|
||||
|
||||
# # repl
|
||||
# (import ./scanner :as s)
|
||||
# (import ./parser :as p)
|
||||
# (import ./validate :as v)
|
||||
|
||||
# (var source nil)
|
||||
|
||||
# (defn- has-errors? [{:errors errors}] (and errors (not (empty? errors))))
|
||||
|
||||
# (defn run []
|
||||
# (def scanned (s/scan source))
|
||||
# (when (has-errors? scanned) (break (scanned :errors)))
|
||||
# (def parsed (p/parse scanned))
|
||||
# (when (has-errors? parsed) (break (parsed :errors)))
|
||||
# (def validated (v/valid parsed b/ctx))
|
||||
# # (when (has-errors? validated) (break (validated :errors)))
|
||||
# # (def cleaned (get-in parsed [:ast :data 1]))
|
||||
# # # (pp cleaned)
|
||||
# # (interpret (parsed :ast) @{:^parent b/ctx})
|
||||
# (try (interpret (parsed :ast) @{:^parent b/ctx})
|
||||
# ([e] (if (struct? e) (error (e :msg)) (error e)))))
|
||||
|
||||
# # (do
|
||||
# (comment
|
||||
# (set source `
|
||||
|
||||
# `)
|
||||
# (def result (run))
|
||||
# )
|
||||
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#!/opt/homebrew/bin/fish
|
||||
|
||||
set FILE $argv[1]
|
||||
set TESTFILE (string join "" $FILE ".tested")
|
||||
judge $FILE
|
||||
if test -e $TESTFILE
|
||||
cp $TESTFILE $FILE
|
||||
rm $TESTFILE
|
||||
end
|
||||
|
|
@ -1,371 +0,0 @@
|
|||
# testing Ludus langauge constructs
|
||||
(try (os/cd "janet") ([_] nil)) # for REPL
|
||||
(import /scanner :as s)
|
||||
(import /parser :as p)
|
||||
(import /validate :as v)
|
||||
(import /interpreter :as i)
|
||||
(import /errors :as e)
|
||||
(import /base :as b)
|
||||
|
||||
(use judge)
|
||||
|
||||
(defn run [source]
|
||||
(def ctx @{})
|
||||
(def scanned (s/scan source :test))
|
||||
(when (any? (scanned :errors))
|
||||
(e/scan-error (scanned :errors)) (error "scanning errors"))
|
||||
(def parsed (p/parse scanned))
|
||||
(when (any? (parsed :errors))
|
||||
(e/parse-error (parsed :errors)) (error "parsing errors"))
|
||||
(def valid (v/valid parsed ctx))
|
||||
(when (any? (valid :errors)) (each err (valid :errors)
|
||||
(e/validation-error err)) (error "validation errors"))
|
||||
(i/interpret (parsed :ast) ctx))
|
||||
|
||||
(deftest "returns bare values from single-line scripts"
|
||||
(test (run "true") true)
|
||||
(test (run "false") false)
|
||||
(test (run "nil") :^nil)
|
||||
(test (run "12.34") 12.34)
|
||||
(test (run "-32") -32)
|
||||
(test (run "0") 0)
|
||||
(test (run ":foo") :foo)
|
||||
(test (run ":bar") :bar)
|
||||
(test (run `"a string, a text, a language"`) "a string, a text, a language"))
|
||||
|
||||
(deftest "returns empty collections from single-line scripts"
|
||||
(test (run "()") [])
|
||||
(test (run "#{}") @{})
|
||||
(test (run "${}") @{:^type :set})
|
||||
(test (run "[]") @[]))
|
||||
|
||||
(deftest "returns populated collections from single-line scripts"
|
||||
(test (run "(1, 2, 3)") [1 2 3])
|
||||
(test (run "[:a, :b, :c]") @[:a :b :c])
|
||||
(test (run "${1, 2, 3, 3}") @{1 true 2 true 3 true :^type :set})
|
||||
(test (run "#{:a 1, :b 2}") @{:a 1 :b 2}))
|
||||
|
||||
(deftest "returns nested collections from single-line scripts"
|
||||
(test (run "((), (1, 2), [:a, (:b)], #{:foo true, :bar false})")
|
||||
[[]
|
||||
[1 2]
|
||||
@[:a [:b]]
|
||||
@{:bar false :foo true}])
|
||||
(test (run `#{:foo #{:bar "thing", :baz (1, :foo, nil)}}`) @{:foo @{:bar "thing" :baz [1 :foo :^nil]}}))
|
||||
|
||||
(deftest "binds names in let bindings with various patterns"
|
||||
(test (run `let foo = :bar; foo`) :bar)
|
||||
(test (run `let 42 = 42`) 42)
|
||||
(test (run `let foo = :bar; let quux = 42; (foo, quux)`) [:bar 42])
|
||||
(test (run `let (:ok, value) = (:ok, 42); value`) 42)
|
||||
(test (run `let #{:a x, ...} = #{:a 1, :b 2}; x`) 1))
|
||||
|
||||
(deftest "executes if/then/else properly"
|
||||
(test (run `if nil then :foo else :bar`) :bar)
|
||||
(test (run `if false then :foo else :bar`) :bar)
|
||||
(test (run `if true then :foo else :bar`) :foo)
|
||||
(test (run `if 42 then :foo else panic! "oops"`) :foo))
|
||||
|
||||
(deftest "panics"
|
||||
(test-error (run `panic! "oops"`)
|
||||
{:msg "oops"
|
||||
:node {:data {:data "oops"
|
||||
:token {:input :test
|
||||
:lexeme "\"oops\""
|
||||
:line 1
|
||||
:literal "oops"
|
||||
:source "panic! \"oops\""
|
||||
:start 7
|
||||
:type :string}
|
||||
:type :string}
|
||||
:token {:input :test
|
||||
:lexeme "panic!"
|
||||
:line 1
|
||||
:literal :none
|
||||
:source "panic! \"oops\""
|
||||
:start 0
|
||||
:type :panic}
|
||||
:type :panic}})
|
||||
)
|
||||
|
||||
(deftest "no match in let panics"
|
||||
(test-error (run "let :foo = :bar")
|
||||
{:msg "no match: let binding"
|
||||
:node {:data @[{:data :foo
|
||||
:token {:input :test
|
||||
:lexeme ":foo"
|
||||
:line 1
|
||||
:literal :foo
|
||||
:source "let :foo = :bar"
|
||||
:start 4
|
||||
:type :keyword}
|
||||
:type :keyword}
|
||||
{:data :bar
|
||||
:token {:input :test
|
||||
:lexeme ":bar"
|
||||
:line 1
|
||||
:literal :bar
|
||||
:source "let :foo = :bar"
|
||||
:start 11
|
||||
:type :keyword}
|
||||
:type :keyword}]
|
||||
:token {:input :test
|
||||
:lexeme "let"
|
||||
:line 1
|
||||
:literal :none
|
||||
:source "let :foo = :bar"
|
||||
:start 0
|
||||
:type :let}
|
||||
:type :let}
|
||||
:value :bar})
|
||||
)
|
||||
|
||||
(deftest "blocks execute code and work"
|
||||
(test (run `
|
||||
let bar = 12
|
||||
let foo = {
|
||||
let bar = 42
|
||||
let baz = :quux
|
||||
:foo
|
||||
}
|
||||
(foo, bar)
|
||||
`)
|
||||
[:foo 12])
|
||||
(test (run `
|
||||
let foo = {
|
||||
let bar = 12
|
||||
{
|
||||
let bar = 15
|
||||
bar
|
||||
}
|
||||
}
|
||||
`)
|
||||
15))
|
||||
|
||||
(deftest "unbound name panics"
|
||||
(test-error (run `foo`) "validation errors"))
|
||||
|
||||
(deftest "rebinding name panics"
|
||||
(test-error (run `let foo = 42; let foo = 23`) "validation errors"))
|
||||
|
||||
(deftest "when forms work as expected"
|
||||
(test (run `
|
||||
when {
|
||||
false -> :nope
|
||||
nil -> :nope
|
||||
12 -> :yes
|
||||
}
|
||||
`)
|
||||
:yes)
|
||||
(test-error (run `
|
||||
when {
|
||||
false -> :nope
|
||||
nil -> :nope
|
||||
}
|
||||
`)
|
||||
{:msg "no match: when form"
|
||||
:node {:data @[[{:data false
|
||||
:token {:input :test
|
||||
:lexeme "false"
|
||||
:line 2
|
||||
:literal false
|
||||
:source " when {\n false -> :nope\n nil -> :nope\n }\n "
|
||||
:start 12
|
||||
:type :false}
|
||||
:type :bool}
|
||||
{:data :nope
|
||||
:token {:input :test
|
||||
:lexeme ":nope"
|
||||
:line 2
|
||||
:literal :nope
|
||||
:source " when {\n false -> :nope\n nil -> :nope\n }\n "
|
||||
:start 21
|
||||
:type :keyword}
|
||||
:type :keyword}]
|
||||
[{:token {:input :test
|
||||
:lexeme "nil"
|
||||
:line 3
|
||||
:literal :none
|
||||
:source " when {\n false -> :nope\n nil -> :nope\n }\n "
|
||||
:start 30
|
||||
:type :nil}
|
||||
:type :nil}
|
||||
{:data :nope
|
||||
:token {:input :test
|
||||
:lexeme ":nope"
|
||||
:line 3
|
||||
:literal :nope
|
||||
:source " when {\n false -> :nope\n nil -> :nope\n }\n "
|
||||
:start 37
|
||||
:type :keyword}
|
||||
:type :keyword}]]
|
||||
:token {:input :test
|
||||
:lexeme "when"
|
||||
:line 1
|
||||
:literal :none
|
||||
:source " when {\n false -> :nope\n nil -> :nope\n }\n "
|
||||
:start 2
|
||||
:type :when}
|
||||
:type :when}})
|
||||
)
|
||||
|
||||
(deftest "match forms work as expected"
|
||||
(test (run `
|
||||
match :foo with {
|
||||
:bar -> :nope
|
||||
:baz -> :nope
|
||||
x -> x
|
||||
}
|
||||
`)
|
||||
:foo)
|
||||
(test (run `
|
||||
let foo = 42
|
||||
match (:ok, foo) with {
|
||||
(:err, _) -> :nope
|
||||
(:ok, :foo) -> :nope
|
||||
(:ok, _) -> :yes
|
||||
}
|
||||
`)
|
||||
:yes)
|
||||
(test-error (run `
|
||||
let foo = "foo"
|
||||
match foo with {
|
||||
"bar" -> :nope
|
||||
"baz" -> :nope
|
||||
12.34 -> :nope
|
||||
}
|
||||
`)
|
||||
{:msg "no match: match form"
|
||||
:node @{:data [{:data "foo"
|
||||
:token {:input :test
|
||||
:lexeme "foo"
|
||||
:line 2
|
||||
:literal :none
|
||||
:source " let foo = \"foo\"\n match foo with {\n \"bar\" -> :nope\n \"baz\" -> :nope\n 12.34 -> :nope \n }\n "
|
||||
:start 26
|
||||
:type :word}
|
||||
:type :word}
|
||||
@[[{:data "bar"
|
||||
:token {:input :test
|
||||
:lexeme "\"bar\""
|
||||
:line 3
|
||||
:literal "bar"
|
||||
:source " let foo = \"foo\"\n match foo with {\n \"bar\" -> :nope\n \"baz\" -> :nope\n 12.34 -> :nope \n }\n "
|
||||
:start 40
|
||||
:type :string}
|
||||
:type :string}
|
||||
nil
|
||||
{:data :nope
|
||||
:token {:input :test
|
||||
:lexeme ":nope"
|
||||
:line 3
|
||||
:literal :nope
|
||||
:source " let foo = \"foo\"\n match foo with {\n \"bar\" -> :nope\n \"baz\" -> :nope\n 12.34 -> :nope \n }\n "
|
||||
:start 49
|
||||
:type :keyword}
|
||||
:type :keyword}]
|
||||
[{:data "baz"
|
||||
:token {:input :test
|
||||
:lexeme "\"baz\""
|
||||
:line 4
|
||||
:literal "baz"
|
||||
:source " let foo = \"foo\"\n match foo with {\n \"bar\" -> :nope\n \"baz\" -> :nope\n 12.34 -> :nope \n }\n "
|
||||
:start 58
|
||||
:type :string}
|
||||
:type :string}
|
||||
nil
|
||||
{:data :nope
|
||||
:token {:input :test
|
||||
:lexeme ":nope"
|
||||
:line 4
|
||||
:literal :nope
|
||||
:source " let foo = \"foo\"\n match foo with {\n \"bar\" -> :nope\n \"baz\" -> :nope\n 12.34 -> :nope \n }\n "
|
||||
:start 67
|
||||
:type :keyword}
|
||||
:type :keyword}]
|
||||
[{:data 12.34
|
||||
:token {:input :test
|
||||
:lexeme "12.34"
|
||||
:line 5
|
||||
:literal 12.34
|
||||
:source " let foo = \"foo\"\n match foo with {\n \"bar\" -> :nope\n \"baz\" -> :nope\n 12.34 -> :nope \n }\n "
|
||||
:start 76
|
||||
:type :number}
|
||||
:type :number}
|
||||
nil
|
||||
{:data :nope
|
||||
:token {:input :test
|
||||
:lexeme ":nope"
|
||||
:line 5
|
||||
:literal :nope
|
||||
:source " let foo = \"foo\"\n match foo with {\n \"bar\" -> :nope\n \"baz\" -> :nope\n 12.34 -> :nope \n }\n "
|
||||
:start 85
|
||||
:type :keyword}
|
||||
:type :keyword}]]]
|
||||
:match @match-fn
|
||||
:token {:input :test
|
||||
:lexeme "match"
|
||||
:line 2
|
||||
:literal :none
|
||||
:source " let foo = \"foo\"\n match foo with {\n \"bar\" -> :nope\n \"baz\" -> :nope\n 12.34 -> :nope \n }\n "
|
||||
:start 20
|
||||
:type :match}
|
||||
:type :match}
|
||||
:value "foo"})
|
||||
)
|
||||
|
||||
(deftest "string patterns work as expected"
|
||||
(test (run `let "I {verb} the {noun}" = "I am the walrus"; (verb, noun)`) ["am" "walrus"])
|
||||
(test (run `let "a {b} c {d}" = "a because I love you c yourself out the door"; (b, d)`)
|
||||
["because I love you"
|
||||
"yourself out the door"])
|
||||
)
|
||||
|
||||
(deftest "lambdas may be defined and called"
|
||||
(test (run `
|
||||
let foo = fn () -> :foo
|
||||
foo ()
|
||||
`)
|
||||
:foo)
|
||||
(test (run `
|
||||
let pair = fn (x, y) -> (x, y)
|
||||
pair (:foo, :bar)
|
||||
`)
|
||||
[:foo :bar])
|
||||
(test-error (run `
|
||||
let foo = fn () -> :foo
|
||||
foo (:bar)
|
||||
`)
|
||||
{:called @{:^type :fn
|
||||
:body [[{:data @[]
|
||||
:token {:input :test
|
||||
:lexeme "("
|
||||
:line 1
|
||||
:source " let foo = fn () -> :foo\n foo (:bar)\n "
|
||||
:start 15
|
||||
:type :lparen}
|
||||
:type :tuple}
|
||||
nil
|
||||
{:data :foo
|
||||
:token {:input :test
|
||||
:lexeme ":foo"
|
||||
:line 1
|
||||
:literal :foo
|
||||
:source " let foo = fn () -> :foo\n foo (:bar)\n "
|
||||
:start 21
|
||||
:type :keyword}
|
||||
:type :keyword}]]
|
||||
:ctx @{}
|
||||
:match @match-fn}
|
||||
:msg "no match: function call"
|
||||
:node {:data "foo"
|
||||
:token {:input :test
|
||||
:lexeme "foo"
|
||||
:line 2
|
||||
:literal :none
|
||||
:source " let foo = fn () -> :foo\n foo (:bar)\n "
|
||||
:start 28
|
||||
:type :word}
|
||||
:type :word}
|
||||
:value [:bar]})
|
||||
)
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
# an integrated Ludus interpreter
|
||||
# devised in order to run under wasm
|
||||
# takes a string, returns a string with a json object
|
||||
# (try (os/cd "janet") ([_] nil)) # for REPL
|
||||
(import /src/scanner :as s)
|
||||
(import /src/parser :as p)
|
||||
(import /src/validate :as v)
|
||||
(import /src/interpreter :as i)
|
||||
(import /src/errors :as e)
|
||||
(import /src/base :as b)
|
||||
(import /src/prelude :as prelude)
|
||||
|
||||
(defn ludus [source]
|
||||
(when (= :error prelude/pkg) (error "could not load prelude"))
|
||||
(def ctx @{:^parent prelude/ctx})
|
||||
(def errors @[])
|
||||
(def draw @[])
|
||||
(var result @"")
|
||||
(def console @"")
|
||||
(def out @{:errors errors :draw draw :result result :console console})
|
||||
(def scanned (s/scan source))
|
||||
(when (any? (scanned :errors))
|
||||
(set (out :errors) (scanned :errors))
|
||||
(each err (scanned :errors)
|
||||
(e/scan-error err))
|
||||
(break out))
|
||||
(def parsed (p/parse scanned))
|
||||
(when (any? (parsed :errors))
|
||||
(set (out :errors) (parsed :errors))
|
||||
(each err (parsed :errors)
|
||||
(e/parse-error err))
|
||||
(break out))
|
||||
(def validated (v/valid parsed ctx))
|
||||
(when (any? (validated :errors))
|
||||
(set (out :errors) (validated :errors))
|
||||
(each err (validated :errors)
|
||||
(e/validation-error err))
|
||||
(break out))
|
||||
(setdyn :out console)
|
||||
(try
|
||||
(set result (i/interpret (parsed :ast) ctx))
|
||||
([err]
|
||||
(e/runtime-error err)
|
||||
(set (out :errors) [err])
|
||||
(break out)))
|
||||
(setdyn :out stdout)
|
||||
(set (out :result) (b/show result))
|
||||
(var post @{})
|
||||
(try
|
||||
(set post (i/interpret prelude/post/ast ctx))
|
||||
([err] (e/runtime-error err)))
|
||||
(set (out :draw) (post :draw))
|
||||
(b/json out))
|
||||
|
||||
2
src/ludus/ast.cljc
Normal file
2
src/ludus/ast.cljc
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
(ns ludus.ast)
|
||||
|
||||
429
src/ludus/base.cljc
Normal file
429
src/ludus/base.cljc
Normal file
|
|
@ -0,0 +1,429 @@
|
|||
(ns ludus.base
|
||||
(:require
|
||||
[ludus.data :as data]
|
||||
[ludus.show :as show]
|
||||
[clojure.math :as math]
|
||||
;[ludus.draw :as d]
|
||||
#?(:cljs [cljs.reader])
|
||||
#?(:cljs [goog.object :as o])
|
||||
))
|
||||
|
||||
;; TODO: make eq, and, or special forms that short-circuit
|
||||
;; Right now, they evaluate all their args
|
||||
(def eq {:name "eq"
|
||||
::data/type ::data/clj
|
||||
:body =})
|
||||
|
||||
(defn- id [x] x)
|
||||
|
||||
(def and- {:name "and"
|
||||
::data/type ::data/clj
|
||||
:body (fn [& args] (every? id args))})
|
||||
|
||||
(def or- {:name "or"
|
||||
::data/type ::data/clj
|
||||
:body (fn [& args] (some id args))})
|
||||
|
||||
(def add {:name "add"
|
||||
::data/type ::data/clj
|
||||
:body +})
|
||||
|
||||
(def sub {:name "sub"
|
||||
::data/type ::data/clj
|
||||
:body -})
|
||||
|
||||
(def mult {:name "mult"
|
||||
::data/type ::data/clj
|
||||
:body *})
|
||||
|
||||
(def div {:name "div"
|
||||
::data/type ::data/clj
|
||||
:body /})
|
||||
|
||||
(def gt {:name "gt"
|
||||
::data/type ::data/clj
|
||||
:body >})
|
||||
|
||||
(def gte {:name "gte"
|
||||
::data/type ::data/clj
|
||||
:body >=})
|
||||
|
||||
(def lt {:name "lt"
|
||||
::data/type ::data/clj
|
||||
:body <})
|
||||
|
||||
(def lte {:name "lte"
|
||||
::data/type ::data/clj
|
||||
:body <=})
|
||||
|
||||
(def inc- {:name "inc"
|
||||
::data/type ::data/clj
|
||||
:body inc})
|
||||
|
||||
(def dec- {:name "dec"
|
||||
::data/type ::data/clj
|
||||
:body dec})
|
||||
|
||||
(def not- {:name "not"
|
||||
::data/type ::data/clj
|
||||
:body not})
|
||||
|
||||
(defn- print-show [lvalue]
|
||||
(if (string? lvalue) lvalue (show/show lvalue)))
|
||||
|
||||
(defn- stringify-args [arglist]
|
||||
(apply str (interpose " " (into [] (map print-show) (rest arglist)))))
|
||||
; (def panic! {:name "panic!"
|
||||
; ::data/type ::data/clj
|
||||
; :body (fn panic-inner
|
||||
; ([] (panic-inner [::data/list]))
|
||||
; ([args] (throw (ex-info (stringify-args args) {}))))})
|
||||
|
||||
(def print- {:name "print"
|
||||
::data/type ::data/clj
|
||||
:body (fn [args]
|
||||
(println (stringify-args args))
|
||||
:ok)})
|
||||
|
||||
(def deref- {:name "deref"
|
||||
::data/type ::data/clj
|
||||
:body (fn [ref]
|
||||
(if (::data/ref ref)
|
||||
(deref (::data/value ref))
|
||||
(throw (ex-info "Cannot deref something that is not a ref" {}))))})
|
||||
|
||||
(def set!- {:name "set!"
|
||||
::data/type ::data/clj
|
||||
:body (fn [ref value]
|
||||
(if (::data/ref ref)
|
||||
(reset! (::data/value ref) value)
|
||||
(throw (ex-info "Cannot set! something that is not a ref" {}))))})
|
||||
|
||||
(def show {:name "show"
|
||||
::data/type ::data/clj
|
||||
:body ludus.show/show})
|
||||
|
||||
(def conj- {:name "conj"
|
||||
::data/type ::data/clj
|
||||
:body conj})
|
||||
|
||||
(def assoc- {:name "assoc"
|
||||
::data/type ::data/clj
|
||||
:body assoc})
|
||||
|
||||
(def dissoc- {name "dissoc"
|
||||
::data/type ::data/clj
|
||||
:body dissoc})
|
||||
|
||||
(def get- {:name "get"
|
||||
::data/type ::data/clj
|
||||
:body (fn
|
||||
([key, map]
|
||||
(if (map? map)
|
||||
(get map key)
|
||||
nil))
|
||||
([key, map, default]
|
||||
(if (map? map)
|
||||
(get map key default)
|
||||
default)))})
|
||||
|
||||
(def rest- {:name "rest"
|
||||
::data/type ::data/clj
|
||||
:body (fn [v]
|
||||
(into [::data/list] (nthrest v 2)))})
|
||||
|
||||
(def nth- {:name "nth"
|
||||
::data/type ::data/clj
|
||||
:body nth})
|
||||
|
||||
(def slice {:name "slice"
|
||||
::data/type ::data/clj
|
||||
:body subvec})
|
||||
|
||||
(def types {
|
||||
:keyword
|
||||
#?(
|
||||
:clj clojure.lang.Keyword
|
||||
:cljs cljs.core/Keyword
|
||||
)
|
||||
|
||||
:long
|
||||
#?(
|
||||
:clj java.lang.Long
|
||||
:cljs js/Number
|
||||
)
|
||||
|
||||
:double
|
||||
#?(
|
||||
:clj java.lang.Double
|
||||
:cljs js/Number
|
||||
)
|
||||
|
||||
:integer
|
||||
#?(
|
||||
:clj java.lang.Integer
|
||||
:cljs js/Number
|
||||
)
|
||||
|
||||
:ratio
|
||||
#?(
|
||||
:clj clojure.lang.Ratio
|
||||
:cljs js/Number
|
||||
)
|
||||
|
||||
:string
|
||||
#?(
|
||||
:clj java.lang.String
|
||||
:cljs js/String
|
||||
)
|
||||
|
||||
:boolean
|
||||
#?(
|
||||
:clj java.lang.Boolean
|
||||
:cljs js/Boolean
|
||||
)
|
||||
|
||||
:set
|
||||
#?(
|
||||
:clj clojure.lang.PersistentHashSet
|
||||
:cljs cljs.core/PersistentHashSet
|
||||
)
|
||||
|
||||
:vector
|
||||
#?(
|
||||
:clj clojure.lang.PersistentVector
|
||||
:cljs cljs.core/PersistentVector
|
||||
)
|
||||
|
||||
:map
|
||||
#?(
|
||||
:clj clojure.lang.PersistentArrayMap
|
||||
:cljs cljs.core/PersistentArrayMap
|
||||
)
|
||||
})
|
||||
|
||||
(defn get-type [value]
|
||||
(let [t (type value)]
|
||||
(cond
|
||||
(nil? value) :nil
|
||||
|
||||
(= (:keyword types) t) :keyword
|
||||
|
||||
(= (:long types) t) :number
|
||||
|
||||
(= (:double types) t) :number
|
||||
|
||||
(= (:integer types) t) :number
|
||||
|
||||
(= (:ratio types) t) :number
|
||||
|
||||
(= (:string types) t) :string
|
||||
|
||||
(= (:boolean types) t) :boolean
|
||||
|
||||
(= (:set types) t) :set
|
||||
|
||||
;; tuples and lists
|
||||
(= (:vector types) t)
|
||||
(if (= ::data/tuple (first value)) :tuple :list)
|
||||
|
||||
;; structs dicts namespaces refs
|
||||
(= (:map types) t)
|
||||
(cond
|
||||
(::data/type value) (case (::data/type value)
|
||||
(::data/fn ::data/clj) :fn
|
||||
::data/ns :ns)
|
||||
(::data/dict value) :dict
|
||||
(::data/struct value) :struct
|
||||
(::data/ref value) :ref
|
||||
:else :none
|
||||
))))
|
||||
|
||||
(def type- {:name "type"
|
||||
::data/type ::data/clj
|
||||
:body get-type})
|
||||
|
||||
(defn- kv->tuple [[k v]] [::data/tuple k v])
|
||||
|
||||
(def to_list {name "to_list"
|
||||
::data/type ::data/clj
|
||||
:body (fn [item]
|
||||
(case (get-type item)
|
||||
(:number :nil :boolean :fn :string :ref :keyword) [::data/list item]
|
||||
:list item
|
||||
:set (into [::data/list] item)
|
||||
:tuple (into [::data/list] (rest item))
|
||||
:dict (into [::data/list] (map kv->tuple) (dissoc item ::data/dict))
|
||||
:struct (into [::data/list] (map kv->tuple) (dissoc item ::data/struct))
|
||||
:ns (into [::data/list] (map kv->tuple) (dissoc item ::data/struct ::data/type ::data/name))
|
||||
))})
|
||||
|
||||
(def to_dict {name "to_dict"
|
||||
::data/type ::data/clj
|
||||
:body (fn [struct] (-> struct (assoc ::data/dict true) (dissoc ::data/struct ::data/type ::data/name)))})
|
||||
|
||||
(defn strpart [kw] (->> kw str rest (apply str)))
|
||||
|
||||
(def readstr
|
||||
#?(
|
||||
:clj read-string
|
||||
:cljs cljs.reader/read-string
|
||||
))
|
||||
|
||||
(defn- resolve-str [str]
|
||||
#?(
|
||||
:clj (eval str)
|
||||
:cljs (.bind (o/get js/window str) js/window)
|
||||
))
|
||||
|
||||
(def extern {:name "extern"
|
||||
::data/type ::data/clj
|
||||
:body (fn [& args]
|
||||
;(println "Args passed: " args)
|
||||
(let [called (-> args first strpart readstr resolve-str)
|
||||
fn-args (rest args)]
|
||||
;(println "Fn: " called)
|
||||
;(println "Args: " (clj->js fn-args))
|
||||
#?(
|
||||
:clj (apply called fn-args)
|
||||
:cljs (.apply called js/window (clj->js fn-args)))))})
|
||||
|
||||
(def count- {:name "count"
|
||||
::data/type ::data/clj
|
||||
:body count})
|
||||
|
||||
(def into- {:name "into"
|
||||
::data/type ::data/clj
|
||||
:body into})
|
||||
|
||||
(def to_vec {:name "to_vec"
|
||||
::data/type ::data/clj
|
||||
:body (fn [xs] (into [] (dissoc xs ::data/type ::data/struct ::data/name)))})
|
||||
|
||||
(def fold {:name "fold"
|
||||
::data/type ::data/clj
|
||||
:body reduce})
|
||||
|
||||
(def map- {:name "map"
|
||||
::data/type ::data/clj
|
||||
:body map})
|
||||
|
||||
(def prn- {:name "raw"
|
||||
::data/type ::data/clj
|
||||
:body println})
|
||||
|
||||
(def concat- {:name "concat"
|
||||
::data/type ::data/clj
|
||||
:body (fn [xs ys]
|
||||
(if (= ::data/list (first xs))
|
||||
(into [::data/list] (concat (rest xs) (rest ys)))
|
||||
(into #{} (concat xs ys))))})
|
||||
|
||||
(def str- {:name "str"
|
||||
::data/type ::data/clj
|
||||
:body str})
|
||||
|
||||
(def doc- {:name "doc"
|
||||
::data/type ::data/clj
|
||||
:body (fn [f]
|
||||
(let [name (:name f)
|
||||
docstring (:doc f)
|
||||
clauses (:clauses f)
|
||||
patterns (map first clauses)
|
||||
pretty-patterns (map show/show-pattern patterns)
|
||||
doc (into [name docstring] pretty-patterns)]
|
||||
(apply str (interpose "\n" doc)))
|
||||
)})
|
||||
|
||||
(def sin {:name "sin"
|
||||
::data/type ::data/clj
|
||||
:body math/sin})
|
||||
|
||||
(def cos {:name "cos"
|
||||
::data/type ::data/clj
|
||||
:body math/cos})
|
||||
|
||||
(def tan {:name "tan"
|
||||
::data/type ::data/clj
|
||||
:body math/tan})
|
||||
|
||||
(def atan_2 {:name "atan_2"
|
||||
::data/type ::data/clj
|
||||
:body math/atan2})
|
||||
|
||||
(def sqrt {:name "sqrt"
|
||||
::data/type ::data/clj
|
||||
:body math/sqrt})
|
||||
|
||||
(def random {:name "random"
|
||||
::data/type ::data/clj
|
||||
:body rand})
|
||||
|
||||
(def floor {:name "floor"
|
||||
::data/type ::data/clj
|
||||
:body math/floor})
|
||||
|
||||
(def ceil {:name "ceil"
|
||||
::data/type ::data/clj
|
||||
:body math/ceil})
|
||||
|
||||
(def round {:name "round"
|
||||
::data/type ::data/clj
|
||||
:body math/round})
|
||||
|
||||
(def range- {:name "range"
|
||||
::data/type ::data/clj
|
||||
:body (fn [start end] (into [::data/list] (range (-> start math/ceil int) end)))})
|
||||
|
||||
(def base {
|
||||
:id id
|
||||
:eq eq
|
||||
:add add
|
||||
:print print-
|
||||
:sub sub
|
||||
:mult mult
|
||||
:div div
|
||||
:gt gt
|
||||
:gte gte
|
||||
:lt lt
|
||||
:lte lte
|
||||
:inc inc-
|
||||
:dec dec-
|
||||
:not not-
|
||||
:show show
|
||||
:deref deref-
|
||||
:set! set!-
|
||||
:and and-
|
||||
:or or-
|
||||
:assoc assoc-
|
||||
:dissoc dissoc-
|
||||
:conj conj-
|
||||
:get get-
|
||||
:type type-
|
||||
:extern extern
|
||||
:rest rest-
|
||||
:nth nth-
|
||||
:slice slice
|
||||
:count count-
|
||||
:into into-
|
||||
:to_vec to_vec
|
||||
:fold fold
|
||||
:map map
|
||||
; :panic! panic!
|
||||
:prn prn-
|
||||
:concat concat-
|
||||
:str str-
|
||||
:to_list to_list
|
||||
:doc doc-
|
||||
:pi math/PI
|
||||
:sin sin
|
||||
:cos cos
|
||||
:tan tan
|
||||
:atan_2 atan_2
|
||||
:sqrt sqrt
|
||||
:random random
|
||||
:ceil ceil
|
||||
:floor floor
|
||||
:round round
|
||||
:range range-
|
||||
})
|
||||
1
src/ludus/collections.cljc
Normal file
1
src/ludus/collections.cljc
Normal file
|
|
@ -0,0 +1 @@
|
|||
(ns ludus.collections)
|
||||
38
src/ludus/core.clj
Normal file
38
src/ludus/core.clj
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
(ns ludus.core
|
||||
"A tree-walk interpreter for the Ludus language."
|
||||
(:require
|
||||
[ludus.scanner :as scanner]
|
||||
[ludus.parser :as p]
|
||||
[ludus.grammar :as g]
|
||||
[ludus.interpreter :as interpreter]
|
||||
[ludus.show :as show]
|
||||
[clojure.pprint :as pp]
|
||||
[ludus.loader :as loader]
|
||||
[ludus.repl :as repl])
|
||||
(:gen-class))
|
||||
|
||||
(defn- run [file source]
|
||||
(let [scanned (scanner/scan source)]
|
||||
(if (not-empty (:errors scanned))
|
||||
(do
|
||||
(println "I found some scanning errors!")
|
||||
(pp/pprint (:errors scanned))
|
||||
(System/exit 65))
|
||||
(let [parsed (p/apply-parser g/script (:tokens scanned))]
|
||||
(if (p/fail? parsed)
|
||||
(do
|
||||
(println "I found some parsing errors!")
|
||||
(println (p/err-msg parsed))
|
||||
(System/exit 66))
|
||||
(let [interpreted (interpreter/interpret source file parsed)]
|
||||
(println (show/show interpreted))
|
||||
(System/exit 0)))))))
|
||||
|
||||
(defn -main [& args]
|
||||
(cond
|
||||
(= (count args) 1)
|
||||
(let [file (first args)
|
||||
source (loader/load-import file)]
|
||||
(run file source))
|
||||
|
||||
:else (repl/launch)))
|
||||
2
src/ludus/data.cljc
Normal file
2
src/ludus/data.cljc
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
(ns ludus.data)
|
||||
|
||||
126
src/ludus/doc.cljc
Normal file
126
src/ludus/doc.cljc
Normal file
|
|
@ -0,0 +1,126 @@
|
|||
(ns ludus.doc
|
||||
(:require [ludus.interpreter :as interpreter]
|
||||
[ludus.base :as base]
|
||||
[ludus.data :as data]
|
||||
[clojure.string :as string]))
|
||||
|
||||
(def prelude interpreter/ludus-prelude)
|
||||
|
||||
(def exports-only (dissoc prelude ::data/type ::data/struct))
|
||||
|
||||
(defn map-values [f] (fn [[k v]] [k (f v)]))
|
||||
|
||||
(def ludus-doc (base/doc- :body))
|
||||
|
||||
(def with-docs (into {} (map (map-values ludus-doc)) exports-only))
|
||||
|
||||
(def sorted-names (-> with-docs keys sort))
|
||||
|
||||
(defn escape-underscores [the-str] (string/replace the-str #"_" "\\_"))
|
||||
|
||||
(defn escape-punctuation [the-str] (string/replace the-str #"[\!\?]" ""))
|
||||
|
||||
(defn toc-entry [name] (let [escaped (escape-underscores name)] (str "[" escaped "](#" (escape-punctuation escaped) ")")))
|
||||
|
||||
(def alphabetical-list (string/join " " (map toc-entry sorted-names)))
|
||||
|
||||
(def topics {
|
||||
"math" ["abs" "add" "angle" "atan/2" "ceil" "cos" "dec" "deg/rad" "deg/turn" "dist" "div"
|
||||
"div/0" "div/safe" "even?" "floor" "gt?" "gte?" "heading/vector" "inc" "lt?" "lte?" "mod"
|
||||
"mult" "neg" "neg?" "odd?" "pi" "pos?" "rad/deg" "rad/turn" "random" "range" "round"
|
||||
"sin" "square" "sub" "sum_of_squares" "tan" "tau" "turn/deg" "turn/rad" "zero?"]
|
||||
"boolean" ["and" "bool" "bool?" "false?" "or" "not"]
|
||||
"dicts" ["assoc" "assoc?" "dict" "diff" "dissoc" "get" "keys" "update" "values"]
|
||||
"lists" ["append" "at" "butlast" "concat" "count" "each!" "first" "fold" "last" "list" "list?" "map" "ordered?" "range"
|
||||
"rest" "second" "slice"]
|
||||
"sets" ["set" "set?"]
|
||||
"strings" ["count" "join" "show" "string" "string?"]
|
||||
"types and values" ["bool?" "coll?" "dict?" "eq?" "fn?" "keyword?" "list?" "neq?" "nil?" "number?" "ordered?" "show" "some" "some?" "type"]
|
||||
"references and state" ["deref" "make!" "update!"]
|
||||
"results" ["err" "err?" "ok" "ok?" "unwrap!" "unwrap_or"]
|
||||
"errors" ["assert!" "panic!"]
|
||||
"turtle graphics" ["back!" "background!" "bk!" "clear!" "fd!" "forward!" "goto!" "heading" "heading/vector" "home!" "left!" "lt!" "pc!" "pd!" "pencolor"
|
||||
"pencolor!" "pendown!" "pendown?" "penup!" "penwidth" "penwidth!" "position" "pu!" "pw!" "render_turtle!" "reset_turtle!"
|
||||
"right!" "rt!" "turtle_state"]
|
||||
"environment and i/o" ["doc!" "flush!" "print!" "prn!" "report!"]
|
||||
})
|
||||
|
||||
(defn topic-entry [topic] (str "### " (string/capitalize topic) "\n"
|
||||
(->> topic (get topics) sort (map toc-entry) (string/join " "))
|
||||
"\n"))
|
||||
|
||||
(def by-topic (let [the-topics (-> topics keys sort)
|
||||
topics-entries (map topic-entry the-topics)]
|
||||
(string/join "\n" topics-entries)))
|
||||
|
||||
(defn compose-entry [name]
|
||||
(let [the-doc (get with-docs name)
|
||||
header (str "### " name "\n")
|
||||
lines (string/split-lines the-doc)]
|
||||
(if (empty? lines) (str header "No documentation available.\n")
|
||||
(let [
|
||||
description (second lines)
|
||||
pattern-lines (subvec lines 2)
|
||||
patterns (string/join "\n" pattern-lines)
|
||||
]
|
||||
(str header description "\n```\n" patterns "\n```")
|
||||
))))
|
||||
|
||||
(def entries (string/join "\n\n" (map compose-entry sorted-names)))
|
||||
|
||||
(def doc-file
|
||||
(str
|
||||
"# Ludus prelude documentation
|
||||
These functions are available in every Ludus script.
|
||||
The documentation for any function can be found within Ludus by passing the function to `doc!`,
|
||||
e.g., running `doc! (add)` will send the documentation for `add` to the console.
|
||||
|
||||
For more information on the syntax & semantics of the Ludus language, see [language.md](./language.md).
|
||||
|
||||
## A few notes
|
||||
**Naming conventions.** Functions whose name ends with a question mark, e.g., `eq?`, return booleans.
|
||||
Functions whose name ends with an exclamation point, e.g., `make!`, change state in some way.
|
||||
In other words, they _do things_ rather than _calculating values_.
|
||||
Functions whose name includes a slash either convert from one value to another, e.g. `deg/rad`,
|
||||
or they are variations on a function, e.g. `div/0` as a variation on `div`.
|
||||
|
||||
**How entries are formatted.** Each entry has a brief (sometimes too brief!) description of what it does.
|
||||
It is followed by the patterns for each of its function clauses.
|
||||
This should be enough to indicate order of arguments, types, and so on.
|
||||
|
||||
**Patterns often, but do not always, indicate types.** Typed patterns are written as `foo as :bar`,
|
||||
where the type is indicated by the keyword.
|
||||
Possible ludus types are: `:nil`, `:boolean`, `:number`, `:keyword` (atomic values);
|
||||
`:string` (strings are their own beast); `:tuple` and `:list` (indexed collections); `:set` (sets are specific),
|
||||
`:dict` and `:ns` (associative collections); and `:ref` (references).
|
||||
|
||||
**Conventional types.** Ludus has two types based on conventions.
|
||||
* _Result tuples._ Results are a way of modeling the result of a calculation that might fail.
|
||||
The two possible values are `(:ok, value)` and `(:err, msg)`.
|
||||
`msg` is usually a string describing what went wrong.
|
||||
To work with result tuples, see [`unwrap!`](#unwrap) and [`unwrap_or`](#unwrap_or).
|
||||
That said, usually you work with these using pattern matching.
|
||||
|
||||
* _Vectors._ Vectors are 2-element tuples of x and y coordinates.
|
||||
The origin is `(0, 0)`.
|
||||
Many math functions take vectors as well as numbers, e.g., `add` and `mult`.
|
||||
You will see vectors indicated in patterns by an `(x, y)` tuple.
|
||||
You can see what this looks like in the last clause of `add`: `((x1, y1), (x2, y2))`.
|
||||
|
||||
## Functions by topic
|
||||
|
||||
"
|
||||
by-topic
|
||||
|
||||
"
|
||||
|
||||
## All functions, alphabetically
|
||||
"
|
||||
alphabetical-list
|
||||
"
|
||||
## Function documentation
|
||||
"
|
||||
entries
|
||||
))
|
||||
|
||||
(spit "prelude.md" doc-file)
|
||||
15
src/ludus/draw.cljs
Normal file
15
src/ludus/draw.cljs
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
(ns ludus.draw)
|
||||
|
||||
(defn background
|
||||
([x] (js/background x))
|
||||
([r g b] (js/background r g b))
|
||||
([r g b a] (js/background r g b a)))
|
||||
|
||||
(defn rect [[x y] [w h]]
|
||||
(js/rect x y w h))
|
||||
|
||||
(defn ellipse [[x y] [w h]])
|
||||
|
||||
(def draw {
|
||||
|
||||
})
|
||||
46
src/ludus/error.cljc
Normal file
46
src/ludus/error.cljc
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
(ns ludus.error
|
||||
(:require [clojure.string :as string]))
|
||||
|
||||
(defn get-line [source line]
|
||||
(let [lines (string/split-lines source)
|
||||
the_line (nth lines (dec line))]
|
||||
the_line))
|
||||
|
||||
(string/split-lines "abcd")
|
||||
|
||||
(defn get-underline [source {:keys [line start lexeme]} prefix]
|
||||
(let [lines (string/split-lines source)
|
||||
lines-before (subvec lines 0 (dec line))
|
||||
line-start (reduce (fn [len line] (+ len (count line))) (count lines-before) lines-before)
|
||||
from-start (- start line-start)
|
||||
underline-length (count lexeme)
|
||||
padding (string/join (take (+ prefix from-start) (repeat "-")))
|
||||
underline (string/join (take underline-length (repeat "^")))]
|
||||
(apply str padding underline)
|
||||
))
|
||||
|
||||
(defn scan-error [] :TODO)
|
||||
|
||||
(defn parse-error [{:keys [trace token]}]
|
||||
(let [source (:source token)
|
||||
input (:input token)
|
||||
line-num (:line token)
|
||||
line (get-line source line-num)
|
||||
line-num (:line token)
|
||||
prefix (str line-num ": ")
|
||||
underline (get-underline source token (count prefix))
|
||||
expected (first trace)
|
||||
got (:type token)
|
||||
message (str "Ludus found a parsing error on line " line-num " in " input ".\nExpected: " expected "\nGot: " got "\n")
|
||||
]
|
||||
(str message "\n" prefix line "\n" underline)
|
||||
)
|
||||
)
|
||||
|
||||
(defn run-error [{:keys [message token line]}]
|
||||
(let [source (:source token) input (:input token)]
|
||||
(if line
|
||||
(str "Ludus panicked!: " message "\nOn line " line " in " input "\n" (get-line source line))
|
||||
(str "Ludus panicked!\n" message)
|
||||
)))
|
||||
|
||||
273
src/ludus/grammar.cljc
Normal file
273
src/ludus/grammar.cljc
Normal file
|
|
@ -0,0 +1,273 @@
|
|||
(ns ludus.grammar
|
||||
(:require
|
||||
#?(
|
||||
:clj [ludus.parser :refer :all]
|
||||
:cljs [ludus.parser
|
||||
:refer [choice quiet one+ zero+ group order-0 order-1 flat maybe weak-order]
|
||||
:refer-macros [defp]
|
||||
]
|
||||
)
|
||||
[ludus.scanner :as s]
|
||||
))
|
||||
|
||||
(declare expression pattern binding-expr non-binding simple)
|
||||
|
||||
(defp separator choice [:comma :newline :break])
|
||||
|
||||
(defp separators quiet one+ separator)
|
||||
|
||||
(defp terminator choice [:newline :semicolon :break])
|
||||
|
||||
(defp terminators quiet one+ terminator)
|
||||
|
||||
(defp nls? quiet zero+ :newline)
|
||||
|
||||
(defp splat group order-1 [(quiet :splat) :word])
|
||||
|
||||
(defp patt-splat-able flat choice [:word :ignored :placeholder])
|
||||
|
||||
(defp splattern group order-1 [(quiet :splat) (maybe patt-splat-able)])
|
||||
|
||||
(defp literal flat choice [:nil :true :false :number :string])
|
||||
|
||||
(defp tuple-pattern-term flat choice [pattern splattern])
|
||||
|
||||
(defp tuple-pattern-entry weak-order [tuple-pattern-term separators])
|
||||
|
||||
(defp tuple-pattern group order-1 [(quiet :lparen)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ tuple-pattern-entry)
|
||||
(quiet :rparen)])
|
||||
|
||||
(defp list-pattern group order-1 [(quiet :lbracket)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ tuple-pattern-entry)
|
||||
(quiet :rbracket)])
|
||||
|
||||
(defp pair-pattern group weak-order [:keyword pattern])
|
||||
|
||||
(defp typed group weak-order [:word (quiet :as) :keyword])
|
||||
|
||||
(defp dict-pattern-term flat choice [pair-pattern typed :word splattern])
|
||||
|
||||
(defp dict-pattern-entry weak-order [dict-pattern-term separators])
|
||||
|
||||
(defp dict-pattern group order-1 [(quiet :startdict)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ dict-pattern-entry)
|
||||
(quiet :rbrace)
|
||||
])
|
||||
|
||||
; (defp struct-pattern group order-1 [(quiet :startstruct)
|
||||
; (quiet (zero+ separator))
|
||||
; (zero+ dict-pattern-entry)
|
||||
; (quiet :rbrace)
|
||||
; ])
|
||||
|
||||
(defp guard order-0 [(quiet :if) simple])
|
||||
|
||||
(defp pattern flat choice [literal
|
||||
:ignored
|
||||
:placeholder
|
||||
typed
|
||||
:word
|
||||
:keyword
|
||||
:else
|
||||
tuple-pattern
|
||||
dict-pattern
|
||||
;struct-pattern
|
||||
list-pattern])
|
||||
|
||||
(defp match-clause group weak-order [pattern (maybe guard) (quiet :rarrow) expression])
|
||||
|
||||
(defp match-entry weak-order [match-clause terminators])
|
||||
|
||||
(defp match group order-1 [(quiet :match) simple nls?
|
||||
(quiet :with) (quiet :lbrace)
|
||||
(quiet (zero+ terminator))
|
||||
(one+ match-entry)
|
||||
(quiet :rbrace)
|
||||
])
|
||||
|
||||
(defp when-lhs flat choice [simple :placeholder :else])
|
||||
|
||||
(defp when-clause group weak-order [when-lhs (quiet :rarrow) expression])
|
||||
|
||||
(defp when-entry weak-order [when-clause terminators])
|
||||
|
||||
(defp when-expr group order-1 [(quiet :when) (quiet :lbrace)
|
||||
(quiet (zero+ terminator))
|
||||
(one+ when-entry)
|
||||
(quiet :rbrace)])
|
||||
|
||||
(defp let-expr group order-1 [(quiet :let)
|
||||
pattern
|
||||
(quiet :equals)
|
||||
nls?
|
||||
non-binding])
|
||||
|
||||
(defp condition flat choice [simple let-expr])
|
||||
|
||||
(defp if-expr group order-1 [(quiet :if)
|
||||
nls?
|
||||
condition
|
||||
nls?
|
||||
(quiet :then)
|
||||
expression
|
||||
nls?
|
||||
(quiet :else)
|
||||
expression])
|
||||
|
||||
(defp tuple-entry weak-order [non-binding separators])
|
||||
|
||||
(defp tuple group order-1 [(quiet :lparen)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ tuple-entry)
|
||||
(quiet :rparen)])
|
||||
|
||||
(defp list-term flat choice [splat non-binding])
|
||||
|
||||
(defp list-entry order-1 [list-term separators])
|
||||
|
||||
(defp list-literal group order-1 [(quiet :lbracket)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ list-entry)
|
||||
(quiet :rbracket)])
|
||||
|
||||
(defp set-literal group order-1 [(quiet :startset)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ list-entry)
|
||||
(quiet :rbrace)])
|
||||
|
||||
(defp pair group order-0 [:keyword non-binding])
|
||||
|
||||
;; "struct-term" and "struct-entry" are necessary for nses
|
||||
(defp struct-term flat choice [:word pair])
|
||||
|
||||
(defp struct-entry order-1 [struct-term separators])
|
||||
|
||||
; (defp struct-literal group order-1 [(quiet :startstruct)
|
||||
; (quiet (zero+ separator))
|
||||
; (zero+ struct-entry)
|
||||
; (quiet :rbrace)])
|
||||
|
||||
(defp dict-term flat choice [splat :word pair])
|
||||
|
||||
(defp dict-entry order-1 [dict-term separators])
|
||||
|
||||
(defp dict group order-1 [(quiet :startdict)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ dict-entry)
|
||||
(quiet :rbrace)])
|
||||
|
||||
(defp arg-expr flat choice [:placeholder non-binding])
|
||||
|
||||
(defp arg-entry weak-order [arg-expr separators])
|
||||
|
||||
(defp args group order-1 [(quiet :lparen)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ arg-entry)
|
||||
(quiet :rparen)])
|
||||
|
||||
(defp recur-call group order-1 [(quiet :recur) tuple])
|
||||
|
||||
(defp synth-root flat choice [:keyword :word])
|
||||
|
||||
(defp synth-term flat choice [args :keyword])
|
||||
|
||||
(defp synthetic group order-1 [synth-root (zero+ synth-term)])
|
||||
|
||||
(defp fn-clause group order-1 [tuple-pattern (maybe guard) (quiet :rarrow) expression])
|
||||
|
||||
(defp fn-entry order-1 [fn-clause terminators])
|
||||
|
||||
(defp fn-compound group order-1 [(quiet :lbrace)
|
||||
nls?
|
||||
(maybe :string)
|
||||
(quiet (zero+ terminator))
|
||||
(one+ fn-entry)
|
||||
(quiet :rbrace)
|
||||
])
|
||||
|
||||
(defp clauses flat choice [fn-clause fn-compound])
|
||||
|
||||
(defp fn-named group order-1 [(quiet :fn) :word clauses])
|
||||
|
||||
(defp lambda group order-1 [(quiet :fn) fn-clause])
|
||||
|
||||
(defp block-line weak-order [expression terminators])
|
||||
|
||||
(defp block group order-1 [(quiet :lbrace)
|
||||
(quiet (zero+ terminator))
|
||||
(one+ block-line)
|
||||
(quiet :rbrace)])
|
||||
|
||||
(defp pipeline quiet order-0 [nls? :pipeline])
|
||||
|
||||
(defp do-entry order-1 [pipeline expression])
|
||||
|
||||
(defp do-expr group order-1 [(quiet :do)
|
||||
expression
|
||||
(one+ do-entry)
|
||||
])
|
||||
|
||||
(defp ref-expr group order-1 [(quiet :ref) :word (quiet :equals) expression])
|
||||
|
||||
; (defp spawn group order-1 [(quiet :spawn) expression])
|
||||
|
||||
; (defp receive group order-1 [(quiet :receive) (quiet :lbrace)
|
||||
; (quiet (zero+ terminator))
|
||||
; (one+ match-entry)
|
||||
; (quiet :rbrace)
|
||||
; ])
|
||||
|
||||
(defp compound-loop group order-0 [(quiet :lbrace)
|
||||
(quiet (zero+ terminator))
|
||||
(one+ fn-entry)
|
||||
(quiet :rbrace)])
|
||||
|
||||
(defp loop-expr group order-1 [(quiet :loop) tuple (quiet :with)
|
||||
(flat (choice :loop-body [fn-clause compound-loop]))])
|
||||
|
||||
(defp repeat-expr group order-1 [(quiet :repeat) (choice :times [:word :number]) non-binding])
|
||||
|
||||
(defp collection flat choice [;struct-literal
|
||||
dict list-literal set-literal tuple])
|
||||
|
||||
(defp panic group order-1 [(quiet :panic) expression])
|
||||
|
||||
(defp simple flat choice [literal collection synthetic recur-call lambda panic])
|
||||
|
||||
(defp compound flat choice [match loop-expr if-expr when-expr do-expr block repeat-expr])
|
||||
|
||||
(defp binding-expr flat choice [fn-named let-expr ref-expr])
|
||||
|
||||
(defp non-binding flat choice [simple compound])
|
||||
|
||||
(defp expression flat choice [binding-expr non-binding])
|
||||
|
||||
(defp test-expr group order-1 [(quiet :test) :string non-binding])
|
||||
|
||||
(defp import-expr group order-1 [(quiet :import) :string (quiet :as) :word])
|
||||
|
||||
(defp ns-expr group order-1 [(quiet :ns)
|
||||
:word
|
||||
(quiet :lbrace)
|
||||
(quiet (zero+ separator))
|
||||
(zero+ struct-entry)
|
||||
(quiet :rbrace)])
|
||||
|
||||
(defp use-expr group order-1 [(quiet :use) :word])
|
||||
|
||||
(defp toplevel flat choice [import-expr
|
||||
ns-expr
|
||||
expression
|
||||
test-expr
|
||||
use-expr])
|
||||
|
||||
(defp script-line weak-order [toplevel terminators])
|
||||
|
||||
(defp script order-0 [nls?
|
||||
(one+ script-line)
|
||||
(quiet :eof)])
|
||||
|
||||
1071
src/ludus/interpreter.cljc
Normal file
1071
src/ludus/interpreter.cljc
Normal file
File diff suppressed because it is too large
Load Diff
16
src/ludus/loader.clj
Normal file
16
src/ludus/loader.clj
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
(ns ludus.loader
|
||||
(:require [babashka.fs :as fs]))
|
||||
|
||||
(defn cwd [] (fs/cwd))
|
||||
|
||||
(defn load-import
|
||||
([file]
|
||||
(let [path (-> file (fs/canonicalize) (fs/file))]
|
||||
(try (slurp path)
|
||||
(catch java.io.FileNotFoundException _
|
||||
(throw (ex-info (str "File " path " not found") {:path path ::error true}))))))
|
||||
([file from]
|
||||
(load-import
|
||||
(fs/path
|
||||
(if (= from :cwd) (fs/cwd) (fs/parent (fs/canonicalize from)))
|
||||
(fs/path file)))))
|
||||
77
src/ludus/node.cljc
Normal file
77
src/ludus/node.cljc
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
(ns ludus.node
|
||||
(:require [ludus.interpreter :as i]
|
||||
[ludus.grammar :as g]
|
||||
[ludus.parser :as p]
|
||||
[ludus.scanner :as s]
|
||||
[ludus.prelude :as pre]
|
||||
[ludus.show :as show]
|
||||
[ludus.base :as base]
|
||||
[ludus.data :as data]
|
||||
[ludus.error :as error]
|
||||
)
|
||||
)
|
||||
|
||||
(declare ld->clj)
|
||||
|
||||
(defn cljify [[k v]] [k (ld->clj v)])
|
||||
|
||||
(defn ld->clj [value]
|
||||
(case (base/get-type value)
|
||||
(:nil :number :string :boolean :keyword :set) value
|
||||
|
||||
(:list :tuple) (into [] (map ld->clj) (rest value))
|
||||
|
||||
(:dict :struct :ns) (into {} (map cljify) (dissoc value ::data/dict ::data/struct ::data/type ::data/name))
|
||||
|
||||
:ref (ld->clj @(::value value))
|
||||
|
||||
:fn (throw (ex-info (str "Cannot export functions from Ludus to Clojure. You tried exporting " (show/show value)) {}))))
|
||||
|
||||
(defn clean-out [value]
|
||||
#?(:clj value :cljs (clj->js value)))
|
||||
|
||||
(defn run
|
||||
([source] (run source false))
|
||||
([source testing?]
|
||||
(let [user_scanned (s/scan source "user input")
|
||||
user_tokens (:tokens user_scanned)
|
||||
user_parsed (p/apply-parser g/script user_tokens)
|
||||
user_result (i/interpret-safe source user_parsed {} testing?)
|
||||
result_str (show/show user_result)
|
||||
test_results @i/test-results
|
||||
post_scanned (s/scan pre/postlude "postlude")
|
||||
post_tokens (:tokens post_scanned)
|
||||
post_parsed (p/apply-parser g/script post_tokens)
|
||||
post_result (i/interpret-safe source post_parsed {} false)
|
||||
ludus_result (assoc post_result :result result_str :test test_results)
|
||||
clj_result (ld->clj ludus_result)
|
||||
]
|
||||
(cond
|
||||
(not-empty (:errors user_tokens))
|
||||
(clean-out {:errors (:errors user_tokens)})
|
||||
|
||||
(= :err (:status user_parsed))
|
||||
(clean-out {:errors [(error/parse-error user_parsed)]})
|
||||
|
||||
(::data/error user_result)
|
||||
(clean-out (assoc (ld->clj post_result) :errors [(error/run-error user_result)]))
|
||||
|
||||
:else
|
||||
(clean-out clj_result)
|
||||
)
|
||||
))
|
||||
)
|
||||
|
||||
(defn doug [source] (run source true))
|
||||
|
||||
(comment
|
||||
|
||||
(def source "
|
||||
|
||||
")
|
||||
|
||||
(-> source run :test println)
|
||||
|
||||
)
|
||||
|
||||
|
||||
316
src/ludus/parser.cljc
Normal file
316
src/ludus/parser.cljc
Normal file
|
|
@ -0,0 +1,316 @@
|
|||
(ns ludus.parser)
|
||||
|
||||
(defn ? [val default] (if (nil? val) default val))
|
||||
|
||||
(defn ok? [{status :status}]
|
||||
(= status :ok))
|
||||
|
||||
(def failing #{:err :none})
|
||||
|
||||
(def passing #{:ok :group :quiet})
|
||||
|
||||
(defn pass? [{status :status}] (contains? passing status))
|
||||
|
||||
(defn fail? [{status :status}] (contains? failing status))
|
||||
|
||||
(defn data [{d :data}] d)
|
||||
|
||||
(defn remaining [{r :remaining}] r)
|
||||
|
||||
(defn pname [parser] (? (:name parser) parser))
|
||||
|
||||
(defn str-part [kw] (apply str (next (str kw))))
|
||||
|
||||
(defn kw+str [kw mystr] (keyword (str (str-part kw) mystr)))
|
||||
|
||||
(defn value [token]
|
||||
(if (= :none (:literal token)) (:lexeme token) (:literal token)))
|
||||
|
||||
(defn apply-kw-parser [kw tokens]
|
||||
(let [token (first tokens)]
|
||||
;(if (= kw (:type token)) (println "Matched " kw))
|
||||
(if (= kw (:type token))
|
||||
{:status :ok
|
||||
:type kw
|
||||
:data (if (some? (value token)) [(value token)] [])
|
||||
:token token
|
||||
:remaining (rest tokens)}
|
||||
{:status :none :token token :trace [kw] :remaining (rest tokens)})))
|
||||
|
||||
(defn apply-fn-parser [parser tokens]
|
||||
(let [rule (:rule parser) name (:name parser) result (rule tokens)]
|
||||
;(if (pass? result) (println "Matched " (:name parser)))
|
||||
result))
|
||||
|
||||
(defn apply-parser [parser tokens]
|
||||
;(println "Applying parser " (? (:name parser) parser))
|
||||
(let [result (cond
|
||||
(keyword? parser) (apply-kw-parser parser tokens)
|
||||
(:rule parser) (apply-fn-parser parser tokens)
|
||||
(fn? parser) (apply-fn-parser (parser) tokens)
|
||||
:else (throw (ex-info "`apply-parser` requires a parser" {})))]
|
||||
;(println "Parser result " (? (:name parser) parser) (:status result))
|
||||
result
|
||||
))
|
||||
|
||||
(defn choice [name parsers]
|
||||
{:name name
|
||||
:rule (fn choice-fn [tokens]
|
||||
(loop [ps parsers]
|
||||
(let [result (apply-parser (first ps) tokens)
|
||||
rem-ts (remaining result)
|
||||
rem-ps (rest ps)]
|
||||
(cond
|
||||
(pass? result)
|
||||
{:status :ok :type name :data [result] :token (first tokens) :remaining rem-ts}
|
||||
|
||||
(= :err (:status result))
|
||||
(update result :trace #(conj % name))
|
||||
|
||||
(empty? rem-ps)
|
||||
{:status :none :token (first tokens) :trace [name] :remaining rem-ts}
|
||||
|
||||
:else (recur rem-ps)))))})
|
||||
|
||||
(defn order-1 [name parsers]
|
||||
{:name name
|
||||
:rule (fn order-fn [tokens]
|
||||
(let [origin (first tokens)
|
||||
first-result (apply-parser (first parsers) tokens)]
|
||||
(case (:status first-result)
|
||||
(:err :none)
|
||||
(assoc (update first-result :trace #(conj % name)) :status :none)
|
||||
|
||||
(:ok :quiet :group)
|
||||
(loop [ps (rest parsers)
|
||||
results (case (:status first-result)
|
||||
:ok [first-result]
|
||||
:quiet []
|
||||
:group (:data first-result))
|
||||
ts (remaining first-result)]
|
||||
(let [result (apply-parser (first ps) ts)
|
||||
res-rem (remaining result)]
|
||||
(if (empty? (rest ps))
|
||||
(case (:status result)
|
||||
:ok {:status :group
|
||||
:type name
|
||||
:data (conj results result)
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
:quiet {:status :group
|
||||
:type name
|
||||
:data results
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
:group {:status :group
|
||||
:type name
|
||||
:data (vec (concat results (:data result)))
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
(:err :none)
|
||||
(assoc (update result :trace #(conj % name)) :status :err))
|
||||
|
||||
(case (:status result)
|
||||
:ok (recur (rest ps) (conj results result) res-rem)
|
||||
:group (recur (rest ps)
|
||||
(vec (concat results (:data result)))
|
||||
res-rem)
|
||||
:quiet (recur (rest ps) results res-rem)
|
||||
|
||||
(:err :none)
|
||||
(assoc (update result :trace #(conj % name)) :status :err))))))))})
|
||||
|
||||
(defn order-0 [name parsers]
|
||||
{:name name
|
||||
:rule (fn order-fn [tokens]
|
||||
(let [origin (first tokens)]
|
||||
(loop [ps parsers
|
||||
results []
|
||||
ts tokens]
|
||||
(let [result (apply-parser (first ps) ts)
|
||||
res-rem (remaining result)]
|
||||
(if (empty? (rest ps))
|
||||
;; Nothing more: return
|
||||
(case (:status result)
|
||||
:ok {:status :group
|
||||
:type name
|
||||
:data (conj results result)
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
:quiet {:status :group
|
||||
:type name
|
||||
:data results
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
:group {:status :group
|
||||
:type name
|
||||
:data (vec (concat results (:data result)))
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
(:err :none)
|
||||
(assoc (update result :trace #(conj % name)) :status :err))
|
||||
|
||||
;; Still parsers left in the vector: recur
|
||||
(case (:status result)
|
||||
:ok (recur (rest ps) (conj results result) res-rem)
|
||||
:group (recur (rest ps)
|
||||
(vec (concat results (:data result)))
|
||||
res-rem)
|
||||
:quiet (recur (rest ps) results res-rem)
|
||||
|
||||
(:err :none)
|
||||
(assoc (update result :trace #(conj % name)) :status :err)
|
||||
|
||||
(throw (ex-info (str "Got bad result: " (:status result)) result))))))))})
|
||||
|
||||
(defn weak-order [name parsers]
|
||||
{:name name
|
||||
:rule (fn order-fn [tokens]
|
||||
(let [origin (first tokens)]
|
||||
(loop [ps parsers
|
||||
results []
|
||||
ts tokens]
|
||||
(let [result (apply-parser (first ps) ts)
|
||||
res-rem (remaining result)]
|
||||
(if (empty? (rest ps))
|
||||
;; Nothing more: return
|
||||
(case (:status result)
|
||||
:ok {:status :group
|
||||
:type name
|
||||
:data (conj results result)
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
:quiet {:status :group
|
||||
:type name
|
||||
:data results
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
:group {:status :group
|
||||
:type name
|
||||
:data (vec (concat results (:data result)))
|
||||
:token origin
|
||||
:remaining res-rem}
|
||||
|
||||
(:err :none)
|
||||
(update result :trace #(conj % name)))
|
||||
|
||||
;; Still parsers left in the vector: recur
|
||||
(case (:status result)
|
||||
:ok (recur (rest ps) (conj results result) res-rem)
|
||||
:group (recur (rest ps)
|
||||
(vec (concat results (:data result)))
|
||||
res-rem)
|
||||
:quiet (recur (rest ps) results res-rem)
|
||||
|
||||
(:err :none)
|
||||
(update result :trace #(conj % name))))))))})
|
||||
|
||||
|
||||
(defn quiet [parser]
|
||||
{:name (kw+str (? (:name parser) parser) "-quiet")
|
||||
:rule (fn quiet-fn [tokens]
|
||||
(let [result (apply-parser parser tokens)]
|
||||
(if (pass? result)
|
||||
(assoc result :status :quiet)
|
||||
result)))})
|
||||
|
||||
(defn zero+
|
||||
([parser] (zero+ (pname parser) parser))
|
||||
([name parser]
|
||||
{:name (kw+str name "-zero+")
|
||||
:rule (fn zero+fn [tokens]
|
||||
(loop [results []
|
||||
ts tokens]
|
||||
(let [result (apply-parser parser ts)]
|
||||
(case (:status result)
|
||||
:ok (recur (conj results result) (remaining result))
|
||||
:group (recur (vec (concat results (:data result))) (remaining result))
|
||||
:quiet (recur results (remaining result))
|
||||
:err (update result :trace #(conj % name))
|
||||
:none {:status :group
|
||||
:type name
|
||||
:data results
|
||||
:token (first tokens)
|
||||
:remaining ts}))))}))
|
||||
|
||||
(defn one+
|
||||
([parser] (one+ (pname parser) parser))
|
||||
([name parser]
|
||||
{:name (kw+str name "-one+")
|
||||
:rule (fn one+fn [tokens]
|
||||
(let [first-result (apply-parser parser tokens)
|
||||
rest-parser (zero+ name parser)]
|
||||
(case (:status first-result)
|
||||
(:ok :group)
|
||||
(let [rest-result (apply-parser rest-parser (remaining first-result))]
|
||||
(case (:status rest-result)
|
||||
|
||||
(:ok :group :quiet)
|
||||
{:status :group
|
||||
:type name
|
||||
:data (vec (concat (:data first-result) (data rest-result)))
|
||||
:token (first tokens)
|
||||
:remaining (remaining rest-result)}
|
||||
|
||||
:none {:status :group :type name
|
||||
:data first-result
|
||||
:token (first tokens)
|
||||
:remaining (remaining rest-result)}
|
||||
|
||||
:err (update rest-result :trace #(conj % name))))
|
||||
|
||||
:quiet
|
||||
(let [rest-result (apply-parser rest-parser (remaining first-result))]
|
||||
{:status :quiet
|
||||
:type name
|
||||
:data []
|
||||
:token (first tokens)
|
||||
:remaining (remaining rest-result)})
|
||||
|
||||
(:err :none) first-result)))}))
|
||||
|
||||
(defn maybe
|
||||
([parser] (maybe (pname parser) parser))
|
||||
([name parser]
|
||||
{:name (kw+str name "-maybe")
|
||||
:rule (fn maybe-fn [tokens]
|
||||
(let [result (apply-parser parser tokens)]
|
||||
(if (pass? result)
|
||||
result
|
||||
{:status :group :type name :data [] :token (first tokens) :remaining tokens}
|
||||
)))}))
|
||||
|
||||
(defn flat
|
||||
([parser] (flat (pname parser) parser))
|
||||
([name parser]
|
||||
{:name (kw+str name "-flat")
|
||||
:rule (fn flat-fn [tokens]
|
||||
(let [result (apply-parser parser tokens)]
|
||||
(if (pass? result) (first (:data result)) result)))}))
|
||||
|
||||
(defn group
|
||||
([parser] (group (pname parser) parser))
|
||||
([name parser]
|
||||
{:name (kw+str name "-group")
|
||||
:rule (fn group-fn [tokens]
|
||||
(let [result (apply-parser parser tokens)]
|
||||
(if (= :group (:status result))
|
||||
(assoc result :status :ok)
|
||||
result)))}))
|
||||
|
||||
(defn err-msg [{token :token trace :trace}]
|
||||
(println "Unexpected token " (:type token) " on line " (:line token))
|
||||
(println "Expected token " (first trace)))
|
||||
|
||||
(defmacro defp [name & items]
|
||||
(let [arg (last items)
|
||||
fns (into [] (butlast items))]
|
||||
`(defn ~name [] ((apply comp ~fns) (keyword '~name) ~arg))))
|
||||
|
|
@ -3,22 +3,22 @@
|
|||
& the goal is to output any global state held in Ludus
|
||||
& this does not have base loaded into it, only prelude: must be pure Ludus
|
||||
|
||||
if turtle_state () :visible? then render_turtle! () else nil
|
||||
if turtle_state() :visible? then render_turtle! () else nil
|
||||
|
||||
reset_turtle! ()
|
||||
|
||||
& let console_msgs = flush! ()
|
||||
let console_msgs = flush! ()
|
||||
|
||||
let (r, g, b, a) = unbox (bgcolor)
|
||||
store! (bgcolor, colors :black)
|
||||
let (r, g, b, a) = deref (bgcolor)
|
||||
make! (bgcolor, colors :black)
|
||||
|
||||
let draw_calls = unbox (p5_calls)
|
||||
store! (p5_calls, [])
|
||||
let draw_calls = deref (p5_calls)
|
||||
make! (p5_calls, [])
|
||||
|
||||
#{
|
||||
& :result result is provided elsewhere
|
||||
& :errors [] & if we get here there are no errors
|
||||
& :console console_msgs
|
||||
:console console_msgs
|
||||
:draw concat (
|
||||
[(:background, r, g, b, a), (:stroke, 255, 255, 255, 255)]
|
||||
draw_calls)
|
||||
15
src/ludus/prelude.cljc
Normal file
15
src/ludus/prelude.cljc
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
(ns ludus.prelude
|
||||
#?(:cljs (:require [shadow.resource :as r]))
|
||||
)
|
||||
|
||||
(def prelude
|
||||
#?(
|
||||
:clj (slurp "src/ludus/prelude.ld")
|
||||
:cljs (r/inline "./prelude.ld")
|
||||
))
|
||||
|
||||
(def postlude
|
||||
#?(
|
||||
:clj (slurp "src/ludus/postlude.ld")
|
||||
:cljs (r/inline "./postlude.ld")
|
||||
))
|
||||
|
|
@ -7,29 +7,6 @@
|
|||
& tuple?
|
||||
& ref?
|
||||
|
||||
& some forward declarations
|
||||
& TODO: fix this so that we don't need (as many of) them
|
||||
fn first
|
||||
fn append
|
||||
fn some?
|
||||
fn update!
|
||||
fn string
|
||||
fn join
|
||||
fn neg?
|
||||
fn atan/2
|
||||
fn mod
|
||||
fn assoc?
|
||||
fn dict
|
||||
fn get
|
||||
fn unbox
|
||||
fn store!
|
||||
fn turn/rad
|
||||
fn deg/rad
|
||||
fn floor
|
||||
fn and
|
||||
fn apply_command
|
||||
fn state/call
|
||||
|
||||
& the very base: know something's type
|
||||
fn type {
|
||||
"Returns a keyword representing the type of the value passed in."
|
||||
|
|
@ -51,40 +28,6 @@ fn eq? {
|
|||
else false
|
||||
}
|
||||
|
||||
&&& true & false: boolean logic (part the first)
|
||||
fn bool? {
|
||||
"Returns true if a value is of type :boolean."
|
||||
(false) -> true
|
||||
(true) -> true
|
||||
(_) -> false
|
||||
}
|
||||
|
||||
fn true? {
|
||||
"Returns true if a value is boolean `true`. Useful to distinguish between `true` and anything else."
|
||||
(true) -> true
|
||||
(_) -> false
|
||||
}
|
||||
|
||||
fn false? {
|
||||
"Returns `true` if a value is `false`, otherwise returns `false`. Useful to distinguish between `false` and `nil`."
|
||||
(false) -> true
|
||||
(_) -> false
|
||||
}
|
||||
|
||||
fn bool {
|
||||
"Returns false if a value is nil or false, otherwise returns true."
|
||||
(nil) -> false
|
||||
(false) -> false
|
||||
(_) -> true
|
||||
}
|
||||
|
||||
fn not {
|
||||
"Returns false if a value is truthy, true if a value is falsy."
|
||||
(nil) -> true
|
||||
(false) -> true
|
||||
(_) -> false
|
||||
}
|
||||
|
||||
fn neq? {
|
||||
"Returns true if none of the arguments have the same value."
|
||||
(x) -> false
|
||||
|
|
@ -130,13 +73,63 @@ fn dec {
|
|||
(x as :number) -> base :dec (x)
|
||||
}
|
||||
|
||||
fn at {
|
||||
"Returns the element at index n of a list or tuple. Zero-indexed: the first element is at index 0."
|
||||
(xs as :list, n as :number) -> when {
|
||||
neg? (n) -> nil
|
||||
gte? (n, count (xs)) -> nil
|
||||
else -> base :nth (xs, inc (n))
|
||||
}
|
||||
(xs as :tuple, n as :number) -> when {
|
||||
neg? (n) -> nil
|
||||
gte? (n, count (xs)) -> nil
|
||||
else -> base :nth (xs, inc (n))
|
||||
}
|
||||
(_) -> nil
|
||||
}
|
||||
|
||||
fn first {
|
||||
"Returns the first element of a list or tuple."
|
||||
(xs) -> at (xs, 0)
|
||||
}
|
||||
|
||||
fn second {
|
||||
"Returns the second element of a list or tuple."
|
||||
(xs) -> at (xs, 1)
|
||||
}
|
||||
|
||||
fn last {
|
||||
"Returns the last element of a list or tuple."
|
||||
(xs) -> at (xs, sub (count (xs), 1))
|
||||
}
|
||||
|
||||
fn butlast {
|
||||
"Returns a list, omitting the last element."
|
||||
(xs as :list) -> base :slice (xs, sub (count (xs), 1))
|
||||
}
|
||||
|
||||
fn slice {
|
||||
"Returns a slice of a list, representing a sub-list."
|
||||
(xs as :list, end as :number) -> slice (xs, 0, end)
|
||||
(xs as :list, start as :number, end as :number) -> when {
|
||||
gte? (start, end) -> []
|
||||
gt? (end, count (xs)) -> slice (xs, start, count (xs))
|
||||
neg? (start) -> slice (xs, 0, end)
|
||||
else -> {
|
||||
let slice = base :slice (xs, inc (start), inc (end))
|
||||
base :into ([], slice)
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
fn count {
|
||||
"Returns the number of elements in a collection (including string)."
|
||||
(xs as :list) -> base :count (xs)
|
||||
(xs as :tuple) -> base :count (xs)
|
||||
(xs as :list) -> dec (base :count (xs))
|
||||
(xs as :tuple) -> dec (base :count (xs))
|
||||
(xs as :dict) -> base :count (xs)
|
||||
(xs as :string) -> base :count (xs)
|
||||
(xs as :set) -> base :count (xs)
|
||||
(xs as :struct) -> dec (base :count (xs))
|
||||
}
|
||||
|
||||
fn empty? {
|
||||
|
|
@ -149,16 +142,6 @@ fn empty? {
|
|||
(_) -> false
|
||||
}
|
||||
|
||||
fn any? {
|
||||
"Returns true if something is not empty, otherwise returns false (including for things that can't be logically full, like numbers)."
|
||||
([...]) -> true
|
||||
(#{...}) -> true
|
||||
(s as :set) -> not (empty? (s))
|
||||
((...)) -> true
|
||||
(s as :string) -> not (empty? (s))
|
||||
(_) -> false
|
||||
}
|
||||
|
||||
fn list? {
|
||||
"Returns true if the value is a list."
|
||||
(l as :list) -> true
|
||||
|
|
@ -170,7 +153,6 @@ fn list {
|
|||
(x) -> base :to_list (x)
|
||||
}
|
||||
|
||||
& TODO: make this work with Janet base
|
||||
fn set {
|
||||
"Takes an ordered collection--list or tuple--and turns it into a set."
|
||||
(xs as :list) -> base :into (${}, xs)
|
||||
|
|
@ -188,20 +170,16 @@ fn set? {
|
|||
fn fold {
|
||||
"Folds a list."
|
||||
(f as :fn, xs as :list) -> fold (f, xs, f ())
|
||||
(f as :fn, xs as :list, root) -> {
|
||||
base :print! (("folding ", xs, " with ", f))
|
||||
loop (root, first (xs), rest (xs)) with {
|
||||
(prev, curr, []) -> f (prev, curr)
|
||||
(prev, curr, remaining) -> recur (
|
||||
f (prev, curr)
|
||||
first (remaining)
|
||||
rest (remaining)
|
||||
)
|
||||
}
|
||||
(f as :fn, xs as :list, root) -> loop (root, first (xs), rest (xs)) with {
|
||||
(prev, curr, []) -> f (prev, curr)
|
||||
(prev, curr, remaining) -> recur (
|
||||
f (prev, curr)
|
||||
first (remaining)
|
||||
rest (remaining)
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
& TODO: optimize these with base :conj!
|
||||
fn map {
|
||||
"Maps a function over a list: returns a new list with elements that are the result of applying the function to each element in the original list. E.g., `map ([1, 2, 3], inc) &=> [2, 3, 4]`."
|
||||
(f as :fn, xs) -> {
|
||||
|
|
@ -240,7 +218,7 @@ fn append {
|
|||
|
||||
fn concat {
|
||||
"Combines two lists, strings, or sets."
|
||||
(x as :string, y as :string) -> base :concat (x, y)
|
||||
(x as :string, y as :string) -> base :str (x, y)
|
||||
(xs as :list, ys as :list) -> base :concat (xs, ys)
|
||||
(xs as :set, ys as :set) -> base :concat (xs, ys)
|
||||
(xs, ys, ...zs) -> fold (concat, zs, concat (xs, ys))
|
||||
|
|
@ -249,13 +227,13 @@ fn concat {
|
|||
& the console: sending messages to the outside world
|
||||
& the console is *both* something we send to the host language's console
|
||||
& ...and also a list of messages.
|
||||
box console = []
|
||||
ref console = []
|
||||
|
||||
fn flush! {
|
||||
"Clears the console, and returns the messages."
|
||||
() -> {
|
||||
let msgs = unbox (console)
|
||||
store! (console, [])
|
||||
let msgs = deref (console)
|
||||
make! (console, [])
|
||||
msgs
|
||||
}
|
||||
}
|
||||
|
|
@ -264,9 +242,7 @@ fn add_msg! {
|
|||
"Adds a message to the console."
|
||||
(msg as :string) -> update! (console, append (_, msg))
|
||||
(msgs as :list) -> {
|
||||
base :print! (("adding msg", msgs))
|
||||
let msg = do msgs > map (string, _) > join
|
||||
base :print! (("msg: ", msg))
|
||||
update! (console, append (_, msg))
|
||||
}
|
||||
}
|
||||
|
|
@ -274,8 +250,8 @@ fn add_msg! {
|
|||
fn print! {
|
||||
"Sends a text representation of Ludus values to the console."
|
||||
(...args) -> {
|
||||
base :print! (args)
|
||||
& add_msg! (args)
|
||||
base :print (args)
|
||||
add_msg! (args)
|
||||
:ok
|
||||
}
|
||||
}
|
||||
|
|
@ -287,11 +263,7 @@ fn show {
|
|||
|
||||
fn prn! {
|
||||
"Prints the underlying Clojure data structure of a Ludus value."
|
||||
(x) -> {
|
||||
base :prn (x)
|
||||
& add_msg! (x)
|
||||
:ok
|
||||
}
|
||||
(x) -> base :prn (x)
|
||||
}
|
||||
|
||||
fn report! {
|
||||
|
|
@ -320,11 +292,11 @@ fn string? {
|
|||
}
|
||||
|
||||
fn string {
|
||||
"Converts a value to a string by using `show`. If it is a string, returns it unharmed. Use this to build up strings of different kinds of values."
|
||||
"Converts a value to a string by using `show`. If it is a string, returns it unharmed. Use this to build up strings of differen kinds of values."
|
||||
(x as :string) -> x
|
||||
(x) -> show (x)
|
||||
(x, ...xs) -> loop (x, xs) with {
|
||||
(out, [x]) -> concat (out, show (x))
|
||||
(out, [x]) -> concat (out, show(x))
|
||||
(out, [x, ...xs]) -> recur (concat (out, show (x)), xs)
|
||||
}
|
||||
}
|
||||
|
|
@ -348,31 +320,28 @@ fn join {
|
|||
|
||||
&&& references: mutable state and state changes
|
||||
|
||||
fn box? {
|
||||
"Returns true if a value is a box."
|
||||
(b as :box) -> true
|
||||
fn ref? {
|
||||
"Returns true if a value is a ref."
|
||||
(r as :ref) -> true
|
||||
(_) -> false
|
||||
}
|
||||
|
||||
fn unbox {
|
||||
"Returns the value that is stored in a box."
|
||||
(b as :box) -> base :unbox (b)
|
||||
fn deref {
|
||||
"Resolves a ref into a value."
|
||||
(r as :ref) -> base :deref (r)
|
||||
}
|
||||
|
||||
fn store! {
|
||||
"Stores a value in a box, replacing the value that was previously there. Returns the value."
|
||||
(b as :box, value) -> {
|
||||
base :store! (b, value)
|
||||
value
|
||||
}
|
||||
fn make! {
|
||||
"Sets the value of a ref."
|
||||
(r as :ref, value) -> base :set! (r, value)
|
||||
}
|
||||
|
||||
fn update! {
|
||||
"Updates a box by applying a function to its value. Returns the new value."
|
||||
(b as :box, f as :fn) -> {
|
||||
let current = unbox (b)
|
||||
"Updates a ref by applying a function to its value. Returns the new value."
|
||||
(r as :ref, f as :fn) -> {
|
||||
let current = deref (r)
|
||||
let new = f (current)
|
||||
store! (b, new)
|
||||
make! (r, new)
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -572,56 +541,6 @@ fn max {
|
|||
(x, y, ...zs) -> fold (max, zs, max (x, y))
|
||||
}
|
||||
|
||||
& additional list operations now that we have comparitors
|
||||
fn at {
|
||||
"Returns the element at index n of a list or tuple. Zero-indexed: the first element is at index 0."
|
||||
(xs as :list, n as :number) -> when {
|
||||
neg? (n) -> nil
|
||||
gte? (n, count (xs)) -> nil
|
||||
true -> base :nth (n, xs)
|
||||
}
|
||||
(xs as :tuple, n as :number) -> when {
|
||||
neg? (n) -> nil
|
||||
gte? (n, count (xs)) -> nil
|
||||
true -> base :nth (n, xs)
|
||||
}
|
||||
(_) -> nil
|
||||
}
|
||||
|
||||
fn first {
|
||||
"Returns the first element of a list or tuple."
|
||||
(xs) -> at (xs, 0)
|
||||
}
|
||||
|
||||
fn second {
|
||||
"Returns the second element of a list or tuple."
|
||||
(xs) -> at (xs, 1)
|
||||
}
|
||||
|
||||
fn last {
|
||||
"Returns the last element of a list or tuple."
|
||||
(xs) -> at (xs, dec (count (xs)))
|
||||
}
|
||||
|
||||
fn butlast {
|
||||
"Returns a list, omitting the last element."
|
||||
(xs as :list) -> base :slice (xs, dec (count (xs)))
|
||||
}
|
||||
|
||||
fn slice {
|
||||
"Returns a slice of a list, representing a sub-list."
|
||||
(xs as :list, end as :number) -> slice (xs, 0, end)
|
||||
(xs as :list, start as :number, end as :number) -> when {
|
||||
gte? (start, end) -> []
|
||||
gt? (end, count (xs)) -> slice (xs, start, count (xs))
|
||||
neg? (start) -> slice (xs, 0, end)
|
||||
true -> {
|
||||
let slice = base :slice (xs, inc (start), inc (end))
|
||||
base :into ([], slice)
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
&&& keywords: funny names
|
||||
fn keyword? {
|
||||
"Returns true if a value is a keyword, otherwise returns false."
|
||||
|
|
@ -651,6 +570,40 @@ fn some {
|
|||
(value, _) -> value
|
||||
}
|
||||
|
||||
&&& true & false: boolean logic
|
||||
|
||||
fn bool? {
|
||||
"Returns true if a value is of type :boolean."
|
||||
(false) -> true
|
||||
(true) -> true
|
||||
(_) -> false
|
||||
}
|
||||
|
||||
fn true? {
|
||||
"Returns true if a value is boolean `true`. Useful to distinguish between `true` and anything else."
|
||||
(true) -> true
|
||||
(_) -> false
|
||||
}
|
||||
|
||||
fn false? {
|
||||
"Returns `true` if a value is `false`, otherwise returns `false`. Useful to distinguish between `false` and `nil`."
|
||||
(false) -> true
|
||||
(_) -> false
|
||||
}
|
||||
|
||||
fn bool {
|
||||
"Returns false if a value is nil or false, otherwise returns true."
|
||||
(nil) -> false
|
||||
(false) -> false
|
||||
(_) -> true
|
||||
}
|
||||
|
||||
fn not {
|
||||
"Returns false if a value is truthy, true if a value is falsy."
|
||||
(nil) -> true
|
||||
(false) -> true
|
||||
(_) -> false
|
||||
}
|
||||
|
||||
& TODO: make `and` and `or` special forms which lazily evaluate arguments
|
||||
fn and {
|
||||
|
|
@ -736,10 +689,11 @@ fn diff {
|
|||
fn coll? {
|
||||
"Returns true if a value is a collection: dict, struct, list, tuple, or set."
|
||||
(coll as :dict) -> true
|
||||
(coll as :struct) -> true
|
||||
(coll as :list) -> true
|
||||
(coll as :tuple) -> true
|
||||
(coll as :set) -> true
|
||||
(coll as :pkg) -> true
|
||||
(coll as :ns) -> true
|
||||
(_) -> false
|
||||
}
|
||||
|
||||
|
|
@ -753,7 +707,8 @@ fn ordered? {
|
|||
fn assoc? {
|
||||
"Returns true if a value is an associative collection: a dict, struct, or namespace."
|
||||
(assoc as :dict) -> true
|
||||
(assoc as :pkg) -> true
|
||||
(assoc as :struct) -> true
|
||||
(assoc as :ns) -> true
|
||||
(_) -> false
|
||||
}
|
||||
|
||||
|
|
@ -773,7 +728,8 @@ fn has? {
|
|||
}
|
||||
|
||||
fn dict {
|
||||
"Takes a list or tuple of (key, value) tuples and returns it as a dict. Returns dicts unharmed."
|
||||
"Takes an ns, and returns it as a dict. Or, takes a list or tuple of (key, value) tuples and returns it as a dict. Returns dicts unharmed."
|
||||
(ns_ as :ns) -> base :to_dict (ns_)
|
||||
(dict as :dict) -> dict
|
||||
(list as :list) -> fold (assoc, list)
|
||||
(tup as :tuple) -> do tup > list > dict
|
||||
|
|
@ -1032,30 +988,29 @@ let turtle_init = #{
|
|||
|
||||
& turtle states: refs that get modified by calls
|
||||
& turtle_commands is a list of commands, expressed as tuples
|
||||
box turtle_commands = []
|
||||
ref turtle_commands = []
|
||||
|
||||
& and a list of turtle states
|
||||
box turtle_states = [turtle_init]
|
||||
ref turtle_states = [turtle_init]
|
||||
|
||||
fn reset_turtle! {
|
||||
"Resets the turtle to its original state."
|
||||
() -> store! (turtle_states, [turtle_init])
|
||||
() -> make! (turtle_states, [turtle_init])
|
||||
}
|
||||
|
||||
& and a list of calls to p5--at least for now
|
||||
box p5_calls = []
|
||||
ref p5_calls = []
|
||||
|
||||
& ...and finally, a background color
|
||||
& we need to store this separately because, while it can be updated later,
|
||||
& it must be the first call to p5.
|
||||
box bgcolor = colors :black
|
||||
ref bgcolor = colors :black
|
||||
|
||||
fn add_call! (call) -> update! (p5_calls, append (_, call))
|
||||
|
||||
fn add_command! (command) -> {
|
||||
print! ("adding command", command)
|
||||
update! (turtle_commands, append (_, command))
|
||||
let prev = do turtle_states > unbox > last
|
||||
let prev = do turtle_states > deref > last
|
||||
let curr = apply_command (prev, command)
|
||||
update! (turtle_states, append (_, curr))
|
||||
let call = state/call ()
|
||||
|
|
@ -1071,12 +1026,12 @@ let turtle_angle = 0.385
|
|||
let turtle_color = (255, 255, 255, 150)
|
||||
|
||||
fn render_turtle! () -> {
|
||||
let state = do turtle_states > unbox > last
|
||||
let state = do turtle_states > deref > last
|
||||
if state :visible?
|
||||
then {
|
||||
let (r, g, b, a) = turtle_color
|
||||
add_call! ((:fill, r, g, b, a))
|
||||
let #{heading, :position (x, y), ...} = state
|
||||
let #{heading, :position (x, y)} = state
|
||||
let first = mult ((0, 1), turtle_radius)
|
||||
let (x1, y1) = first
|
||||
let (x2, y2) = rotate (first, turtle_angle)
|
||||
|
|
@ -1100,8 +1055,8 @@ fn render_turtle! () -> {
|
|||
}
|
||||
|
||||
fn state/call () -> {
|
||||
let cmd = do turtle_commands > unbox > last > first
|
||||
let states = unbox (turtle_states)
|
||||
let cmd = do turtle_commands > deref > last > first
|
||||
let states = deref (turtle_states)
|
||||
let curr = last (states)
|
||||
let prev = at (states, sub (count (states), 2))
|
||||
match cmd with {
|
||||
|
|
@ -1123,7 +1078,7 @@ fn state/call () -> {
|
|||
(:stroke, r, g, b, a)
|
||||
}
|
||||
:clear -> (:background, 0, 0, 0, 255)
|
||||
_ -> nil
|
||||
else -> nil
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -1189,9 +1144,9 @@ let pw! = penwidth!
|
|||
|
||||
fn background! {
|
||||
"Sets the background color behind the turtle and path. Alias: bg!"
|
||||
(gray as :number) -> store! (bgcolor, (gray, gray, gray, 255))
|
||||
((r as :number, g as :number, b as :number)) -> store! (bgcolor, (r, b, g, 255))
|
||||
((r as :number, g as :number, b as :number, a as :number)) -> store! (bgcolor, (r, g, b, a))
|
||||
(gray as :number) -> make! (bgcolor, (gray, gray, gray, 255))
|
||||
((r as :number, g as :number, b as :number)) -> make! (bgcolor, (r, b, g, 255))
|
||||
((r as :number, g as :number, b as :number, a as :number)) -> make! (bgcolor, (r, g, b, a))
|
||||
}
|
||||
|
||||
let bg! = background!
|
||||
|
|
@ -1230,13 +1185,13 @@ fn apply_command {
|
|||
(:right, turns) -> update (state, :heading, add (_, turns))
|
||||
(:left, turns) -> update (state, :heading, sub (_, turns))
|
||||
(:forward, steps) -> {
|
||||
let #{heading, position, ...} = state
|
||||
let #{heading, position} = state
|
||||
let unit = heading/vector (heading)
|
||||
let vect = mult (steps, unit)
|
||||
update (state, :position, add (vect, _))
|
||||
}
|
||||
(:back, steps) -> {
|
||||
let #{heading, position, ...} = state
|
||||
let #{heading, position} = state
|
||||
let unit = heading/vector (heading)
|
||||
let vect = mult (steps, unit)
|
||||
update (state, :position, sub (_, vect))
|
||||
|
|
@ -1250,7 +1205,7 @@ fn apply_command {
|
|||
|
||||
fn turtle_state {
|
||||
"Returns the turtle's current state."
|
||||
() -> do turtle_states > unbox > last
|
||||
() -> do turtle_states > deref > last
|
||||
}
|
||||
|
||||
& position () -> (x, y)
|
||||
|
|
@ -1279,155 +1234,135 @@ fn penwidth {
|
|||
() -> turtle_state () :pencolor
|
||||
}
|
||||
|
||||
pkg Prelude {
|
||||
abs
|
||||
add
|
||||
and
|
||||
angle
|
||||
any?
|
||||
append
|
||||
assert!
|
||||
assoc
|
||||
assoc?
|
||||
ns prelude {
|
||||
type
|
||||
eq?
|
||||
neq?
|
||||
tuple?
|
||||
fn?
|
||||
first
|
||||
second
|
||||
rest
|
||||
at
|
||||
atan/2
|
||||
back!
|
||||
background!
|
||||
between?
|
||||
bg!
|
||||
bgcolor
|
||||
bk!
|
||||
bool
|
||||
bool?
|
||||
box?
|
||||
last
|
||||
butlast
|
||||
ceil
|
||||
clear!
|
||||
coll?
|
||||
colors
|
||||
concat
|
||||
console
|
||||
cos
|
||||
slice
|
||||
count
|
||||
append
|
||||
fold
|
||||
map
|
||||
filter
|
||||
keep
|
||||
list
|
||||
set
|
||||
set?
|
||||
inc
|
||||
dec
|
||||
deg/rad
|
||||
deg/turn
|
||||
dict
|
||||
dict?
|
||||
diff
|
||||
dissoc
|
||||
dist
|
||||
print!
|
||||
flush!
|
||||
console
|
||||
show
|
||||
prn!
|
||||
report!
|
||||
doc!
|
||||
concat
|
||||
ref?
|
||||
deref
|
||||
make!
|
||||
update!
|
||||
string
|
||||
string?
|
||||
join
|
||||
add
|
||||
sub
|
||||
mult
|
||||
div
|
||||
div/0
|
||||
div/safe
|
||||
doc!
|
||||
each!
|
||||
empty?
|
||||
eq?
|
||||
err
|
||||
err?
|
||||
even?
|
||||
false?
|
||||
fd!
|
||||
filter
|
||||
first
|
||||
floor
|
||||
flush!
|
||||
fn?
|
||||
fold
|
||||
forward!
|
||||
get
|
||||
goto!
|
||||
gt?
|
||||
gte?
|
||||
heading
|
||||
heading/vector
|
||||
home!
|
||||
inc
|
||||
inv
|
||||
inv/0
|
||||
join
|
||||
keep
|
||||
keys
|
||||
keyword?
|
||||
last
|
||||
left!
|
||||
list
|
||||
lt!
|
||||
angle
|
||||
abs
|
||||
neg
|
||||
zero?
|
||||
neg?
|
||||
pos?
|
||||
even?
|
||||
odd?
|
||||
gt?
|
||||
gte?
|
||||
lt?
|
||||
lte?
|
||||
map
|
||||
max
|
||||
min
|
||||
mod
|
||||
mult
|
||||
neg
|
||||
neg?
|
||||
neq?
|
||||
max
|
||||
between?
|
||||
keyword?
|
||||
nil?
|
||||
some?
|
||||
some
|
||||
bool?
|
||||
false?
|
||||
bool
|
||||
not
|
||||
odd?
|
||||
ok
|
||||
ok?
|
||||
and
|
||||
or
|
||||
coll?
|
||||
ordered?
|
||||
p5_calls
|
||||
pc!
|
||||
pd!
|
||||
pencolor
|
||||
pencolor!
|
||||
pendown!
|
||||
pendown?
|
||||
penup!
|
||||
penwidth
|
||||
penwidth!
|
||||
pi
|
||||
pos?
|
||||
position
|
||||
print!
|
||||
prn!
|
||||
pu!
|
||||
pw!
|
||||
rad/deg
|
||||
assoc?
|
||||
assoc
|
||||
dissoc
|
||||
update
|
||||
get
|
||||
dict
|
||||
dict?
|
||||
keys
|
||||
values
|
||||
diff
|
||||
each!
|
||||
sin
|
||||
cos
|
||||
tan
|
||||
turn/rad
|
||||
rad/turn
|
||||
turn/deg
|
||||
deg/turn
|
||||
rad/deg
|
||||
deg/rad
|
||||
atan/2
|
||||
mod
|
||||
square
|
||||
sum_of_squares
|
||||
dist
|
||||
random
|
||||
random_int
|
||||
range
|
||||
render_turtle!
|
||||
report!
|
||||
reset_turtle!
|
||||
rest
|
||||
right!
|
||||
round
|
||||
rt!
|
||||
second
|
||||
set
|
||||
set?
|
||||
show
|
||||
sin
|
||||
slice
|
||||
some
|
||||
some?
|
||||
square
|
||||
store!
|
||||
string
|
||||
string?
|
||||
sub
|
||||
sum_of_squares
|
||||
tan
|
||||
pi
|
||||
tau
|
||||
tuple?
|
||||
turn/deg
|
||||
turn/rad
|
||||
turtle_commands
|
||||
turtle_state
|
||||
turtle_states
|
||||
type
|
||||
unbox
|
||||
floor
|
||||
ceil
|
||||
round
|
||||
range
|
||||
ok
|
||||
ok?
|
||||
err
|
||||
err?
|
||||
unwrap!
|
||||
unwrap_or
|
||||
update
|
||||
update!
|
||||
values
|
||||
zero?
|
||||
assert!
|
||||
colors
|
||||
forward!, fd!
|
||||
back!, bk!
|
||||
right!, rt!
|
||||
left!, lt!
|
||||
penup!, pu!
|
||||
pendown!, pd!
|
||||
pencolor!, pc!
|
||||
background!, bg!
|
||||
penwidth!, pw!
|
||||
home!, clear!, goto!,
|
||||
heading, position, pendown?
|
||||
pencolor, penwidth
|
||||
heading/vector
|
||||
turtle_state
|
||||
p5_calls, turtle_states, turtle_commands, bgcolor
|
||||
render_turtle!, reset_turtle!
|
||||
}
|
||||
118
src/ludus/repl.clj
Normal file
118
src/ludus/repl.clj
Normal file
|
|
@ -0,0 +1,118 @@
|
|||
(ns ludus.repl
|
||||
(:require
|
||||
[ludus.scanner :as scanner]
|
||||
[ludus.parser :as p]
|
||||
[ludus.grammar :as g]
|
||||
[ludus.interpreter :as interpreter]
|
||||
[ludus.base :as base]
|
||||
[ludus.show :as show]
|
||||
[ludus.data :as data]
|
||||
;[ludus.process :as process]
|
||||
))
|
||||
|
||||
(declare repl-prelude new-session)
|
||||
|
||||
(def sessions (atom {}))
|
||||
|
||||
(def current-session (atom nil))
|
||||
|
||||
(def prompt "=> ")
|
||||
|
||||
(defn- exit []
|
||||
(println "\nGoodbye!")
|
||||
(System/exit 0))
|
||||
|
||||
(def repl-ctx (merge interpreter/ludus-prelude
|
||||
{::repl true
|
||||
"repl"
|
||||
{::data/struct true
|
||||
::data/type ::data/ns
|
||||
::data/name "repl"
|
||||
|
||||
:flush
|
||||
{:name "flush"
|
||||
::data/type ::data/clj
|
||||
:body (fn
|
||||
([]
|
||||
(let [session @current-session]
|
||||
(swap! session #(assoc % :ctx (volatile! repl-ctx)))
|
||||
:ok))
|
||||
([name]
|
||||
(if-let [session (get @sessions name)]
|
||||
(do
|
||||
(swap! session #(assoc % :ctx (volatile! repl-ctx)))
|
||||
:ok)
|
||||
(do
|
||||
(println "No session named" name)
|
||||
:error))))}
|
||||
|
||||
:new
|
||||
{:name "new"
|
||||
::data/type ::data/clj
|
||||
:body (fn [name]
|
||||
(let [session (new-session name)]
|
||||
(reset! current-session session)
|
||||
:ok))}
|
||||
|
||||
:switch
|
||||
{:name "switch"
|
||||
::data/type ::data/clj
|
||||
:body (fn [name]
|
||||
(if-let [session (get @sessions name)]
|
||||
(do
|
||||
(reset! current-session session)
|
||||
:ok)
|
||||
(do
|
||||
(println "No session named" name)
|
||||
:error)))}
|
||||
|
||||
:quit
|
||||
{:name "quit"
|
||||
::data/type ::data/clj
|
||||
:body (fn [] (exit))}
|
||||
}}))
|
||||
|
||||
(defn- new-session [name]
|
||||
(let [session (atom {:name name
|
||||
:ctx (volatile! repl-ctx)
|
||||
:history []})]
|
||||
(swap! sessions #(assoc % name session))
|
||||
session))
|
||||
|
||||
(defn repl-loop []
|
||||
(let [session-atom @current-session
|
||||
session @session-atom
|
||||
orig-ctx (:ctx session)]
|
||||
(print (str (:name session) prompt))
|
||||
(flush)
|
||||
(let [input (read-line)]
|
||||
(cond
|
||||
(= nil input) (exit)
|
||||
|
||||
(= "" input) (recur)
|
||||
|
||||
:else
|
||||
(let [parsed (->> input
|
||||
(scanner/scan)
|
||||
:tokens
|
||||
(p/apply-parser g/script))]
|
||||
(if (= :err (:status parsed))
|
||||
(do
|
||||
(println (p/err-msg parsed))
|
||||
(recur))
|
||||
(let [{result :result ctx :ctx}
|
||||
(interpreter/interpret-repl parsed orig-ctx true)]
|
||||
(if (= result :error)
|
||||
(recur)
|
||||
(do
|
||||
(println (show/show result))
|
||||
(when (not (= @ctx @orig-ctx))
|
||||
(swap! session-atom #(assoc % :ctx ctx)))
|
||||
(recur))))))))))
|
||||
|
||||
(defn launch []
|
||||
(println "Welcome to Ludus (v. 0.1.0-alpha)")
|
||||
(let [session (new-session :ludus)]
|
||||
(reset! current-session session)
|
||||
(repl-loop)))
|
||||
|
||||
336
src/ludus/scanner.cljc
Normal file
336
src/ludus/scanner.cljc
Normal file
|
|
@ -0,0 +1,336 @@
|
|||
(ns ludus.scanner
|
||||
(:require
|
||||
[ludus.token :as token]
|
||||
;; [clojure.pprint :as pp]
|
||||
[clojure.edn :as edn]))
|
||||
|
||||
(def reserved-words
|
||||
"List of Ludus reserved words."
|
||||
;; see ludus-spec repo for more info
|
||||
{"as" :as ;; impl for `import`; not yet for patterns
|
||||
;"cond" :cond ;; impl
|
||||
"do" :do ;; impl
|
||||
"else" :else ;; impl
|
||||
"false" :false ;; impl -> literal word
|
||||
"fn" :fn ;; impl
|
||||
"if" :if ;; impl
|
||||
"import" :import ;; impl
|
||||
"let" :let ;; impl
|
||||
"loop" :loop ;; impl
|
||||
"match" :match ;; impl
|
||||
"nil" :nil ;; impl -> literal word
|
||||
"ns" :ns ;; impl
|
||||
"panic!" :panic ;; impl (should _not_ be a function)
|
||||
"recur" :recur ;; impl
|
||||
"ref" :ref ;; impl
|
||||
"then" :then ;; impl
|
||||
"true" :true ;; impl -> literal word
|
||||
"use" :use ;; wip
|
||||
"with" :with ;; impl
|
||||
"when" :when ;; impl, replaces cond
|
||||
|
||||
;; actor model/concurrency
|
||||
;"receive" :receive
|
||||
;;"self" :self ;; maybe not necessary?: self() is a function
|
||||
;;"send" :send ;; not necessary: send(pid, message) is a function
|
||||
;"spawn" :spawn
|
||||
;;"to" :to ;; not necessary if send is a function
|
||||
;; type system
|
||||
;; "data" :data ;; we are going to tear out datatypes for now: see if dynamism works for us
|
||||
;; others
|
||||
"repeat" :repeat ;; syntax sugar over "loop": still unclear what this syntax could be
|
||||
"test" :test
|
||||
;; "module" :module ;; not necessary if we don't have datatypes
|
||||
})
|
||||
|
||||
(def literal-words {
|
||||
"true" true
|
||||
"false" false
|
||||
"nil" nil
|
||||
})
|
||||
|
||||
(defn- new-scanner
|
||||
"Creates a new scanner."
|
||||
[source input]
|
||||
{:source source
|
||||
:input input
|
||||
:length (count source)
|
||||
:errors []
|
||||
:start 0
|
||||
:current 0
|
||||
:line 1
|
||||
:tokens []})
|
||||
|
||||
(defn- at-end?
|
||||
"Tests if a scanner is at end of input."
|
||||
[scanner]
|
||||
(>= (:current scanner) (:length scanner)))
|
||||
|
||||
(defn- current-char
|
||||
"Gets the current character of the scanner."
|
||||
[scanner]
|
||||
(nth (:source scanner) (:current scanner) nil))
|
||||
|
||||
(defn- advance
|
||||
"Advances the scanner by a single character."
|
||||
[scanner]
|
||||
(update scanner :current inc))
|
||||
|
||||
(defn- next-char
|
||||
"Gets the next character from the scanner."
|
||||
[scanner]
|
||||
(current-char (advance scanner)))
|
||||
|
||||
(defn- current-lexeme
|
||||
[scanner]
|
||||
(subs (:source scanner) (:start scanner) (:current scanner)))
|
||||
|
||||
(defn- char-code [char]
|
||||
#?(
|
||||
:clj (int char)
|
||||
:cljs (.charCodeAt char 0)
|
||||
))
|
||||
|
||||
(defn- char-in-range? [start end char]
|
||||
(and char
|
||||
(>= (char-code char) (char-code start))
|
||||
(<= (char-code char) (char-code end))))
|
||||
|
||||
(defn- digit? [c]
|
||||
(char-in-range? \0 \9 c))
|
||||
|
||||
(defn- nonzero-digit? [c]
|
||||
(char-in-range? \1 \9 c))
|
||||
|
||||
;; for now, use very basic ASCII charset in words
|
||||
;; TODO: research the implications of using the whole
|
||||
;; (defn- alpha? [c] (boolean (re-find #"\p{L}" (str c))))
|
||||
(defn- alpha? [c]
|
||||
(or (char-in-range? \a \z c) (char-in-range? \A \Z c)))
|
||||
|
||||
(defn- lower? [c] (char-in-range? \a \z c))
|
||||
|
||||
(defn- upper? [c] (char-in-range? \A \Z c))
|
||||
|
||||
;; legal characters in words
|
||||
(def word-chars #{\_ \? \! \* \/})
|
||||
|
||||
(defn- word-char? [c]
|
||||
(or (alpha? c) (digit? c) (contains? word-chars c)))
|
||||
|
||||
(defn- whitespace? [c]
|
||||
(or (= c \space) (= c \tab)))
|
||||
|
||||
(def terminators #{\: \; \newline \{ \} \( \) \[ \] \$ \# \- \= \& \, \> nil \\})
|
||||
|
||||
(defn- terminates? [c]
|
||||
(or (whitespace? c) (contains? terminators c)))
|
||||
|
||||
(defn- add-token
|
||||
([scanner token-type]
|
||||
(add-token scanner token-type nil))
|
||||
([scanner token-type literal]
|
||||
(update scanner :tokens conj
|
||||
(token/token
|
||||
token-type
|
||||
(current-lexeme scanner)
|
||||
literal
|
||||
(:line scanner)
|
||||
(:start scanner)
|
||||
(:source scanner)
|
||||
(:input scanner)))))
|
||||
|
||||
;; TODO: errors should also be in the vector of tokens
|
||||
;; The goal is to be able to be able to hand this to an LSP?
|
||||
;; Do we need a different structure
|
||||
(defn- add-error [scanner msg]
|
||||
(let [token (token/token
|
||||
:error
|
||||
(current-lexeme scanner)
|
||||
nil
|
||||
(:line scanner)
|
||||
(:start scanner)
|
||||
(:source scanner)
|
||||
(:input scanner))
|
||||
err-token (assoc token :message msg)]
|
||||
(-> scanner
|
||||
(update :errors conj err-token)
|
||||
(update :tokens conj err-token))))
|
||||
|
||||
(defn- add-keyword
|
||||
[scanner]
|
||||
(loop [scanner scanner
|
||||
key ""]
|
||||
(let [char (current-char scanner)]
|
||||
(cond
|
||||
(terminates? char) (add-token scanner :keyword (keyword key))
|
||||
(word-char? char) (recur (advance scanner) (str key char))
|
||||
:else (add-error scanner (str "Unexpected " char "after keyword :" key))))))
|
||||
|
||||
;; TODO: improve number parsing?
|
||||
;; Currently this uses Clojure's number formatting rules (since we use the EDN reader)
|
||||
;; These rules are here: https://cljs.github.io/api/syntax/number
|
||||
(defn- add-number [char scanner]
|
||||
(loop [scanner scanner
|
||||
num (str char)
|
||||
float? false]
|
||||
(let [curr (current-char scanner)]
|
||||
(cond
|
||||
(= curr \_) (recur (advance scanner) num float?) ;; consume underscores unharmed
|
||||
(= curr \.) (if float?
|
||||
(add-error scanner (str "Unexpected second decimal point after " num "."))
|
||||
(recur (advance scanner) (str num curr) true))
|
||||
(terminates? curr) (add-token scanner :number (edn/read-string num))
|
||||
(digit? curr) (recur (advance scanner) (str num curr) float?)
|
||||
:else (add-error scanner (str "Unexpected " curr " after number " num "."))))))
|
||||
|
||||
;; TODO: activate string interpolation
|
||||
(defn- add-string
|
||||
[scanner]
|
||||
(loop [scanner scanner
|
||||
string ""
|
||||
interpolate? false]
|
||||
(let [char (current-char scanner)]
|
||||
(case char
|
||||
\{ (recur (advance scanner) (str string char) true)
|
||||
; allow multiline strings
|
||||
\newline (recur (update (advance scanner) :line inc) (str string char) interpolate?)
|
||||
\" (if interpolate?
|
||||
;(add-token (advance scanner) :interpolated string)
|
||||
(add-token (advance scanner) :string string)
|
||||
(add-token (advance scanner) :string string))
|
||||
\\ (let [next (next-char scanner)
|
||||
scanner (if (= next \newline)
|
||||
(update scanner :line inc)
|
||||
scanner)]
|
||||
(recur (advance (advance scanner)) (str string next) interpolate?))
|
||||
(if (at-end? scanner)
|
||||
(add-error scanner "Unterminated string.")
|
||||
(recur (advance scanner) (str string char) interpolate?))))))
|
||||
|
||||
(defn- add-word
|
||||
[char scanner]
|
||||
(loop [scanner scanner
|
||||
word (str char)]
|
||||
(let [curr (current-char scanner)]
|
||||
(cond
|
||||
(terminates? curr) (add-token scanner
|
||||
(get reserved-words word :word)
|
||||
(get literal-words word :none))
|
||||
(word-char? curr) (recur (advance scanner) (str word curr))
|
||||
:else (add-error scanner (str "Unexpected " curr " after word " word "."))))))
|
||||
|
||||
(defn- add-data
|
||||
[char scanner]
|
||||
(loop [scanner scanner
|
||||
word (str char)]
|
||||
(let [curr (current-char scanner)]
|
||||
(cond
|
||||
(terminates? curr) (add-token scanner :datatype)
|
||||
(word-char? curr) (recur (advance scanner) (str word curr))
|
||||
:else (add-error scanner (str "Unexpected " curr " after datatype " word "."))))))
|
||||
|
||||
(defn- add-ignored
|
||||
[scanner]
|
||||
(loop [scanner scanner
|
||||
ignored "_"]
|
||||
(let [char (current-char scanner)]
|
||||
(cond
|
||||
(terminates? char) (add-token scanner :ignored)
|
||||
(word-char? char) (recur (advance scanner) (str ignored char))
|
||||
:else (add-error scanner (str "Unexpected " char " after word " ignored "."))))))
|
||||
|
||||
(defn- add-comment [char scanner]
|
||||
(loop [scanner scanner
|
||||
comm (str char)]
|
||||
(let [char (current-char scanner)]
|
||||
(if (= \newline char)
|
||||
scanner
|
||||
(recur (advance scanner) (str comm char))))))
|
||||
|
||||
(defn- scan-token [scanner]
|
||||
(let [char (current-char scanner)
|
||||
scanner (advance scanner)
|
||||
next (current-char scanner)]
|
||||
(case char
|
||||
;; one-character tokens
|
||||
\( (add-token scanner :lparen)
|
||||
;; :break is a special zero-char token before closing braces
|
||||
;; it makes parsing much simpler
|
||||
\) (add-token (add-token scanner :break) :rparen)
|
||||
\{ (add-token scanner :lbrace)
|
||||
\} (add-token (add-token scanner :break) :rbrace)
|
||||
\[ (add-token scanner :lbracket)
|
||||
\] (add-token (add-token scanner :break) :rbracket)
|
||||
\; (add-token scanner :semicolon)
|
||||
\, (add-token scanner :comma)
|
||||
\newline (add-token (update scanner :line inc) :newline)
|
||||
\\ (add-token scanner :backslash)
|
||||
\= (add-token scanner :equals)
|
||||
\> (add-token scanner :pipeline)
|
||||
|
||||
;; two-character tokens
|
||||
;; ->
|
||||
\- (cond
|
||||
(= next \>) (add-token (advance scanner) :rarrow)
|
||||
(digit? next) (add-number char scanner)
|
||||
:else (add-error scanner (str "Expected -> or negative number after `-`. Got `" char next "`")))
|
||||
|
||||
;; dict #{
|
||||
\# (if (= next \{)
|
||||
(add-token (advance scanner) :startdict)
|
||||
(add-error scanner (str "Expected beginning of dict: #{. Got " char next)))
|
||||
|
||||
;; set ${
|
||||
\$ (if (= next \{)
|
||||
(add-token (advance scanner) :startset)
|
||||
(add-error scanner (str "Expected beginning of set: ${. Got " char next)))
|
||||
|
||||
;; struct @{: Deleted from the language in December 2023
|
||||
; \@ (if (= next \{)
|
||||
; (add-token (advance scanner) :startstruct)
|
||||
; (add-error scanner (str "Expected beginning of struct: @{. Got " char next)))
|
||||
|
||||
;; placeholders
|
||||
;; there's a flat _, and then ignored words
|
||||
\_ (cond
|
||||
(terminates? next) (add-token scanner :placeholder)
|
||||
(alpha? next) (add-ignored scanner)
|
||||
:else (add-error scanner (str "Expected placeholder: _. Got " char next)))
|
||||
|
||||
;; comments
|
||||
;; & starts an inline comment
|
||||
\& (add-comment char scanner)
|
||||
|
||||
;; keywords
|
||||
\: (cond
|
||||
(alpha? next) (add-keyword scanner)
|
||||
:else (add-error scanner (str "Expected keyword. Got " char next)))
|
||||
|
||||
;; splats
|
||||
\. (let [after_next (current-char (advance scanner))]
|
||||
(if (= ".." (str next after_next))
|
||||
(add-token (advance (advance scanner)) :splat)
|
||||
(add-error scanner (str "Expected splat: ... . Got " (str "." next after_next)))))
|
||||
|
||||
;; strings
|
||||
\" (add-string scanner)
|
||||
|
||||
;; word matches
|
||||
(cond
|
||||
(whitespace? char) scanner ;; for now just skip whitespace characters
|
||||
(digit? char) (add-number char scanner)
|
||||
(upper? char) (add-word char scanner) ;; no datatypes for now
|
||||
(lower? char) (add-word char scanner)
|
||||
:else (add-error scanner (str "Unexpected character: " char))))))
|
||||
|
||||
(defn- next-token [scanner]
|
||||
(assoc scanner :start (:current scanner)))
|
||||
|
||||
(defn scan [source input]
|
||||
(loop [scanner (new-scanner source input)]
|
||||
(if (at-end? scanner)
|
||||
(let [scanner (add-token (add-token scanner :break) :eof)]
|
||||
{:tokens (:tokens scanner)
|
||||
:errors (:errors scanner)})
|
||||
(recur (-> scanner (scan-token) (next-token))))))
|
||||
122
src/ludus/show.cljc
Normal file
122
src/ludus/show.cljc
Normal file
|
|
@ -0,0 +1,122 @@
|
|||
(ns ludus.show
|
||||
(:require
|
||||
[ludus.data :as data]
|
||||
; [ludus.scanner :as s]
|
||||
; [ludus.parser :as p]
|
||||
; [ludus.grammar :as g]
|
||||
; [ludus.interpreter :as i]
|
||||
[clojure.pprint :as pp]))
|
||||
|
||||
(declare show show-linear show-keyed)
|
||||
|
||||
(defn- show-vector [v]
|
||||
(if (= (first v) ::data/tuple)
|
||||
(str "(" (apply str (into [] show-linear (next v))) ")")
|
||||
(str "[" (apply str (into [] show-linear (next v))) "]")))
|
||||
|
||||
(defn- show-map [v]
|
||||
(cond
|
||||
(or (= (::data/type v) ::data/fn)
|
||||
(= (::data/type v) ::data/clj))
|
||||
(str "fn " (:name v))
|
||||
|
||||
(= (::data/type v) ::data/ns)
|
||||
(str "ns " (::data/name v) " {"
|
||||
(apply str (into [] show-keyed (dissoc v ::data/struct ::data/type ::data/name)))
|
||||
"}")
|
||||
|
||||
(::data/struct v)
|
||||
(str "@{" (apply str (into [] show-keyed (dissoc v ::data/struct))) "}")
|
||||
|
||||
(::data/ref v) ;; TODO: reconsider this
|
||||
(str "ref: " (::data/name v) " {" (-> v ::data/value deref show) "}")
|
||||
|
||||
(::data/dict v)
|
||||
(str "#{" (apply str (into [] show-keyed (dissoc v ::data/dict))) "}")
|
||||
|
||||
:else
|
||||
(with-out-str (pp/pprint v))))
|
||||
|
||||
(defn- show-set [v]
|
||||
(str "${" (apply str (into [] show-linear v)) "}"))
|
||||
|
||||
(defn show
|
||||
([v]
|
||||
(cond
|
||||
(string? v) (str "\"" v "\"")
|
||||
(number? v) (str v)
|
||||
(keyword? v) (str v)
|
||||
(boolean? v) (str v)
|
||||
(nil? v) "nil"
|
||||
(vector? v) (show-vector v)
|
||||
(set? v) (show-set v)
|
||||
(map? v) (show-map v)
|
||||
:else
|
||||
(with-out-str (pp/pprint v))
|
||||
))
|
||||
([v & vs] (apply str (into [] (comp (map show) (interpose " ")) (concat [v] vs))))
|
||||
)
|
||||
|
||||
(def show-linear (comp (map show) (interpose ", ")))
|
||||
|
||||
(def show-keyed (comp
|
||||
(map #(str (show (first %)) " " (show (second %))))
|
||||
(interpose ", ")))
|
||||
|
||||
(declare show-pattern)
|
||||
|
||||
(defn show-coll-pattern [pattern [start end]]
|
||||
(let [data (:data pattern)
|
||||
members (map show-pattern data)
|
||||
output (apply str (interpose ", " members))]
|
||||
(str start output end)))
|
||||
|
||||
(defn show-pattern [pattern]
|
||||
(case (:type pattern)
|
||||
nil ""
|
||||
|
||||
:placeholder "_"
|
||||
|
||||
:else "else"
|
||||
|
||||
:true "true"
|
||||
|
||||
:false "false"
|
||||
|
||||
:nil "nil"
|
||||
|
||||
:string (-> pattern :data first show)
|
||||
|
||||
(:word :number :keyword) (-> pattern :data first str)
|
||||
|
||||
:typed
|
||||
(let [word (-> pattern :data first :data first)
|
||||
type (-> pattern :data second :data first)]
|
||||
(str word " as " type))
|
||||
|
||||
:splattern
|
||||
(let [splatted (-> pattern :data first show-pattern)]
|
||||
(str "..." splatted))
|
||||
|
||||
:pair-pattern
|
||||
(let [key (-> pattern :data first)
|
||||
value (-> pattern :data second)]
|
||||
(str (show-pattern key) " " (show-pattern value)))
|
||||
|
||||
:tuple-pattern (show-coll-pattern pattern ["(" ")"])
|
||||
|
||||
:list-pattern (show-coll-pattern pattern ["[" "]"])
|
||||
|
||||
:dict-pattern (show-coll-pattern pattern ["#{" "}"])
|
||||
|
||||
:struct-pattern (show-coll-pattern pattern ["@{" "}"])
|
||||
|
||||
))
|
||||
|
||||
(comment
|
||||
(def source "let 1 = 0")
|
||||
(def tokens (-> source s/scan :tokens))
|
||||
(def ast (p/apply-parser g/script tokens))
|
||||
(println (i/prettify-ast ast))
|
||||
(println (-> ast :data first :data first show-pattern))
|
||||
)
|
||||
11
src/ludus/token.cljc
Normal file
11
src/ludus/token.cljc
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
(ns ludus.token)
|
||||
|
||||
(defn token
|
||||
[type text literal line start source input]
|
||||
{:type type
|
||||
:lexeme text
|
||||
:literal literal
|
||||
:line line
|
||||
:source source
|
||||
:input input
|
||||
:start start})
|
||||
44
src/ludus/web.cljs
Normal file
44
src/ludus/web.cljs
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
(ns ludus.web
|
||||
(:require
|
||||
[ludus.core :as core]
|
||||
[goog.object :as o]
|
||||
)
|
||||
)
|
||||
|
||||
(defn get-element [id]
|
||||
(.getElementById (.-document js/window) id))
|
||||
|
||||
(def canv (get-element "canv"))
|
||||
|
||||
(def code (get-element "code"))
|
||||
|
||||
(def out (get-element "output"))
|
||||
|
||||
(def play (get-element "play"))
|
||||
|
||||
(defn run-code []
|
||||
(let [source (.-value code)
|
||||
result (core/run source)]
|
||||
(println "Running code:" source)
|
||||
(o/set out "value" result)))
|
||||
|
||||
(.addEventListener play "click" run-code)
|
||||
|
||||
(defn setup []
|
||||
(js/createCanvas 640 240 canv)
|
||||
(js/background 235)
|
||||
)
|
||||
|
||||
(defn draw []
|
||||
(if js/mouseIsPressed
|
||||
(js/fill 255)
|
||||
(js/fill 155))
|
||||
(js/ellipse js/mouseX js/mouseY 80 80))
|
||||
|
||||
(defn init []
|
||||
(doto js/window
|
||||
(o/set "setup" setup)
|
||||
(o/set "draw" draw)))
|
||||
|
||||
(o/set js/window "ludus_init" init)
|
||||
|
||||
1125
src/parser.janet
1125
src/parser.janet
File diff suppressed because it is too large
Load Diff
|
|
@ -1,41 +0,0 @@
|
|||
(import /src/base :as b)
|
||||
(import /src/scanner :as s)
|
||||
(import /src/parser :as p)
|
||||
(import /src/validate :as v)
|
||||
(import /src/interpreter :as i)
|
||||
(import /src/errors :as e)
|
||||
|
||||
(def pkg (do
|
||||
(def pre-ctx @{:^parent {"base" b/base}})
|
||||
(def pre-src (slurp "prelude.ld"))
|
||||
(def pre-scanned (s/scan pre-src :prelude))
|
||||
(def pre-parsed (p/parse pre-scanned))
|
||||
(def parse-errors (pre-parsed :errors))
|
||||
(when (any? parse-errors) (each err parse-errors (e/parse-error err)) (break :error))
|
||||
(def pre-validated (v/valid pre-parsed pre-ctx))
|
||||
(def validation-errors (pre-validated :errors))
|
||||
(when (any? validation-errors) (each err validation-errors (e/validation-error err)) (break :error))
|
||||
(try
|
||||
(i/interpret (pre-parsed :ast) pre-ctx)
|
||||
([err] (e/runtime-error err) :error))))
|
||||
|
||||
(def ctx (do
|
||||
(def ctx @{})
|
||||
(each [k v] (pairs pkg)
|
||||
(set (ctx (string k)) v))
|
||||
(set (ctx "^name") nil)
|
||||
(set (ctx "^type") nil)
|
||||
ctx))
|
||||
|
||||
(def post/src (slurp "postlude.ld"))
|
||||
|
||||
(def post/ast (do
|
||||
(def post-ctx @{:^parent ctx})
|
||||
(def post-scanned (s/scan post/src :postlude))
|
||||
(def post-parsed (p/parse post-scanned))
|
||||
(def parse-errors (post-parsed :errors))
|
||||
(when (any? parse-errors) (each err parse-errors (e/parse-error err)) (break :error))
|
||||
(def post-validated (v/valid post-parsed post-ctx))
|
||||
(def validation-errors (post-validated :errors))
|
||||
(when (any? validation-errors) (each err validation-errors (e/validation-error err)) (break :error))
|
||||
(post-parsed :ast)))
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
# testing the prelude
|
||||
(try (os/cd "janet") ([_] nil))
|
||||
(import /scanner :as s)
|
||||
(import /parser :as p)
|
||||
(import /validate :as v)
|
||||
(import /interpreter :as i)
|
||||
(import /errors :as e)
|
||||
(import /base :as b)
|
||||
(import /load-prelude :as pre)
|
||||
(use judge)
|
||||
|
||||
(defn run [source]
|
||||
(when (= :error pre/pkg) (error "could not load prelude"))
|
||||
(def ctx @{:^parent pre/ctx})
|
||||
(def scanned (s/scan source :test))
|
||||
(when (any? (scanned :errors))
|
||||
(e/scan-error (scanned :errors)) (error "scanning errors"))
|
||||
(def parsed (p/parse scanned))
|
||||
(when (any? (parsed :errors))
|
||||
(e/parse-error (parsed :errors)) (error "parsing errors"))
|
||||
(def valid (v/valid parsed ctx))
|
||||
(when (any? (valid :errors)) (each err (valid :errors)
|
||||
(e/validation-error err)) (error "validation errors"))
|
||||
(i/interpret (parsed :ast) ctx))
|
||||
|
||||
(deftest "debug add_msg"
|
||||
(test (run `
|
||||
let msgs = [1, :foo, nil]
|
||||
let msg = do msgs > map (string, _)
|
||||
msg
|
||||
`)
|
||||
@["1" ":foo" ":^nil"])
|
||||
# (test (run `print! ("foo", "bar")`) :ok)
|
||||
)
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
(declare-project
|
||||
:dependencies [
|
||||
{:url "https://github.com/ianthehenry/judge.git"
|
||||
:tag "v2.8.1"}
|
||||
{:url "https://github.com/janet-lang/spork"}
|
||||
])
|
||||
|
||||
(declare-source
|
||||
:source ["ludus.janet"])
|
||||
|
|
@ -1,343 +0,0 @@
|
|||
(def reserved-words
|
||||
"List of Ludus reserved words."
|
||||
## see ludus-spec repo for more info
|
||||
{"as" :as ## impl
|
||||
"box" :ref
|
||||
"do" :do ## impl
|
||||
"else" :else ## impl
|
||||
"false" :false ## impl -> literal word
|
||||
"fn" :fn ## impl
|
||||
"if" :if ## impl
|
||||
"import" :import ## impl
|
||||
"let" :let ## impl
|
||||
"loop" :loop ## impl
|
||||
"match" :match ## impl
|
||||
"nil" :nil ## impl -> literal word
|
||||
"ns" :ns ## impl
|
||||
"panic!" :panic ## impl (should _not_ be a function)
|
||||
"pkg" :pkg
|
||||
"recur" :recur ## impl
|
||||
"then" :then ## impl
|
||||
"true" :true ## impl -> literal word
|
||||
"use" :use ## wip
|
||||
"with" :with ## impl
|
||||
"when" :when ## impl, replaces cond
|
||||
"repeat" :repeat ## syntax sugar over "loop": still unclear what this syntax could be
|
||||
"test" :test
|
||||
})
|
||||
|
||||
(def literal-words {"true" true
|
||||
"false" false
|
||||
"nil" nil
|
||||
})
|
||||
|
||||
(defn- new-scanner
|
||||
"Creates a new scanner."
|
||||
[source input]
|
||||
@{:source source
|
||||
:input input
|
||||
:length (length source)
|
||||
:errors @[]
|
||||
:start 0
|
||||
:current 0
|
||||
:line 1
|
||||
:tokens @[]})
|
||||
|
||||
(defn- at-end?
|
||||
"Tests if a scanner is at end of input."
|
||||
[scanner]
|
||||
(>= (get scanner :current) (get scanner :length)))
|
||||
|
||||
(defn- current-char
|
||||
"Gets the current character of the scanner."
|
||||
[scanner]
|
||||
(let [source (get scanner :source)
|
||||
current (get scanner :current)
|
||||
length (length source)]
|
||||
(if (>= current length)
|
||||
nil
|
||||
(string/from-bytes (get source current)))))
|
||||
|
||||
(defn- advance
|
||||
"Advances the scanner by a single character."
|
||||
[scanner]
|
||||
(update scanner :current inc))
|
||||
|
||||
(defn- next-char
|
||||
"Gets the next character from the scanner."
|
||||
[scanner]
|
||||
(let [source (get scanner :source)
|
||||
current (get scanner :current)
|
||||
next (inc current)
|
||||
length (length source)]
|
||||
(if (>= next length)
|
||||
nil
|
||||
(string/from-bytes (get source next)))))
|
||||
|
||||
(defn- current-lexeme
|
||||
[scanner]
|
||||
(slice (get scanner :source) (get scanner :start) (get scanner :current)))
|
||||
|
||||
(defn- char-code [char] (get char 0))
|
||||
|
||||
(defn- char-in-range? [start end char]
|
||||
(and char
|
||||
(>= (char-code char) (char-code start))
|
||||
(<= (char-code char) (char-code end))))
|
||||
|
||||
(defn- digit? [c]
|
||||
(char-in-range? "0" "9" c))
|
||||
|
||||
(defn- nonzero-digit? [c]
|
||||
(char-in-range? "1" "9" c))
|
||||
|
||||
## for now, use very basic ASCII charset in words
|
||||
## TODO: research the implications of using the whole
|
||||
## (defn- alpha? [c] (boolean (re-find #"\p{L}" (string c))))
|
||||
(defn- alpha? [c]
|
||||
(or (char-in-range? "a" "z" c) (char-in-range? "A" "Z" c)))
|
||||
|
||||
(defn- lower? [c] (char-in-range? "a" "z" c))
|
||||
|
||||
(defn- upper? [c] (char-in-range? "A" "Z" c))
|
||||
|
||||
## legal characters in words
|
||||
(def word-chars {"_" true "?" true "!" true "*" true "/" true})
|
||||
|
||||
(defn- word-char? [c]
|
||||
(or (alpha? c) (digit? c) (get word-chars c)))
|
||||
|
||||
(defn- whitespace? [c]
|
||||
(or (= c " ") (= c "\t")))
|
||||
|
||||
(def terminators {
|
||||
":" true
|
||||
";" true
|
||||
"\n" true
|
||||
"{" true
|
||||
"}" true
|
||||
"(" true
|
||||
")" true
|
||||
"[" true
|
||||
"]" true
|
||||
"$" true
|
||||
"#" true
|
||||
"-" true
|
||||
"=" true
|
||||
"&" true
|
||||
"," true
|
||||
">" true
|
||||
"\"" true})
|
||||
|
||||
(defn- terminates? [c]
|
||||
(or (nil? c) (whitespace? c) (get terminators c)))
|
||||
|
||||
(defn- add-token
|
||||
[scanner token-type &opt literal]
|
||||
(update scanner :tokens array/push
|
||||
{:type token-type
|
||||
:lexeme (current-lexeme scanner)
|
||||
:literal literal
|
||||
:line (get scanner :line)
|
||||
:start (get scanner :start)
|
||||
:source (get scanner :source)
|
||||
:input (get scanner :input)}))
|
||||
|
||||
## TODO: errors should also be in the vector of tokens
|
||||
## The goal is to be able to be able to hand this to an LSP?
|
||||
## Do we need a different structure
|
||||
(defn- add-error [scanner msg]
|
||||
(let [token {:type :error
|
||||
:lexeme (current-lexeme scanner)
|
||||
:literal nil
|
||||
:line (get scanner :line)
|
||||
:start (get scanner :start)
|
||||
:source (get scanner :source)
|
||||
:input (get scanner :input)
|
||||
:message msg}]
|
||||
(-> scanner
|
||||
(update :errors array/push token)
|
||||
(update :tokens array/push token))))
|
||||
|
||||
(defn- add-keyword
|
||||
[scanner]
|
||||
(defn recur [scanner key]
|
||||
(let [char (current-char scanner)]
|
||||
(cond
|
||||
(terminates? char) (add-token scanner :keyword (keyword key))
|
||||
(word-char? char) (recur (advance scanner) (string key char))
|
||||
:else (add-error scanner (string "Unexpected " char "after keyword :" key)))))
|
||||
(recur scanner ""))
|
||||
|
||||
(defn- add-pkg-kw [scanner]
|
||||
(defn recur [scanner key]
|
||||
(let [char (current-char scanner)]
|
||||
(cond
|
||||
(terminates? char) (add-token scanner :pkg-kw (keyword key))
|
||||
(word-char? char) (recur (advance scanner) (string key char))
|
||||
:else (add-error scanner (string "Unexpected " char " after pkg keyword :" key)))))
|
||||
(recur scanner ""))
|
||||
|
||||
(defn- read-literal [lit] (-> lit parse-all first))
|
||||
|
||||
### TODO: consider whether Janet's number rules are right for Ludus
|
||||
(defn- add-number [char scanner]
|
||||
(defn recur [scanner num float?]
|
||||
(let [curr (current-char scanner)]
|
||||
(cond
|
||||
(= curr "_") (recur (advance scanner) num float?) ## consume underscores unharmed
|
||||
(= curr ".") (if float?
|
||||
(add-error scanner (string "Unexpected second decimal point after " num "."))
|
||||
(recur (advance scanner) (buffer/push num curr) true))
|
||||
(terminates? curr) (add-token scanner :number (read-literal num))
|
||||
(digit? curr) (recur (advance scanner) (buffer/push num curr) float?)
|
||||
:else (add-error scanner (string "Unexpected " curr " after number " num ".")))))
|
||||
(recur scanner (buffer char) false))
|
||||
|
||||
(defn- add-string
|
||||
[scanner]
|
||||
(defn recur [scanner buff interpolate?]
|
||||
(let [char (current-char scanner)]
|
||||
(case char
|
||||
"{" (recur (advance scanner) (buffer/push buff char) true)
|
||||
# allow multiline strings
|
||||
"\n" (recur (update (advance scanner) :line inc) (buffer/push buff char) interpolate?)
|
||||
"\"" (add-token (advance scanner) (if interpolate? :interpolated :string)(string buff))
|
||||
"\\" (let [next (next-char scanner)]
|
||||
(if (= next "{")
|
||||
(do
|
||||
(buffer/push buff char)
|
||||
(buffer/push buff next)
|
||||
(recur (advance (advance scanner)) buff interpolate?))
|
||||
(recur (advance scanner) (buffer/push buff char) interpolate?)))
|
||||
(if (at-end? scanner)
|
||||
(add-error scanner "Unterminated string.")
|
||||
(recur (advance scanner) (buffer/push buff char) interpolate?)))))
|
||||
(recur scanner @"" false))
|
||||
|
||||
(defn- add-word
|
||||
[char scanner]
|
||||
(defn recur [scanner word]
|
||||
(let [curr (current-char scanner)]
|
||||
(cond
|
||||
(terminates? curr) (add-token scanner
|
||||
(get reserved-words (string word) :word)
|
||||
(get literal-words (string word) :none))
|
||||
(word-char? curr) (recur (advance scanner) (buffer/push word curr))
|
||||
:else (add-error scanner (string "Unexpected " curr " after word " word ".")))))
|
||||
(recur scanner (buffer char)))
|
||||
|
||||
(defn- add-pkg
|
||||
[char scanner]
|
||||
(defn recur [scanner pkg]
|
||||
(let [curr (current-char scanner)]
|
||||
(cond
|
||||
(terminates? curr) (add-token scanner :pkg-name :none)
|
||||
(word-char? curr) (recur (advance scanner) (buffer/push pkg curr))
|
||||
:else (add-error scanner (string "unexpected " curr " after pkg name " pkg)))))
|
||||
(recur scanner (buffer char)))
|
||||
|
||||
(defn- add-ignored
|
||||
[scanner]
|
||||
(defn recur [scanner ignored]
|
||||
(let [char (current-char scanner)]
|
||||
(cond
|
||||
(terminates? char) (add-token scanner :ignored)
|
||||
(word-char? char) (recur (advance scanner) (buffer/push ignored char))
|
||||
:else (add-error scanner (string "Unexpected " char " after word " ignored ".")))))
|
||||
(recur scanner @"_"))
|
||||
|
||||
(defn- add-comment [char scanner]
|
||||
(defn recur [scanner comm]
|
||||
(let [char (current-char scanner)]
|
||||
(if (or (= "\n" char) (at-end? scanner))
|
||||
scanner # for now, we don't do anything with comments; can be added later
|
||||
(recur (advance scanner) (buffer/push comm char)))))
|
||||
(recur scanner (buffer char)))
|
||||
|
||||
(defn- scan-token [scanner]
|
||||
(let [char (current-char scanner)
|
||||
scanner (advance scanner)
|
||||
next (current-char scanner)]
|
||||
(case char
|
||||
## one-character tokens
|
||||
## :break is a special zero-char token before closing braces
|
||||
## it makes parsing much simpler
|
||||
"(" (add-token scanner :lparen)
|
||||
")" (add-token (add-token scanner :break) :rparen)
|
||||
"{" (add-token scanner :lbrace)
|
||||
"}" (add-token (add-token scanner :break) :rbrace)
|
||||
"[" (add-token scanner :lbracket)
|
||||
"]" (add-token (add-token scanner :break) :rbracket)
|
||||
";" (add-token scanner :semicolon)
|
||||
"," (add-token scanner :comma)
|
||||
"\n" (add-token (update scanner :line inc) :newline)
|
||||
"\\" (add-token scanner :backslash)
|
||||
"=" (add-token scanner :equals)
|
||||
">" (add-token scanner :pipeline)
|
||||
|
||||
## two-character tokens
|
||||
## ->
|
||||
"-" (cond
|
||||
(= next ">") (add-token (advance scanner) :arrow)
|
||||
(digit? next) (add-number char scanner)
|
||||
:else (add-error scanner (string "Expected > or negative number after `-`. Got `" char next "`")))
|
||||
|
||||
## dict #{
|
||||
"#" (if (= next "{")
|
||||
(add-token (advance scanner) :startdict)
|
||||
(add-error scanner (string "Expected beginning of dict: #{. Got " char next)))
|
||||
|
||||
## set ${
|
||||
"$" (if (= next "{")
|
||||
(add-token (advance scanner) :startset)
|
||||
(add-error scanner (string "Expected beginning of set: ${. Got " char next)))
|
||||
|
||||
## placeholders
|
||||
## there's a flat _, and then ignored words
|
||||
"_" (cond
|
||||
(terminates? next) (add-token scanner :placeholder)
|
||||
(alpha? next) (add-ignored scanner)
|
||||
:else (add-error scanner (string "Expected placeholder: _. Got " char next)))
|
||||
|
||||
## comments
|
||||
## & starts an inline comment
|
||||
"&" (add-comment char scanner)
|
||||
|
||||
## keywords
|
||||
# XXX: make sure we want only lower-only keywords
|
||||
":" (cond
|
||||
(lower? next) (add-keyword scanner)
|
||||
(upper? next) (add-pkg-kw scanner)
|
||||
:else (add-error scanner (string "Expected keyword or pkg keyword. Got " char next)))
|
||||
|
||||
## splats
|
||||
"." (let [after_next (current-char (advance scanner))]
|
||||
(if (= ".." (string next after_next))
|
||||
(add-token (advance scanner) :splat)
|
||||
(add-error scanner (string "Expected splat: ... . Got " (string "." next after_next)))))
|
||||
|
||||
## strings
|
||||
"\"" (add-string scanner)
|
||||
|
||||
## word matches
|
||||
(cond
|
||||
(whitespace? char) scanner ## for now just skip whitespace characters
|
||||
(digit? char) (add-number char scanner)
|
||||
(upper? char) (add-pkg char scanner)
|
||||
(lower? char) (add-word char scanner)
|
||||
:else (add-error scanner (string "Unexpected character: " char))))))
|
||||
|
||||
(defn- next-token [scanner]
|
||||
(put scanner :start (get scanner :current)))
|
||||
|
||||
(defn scan [source &opt input]
|
||||
(default input :input)
|
||||
(defn recur [scanner]
|
||||
(if (at-end? scanner)
|
||||
(let [scanner (add-token (add-token scanner :break) :eof)]
|
||||
{:tokens (get scanner :tokens)
|
||||
:errors (get scanner :errors [])})
|
||||
(recur (-> scanner (scan-token) (next-token)))))
|
||||
(recur (new-scanner source input)))
|
||||
|
||||
|
|
@ -1,781 +0,0 @@
|
|||
### A validator for a Ludus AST
|
||||
|
||||
(comment
|
||||
|
||||
Tracking here, before I start writing this code, the kinds of validation we're hoping to accomplish:
|
||||
|
||||
* [x] ensure called keywords are only called w/ one arg
|
||||
* [x] first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo
|
||||
- [x] accept pkg-kws
|
||||
* [x] validate dict patterns
|
||||
* [x] compile string-patterns
|
||||
* [x] `loop` form arity checking
|
||||
* [x] arity checking of explicit named function calls
|
||||
* [x] flag tail calls
|
||||
* [x] no re-bound names
|
||||
* [x] no unbound names
|
||||
* [x] no unbound names with `use` forms
|
||||
* [x] recur in tail position in `loop` forms
|
||||
* [x] recur not called outside of `loop` forms
|
||||
* [x] splats come at the end of list, tuple, and dict patterns
|
||||
|
||||
Deferred until a later iteration of Ludus:
|
||||
* [ ] no circular imports DEFERRED
|
||||
* [ ] correct imports DEFERRED
|
||||
* [ ] validate `with` forms
|
||||
)
|
||||
|
||||
(def- package-registry @{})
|
||||
|
||||
# (try (os/cd "janet") ([_] nil))
|
||||
(import ./scanner :as s)
|
||||
(import ./parser :as p)
|
||||
|
||||
(defn- new-validator [parser]
|
||||
(def ast (parser :ast))
|
||||
@{:ast ast
|
||||
:errors @[]
|
||||
:ctx @{}
|
||||
:status @{}}
|
||||
)
|
||||
|
||||
(var validate nil)
|
||||
|
||||
(def terminals [:number :string :bool :nil :placeholder])
|
||||
|
||||
(def simple-colls [:list :tuple :set :args])
|
||||
|
||||
(defn- simple-coll [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(each node data
|
||||
(set (validator :ast) node)
|
||||
(validate validator))
|
||||
validator)
|
||||
|
||||
(defn- iff [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(each node data
|
||||
(set (validator :ast) node)
|
||||
(validate validator))
|
||||
validator)
|
||||
|
||||
(defn- script [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(def status (validator :status))
|
||||
(set (status :toplevel) true)
|
||||
(each node data
|
||||
(set (validator :ast) node)
|
||||
(validate validator))
|
||||
validator)
|
||||
|
||||
(defn- block [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(def status (validator :status))
|
||||
(set (status :toplevel) nil)
|
||||
(def tail? (status :tail))
|
||||
(set (status :tail) false)
|
||||
(def parent (validator :ctx))
|
||||
(def ctx @{:^parent parent})
|
||||
(set (validator :ctx) ctx)
|
||||
(for i 0 (-> data length dec)
|
||||
(set (validator :ast) (data i))
|
||||
(validate validator))
|
||||
(set (status :tail) tail?)
|
||||
(set (validator :ast) (last data))
|
||||
(validate validator)
|
||||
(set (validator :ctx) parent)
|
||||
validator)
|
||||
|
||||
(defn- resolve-local [ctx name]
|
||||
(get ctx name))
|
||||
|
||||
(defn- resolve-name [ctx name]
|
||||
(when (nil? ctx) (break nil))
|
||||
(def node (get ctx name))
|
||||
(if node node (resolve-name (get ctx :^parent) name)))
|
||||
|
||||
(defn- word [validator]
|
||||
(def ast (validator :ast))
|
||||
(def name (ast :data))
|
||||
(def ctx (validator :ctx))
|
||||
(def resolved (resolve-name ctx name))
|
||||
(when (not resolved)
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg "unbound name"}))
|
||||
validator)
|
||||
|
||||
|
||||
### patterns
|
||||
(var pattern nil)
|
||||
|
||||
(defn- lett [validator]
|
||||
(def ast (validator :ast))
|
||||
(def [lhs rhs] (ast :data))
|
||||
# evaluate the expression first
|
||||
# otherwise lhs names will appear bound
|
||||
(set (validator :ast) rhs)
|
||||
(validate validator)
|
||||
(set (validator :ast) lhs)
|
||||
(pattern validator)
|
||||
validator)
|
||||
|
||||
(defn- splattern [validator]
|
||||
(def ast (validator :ast))
|
||||
(def status (validator :status))
|
||||
(when (not (status :last))
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg "splats may only come last in collection patterns"}))
|
||||
(def data (ast :data))
|
||||
(when data
|
||||
(set (validator :ast) data)
|
||||
(pattern validator))
|
||||
validator)
|
||||
|
||||
(defn- simple-coll-pattern [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(when (empty? data) (break validator))
|
||||
(def status (validator :status))
|
||||
(for i 0 (-> data length dec)
|
||||
(set (validator :ast) (get data i))
|
||||
(pattern validator))
|
||||
(set (status :last) true)
|
||||
(set (validator :ast) (last data))
|
||||
(pattern validator)
|
||||
(set (status :last) nil)
|
||||
validator)
|
||||
|
||||
(defn- word-pattern [validator]
|
||||
(def ast (validator :ast))
|
||||
(def name (ast :data))
|
||||
(def ctx (validator :ctx))
|
||||
(when (has-key? ctx name)
|
||||
(def {:line line :input input} (get-in ctx [name :token]))
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg (string "name is already bound on line "
|
||||
line " of " input)}))
|
||||
(set (ctx name) ast)
|
||||
# (pp ctx)
|
||||
validator)
|
||||
|
||||
(def types [
|
||||
:nil
|
||||
:bool
|
||||
:number
|
||||
:keyword
|
||||
:string
|
||||
:set
|
||||
:tuple
|
||||
:dict
|
||||
:list
|
||||
:fn
|
||||
:box
|
||||
:pkg
|
||||
])
|
||||
|
||||
(defn typed [validator]
|
||||
(def ast (validator :ast))
|
||||
(def [kw-type word] (ast :data))
|
||||
(def type (kw-type :data))
|
||||
(when (not (has-value? types type))
|
||||
(array/push (validator :errors)
|
||||
{:node kw-type :msg "unknown type"}))
|
||||
(set (validator :ast) word)
|
||||
(pattern validator))
|
||||
|
||||
(defn- str-pattern [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(def last-term (-> data array/pop string))
|
||||
(def grammar @{})
|
||||
(def bindings @[])
|
||||
(var current 0)
|
||||
(each node data
|
||||
(when (not (buffer? node))
|
||||
(set (validator :ast) node)
|
||||
(pattern validator))
|
||||
(if (buffer? node)
|
||||
(set (grammar (keyword current)) (string node))
|
||||
(do
|
||||
(set (grammar (keyword current))
|
||||
~(<- (to ,(keyword (inc current)))))
|
||||
(array/push bindings (node :data))))
|
||||
(set current (inc current)))
|
||||
(set (grammar (keyword current)) ~(* ,last-term -1))
|
||||
(def rules (map keyword (range (length grammar))))
|
||||
(set (grammar :main) ~(* ,;rules))
|
||||
(set (ast :grammar) grammar)
|
||||
(set (ast :compiled) (peg/compile grammar))
|
||||
(set (ast :bindings) bindings))
|
||||
|
||||
(defn- pair [validator]
|
||||
(def ast (validator :ast))
|
||||
(def [_ patt] (ast :data))
|
||||
(set (validator :ast) patt)
|
||||
(pattern validator))
|
||||
|
||||
(defn- pattern* [validator]
|
||||
# (print "PATTERN*")
|
||||
(def ast (validator :ast))
|
||||
(def type (ast :type))
|
||||
# (print "validating pattern " type)
|
||||
(cond
|
||||
(has-value? terminals type) validator
|
||||
(case type
|
||||
:word (word-pattern validator)
|
||||
:placeholder validator
|
||||
:ignored validator
|
||||
:word (word-pattern validator)
|
||||
:list (simple-coll-pattern validator)
|
||||
:tuple (simple-coll-pattern validator)
|
||||
:dict (simple-coll-pattern validator)
|
||||
:splat (splattern validator)
|
||||
:typed (typed validator)
|
||||
:interpolated (str-pattern validator)
|
||||
:pair (pair validator)
|
||||
)))
|
||||
|
||||
(set pattern pattern*)
|
||||
|
||||
# XXX: ensure guard includes only allowable names
|
||||
# XXX: what to include here? (cf Elixir)
|
||||
(defn- guard [validator])
|
||||
|
||||
(defn- match-clauses [validator clauses]
|
||||
# (print "validating clauses in match-clauses")
|
||||
(each clause clauses
|
||||
(def parent (validator :ctx))
|
||||
(def ctx @{:^parent parent})
|
||||
(set (validator :ctx) ctx)
|
||||
(def [lhs guard rhs] clause)
|
||||
(set (validator :ast) lhs)
|
||||
(pattern validator)
|
||||
# (pp (validator :ctx))
|
||||
# (pp (validator :ctx))
|
||||
(when guard
|
||||
(set (validator :ast) guard)
|
||||
(validate validator))
|
||||
(set (validator :ast) rhs)
|
||||
(validate validator)
|
||||
(set (validator :ctx) parent)))
|
||||
|
||||
(defn- matchh [validator]
|
||||
# (print "validating in matchh")
|
||||
(def ast (validator :ast))
|
||||
(def [to-match clauses] (ast :data))
|
||||
# (print "validating expression:")
|
||||
# (pp to-match)
|
||||
(set (validator :ast) to-match)
|
||||
(validate validator)
|
||||
# (print "validating clauses")
|
||||
(match-clauses validator clauses)
|
||||
validator)
|
||||
|
||||
(defn- declare [validator fnn]
|
||||
(def status (validator :status))
|
||||
(def declared (get status :declared @{}))
|
||||
(set (declared fnn) true)
|
||||
(set (status :declared) declared)
|
||||
# (print "declared function " (fnn :name))
|
||||
# (pp declared)
|
||||
validator)
|
||||
|
||||
(defn- define [validator fnn]
|
||||
(def status (validator :status))
|
||||
(def declared (get status :declared @{}))
|
||||
(set (declared fnn) nil)
|
||||
(set (status :declared) declared)
|
||||
# (print "defined function " (fnn :name))
|
||||
# (pp declared)
|
||||
validator)
|
||||
|
||||
(defn- fnn [validator]
|
||||
(def ast (validator :ast))
|
||||
(def name (ast :name))
|
||||
# (print "function name: " name)
|
||||
(def status (validator :status))
|
||||
(def tail? (status :tail))
|
||||
(set (status :tail) true)
|
||||
(when name
|
||||
(def ctx (validator :ctx))
|
||||
(def resolved (ctx name))
|
||||
(when (and resolved (not= :nothing (resolved :data)))
|
||||
(def {:line line :input input} (get-in ctx [name :token]))
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg (string "name is already bound on line " line " of " input)}))
|
||||
(when (and resolved (= :nothing (resolved :data)))
|
||||
(define validator resolved))
|
||||
(set (ctx name) ast))
|
||||
(def data (ast :data))
|
||||
(when (= data :nothing)
|
||||
(break (declare validator ast)))
|
||||
(match-clauses validator data)
|
||||
(set (status :tail) tail?)
|
||||
(def rest-arities @{})
|
||||
(def arities @{:rest rest-arities})
|
||||
(each clause data
|
||||
# (print "CLAUSE:")
|
||||
# (pp clause)
|
||||
(def patt (first clause))
|
||||
(def params (patt :data))
|
||||
(def arity (length params))
|
||||
# (print "checking clause with arity " arity)
|
||||
(def rest-param? (and (> arity 0) (= :splat ((last params) :type))))
|
||||
(if rest-param?
|
||||
(set (rest-arities arity) true)
|
||||
(set (arities arity) true)))
|
||||
# (pp arities)
|
||||
(set (ast :arities) arities)
|
||||
validator)
|
||||
|
||||
(defn- ref [validator]
|
||||
(def ast (validator :ast))
|
||||
(def ctx (validator :ctx))
|
||||
(def expr (ast :data))
|
||||
(set (validator :ast) expr)
|
||||
(validate validator)
|
||||
(def name (ast :name))
|
||||
(def resolved (ctx name))
|
||||
(when resolved
|
||||
(def {:line line :input input} (get-in ctx [name :token]))
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg (string "name is already bound on line " line " of " input)}))
|
||||
(set (ctx name) ast)
|
||||
validator)
|
||||
|
||||
(defn- interpolated [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(each node data
|
||||
(when (not (buffer? node))
|
||||
(set (validator :ast) node)
|
||||
(validate validator))))
|
||||
|
||||
### TODO:
|
||||
# * [ ] ensure properties are on pkgs (if *only* pkgs from root)
|
||||
|
||||
(defn- pkg-root [validator]
|
||||
# (print "validating pkg-root access")
|
||||
(def ast (validator :ast))
|
||||
(def ctx (validator :ctx))
|
||||
(def terms (ast :data))
|
||||
(def pkg-name ((first terms) :data))
|
||||
(def the-pkg (resolve-name ctx pkg-name))
|
||||
(when (not the-pkg)
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg "unbound pkg name"})
|
||||
(break validator))
|
||||
(def member (get terms 1))
|
||||
(def accessed (case (member :type)
|
||||
:keyword (get-in the-pkg [:pkg (member :data)])
|
||||
:pkg-kw (get-in the-pkg [:pkg (member :data)])
|
||||
:args (do
|
||||
(array/push (validator :errors)
|
||||
{:node member :msg "cannot call a pkg"}
|
||||
(break validator)))))
|
||||
(when (not accessed)
|
||||
# (print "no member " (member :data) " on " pkg-name)
|
||||
(array/push (validator :errors)
|
||||
{:node member :msg "invalid pkg access"})
|
||||
(break validator))
|
||||
# TODO: validate nested pkg access
|
||||
)
|
||||
|
||||
# (defn- tail-call [validator]
|
||||
# (def ast (validator :ast))
|
||||
# (when (ast :partial) (break validator))
|
||||
# (def status (validator :status))
|
||||
# (when (not (status :tail)) (break validator))
|
||||
# (def data (ast :data))
|
||||
# (def args (last data))
|
||||
# (set (args :tail-call) true))
|
||||
|
||||
(defn- check-arity [validator]
|
||||
# (print "CHECKING ARITY")
|
||||
(def ast (validator :ast))
|
||||
# (when (ast :partial) (break validator))
|
||||
(def ctx (validator :ctx))
|
||||
(def data (ast :data))
|
||||
(def fn-word (first data))
|
||||
# (pp fn-word)
|
||||
(def the-fn (resolve-name ctx (fn-word :data)))
|
||||
# (print "the called function: " the-fn)
|
||||
# (pp the-fn)
|
||||
(when (not the-fn) (break validator))
|
||||
# (print "the function is not nil")
|
||||
# (print "the function type is " (type the-fn))
|
||||
(when (= :function (type the-fn)) (break validator))
|
||||
(when (= :cfunction (type the-fn)) (break validator))
|
||||
# (print "the function is not a janet fn")
|
||||
# (print "fn type: " (the-fn :type))
|
||||
(when (not= :fn (the-fn :type)) (break validator))
|
||||
# (print "fn name: " (the-fn :name))
|
||||
(def arities (the-fn :arities))
|
||||
# when there aren't arities yet, break, since that means we're making a recursive function call
|
||||
# TODO: enahnce this so that we can determine arities *before* all function bodies; this ensures arity-checking for self-recursive calls
|
||||
(when (not arities) (break validator))
|
||||
# (print "arities: ")
|
||||
# (pp arities)
|
||||
(def args (get data 1))
|
||||
(def num-args (length (args :data)))
|
||||
# (print "called with #args " num-args)
|
||||
# (pp (get (validator :ctx) "bar"))
|
||||
(when (has-key? arities num-args) (break validator))
|
||||
# (print "arities: ")
|
||||
# (pp arities)
|
||||
(when (not arities) (break validator))
|
||||
(def rest-arities (keys (arities :rest)))
|
||||
(when (empty? rest-arities)
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg "mismatched arity"})
|
||||
(break validator))
|
||||
(def rest-min (min ;rest-arities))
|
||||
(when (< num-args rest-min)
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg "mismatched arity"}))
|
||||
validator)
|
||||
|
||||
(defn- kw-root [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(def [_ args] data)
|
||||
(when (not= :args (args :type))
|
||||
(break (array/push (validator :errors)
|
||||
{:node args :msg "called keyword expects an argument"})))
|
||||
(when (not= 1 (length (args :data)))
|
||||
(array/push (validator :errors)
|
||||
{:node args :msg "called keywords take one argument"})))
|
||||
|
||||
(defn- synthetic [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(def status (validator :status))
|
||||
(def ftype ((first data) :type))
|
||||
(def stype ((get data 1) :type))
|
||||
(def ltype ((last data) :type))
|
||||
(set (status :pkg-access?) nil)
|
||||
(when (= ftype :pkg-name)
|
||||
(set (status :pkg-access?) true))
|
||||
(each node data
|
||||
(set (validator :ast) node)
|
||||
(validate validator))
|
||||
(set (validator :ast) ast)
|
||||
# (print "ftype " ftype)
|
||||
# (print "stype " stype)
|
||||
# (print "ltype " ltype)
|
||||
(when (= ftype :pkg-name) (pkg-root validator))
|
||||
(when (= ftype :keyword) (kw-root validator))
|
||||
# (when (= ltype :args) (tail-call validator))
|
||||
(when (and (= ftype :word) (= stype :args))
|
||||
(check-arity validator))
|
||||
validator)
|
||||
|
||||
(defn- pair [validator]
|
||||
(def ast (validator :ast))
|
||||
(def [k v] (ast :data))
|
||||
(set (validator :ast) k)
|
||||
(validate validator)
|
||||
(set (validator :ast) v)
|
||||
(validate validator))
|
||||
|
||||
(defn- splat [validator]
|
||||
(def ast (validator :ast))
|
||||
(when (get-in validator [:status :pkg])
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg "splats are not allowed in pkgs"})
|
||||
(break validator))
|
||||
(def data (ast :data))
|
||||
(when data
|
||||
(set (validator :ast) data)
|
||||
(validate validator))
|
||||
validator)
|
||||
|
||||
(defn- dict [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(each node data
|
||||
(set (validator :ast) node)
|
||||
(validate validator))
|
||||
validator)
|
||||
|
||||
(defn- whenn [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(each node data
|
||||
(def [lhs rhs] node)
|
||||
(set (validator :ast) lhs)
|
||||
(validate validator)
|
||||
(set (validator :ast) rhs)
|
||||
(validate validator))
|
||||
validator)
|
||||
|
||||
# XXX: do this!
|
||||
(defn- withh [validator])
|
||||
|
||||
# XXX: tail calls in last position
|
||||
(defn- doo [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(each node data
|
||||
(set (validator :ast) node)
|
||||
(validate validator))
|
||||
validator)
|
||||
|
||||
(defn- usee [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(set (validator :ast) data)
|
||||
(validate validator)
|
||||
(def name (data :data))
|
||||
(def ctx (validator :ctx))
|
||||
(def pkg (get-in ctx [name :pkg] @{}))
|
||||
(loop [[k v] :pairs pkg]
|
||||
(set (ctx (string k)) v))
|
||||
validator)
|
||||
|
||||
(defn- pkg-entry [validator pkg]
|
||||
(def ast (validator :ast))
|
||||
(def status (validator :status))
|
||||
(when (= :pkg-pair (ast :type))
|
||||
(set (status :pkg-access?) true))
|
||||
(def data (ast :data))
|
||||
(def [key value] (ast :data))
|
||||
# (print "PKG ENTRY***")
|
||||
# (pp key)
|
||||
# (pp value)
|
||||
(set (validator :ast) key)
|
||||
(validate validator)
|
||||
(set (validator :ast) value)
|
||||
(validate validator)
|
||||
(def entry (if (= :pkg-name (value :type))
|
||||
(resolve-name (validator :ctx) (string (value :data)))
|
||||
value))
|
||||
# (print "entry at " (key :data))
|
||||
# (pp entry)
|
||||
(set (status :pkg-access?) nil)
|
||||
(def kw (key :data))
|
||||
# (pp kw)
|
||||
(set (pkg kw) entry)
|
||||
# (pp pkg)
|
||||
validator)
|
||||
|
||||
(defn- pkg [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(def name (ast :name))
|
||||
(def pkg @{})
|
||||
(each node data
|
||||
(set (validator :ast) node)
|
||||
(pkg-entry validator pkg))
|
||||
(set (ast :pkg) pkg)
|
||||
# (print "THE PACKAGE")
|
||||
# (pp pkg)
|
||||
(def ctx (validator :ctx))
|
||||
(set (ctx name) ast)
|
||||
validator)
|
||||
|
||||
(defn- ns [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(def name (ast :name))
|
||||
(def parent (validator :ctx))
|
||||
(def ctx @{:^parent parent})
|
||||
(def block (data :data))
|
||||
(each node block
|
||||
(set (validator :ast) node)
|
||||
(validate validator))
|
||||
(set (ast :pkg) ctx)
|
||||
(set (parent name) ast)
|
||||
validator)
|
||||
|
||||
(defn- loopp [validator]
|
||||
(def ast (validator :ast))
|
||||
(def status (validator :status))
|
||||
(def data (ast :data))
|
||||
(def input (first data))
|
||||
# (print "LOOP INPUT")
|
||||
# (pp input)
|
||||
(def clauses (get data 1))
|
||||
(def input-arity (length (input :data)))
|
||||
(set (ast :arity) input-arity)
|
||||
# (print "input arity to loop " input-arity)
|
||||
(set (validator :ast) input)
|
||||
(validate validator)
|
||||
# harmonize arities
|
||||
(def rest-arities @{})
|
||||
(each clause clauses
|
||||
# (print "CLAUSE:")
|
||||
# (pp clause)
|
||||
(def patt (first clause))
|
||||
(def params (patt :data))
|
||||
(def clause-arity (length params))
|
||||
# (print "checking clause with arity " clause-arity)
|
||||
(def rest-param? (= :splat (get (last params) :type)))
|
||||
(when (and
|
||||
(not rest-param?) (not= clause-arity input-arity))
|
||||
(array/push (validator :errors)
|
||||
{:node patt :msg "arity mismatch"}))
|
||||
(when rest-param?
|
||||
(set (rest-arities clause-arity) patt)))
|
||||
# (pp rest-arities)
|
||||
(loop [[arity patt] :pairs rest-arities]
|
||||
(when (< input-arity arity)
|
||||
(array/push (validator :errors)
|
||||
{:node patt :msg "arity mismatch"})))
|
||||
(def loop? (status :loop))
|
||||
(set (status :loop) input-arity)
|
||||
(def tail? (status :tail))
|
||||
(set (status :tail) true)
|
||||
(match-clauses validator clauses)
|
||||
(set (status :loop) loop?)
|
||||
(set (status :tail) tail?)
|
||||
validator)
|
||||
|
||||
(defn- recur [validator]
|
||||
(def ast (validator :ast))
|
||||
(def status (validator :status))
|
||||
(def loop-arity (status :loop))
|
||||
(when (not loop-arity)
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg "recur may only be used inside a loop"})
|
||||
(break validator))
|
||||
(def called-with (get-in ast [:data :data]))
|
||||
(def recur-arity (length called-with))
|
||||
# (print "loop arity " loop-arity)
|
||||
# (print "recur arity" recur-arity)
|
||||
(when (not= recur-arity loop-arity)
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg "recur must have the same number of args as its loop"}))
|
||||
(when (not (status :tail))
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg "recur must be in tail position"}))
|
||||
(set (validator :ast) (ast :data))
|
||||
(validate validator))
|
||||
|
||||
(defn- repeatt [validator]
|
||||
(def ast (validator :ast))
|
||||
(def [times body] (ast :data))
|
||||
(set (validator :ast) times)
|
||||
(validate validator)
|
||||
(set (validator :ast) body)
|
||||
(validate validator))
|
||||
|
||||
(defn- panic [validator]
|
||||
(def ast (validator :ast))
|
||||
(def data (ast :data))
|
||||
(set (validator :ast) data)
|
||||
(validate validator))
|
||||
|
||||
(defn- testt [validator]
|
||||
(def ast (validator :ast))
|
||||
(def [_ body] (ast :data))
|
||||
(set (validator :ast) body)
|
||||
(validate validator))
|
||||
|
||||
(defn- pkg-name [validator]
|
||||
(def ast (validator :ast))
|
||||
(def name (ast :data))
|
||||
(def ctx (validator :ctx))
|
||||
(def pkg (resolve-name ctx name))
|
||||
(when (not pkg)
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg "unbound name"}))
|
||||
validator)
|
||||
|
||||
(defn- pkg-kw [validator]
|
||||
# (print "validating pkg-kw")
|
||||
(def ast (validator :ast))
|
||||
(def pkg-access? (get-in validator [:status :pkg-access?]))
|
||||
# (print "pkg-access? " pkg-access?)
|
||||
(when (not pkg-access?)
|
||||
(array/push (validator :errors)
|
||||
{:node ast :msg "cannot use pkg-kw here"}))
|
||||
validator)
|
||||
|
||||
(defn- pkg-pair [validator]
|
||||
# (print "validating pkg-pair")
|
||||
(def ast (validator :ast))
|
||||
(def status (validator :status))
|
||||
(def [_ pkg] (ast :data))
|
||||
(set (status :pkg-access?) true)
|
||||
(set (validator :ast) pkg)
|
||||
(validate validator)
|
||||
(set (status :pkg-access?) nil)
|
||||
validator)
|
||||
|
||||
(defn- kw [validator]
|
||||
(def status (validator :status))
|
||||
(set (status :pkg-access?) nil)
|
||||
validator)
|
||||
|
||||
(defn- validate* [validator]
|
||||
(def ast (validator :ast))
|
||||
(def type (ast :type))
|
||||
# (print "validating node " type)
|
||||
(cond
|
||||
(has-value? terminals type) validator
|
||||
(has-value? simple-colls type) (simple-coll validator)
|
||||
(case type
|
||||
:keyword (kw validator)
|
||||
:if (iff validator)
|
||||
:let (lett validator)
|
||||
:script (script validator)
|
||||
:block (block validator)
|
||||
:word (word validator)
|
||||
:fn (fnn validator)
|
||||
:match (matchh validator)
|
||||
:interpolated (interpolated validator)
|
||||
:synthetic (synthetic validator)
|
||||
:do (doo validator)
|
||||
:dict (dict validator)
|
||||
:test (testt validator)
|
||||
:panic (panic validator)
|
||||
:repeat (repeatt validator)
|
||||
:when (whenn validator)
|
||||
:splat (splat validator)
|
||||
:pair (pair validator)
|
||||
:pkg-pair (pkg-pair validator)
|
||||
:ns (ns validator)
|
||||
:pkg (pkg validator)
|
||||
:pkg-name (pkg-name validator)
|
||||
:pkg-kw (pkg-kw validator)
|
||||
:use (usee validator)
|
||||
:loop (loopp validator)
|
||||
:recur (recur validator)
|
||||
:ref (ref validator)
|
||||
(error (string "unknown node type " type)))))
|
||||
|
||||
(set validate validate*)
|
||||
|
||||
(defn- cleanup [validator]
|
||||
(def declared (get-in validator [:status :declared] {}))
|
||||
(when (any? declared)
|
||||
(each declaration declared
|
||||
(array/push (validator :errors) {:node declaration :msg "declared fn, but not defined"})))
|
||||
validator)
|
||||
|
||||
(defn valid [ast &opt ctx]
|
||||
(default ctx @{})
|
||||
(def validator (new-validator ast))
|
||||
(def base-ctx @{:^parent ctx})
|
||||
(set (validator :ctx) base-ctx)
|
||||
(validate validator)
|
||||
(cleanup validator))
|
||||
|
||||
(import ./base :as b)
|
||||
|
||||
# (do
|
||||
(comment
|
||||
(def source `
|
||||
dec (12)
|
||||
`)
|
||||
(def scanned (s/scan source))
|
||||
(def parsed (p/parse scanned))
|
||||
(def validated (valid parsed b/ctx))
|
||||
# (get-in validated [:status :declared])
|
||||
# (validated :ctx)
|
||||
)
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#!/opt/homebrew/bin/fish
|
||||
|
||||
set FILE $argv[1]
|
||||
|
||||
fd $FILE | entr ./judgy.fish /_
|
||||
7
test/cases/if.ld
Normal file
7
test/cases/if.ld
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
& EXPECT (:true, :false, :true, :false)
|
||||
let true_literal = if true then :true else :false
|
||||
let false_literal = if false then :true else :false
|
||||
let truthy = if :truthy then :true else :false
|
||||
let falsy = if nil then :true else :false
|
||||
|
||||
(true_literal, false_literal, truthy, falsy)
|
||||
2
test/cases/list_atoms.ld
Normal file
2
test/cases/list_atoms.ld
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
& EXPECT [:one, 2, "three"]
|
||||
[:one, 2, "three"]
|
||||
2
test/cases/single_float.ld
Normal file
2
test/cases/single_float.ld
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
& EXPECT 12.123
|
||||
12.123
|
||||
2
test/cases/single_int.ld
Normal file
2
test/cases/single_int.ld
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
& EXPECT 42
|
||||
42
|
||||
2
test/cases/single_string.ld
Normal file
2
test/cases/single_string.ld
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
& EXPECT "foo"
|
||||
"foo"
|
||||
2
test/cases/tuple_keywords.ld
Normal file
2
test/cases/tuple_keywords.ld
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
& EXPECT (true, false, nil)
|
||||
(true, false, nil)
|
||||
7
test/ludus/core_test.clj
Normal file
7
test/ludus/core_test.clj
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
(ns ludus.core-test
|
||||
(:require [clojure.test :refer :all]
|
||||
[cludus.core :refer :all]))
|
||||
|
||||
(deftest a-test
|
||||
(testing "FIXME, I fail."
|
||||
(is (= 0 1))))
|
||||
30
test/run_tests.js
Normal file
30
test/run_tests.js
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
import {run} from "../target/js/ludus.js"
|
||||
import * as fs from "node:fs/promises"
|
||||
import t from "tap"
|
||||
|
||||
const case_path = "./cases"
|
||||
const files = await fs.readdir(case_path)
|
||||
|
||||
for (const file of files) {
|
||||
const source = await fs.readFile(`${case_path}/${file}`, {encoding: "utf8"})
|
||||
const first_line = source.split("\n")[0]
|
||||
const expected = first_line.split("EXPECT")[1].trim()
|
||||
if (expected === "PANIC") expect_panic(file, source)
|
||||
else expect_result(file, source, expected)
|
||||
}
|
||||
|
||||
function expect_panic(file, source) {
|
||||
const result = run(source).errors[0]
|
||||
t.test(`testing ${file}: EXPECT PANIC`, t => {
|
||||
t.ok(result)
|
||||
t.end()
|
||||
})
|
||||
}
|
||||
|
||||
function expect_result(file, source, expected) {
|
||||
const result = run(source).result
|
||||
t.test(`testing ${file}: EXPECT ${expected}, GOT ${result}`, t => {
|
||||
t.equal(expected, result)
|
||||
t.end()
|
||||
})
|
||||
}
|
||||
47
tokens
Normal file
47
tokens
Normal file
|
|
@ -0,0 +1,47 @@
|
|||
TOKENS:
|
||||
|
||||
:nil
|
||||
:true
|
||||
:false
|
||||
:word
|
||||
:keyword
|
||||
:number
|
||||
:string
|
||||
|
||||
:as
|
||||
:cond
|
||||
:do
|
||||
:else
|
||||
:fn
|
||||
:if
|
||||
:import
|
||||
:let
|
||||
:loop
|
||||
:ref
|
||||
:then
|
||||
:with
|
||||
|
||||
:receive
|
||||
:spawn
|
||||
:repeat
|
||||
:test
|
||||
:when
|
||||
|
||||
:lparen
|
||||
:rparen
|
||||
:lbrace
|
||||
:rbrace
|
||||
:lbracket
|
||||
:rbracket
|
||||
:semicolon
|
||||
:comma
|
||||
:newline
|
||||
:backslash
|
||||
:equals
|
||||
:pipeline
|
||||
:rarrow
|
||||
:startdict
|
||||
:startstruct
|
||||
:startset
|
||||
:splat
|
||||
:eof
|
||||
Loading…
Reference in New Issue
Block a user