From f397045844d1af23ecbc406e9757f7f0adb4cd28 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Sun, 6 Jul 2025 23:14:32 -0400 Subject: [PATCH] bring in old janet interpreter for doc purposes Former-commit-id: 2353b6eb9ae7fb866aab5ae83db6000bf8538fc1 --- janet/base.janet | 338 +++++++++++ janet/doc.janet | 132 +++++ janet/errors.janet | 140 +++++ janet/interpreter.janet | 657 ++++++++++++++++++++++ janet/json.janet | 131 +++++ janet/ludus.janet | 110 ++++ janet/parser.janet | 1181 +++++++++++++++++++++++++++++++++++++++ janet/prelude.janet | 42 ++ janet/project.janet | 9 + janet/scanner.janet | 355 ++++++++++++ janet/validate.janet | 793 ++++++++++++++++++++++++++ 11 files changed, 3888 insertions(+) create mode 100644 janet/base.janet create mode 100644 janet/doc.janet create mode 100644 janet/errors.janet create mode 100644 janet/interpreter.janet create mode 100644 janet/json.janet create mode 100644 janet/ludus.janet create mode 100644 janet/parser.janet create mode 100644 janet/prelude.janet create mode 100644 janet/project.janet create mode 100644 janet/scanner.janet create mode 100644 janet/validate.janet diff --git a/janet/base.janet b/janet/base.janet new file mode 100644 index 0000000..ef68628 --- /dev/null +++ b/janet/base.janet @@ -0,0 +1,338 @@ +# A base library for Ludus +# Only loaded in the prelude + +(import /src/scanner :as s) + +(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] + (when (= :^nil value) (break :nil)) + (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*) + +(var show nil) + +(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- dict-show [dict] + (string/join + (map + (fn [[k v]] (string (show k) " " (show v))) + (pairs dict)) + ", ")) + +(defn- set-show [sett] + (def prepped (merge sett)) + (set (prepped :^type) nil) + (def shown (map show (keys prepped))) + (string/join shown ", ") +) + +(defn- show* [x] + (case (ludus/type x) + :nil "nil" + :string (string "\"" x "\"") + :tuple (string "(" (string/join (map show x) ", ") ")") + :list (string "[" (string/join (map show x) ", ") "]") + :dict (string "#{" (dict-show x) "}") + :set (string "${" (set-show x) "}") + :box (string "box " (x :name) " [ " (show (x :^value)) " ]") + :pkg (show-pkg x) + (stringify x))) + +(set show show*) + +# (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 :data) (show-patt (x :data)))) + (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) "\n")) + +(defn doc [fnn] + (when (not= :fn (ludus/type fnn)) (break "No documentation available.")) + (def {:name name :doc docstring} fnn) + (string/join [name + (pretty-patterns fnn) + (if docstring docstring "No docstring available.")] + "\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 showprint [x] + (if (= :string (ludus/type x)) + x + (show x))) + +(defn print! [args] + (print ;(map showprint 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)) + +(defn mod [x y] + (% x y)) + +(defn- byte->ascii [c i] + (if (< c 128) + (string/from-bytes c) + (error (string "non-ASCII character at index" i)))) + +(defn chars [str] + (def out @[]) + (try + (for i 0 (length str) + (array/push out (byte->ascii (str i) i))) + ([e] (break [:err e]))) + [:ok out]) + +(defn to_number [str] + (when (string/find "&" str) + (break [:err (string "Could not parse `" str "` as a number")])) + (def scanned (s/scan (string/trim str))) + (when (< 0 (length (scanned :errors))) + (break [:err (string "Could not parse `" str "` as a number")])) + (def tokens (scanned :tokens)) + (when (< 3 (length tokens)) + (break [:err (string "Could not parse `" str "` as a number")])) + (def fst (first tokens)) + (when (not= :number (fst :type)) + (break [:err (string "Could not parse `" str "` as a number")])) + [:ok (fst :literal)]) + +(def ctx { + "add" + + "and" ludus/and + "assoc!" assoc! + "assoc" assoc + "atan_2" math/atan2 + "bool" bool + "ceil" math/ceil + "chars" chars + "concat" concat + "conj!" conj! + "conj" conj + "cos" math/cos + "count" length + "dec" dec + "disj!" disj! + "disj" disj + "dissoc!" dissoc! + "dissoc" dissoc + "div" / + "doc" doc + "downcase" string/ascii-lower + "e" math/e + "eq?" deep= + "first" first + "floor" math/floor + "get" ludus/get + "gt" > + "gte" >= + "inc" inc + "last" last + "lt" < + "lte" <= + "mod" mod + "mult" * + "not" not + "nth" ludus/get + "or" ludus/or + "pi" math/pi + "pow" math/pow + "print!" print! + "prn" prn + "push" array/push + "random" math/random + "range" range + "rest" rest + "round" math/round + "show" show + "sin" math/sin + "slice" array/slice + "split" string/split + "sqrt" math/sqrt + "store!" store! + "str_slice" string/slice + "stringify" stringify + "sub" - + "tan" math/tan + "to_list" to_list + "to_number" to_number + "trim" string/trim + "triml" string/triml + "trimr" string/trimr + "type" ludus/type + "unbox" unbox + "upcase" string/ascii-upper +}) + +(def base (let [b @{:^type :dict}] + (each [k v] (pairs ctx) + (set (b (keyword k)) v)) + b)) + diff --git a/janet/doc.janet b/janet/doc.janet new file mode 100644 index 0000000..5802a27 --- /dev/null +++ b/janet/doc.janet @@ -0,0 +1,132 @@ +(import /src/base :as base) +(import /src/prelude :as prelude) + +(defn map-values [f dict] + (from-pairs (map (fn [[k v]] [k (f v)]) (pairs dict)))) + +(def with-docs (map-values base/doc prelude/ctx)) + +(def sorted-names (-> with-docs keys sort)) + +(defn escape-underscores [str] (string/replace "_" "\\_" str)) + +(defn escape-punctuation [str] (->> str + (string/replace "?" "") + (string/replace "!" "") + (string/replace "/" ""))) + +(defn toc-entry [name] + (def escaped (escape-underscores name)) + (string "[" escaped "](#" (escape-punctuation escaped) ")")) + +(def alphabetical-list + (string/join (map toc-entry sorted-names) "    ")) + +(def topics { + "math" ["abs" "add" "angle" "atan/2" "between?" "ceil" "cos" "dec" "deg/rad" "deg/turn" "dist" "div" "div/0" "div/safe" "even?" "floor" "gt?" "gte?" "heading/vector" "inc" "inv" "inv/0" "inv/safe" "lt?" "lte?" "max" "min" "mod" "mod/0" "mod/safe" "mult" "neg" "neg?" "odd?" "pi" "pos?" "rad/deg" "rad/turn" "random" "random_int" "range" "round" "sin" "sqrt" "sqrt/safe" "square" "sub" "sum_of_squares" "tan" "tau" "to_number" "turn/deg" "turn/rad" "zero?"] + "boolean" ["and" "bool" "bool?" "false?" "not" "or" "true?"] + "dicts" ["any?" "assoc" "assoc?" "coll?" "count" "dict" "dict?" "diff" "dissoc" "empty?" "get" "keys" "random" "update" "values"] + "lists" ["any?" "append" "at" "butlast" "coll?" "concat" "count" "each!" "empty?" "filter" "first" "fold" "join" "keep" "last" "list" "list?" "map" "ordered?" "random" "range" "rest" "second" "sentence" "slice"] + "llists" ["car" "cdr" "cons" "llist"] + "sets" ["any?" "append" "coll?" "concat" "contains?" "count" "empty?" "omit" "random" "set" "set?"] + "tuples" ["any?" "at" "coll?" "count" "empty?" "first" "last" "ordered?" "rest" "second" "tuple?"] + "strings" ["any?" "chars" "chars/safe" "concat" "count" "downcase" "empty?" "join" "sentence" "show" "slice" "split" "string" "string?" "strip" "to_number" "trim" "upcase" "words"] + "types and values" ["assoc?" "bool?" "box?" "coll?" "dict?" "eq?" "fn?" "keyword?" "list?" "neq?" "nil?" "number?" "ordered?" "set?" "show" "some" "some?" "string?" "tuple?" "type"] + "boxes and state" ["box?" "unbox" "store!" "update!"] + "results" ["err" "err?" "ok" "ok?" "unwrap!" "unwrap_or"] + "errors" ["assert!"] + "turtle graphics" ["back!" "background!" "bk!" "clear!" "colors" "fd!" "forward!" "goto!" "heading" "heading/vector" "hideturtle!" "home!" "left!" "loadstate!" "lt!" "pc!" "pd!" "pencolor" "pencolor!" "pendown!" "pendown?" "penup!" "penwidth" "penwidth!" "position" "pu!" "pw!" "render_turtle!" "reset_turtle!" "right!" "rt!" "setheading!" "showturtle!" "turtle_state"] + "environment and i/o" ["doc!" "print!" "report!" "state"] + }) + +(defn capitalize [str] + (def fst (slice str 0 1)) + (def rest (slice str 1)) + (def init_cap (string/ascii-upper fst)) + (def lower_rest (string/ascii-lower rest)) + (string init_cap lower_rest)) + +(defn topic-entry [topic] + (string "### " (capitalize topic) "\n" + (as-> topic _ (topics _) (array/slice _) (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 topics-entries "\n"))) + +(defn compose-entry [name] + (def header (string "\n### " name "\n")) + (def the-doc (get with-docs name)) + (when (= "No documentation available." the-doc) + (break (string header the-doc "\n"))) + (def lines (string/split "\n" the-doc)) + (def description (last lines)) + (def patterns (string/join (slice lines 1 (-> lines length dec)) "\n")) + (def backto "[Back to top.](#ludus-prelude-documentation)\n") + (string header description "\n```\n" patterns "\n```\n" backto)) + +(compose-entry "update") + +(def entries (string/join (map compose-entry sorted-names) "\n---")) + +(def doc-file (string +``` +# 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). + +The prelude itself is just a Ludus file, which you can see at [prelude.ld](./prelude.ld). + +## 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` (ordered collections), `:set`s, and `:dict`ionaries (the other collection types); `:pkg` (packages, which are quasi-collections); `:fn` (functions); and `:box`es. + +**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) diff --git a/janet/errors.janet b/janet/errors.janet new file mode 100644 index 0000000..5380409 --- /dev/null +++ b/janet/errors.janet @@ -0,0 +1,140 @@ +(import /src/base :as b) + +(defn- get-line [source line] + ((string/split "\n" source) (dec line))) + +(defn- caret [source line start] + (def lines (string/split "\n" source)) + (def the-line (lines (dec line))) + (def prev-lines (slice lines 0 (dec line))) + (def char-counts (map (fn [x] (-> x length inc)) prev-lines)) + (def prev-line-chars (sum char-counts)) + (def offset (- start prev-line-chars)) + (def indent (string/repeat "." (+ 6 offset))) + (string indent "^") +) + + +(defn scan-error [e] + (def {:line line-num :input input :source source :start start :msg msg} e) + (print "Syntax error: " msg) + (print " on line " line-num " in " input ":") + (def source-line (get-line source line-num)) + (print " >>> " source-line) + (print (caret source line-num start)) + e) + +(defn parse-error [e] + (def msg (e :msg)) + (def {:line line-num :input input :source source :start start} (e :token)) + (def source-line (get-line source line-num)) + (print "Syntax error: " msg) + (print " on line " line-num " in " input ":") + (print " >>> " source-line) + (print (caret source line-num start)) + e) + +(defn validation-error [e] + (def msg (e :msg)) + (def {:line line-num :input input :source source :start start} (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) + (print (caret source line-num start))) + (do + (print "Validation error: " msg) + (print " on line " line-num " in " input ":") + (print " >>> " source-line) + (print (caret source line-num start)))) + e) + +(defn- fn-no-match [e] + (print "Ludus panicked! no match") + (def {:line line-num :source source :input input :start start} (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: " (slice (b/show called) 3)) + (def value (e :value)) + (print " with arguments: " (b/show value)) + (print " expected match with one of:") + (def patterns (b/pretty-patterns called)) + (def fmt-patt (do + (def lines (string/split "\n" patterns)) + (def indented (map (fn [x] (string " " x)) lines)) + (string/join indented "\n") + )) + (print fmt-patt) + (print " >>> " source-line) + (print (caret source line-num start)) + ) + +(defn- let-no-match [e] + (print "Ludus panicked! no match") + (def {:line line-num :source source :input input :start start} (get-in e [:node :token])) + (def source-line (get-line source line-num)) + (print " on line " line-num " in " input ", ") + (print " matching: " (b/show (e :value))) + (def pattern (get-in e [:node :data 0])) + (print " with pattern: " (b/show-patt pattern)) + (print " >>> " source-line) + (print (caret source line-num start)) + e) + +(defn- match-no-match [e] + (print "Ludus panicked! no match") + (def {:line line-num :source source :input input :start start} (get-in e [:node :token])) + (print " on line " line-num " in " input ", ") + (def value (e :value)) + (print " matching: " (b/show value)) + (print " with patterns:") + (def clauses (get-in e [:node :data 1])) + (def patterns (b/pretty-patterns {:body clauses})) + (def fmt-patt (do + (def lines (string/split "\n" patterns)) + (def indented (map (fn [x] (string " " x)) lines)) + (string/join indented "\n") + )) + (print fmt-patt) + (def source-line (get-line source line-num)) + (print " >>> " source-line) + (print (caret source line-num start)) + e) + +(defn- generic-panic [e] + (def msg (e :msg)) + (def {:line line-num :source source :input input :start start} (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) + (print (caret source line-num start)) + e) + +(defn- unbound-name [e] + (def {:line line-num :source source :lexeme name :input input :start start} (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) + (print (caret source line-num start)) + e) + +(defn runtime-error [e] + (when (= :string (type e)) + (print (string "Internal Ludus error: " e)) + (print "Please file an issue at https://alea.ludus.dev/twc/ludus/issues") + (break e)) + (def msg (e :msg)) + (case msg + "no match: function call" (fn-no-match e) + "no match: let binding" (let-no-match e) + "no match: match form" (match-no-match e) + "no match: when form" (generic-panic e) + "unbound name" (unbound-name e) + (generic-panic e)) + e) diff --git a/janet/interpreter.janet b/janet/interpreter.janet new file mode 100644 index 0000000..f6a5e53 --- /dev/null +++ b/janet/interpreter.janet @@ -0,0 +1,657 @@ +# 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] + (if (buffer? x) + (string 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- box [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) root-ast 0 args))) + (defn match-fn [root-ast 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 root-ast (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 root-ast (inc i) args))) + (interpret expr body-ctx)) + (set (the-fn :match) match-fn) + (match-fn root-ast 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) + [:keyword :tuple] (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) + (error (string "cannot call " (b/ludus/type prev) " `" (b/show prev) "`")))) + +(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 (apply-synth-term (first terms) curr [prev]))) + (def last-fn (interpret last-term ctx)) + (apply-synth-term (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) + :box (box 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 /src/scanner :as s) +# (import /src/parser :as p) +# (import /src/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/lett}) +# # (try (interpret (parsed :ast) @{:^parent b/ctx}) +# # ([e] (if (struct? e) (error (e :msg)) (error e)))) +# ) + +# # (do +# (comment +# (set source ` +# let foo = 42 +# "{foo} bar baz" +# `) +# (def result (run)) +# ) + diff --git a/janet/json.janet b/janet/json.janet new file mode 100644 index 0000000..534edf3 --- /dev/null +++ b/janet/json.janet @@ -0,0 +1,131 @@ +# pulled from cfiggers/jayson + +(defmacro- letv [bindings & body] + ~(do ,;(seq [[k v] :in (partition 2 bindings)] ['var k v]) ,;body)) + +(defn- read-hex [n] + (scan-number (string "0x" n))) + +(defn- check-utf-16 [capture] + (let [u (read-hex capture)] + (if (and (>= u 0xD800) + (<= u 0xDBFF)) + capture + false))) + +(def- utf-8->bytes + (peg/compile + ~{:double-u-esc (/ (* "\\u" (cmt (<- 4) ,|(check-utf-16 $)) "\\u" (<- 4)) + ,|(+ (blshift (- (read-hex $0) 0xD800) 10) + (- (read-hex $1) 0xDC00) 0x10000)) + :single-u-esc (/ (* "\\u" (<- 4)) ,|(read-hex $)) + :unicode-esc (/ (+ :double-u-esc :single-u-esc) + ,|(string/from-bytes + ;(cond + (<= $ 0x7f) [$] + (<= $ 0x7ff) + [(bor (band (brshift $ 6) 0x1F) 0xC0) + (bor (band (brshift $ 0) 0x3F) 0x80)] + (<= $ 0xffff) + [(bor (band (brshift $ 12) 0x0F) 0xE0) + (bor (band (brshift $ 6) 0x3F) 0x80) + (bor (band (brshift $ 0) 0x3F) 0x80)] + # Otherwise + [(bor (band (brshift $ 18) 0x07) 0xF0) + (bor (band (brshift $ 12) 0x3F) 0x80) + (bor (band (brshift $ 6) 0x3F) 0x80) + (bor (band (brshift $ 0) 0x3F) 0x80)]))) + :escape (/ (* "\\" (<- (set "avbnfrt\"\\/"))) + ,|(get {"a" "\a" "v" "\v" "b" "\b" + "n" "\n" "f" "\f" "r" "\r" + "t" "\t"} $ $)) + :main (+ (some (+ :unicode-esc :escape (<- 1))) -1)})) + +(defn decode + `` + Returns a janet object after parsing JSON. If `keywords` is truthy, + string keys will be converted to keywords. If `nils` is truthy, `null` + will become `nil` instead of the keyword `:json/null`. + `` + [json-source &opt keywords nils] + + (def json-parser + {:null (if nils + ~(/ (<- (+ "null" "Null")) nil) + ~(/ (<- (+ "null" "Null")) :json/null)) + :bool-t ~(/ (<- (+ "true")) true) + :bool-f ~(/ (<- (+ "false")) false) + :number ~(/ (<- (* (? "-") :d+ (? (* "." :d+)))) ,|(scan-number $)) + :string ~(/ (* "\"" (<- (to (* (> -1 (not "\\")) "\""))) + (* (> -1 (not "\\")) "\"")) + ,|(string/join (peg/match utf-8->bytes $))) + :array ~(/ (* "[" :s* (? (* :value (any (* :s* "," :value)))) "]") ,|(array ;$&)) + :key-value (if keywords + ~(* :s* (/ :string ,|(keyword $)) :s* ":" :value) + ~(* :s* :string :s* ":" :value)) + :object ~(/ (* "{" :s* (? (* :key-value (any (* :s* "," :key-value)))) "}") + ,|(from-pairs (partition 2 $&))) + :value ~(* :s* (+ :null :bool-t :bool-f :number :string :array :object) :s*) + :unmatched ~(/ (<- (to (+ :value -1))) ,|[:unmatched $]) + :main ~(some (+ :value "\n" :unmatched))}) + + (first (peg/match (peg/compile json-parser) json-source))) + +(def- bytes->utf-8 + (peg/compile + ~{:four-byte (/ (* (<- (range "\xf0\xff")) (<- 1) (<- 1) (<- 1)) + ,|(bor (blshift (band (first $0) 0x07) 18) + (blshift (band (first $1) 0x3F) 12) + (blshift (band (first $2) 0x3F) 6) + (blshift (band (first $3) 0x3F) 0))) + :three-byte (/ (* (<- (range "\xe0\xef")) (<- 1) (<- 1)) + ,|(bor (blshift (band (first $0) 0x0F) 12) + (blshift (band (first $1) 0x3F) 6) + (blshift (band (first $2) 0x3F) 0))) + :two-byte (/ (* (<- (range "\x80\xdf")) (<- 1)) + ,|(bor (blshift (band (first $0) 0x1F) 6) + (blshift (band (first $1) 0x3F) 0))) + :multi-byte (/ (+ :two-byte :three-byte :four-byte) + ,|(if (< $ 0x10000) + (string/format "\\u%04X" $) + (string/format "\\u%04X\\u%04X" + (+ (brshift (- $ 0x10000) 10) 0xD800) + (+ (band (- $ 0x10000) 0x3FF) 0xDC00)))) + :one-byte (<- (range "\x20\x7f")) + :0to31 (/ (<- (range "\0\x1F")) + ,|(or ({"\a" "\\u0007" "\b" "\\u0008" + "\t" "\\u0009" "\n" "\\u000A" + "\v" "\\u000B" "\f" "\\u000C" + "\r" "\\u000D"} $) + (string/format "\\u%04X" (first $)))) + :backslash (/ (<- "\\") "\\\\") + :quote (/ (<- "\"") "\\\"") + :main (+ (some (+ :0to31 :backslash :quote :one-byte :multi-byte)) -1)})) + +(defn- encodeone [x depth] + (if (> depth 1024) (error "recurred too deeply")) + (cond + (= x :json/null) "null" + (= x nil) "null" + (bytes? x) (string "\"" (string/join (peg/match bytes->utf-8 x)) "\"") + (indexed? x) (string "[" (string/join (map |(encodeone $ (inc depth)) x) ",") "]") + (dictionary? x) (string "{" (string/join + (seq [[k v] :in (pairs x)] + (string "\"" (string/join (peg/match bytes->utf-8 k)) "\"" ":" (encodeone v (inc depth)))) ",") "}") + (case (type x) + :nil "null" + :boolean (string x) + :number (string x) + (error "type not supported")))) + +(defn encode + `` + Encodes a janet value in JSON (utf-8). If `buf` is provided, the formated + JSON is append to `buf` instead of a new buffer. Returns the modifed buffer. + `` + [x &opt buf] + + (letv [ret (encodeone x 0)] + (if (and buf (buffer? buf)) + (buffer/push ret) + (thaw ret)))) diff --git a/janet/ludus.janet b/janet/ludus.janet new file mode 100644 index 0000000..72aadef --- /dev/null +++ b/janet/ludus.janet @@ -0,0 +1,110 @@ +# 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) +(import /src/json :as j) + +(defn ludus [source] + # if we can't load prelude, bail + (when (= :error prelude/pkg) (error "could not load prelude")) + + # get us a clean working slate + (def ctx @{:^parent prelude/ctx}) + (def errors @[]) + (var result @"") + (def console @"") + + # capture all `print`s + (setdyn :out console) + + # an output table + # this will change: the shape of our output + # at the moment, there's only one stack of turtle graphics + # we will be getting more + (def out @{:errors errors :result result + :io @{ + :stdout @{:proto [:text-stream "0.1.0"] :data console} + :turtle @{:proto [:turtle-graphics "0.1.0"] :data @[]}}}) + + ### start the program + # first, scanning + (def scanned (s/scan source)) + (when (any? (scanned :errors)) + (each err (scanned :errors) + (e/scan-error err)) + (break (-> out j/encode string))) + # then, parsing + (def parsed (p/parse scanned)) + (when (any? (parsed :errors)) + (each err (parsed :errors) + (e/parse-error err)) + (break (-> out j/encode string))) + # then, validation + (def validated (v/valid parsed ctx)) + (when (any? (validated :errors)) + (each err (validated :errors) + (e/validation-error err)) + (break (-> out j/encode string))) + # and, finally, try interpreting the program + (try (do + # we need to do this every run or we get the very same sequence of "random" numbers every time we run a program + (math/seedrandom (os/cryptorand 8)) + (set result (i/interpret (parsed :ast) ctx))) + ([err] + (e/runtime-error err) + (break (-> out j/encode string)))) + + # stop capturing output + (setdyn :out stdout) + + # update our output table with our output + (set (out :result) (b/show result)) + (set (((out :io) :turtle) :data) (get-in prelude/pkg [:turtle_commands :^value])) + + # run the "postlude": any Ludus code that needs to run after each program + # right now this is just resetting the boxes that hold turtle commands and state + (try + (i/interpret prelude/post/ast ctx) + ([err] (e/runtime-error err))) + + # json-encode our output table, and convert it from a buffer to a string (which we require for playing nice with WASM/C) + (-> out j/encode string)) + +#### REPL +(comment +# (do + (def start (os/clock)) + (def source ` + +fn fib { + (1) -> 1 + (2) -> 1 + (n) -> add ( + fib (sub (n, 1)) + fib (sub (n, 2)) + ) +} + +fib (30) + `) + (def out (-> source + ludus + j/decode + )) + (def end (os/clock)) + (setdyn :out stdout) + (pp out) + (def console (out "console")) + (print console) + (def result (out "result")) + (print result) + (print (- end start)) +) + diff --git a/janet/parser.janet b/janet/parser.janet new file mode 100644 index 0000000..edb84d0 --- /dev/null +++ b/janet/parser.janet @@ -0,0 +1,1181 @@ +### A recursive descent parser for Ludus + +### We still need to scan some things +(import /src/scanner :as s) + +# stash janet type +(def janet-type type) + +(defmacro declare + "Forward-declares a function name, so that it can be called in a mutually recursive manner." + [& names] + (def bindings @[]) + (loop [name :in names] + (def binding ~(var ,name nil)) + (array/push bindings binding)) + ~(upscope ,;bindings)) + +(defmacro defrec + "Defines a function depended on by another function, that has been forward `declare`d." + [name & forms] + (if-not (dyn name) (error "recursive functions must be declared before they are defined")) + ~(set ,name (defn- ,name ,;forms))) + +### Some more human-readable formatting +(defn- pp-tok [token] + (if (not token) (break "nil")) + (def {:line line :lexeme lex :type type :start start} token) + (string "<" line "[" start "]" ": " type ": " lex ">")) + +(defn- pp-ast [ast &opt indent] + (default indent 0) + (def {:token token :data data :type type} ast) + (def pretty-tok (pp-tok token)) + (def data-rep (if (= :array (janet-type data)) + (string "[\n" + (string/join (map (fn [x] (pp-ast x (inc indent))) data) + (string (string/repeat " " indent) "\n")) + "\n" (string/repeat " " indent) "]") + data + )) + (string (string/repeat " " indent) type ": " pretty-tok " " data-rep) +) + +### Next: a data structure for a parser +(defn- new-parser + "Creates a new parser data structure to pass around" + [tokens] + @{ + :tokens (tokens :tokens) + :ast @[] + :current 0 + :errors @[] + }) + +### and some helper functions for interfacing with that data structure +(defn- current + "Returns the current token of a parser. If the parser is at the last token, keeps returning the last token." + [parser] + (def tokens (parser :tokens)) + (get tokens (parser :current) (last tokens))) + +(defn- peek + "Returns the next token of the parser. If the parser is at the last token, keeps returning the last token." + [parser] + (def tokens (parser :tokens)) + (get tokens (inc (parser :current)) (last tokens))) + +(defn- advance + "Advances the parser by a token" + [parser] + (update parser :current inc)) + +(defn- type + "Returns the type of a token" + [token] + (get token :type)) + +(defn- check + "Returns true if the parser's current token is one of the passed types" + [parser type & types] + (def accepts [type ;types]) + (def current-type (-> parser current (get :type))) + (has-value? accepts current-type)) + +### Parsing functions +# forward declarations +(declare simple nonbinding expr toplevel synthetic) + +# errors +# terminators are what terminate expressions +(def terminators [:break :newline :semicolon]) + +(defn- terminates? + "Returns true if the current token in the parser is a terminator" + [parser] + (def curr (current parser)) + (def ttype (type curr)) + (has-value? terminators ttype)) + +# breakers are what terminate panics +(def breaking [:break :newline :semicolon :comma :eof +# :then :else :arrow +]) + +(defn- breaks? + "Returns true if the current token in the parser should break a panic" + [parser] + (def curr (current parser)) + (def ttype (type curr)) + (has-value? breaking ttype)) + +(defn- panic + "Panics the parser: starts skipping tokens until a breaking token is encountered. Adds the error to the parser's errors array, and also errors out." + [parser message] +# (print "Panic in the parser: " message) + (def origin (current parser)) + (def skipped @[]) + (while (not (breaks? parser)) + (array/push skipped (current parser)) + (advance parser)) + (array/push skipped (current parser)) + # (advance parser) + (def err {:type :error :data skipped :token origin :msg message}) + (update parser :errors array/push err) + (error err)) + +(defn- expected + "Panics the parser with a message: expected {type} got ..." + [parser ttype & ttypes] + (def expected (map string [ttype ;ttypes])) + (def type-msg (string/join expected " | ")) + (panic parser (string "expected {" type-msg "}, got " (-> parser current type)))) + +(defn- expect + "Panics if the parser's current token is not of type; otherwise does nothing & returns nil" + [parser type & types] + (if-not (check parser type ;types) (expected parser type ;types))) + +(defn- expect-ret + "Same as expect, but captures the error, returning it as a value" + [parser type & types] + (try (expect parser type ;types) ([e] e))) + +(defn- capture + "Applies the parse function to the parser, returning the parsed AST. If there is a panic, captures the panic and returns it as a value." + [parse-fn parser] + (try (parse-fn parser) ([e] e))) + +(defn- accept-one + "Accepts a single token of passed type, advancing the parser if a match, doing nothing if not." + [parser type & types] + (if (check parser type ;types) (advance parser))) + +(defn- accept-many + "Accepts any number of tokens of a passed type, advancing the parser on match until there are no more matches. Does nothing on no match." + [parser type & types] + (while (check parser type ;types) (advance parser))) + +# atoms +(defn- bool [parser] + (expect parser :true :false) + (def curr (-> parser current)) + (def ttype (type curr)) + (def value (if (= ttype :true) true false)) + (advance parser) + {:type :bool :data value :token curr} + ) + +(defn- num [parser] + (expect parser :number) + (def curr (-> parser current)) + (advance parser) + {:type :number :data (curr :literal) :token curr} + ) + +(defn- kw [parser] + (expect parser :keyword) + (if (= :lparen (-> parser peek type)) (break (synthetic parser))) + (def curr (-> parser current)) + (advance parser) + {:type :keyword :data (curr :literal) :token curr} + ) + +(defn- kw-only [parser] + (expect parser :keyword) + (def curr (-> parser current)) + (advance parser) + {:type :keyword :data (curr :literal) :token curr}) + +(defn- pkg-kw [parser] + (expect parser :pkg-kw) + (def curr (-> parser current)) + (advance parser) + {:type :pkg-kw :data (curr :literal) :token curr}) + +(defn- nill [parser] + (expect parser :nil) + (def curr (current parser)) + (advance parser) + {:type :nil :token curr}) + +(defn- str [parser] + (expect parser :string) + (def curr (-> parser current)) + (advance parser) + {:type :string :data (curr :literal) :token curr}) + +# interpolated strings, which are a whole other scene +(defn- scan-interpolations [data] +# (print "scanning interpolation: " data) + (when (buffer? data) (break data)) + # (pp data) + (def to-scan (data :to-scan)) + (def {:tokens tokens :errors errors} (s/scan to-scan)) + # (pp tokens) +# (print "there are " (length tokens) " tokens") + (def first-token (first tokens)) + (cond + (first errors) (first errors) + (empty? tokens) + {:type :error :msg "string interpolations/patterns must be single words"} + (< 3 (length tokens)) + {:type :error :msg "string interpolations/patterns must be single words"} + (= :word (first-token :type)) + {:type :word :data (first-token :lexeme) :token first-token} + :else {:type :error :msg "string interpolations/patterns must be single words"})) + +(defn- is-error? [data] + (cond + (buffer? data) false + (= :error (data :type)) true + false)) + +(defn- interpolated [parser] + (expect parser :interpolated) + (def origin (current parser)) + (def source (origin :literal)) + (def data @[]) + (var curr @"") + (var interp? false) + (var escape? false) + (each code source + (def char (string/from-bytes code)) + (cond + (= char "\\") (set escape? true) + escape? (if (= char "{") + (do + (buffer/push curr "{") + (set escape? false)) + (do + (buffer/push curr "\\") + (buffer/push curr char) + (set escape? false))) + (= char "{") (do + (set interp? true) + (array/push data curr) + (set curr @"")) + (= char "}") (if interp? (do + (set interp? false) + (array/push data {:to-scan curr}) + (set curr @"")) + (buffer/push curr char)) + :else (buffer/push curr char))) + (array/push data curr) + (def interpolated (map scan-interpolations data)) + (advance parser) + (def ast @{:type :interpolated :data interpolated :token origin}) + (if (some is-error? interpolated) + (do + (def err {:type :error :msg "bad interpolated string" :data ast :token origin}) + (array/push (parser :errors) err) + err) + ast)) + +# words & synthetic expressions +(def separates [:break :newline :comma]) + +(defn- separates? [parser] + (def curr (current parser)) + (def ttype (type curr)) + (has-value? separates ttype)) + +(defn- separators [parser] + (if-not (separates? parser) + (panic parser (string "expected separator, got " (-> parser current type)))) + (while (separates? parser) (advance parser))) + +(def sequels [:lparen :keyword :pkg-kw]) + +(defn- word-expr [parser] + (expect parser :word) + (if (has-value? sequels (-> parser peek type)) (break (synthetic parser))) + (def curr (-> parser current)) + (advance parser) + {:type :word :data (curr :lexeme) :token curr}) + +(defn- word-only [parser] + (expect parser :word) + (def curr (current parser)) + (advance parser) + {:type :word :data (curr :lexeme) :token curr}) + +(defn- args [parser] + (def origin (current parser)) + (advance parser) # consume the :lparen + (def ast @{:type :args :data @[] :token origin :partial false}) + (while (not (check parser :rparen)) + (accept-many parser :newline :comma) + (when (= :break ((current parser) :type)) + (break (advance parser))) + (when (check parser :eof) + (def err {:type :error :token origin :msg "unclosed paren"}) + (array/push (parser :errors) err) + (error err)) + (def origin (current parser)) + (def term (if (check parser :placeholder) + (if (ast :partial) + (do + (def err {:type :error :data [] :token origin :msg "partially applied functions may only use one placeholder"}) + (advance parser) + (update parser :errors array/push err) + err) + (do + (set (ast :partial) true) + (advance parser) + {:type :placeholder :token origin})) + (capture nonbinding parser))) + (array/push (ast :data) term) + (capture separators parser)) + (advance parser) + ast) + +(defn- synth-root [parser] +# (print "parsing synth root") + (def origin (current parser)) + (advance parser) + (case (type origin) + :word {:type :word :data (origin :lexeme) :token origin} + :keyword {:type :keyword :data (origin :literal) :token origin} + :pkg-name {:type :pkg-name :data (origin :lexeme) :token origin} + (panic parser "expected word, keyword, or package") + ) +) + +(defrec synthetic [parser] +# (print "parsing synthetic") + (def origin (current parser)) + # (def ast {:type :synthetic :data @[(synth-root parser)] :token origin}) + (def terms @[(synth-root parser)]) + (while (has-value? sequels (-> parser current type)) + (def term + (case (-> parser current type) + :lparen (args parser) + :keyword (kw-only parser) + :pkg-kw (pkg-kw parser) + )) + (array/push terms term) + ) + {:type :synthetic :data [;terms] :token origin}) + +# collections +### XXX: the current panic/capture structure in this, script, etc. is blowing up when the LAST element (line, tuple member, etc.) has an error +# it does, however, work perfectly well when there isn't one +# there's something about advancing past the breaking token, or not +# aslo, I removed the captures here around nonbinding and separators, and we got into a loop with a panic +# oy +(defn- tup [parser] + (def origin (current parser)) + (advance parser) # consume the :lparen + (def ast {:type :tuple :data @[] :token origin}) + (while (not (check parser :rparen)) + (accept-many parser :newline :comma) + (when (= :break ((current parser) :type)) + (break (advance parser))) + (when (check parser :eof) + (def err {:type :error :token origin :msg "unclosed paren"}) + (array/push (parser :errors) err) + (error err)) + (def term (capture nonbinding parser)) + (array/push (ast :data) term) + (capture separators parser)) + (advance parser) + ast) + +(defn- list [parser] + (def origin (current parser)) + (advance parser) + (def ast {:type :list :data @[] :token origin}) + (while (not (check parser :rbracket)) + (accept-many parser :newline :comma) + (when (= :break ((current parser) :type)) + (break (advance parser))) + (when (check parser :eof) + (def err {:type :error :token origin :msg "unclosed bracket"}) + (array/push (parser :errors) err) + (error err)) + (def origin (current parser)) + (def term (if (check parser :splat) + (do + (advance parser) + (def splatted (capture word-only parser)) + {:type :splat :data splatted :token origin} + ) + (capture nonbinding parser))) + (array/push (ast :data) term) + (capture separators parser)) + (advance parser) + ast) + +(defn- sett [parser] + (def origin (current parser)) + (advance parser) + (def ast {:type :set :data @[] :token origin}) + (while (not (check parser :rbrace)) + (accept-many parser :newline :comma) + (when (= :break ((current parser) :type)) + (break (advance parser))) + (when (check parser :eof) + (def err {:type :error :token origin :msg "unclosed brace"}) + (array/push (parser :errors) err) + (error err)) + (def origin (current parser)) + (def term (if (check parser :splat) + (do + (advance parser) + (def splatted (capture word-only parser)) + {:type :splat :data splatted :token origin} + ) + (capture nonbinding parser))) + (array/push (ast :data) term) + (capture separators parser)) + (advance parser) + ast) + +(defn- dict [parser] + (def origin (current parser)) + (advance parser) + (def ast {:type :dict :data @[] :token origin}) + (while (not (check parser :rbrace)) + (accept-many parser :newline :comma) + (when (= :break ((current parser) :type)) + (break (advance parser))) + (when (check parser :eof) + (def err {:type :error :token origin :msg "unclosed brace"}) + (array/push (parser :errors) err) + (error err)) + (def origin (current parser)) + (def term (case (type origin) + :splat {:type :splat :data (capture word-only (advance parser)) :token origin} + :word (do + (def value (capture word-only parser)) + (def key {:type :keyword :data (keyword (value :data)) + :token origin}) + {:type :pair :data [key value] :token origin}) + :keyword (do + (def key (capture kw-only parser)) + (def value (capture nonbinding parser)) + {:type :pair :data [key value] :token origin}) + (try (panic parser (string "expected dict term, got " (type origin))) ([e] e)) + )) + (array/push (ast :data) term) + (capture separators parser)) + (advance parser) + ast) + +### patterns +(declare pattern) + +(defn- placeholder [parser] + (expect parser :placeholder :ignored) + (def origin (current parser)) + (advance parser) + {:type :placeholder :token origin}) + +(defn- word-pattern [parser] + (expect parser :word) + (def origin (current parser)) + (advance parser) + (def the-word {:type :word :data (origin :lexeme) :token origin}) + (if (check parser :as) + (do + (advance parser) + (def type (kw parser)) + {:type :typed :data [type the-word] :token origin}) + the-word)) + +(defn- tup-pattern [parser] + (def origin (current parser)) + (advance parser) # consume the :lparen + (def ast {:type :tuple :data @[] :token origin}) + (while (not (check parser :rparen)) + (accept-many parser :newline :comma) + (when (= :break ((current parser) :type)) + (break (advance parser))) + (when (check parser :eof) + (def err {:type :error :token origin :msg "unclosed paren"}) + (array/push (parser :errors) err) + (error err)) + (def origin (current parser)) + (def term (if (check parser :splat) + (do + (advance parser) + (def splatted (when (check parser :word) (word-only parser))) + {:type :splat :data splatted :token origin}) + (capture pattern parser))) + (array/push (ast :data) term) + (capture separators parser)) + (advance parser) + ast) + +(defn- list-pattern [parser] + (def origin (current parser)) + (advance parser) + (def ast {:type :list :data @[] :token origin}) + (while (not (check parser :rbracket)) + (accept-many parser :newline :comma) + (when (= :break ((current parser) :type)) + (break (advance parser))) + (when (check parser :eof) + (def err {:type :error :token origin :msg "unclosed bracket"}) + (array/push (parser :errors) err) + (error err)) + (def origin (current parser)) + (def term (if (check parser :splat) + (do + (advance parser) + (def splatted (when (check parser :word) (word-only parser))) + {:type :splat :data splatted :token origin}) + (capture pattern parser))) + (array/push (ast :data) term) + (capture separators parser)) + (advance parser) + ast) + +(defn- dict-pattern [parser] + (def origin (current parser)) + (advance parser) + (def ast {:type :dict :data @[] :token origin}) + (while (not (check parser :rbrace)) + (accept-many parser :newline :comma) + (when (= :break ((current parser) :type)) + (break (advance parser))) + (when (check parser :eof) + (def err {:type :error :token origin :msg "unclosed brace"}) + (array/push (parser :errors) err) + (error err)) + (def origin (current parser)) + (def term (case (type origin) + :splat {:type :splat :data (when (check (advance parser) :word) (word-only parser)) :token origin} + :word (do + (def word (capture word-pattern parser)) + (def name (word :data)) + (def key {:type :keyword :data (keyword name) :token origin}) + {:type :pair :data [key word] :token origin}) + :keyword (do + (def key (capture kw-only parser)) + (def value (capture pattern parser)) + {:type :pair :data [key value] :token origin}) + (try (panic parser (string "expected dict term, got " (type origin))) ([e] e)) + )) + (array/push (ast :data) term) + (capture separators parser)) + (advance parser) + ast) + +### TODO: add as patterns +(defrec pattern [parser] + (case (-> parser current type) + :nil (nill parser) + :true (bool parser) + :false (bool parser) + :keyword (kw parser) + :number (num parser) + :string (str parser) + :word (word-pattern parser) + :placeholder (placeholder parser) + :ignored (placeholder parser) + :lparen (tup-pattern parser) + :lbracket (list-pattern parser) + :startdict (dict-pattern parser) + :interpolated (interpolated parser) + (panic parser "expected pattern") + )) + +### let +# let {pattern} = {nonbinding} +(defn- lett [parser] + (def ast {:type :let :data @[] :token (current parser)}) + (advance parser) # consume the let + (array/push (ast :data) (capture pattern parser)) + (if-let [err (expect-ret parser :equals)] + (do (array/push (ast :data) err) (break ast)) + (advance parser)) + (accept-many parser :newline) + (array/push (ast :data) (capture nonbinding parser)) + ast) + +### conditional forms +# if {simple} then {nonbinding} else {nonbinding} +(defn- iff [parser] + (def ast {:type :if :data @[] :token (current parser)}) + (advance parser) #consume the if + (array/push (ast :data) (simple parser)) + (accept-many parser :newline) + (if-let [err (expect-ret parser :then)] + (array/push (ast :data) err) + (advance parser)) + (array/push (ast :data) (nonbinding parser)) + (accept-many parser :newline) + (if-let [err (expect-ret parser :else)] + (array/push (ast :data) err) + (advance parser)) + (array/push (ast :data) (nonbinding parser)) + ast) + +(defn- literal-terminator? [token] + (def tok-type (token :type)) + (or (= :newline tok-type) (= :semicolon tok-type))) + +(defn- terminator [parser] + (if-not (terminates? parser) + (panic parser "expected terminator")) + (advance parser) + (while (terminates? parser) (advance parser))) + +# {simple} -> {nonbinding} {terminator} +### TODO: add placeholder as valid lhs +(defn- when-clause [parser] + (try + (do + (def lhs (simple parser)) + (expect parser :arrow) + (advance parser) + (accept-many parser :newline) + (def rhs (nonbinding parser)) + (terminator parser) + [lhs rhs]) + ([err] + (advance parser) # consume the breaking token + (accept-many parser :newline :semicolon :break) # ...and any additional ones + err))) + +# when { {when-clause}+ } +(defn- whenn [parser] + (def origin (current parser)) + (def ast {:type :when :data @[] :token origin}) + (advance parser) # consume when + (if-let [err (expect-ret parser :lbrace)] + (do + (array/push (ast :data) err) + (break ast)) # early return; just bail if we don't have { + (advance parser)) + (accept-many parser :newline) + (while (not (check parser :rbrace )) # make sure we don't roll past eof + (when (check parser :eof) (error {:type :error :token origin :data ast :msg "unclosed brace"})) + (array/push (ast :data) (capture when-clause parser))) + (advance parser) + ast) + +### TODO: add guards to patterns +(defn- match-clause [parser] + (try + (do + (def ast {:type :clause :data @[] :origin (current parser)}) + (def lhs (pattern parser)) + (def guard (when (check parser :if) + (advance parser) + (simple parser))) + (expect parser :arrow) + (advance parser) + (accept-many parser :newline) + (def rhs (nonbinding parser)) + (terminator parser) + [lhs guard rhs]) + ([err] + (accept-many parser ;terminators) + err))) + +(defn- matchh [parser] + (def origin (current parser)) + (def ast {:type :match :data @[] :token origin}) + (var to-match nil) + (def clauses @[]) + (expect parser :match) + (advance parser) + (try + (do + (set to-match (simple parser)) + (expect parser :with) (advance parser) + (def open-brace (current parser)) + (expect parser :lbrace) (advance parser) + (accept-many parser :newline) + (while (not (check parser :rbrace)) + (when (check parser :eof) + (error {:type :error :token open-brace :msg "unclosed brace"})) + (array/push clauses (match-clause parser))) + (advance parser) + @{:type :match :data [to-match clauses] :token origin}) + ([err] err))) + +# {pattern} = {nonbinding} {terminators} +(defn- with-clause [parser] + (try + (do + (def lhs (pattern parser)) + (def guard (when (check parser :if) + (advance parser) + (simple parser))) + (expect parser :equals) (advance parser) + (def rhs (nonbinding parser)) + (terminator parser) + [lhs guard rhs] + ) + ([err] + (accept-many parser ;terminators) + err) + ) +) + +# with { {clauses}+ } {terminators}? then {nonbinding} {terminators}? else {nonbinding} +(defn- withh [parser] + (def origin (current parser)) + (expect parser :with) (advance parser) + (try + (do + (expect parser :lbrace) (var lbrace (current parser)) (advance parser) + (accept-many parser ;terminators) + (def clauses @[]) + (array/push clauses (with-clause parser)) + (accept-many parser ;terminators) + (while (not (check parser :rbrace)) + (if (check parser :eof) + (error {:type :error :data [clauses] :token lbrace :msg "unclosed brace"})) + (array/push clauses (with-clause parser)) + (accept-many parser ;terminators)) + (advance parser) # consume closing brace + (accept-many parser :newline) + (expect parser :then) (advance parser) + (def then (nonbinding parser)) + (accept-many parser :newline) + (expect parser :else) (advance parser) + (expect parser :lbrace) (set lbrace (current parser)) (advance parser) + (accept-many parser ;terminators) + (def else @[]) + (while (not (check parser :rbrace)) + (when (check parser :eof) (error {:type :error :token lbrace :data [else] :msg "unclosed brace"})) + (array/push else (match-clause parser))) + (advance parser) + {:type :with :data [clauses then else] :token origin}) + ([err] err) + ) +) + +### function forms +(defn- fn-simple [parser] +# (print "parsing simple function body") + (try + (do + (def lhs (tup-pattern parser)) +# (print "parsed lhs") + (def guard (when (check parser :if) + (advance parser) + (simple parser))) +# (print "parsed guard") + (expect parser :arrow) (advance parser) +# (print "parsed arrow") + (accept-many parser :newline) + (def rhs (nonbinding parser)) +# (print "parsed rhs") + {:clauses [[lhs guard rhs]]} + ) + ([err] err) + ) +) + +(defn- fn-clause [parser] + (def origin (current parser)) + (try + (do + (def lhs (tup-pattern parser)) + (def guard (when (check parser :if) + (advance parser) + (simple parser))) + (expect parser :arrow) (advance parser) + (accept-many parser :newline) + (def rhs (nonbinding parser)) + (terminator parser) + [lhs guard rhs]) + ([err] + (advance parser) + (accept-many parser ;terminators) + err + ) + ) +) + +(defn- fn-clauses [parser] +# (print "parsing fn clauses") + (def origin (current parser)) + (expect parser :lbrace) (advance parser) + (accept-many parser ;terminators) + (def doc (when (= :string ((current parser) :type)) + (def docstring ((current parser) :literal)) + (advance parser) + (accept-many parser ;terminators) + docstring)) + (def data @[]) + (while (not (check parser :rbrace)) + (if (check parser :eof) + (error {:type :error :token origin :data data :msg "unclosed brace"})) + (array/push data (capture fn-clause parser))) + (advance parser) + {:clauses data :doc doc}) + +(defn- lambda [parser] + (def origin (current parser)) + (expect parser :fn) (advance parser) + @{:type :fn :data ((fn-simple parser) :clauses) :token origin}) + +(defn- fnn [parser] + (if (= :lparen (-> parser peek type)) (break (lambda parser))) + (try + (do +# (print "parsing named function") + (def origin (current parser)) + (expect parser :fn) (advance parser) +# (print "consumed `fn`") +# (print "next token: ") + # (pp (current parser)) + (def name (-> parser word-only (get :data))) +# (print "function name: ") + # (pp name) + (def {:clauses data :doc doc} (case (-> parser current type) + :lbrace (fn-clauses parser) + :lparen (fn-simple parser) + {:clauses :nothing})) + @{:type :fn :name name :data data :token origin :doc doc}) + ([err] err))) + +### compoound forms +(defn- block [parser] + (def origin (current parser)) + (expect parser :lbrace) (advance parser) + (def data @[]) + (while (not (check parser :rbrace)) + (accept-many parser :newline :semicolon) + (when (= :break ((current parser) :type)) + (break (advance parser))) + (if (check parser :eof) + (error {:type :error :token origin :data data :msg "unclosed brace"})) + (array/push data (capture expr parser)) + (capture terminator parser)) + (advance parser) + {:type :block :data data :token origin}) + +### TODO: decide whether this design works +# newlines are allowed AFTER pipelines, but not before +# eg. `do foo > \n bar > \n baz` +# but not `do foo \n > bar \n > baz` +# Otherwise, this isn't LR +(defn- doo [parser] + (def origin (current parser)) + (expect parser :do) (advance parser) + (def data @[]) + (array/push data (capture simple parser)) +# (print "added first expression. current token:") + # (pp (current parser)) + (while (check parser :pipeline) + (advance parser) + (accept-many parser :newline) + (array/push data (capture simple parser))) + {:type :do :data data :token origin}) + +### boxs, pkgs, nses, etc. +(defn- box [parser] + (def origin (current parser)) + (expect parser :box) (advance parser) + (try + (do + (def name (-> parser word-only (get :data))) + (expect parser :equals) (advance parser) + (def value (nonbinding parser)) + {:type :box :data value :name name :token origin}) + ([err] err))) + +(defn- pkg-name [parser] + (expect parser :pkg-name) + (def origin (current parser)) + (def next-type (-> parser peek type)) + (when (or (= :keyword next-type) (= :pkg-kw next-type)) + (break (synthetic parser))) + (advance parser) + {:type :pkg-name :data (origin :lexeme) :token origin}) + + +(defn- pkg-name-only [parser] + (expect parser :pkg-name) + (def origin (current parser)) + (advance parser) + {:type :pkg-name :data (origin :lexeme) :token origin}) + +(defn- usee [parser] + (def origin (current parser)) + (expect parser :use) (advance parser) + (try + (do + {:type :use :data (pkg-name parser) :token origin}) + ([err] err))) + +(defn- pkg [parser] + (try + (do + (def origin (current parser)) + (expect parser :pkg) (advance parser) + (def name (-> parser pkg-name (get :data))) + (expect parser :lbrace) (advance parser) + (while (separates? parser) (advance parser)) + (def data @[]) + (while (not (check parser :rbrace)) + (when (check parser :eof) + (def err {:type :error :token origin :data data :msg "unclosed brace"}) + (array/push (parser :errors) err) + (error err)) + (case (-> parser current type) + :pkg-name (do + (def origin (current parser)) + (def value (pkg-name-only parser)) + (def key (keyword (value :data))) + (def pkg-kw-ast {:type :pkg-kw :data key :token origin}) + (array/push data {:type :pkg-pair :data [pkg-kw-ast value] :token origin})) + :keyword (do + (def origin (current parser)) + (def key (capture kw parser)) + (def value (capture simple parser)) + (array/push data {:type :pair :data [key value] :token origin})) + :word (do + (def origin (current parser)) + (def value (word-only parser)) + (def key (keyword (value :data))) + (def kw-ast {:type :keyword :data key :token origin}) + (array/push data {:type :pair :data [kw-ast value] :token origin})) + (panic parser "expected pkg term")) + (separators parser)) + (advance parser) + @{:type :pkg :data data :token origin :name name}) + ([err] err))) + +(defn- ns [parser] + (try + (do + (def origin (current parser)) + (expect parser :ns) (advance parser) + (def name (-> parser pkg-name (get :data))) + (def body (block parser)) + @{:type :ns :data body :name name :token origin}) + ([err] err))) + +(defn- importt [parser] + (def origin (current parser)) + (expect parser :import) (advance parser) + (def path (str parser)) + (expect parser :as) (advance parser) + (def name-parser (if (check parser :pkg-name) pkg-name word-only)) + (def name + (-> parser name-parser (get :data))) + {:type :import :data path :name name :token origin}) + +### tests +(defn- testt [parser] + (def origin (current parser)) + (expect parser :test) (advance parser) + (def desc (str parser)) + (def body (nonbinding parser)) + {:type :test :data [desc body] :token origin}) + +### loops and repeates +(defn- loopp [parser] + (def origin (current parser)) + (expect parser :loop) (advance parser) + (def args (tup parser)) + (expect parser :with) (advance parser) + (def {:clauses clauses} (case (-> parser current type) + :lparen (fn-simple parser) + :lbrace (fn-clauses parser) + )) + @{:type :loop :data [args clauses] :token origin}) + +(defn- recur [parser] + (def origin (current parser)) + (expect parser :recur) (advance parser) + (def args (tup parser)) + {:type :recur :data args :token origin}) + +(defn- repeatt [parser] + (def origin (current parser)) + (advance parser) + (def times (case (-> parser current type) + :number (num parser) + :word (word-only parser) + (panic parser "expected number or word") + )) + (def body (block parser)) + {:type :repeat :data [times body] :token origin}) + +### panics +(defn- panicc [parser] + (def origin (current parser)) + (expect parser :panic) (advance parser) + {:type :panic :data (nonbinding parser) :token origin}) + +### expressions +# four levels of expression complexity: +# simple (atoms, collections, synthetic expressions; no conditionals or binding or blocks) +# nonbinding (excludes let, box, named fn: what is allowed inside collections) +# plain old exprs (anything but toplevel) +# toplevel (exprs + ns, pkg, test, import, use) + +# simple expressions: what can go anywhere you expect an expression +(defrec simple [parser] + (def curr (current parser)) + (case (type curr) + :nil (nill parser) + :true (bool parser) + :false (bool parser) + :number (num parser) + :keyword (kw parser) + :string (str parser) + :interpolated (interpolated parser) + :lparen (tup parser) + :lbracket (list parser) + :startdict (dict parser) + :startset (sett parser) + :word (word-expr parser) + :pkg-name (pkg-name parser) + :recur (recur parser) + :panic (panicc parser) + (panic parser (string "expected simple expression, got " (type curr))) + ) +) + +# non-binding expressions +# the rhs of lets, clauses, inside conditional forms, etc. +# any form that does not bind a name +(defrec nonbinding [parser] + (def curr (current parser)) + (case (type curr) + # atoms + :nil (nill parser) + :true (bool parser) + :false (bool parser) + :number (num parser) + :keyword (kw parser) + + # strings + :string (str parser) + ### TODO: interpolated strings + :interpolated (interpolated parser) + + # collection literals + :lparen (tup parser) + :lbracket (list parser) + :startdict (dict parser) + :startset (sett parser) + + # synthetic + :word (word-expr parser) + :pkg-name (pkg-name parser) + :recur (recur parser) + + # conditional forms + :if (iff parser) + :when (whenn parser) + :match (matchh parser) + :with (withh parser) + + # do + :do (doo parser) + + # fn: but only lambda + :fn (lambda parser) + + # blocks + :lbrace (block parser) + + # looping forms + :loop (loopp parser) + :repeat (repeatt parser) + + # panic! + :panic (panicc parser) + + (panic parser (string "expected nonbinding expression, got " (type curr))) + ) +) + +(defrec expr [parser] + (def curr (current parser)) + (case (type curr) + # binding forms + :let (lett parser) + :fn (fnn parser) + :box (box parser) + + # nonbinding forms + :nil (nill parser) + :true (bool parser) + :false (bool parser) + :number (num parser) + :keyword (kw parser) + :string (str parser) + :interpolated (interpolated parser) + :lparen (tup parser) + :lbracket (list parser) + :startdict (dict parser) + :startset (sett parser) + :word (word-expr parser) + :pkg-name (pkg-name parser) + :recur (recur parser) + :if (iff parser) + :when (whenn parser) + :match (matchh parser) + :with (withh parser) + :do (doo parser) + :lbrace (block parser) + :loop (loopp parser) + :repeat (repeatt parser) + :panic (panicc parser) + (panic parser (string "expected expression, got " (type curr))) + ) +) + +(defrec toplevel [parser] + (def curr (current parser)) + (case (type curr) + # toplevel-only + :pkg (pkg parser) + :ns (ns parser) + :test (testt parser) + :import (importt parser) + :use (usee parser) + + # all the other expressions + (expr parser) + ) +) + +(defn- script [parser] + (def origin (current parser)) + (def lines @[]) + (while (not (check parser :eof)) + # (print "starting script loop with " (pp-tok origin)) + (accept-many parser :newline :semicolon) + (when (= :break ((current parser) :type)) + (break (advance parser))) + (def term (capture toplevel parser)) + (array/push lines term) + (capture terminator parser)) + {:type :script :data lines :token origin}) + +(defn parse [scanned] + (def parser (new-parser scanned)) + (def ast (script parser)) + (set (parser :ast) ast) + parser) + +# (do +(comment +(def source ` +{ + foo bar + quux frobulate + baz + 12 23 42 +} +`) +(def scanned (s/scan source)) +# (print "\n***NEW PARSE***\n") +(def parsed (parse scanned)) +(pp (map (fn [err] (err :msg)) (parsed :errors))) +(print (pp-ast (parsed :ast))) +) diff --git a/janet/prelude.janet b/janet/prelude.janet new file mode 100644 index 0000000..ef92a71 --- /dev/null +++ b/janet/prelude.janet @@ -0,0 +1,42 @@ +(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 "../assets/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))) + diff --git a/janet/project.janet b/janet/project.janet new file mode 100644 index 0000000..0b0ac3a --- /dev/null +++ b/janet/project.janet @@ -0,0 +1,9 @@ +(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"]) diff --git a/janet/scanner.janet b/janet/scanner.janet new file mode 100644 index 0000000..e593728 --- /dev/null +++ b/janet/scanner.janet @@ -0,0 +1,355 @@ +(def reserved-words + "List of Ludus reserved words." + ## see ludus-spec repo for more info + { + "as" :as ## impl + "box" :box + "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 + "repeat" :repeat ## impl + "test" :test + "then" :then ## impl + "true" :true ## impl -> literal word + "use" :use ## wip + "when" :when ## impl, replaces cond + "with" :with ## impl + }) + +(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) + :msg 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)) + +(def escape { + "\"" "\"" + "n" "\n" + "{" "{" + "t" "\t" + "r" "\r" + "\\" "\\" +}) + +(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)] + (recur + (advance (advance scanner)) + (buffer/push buff (get escape next next)) + 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))) + +# (comment +(do + (def source " -123 ") + (length ((scan source) :tokens))) diff --git a/janet/validate.janet b/janet/validate.janet new file mode 100644 index 0000000..88c3501 --- /dev/null +++ b/janet/validate.janet @@ -0,0 +1,793 @@ +### 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)) + (when (= 0 (length data)) + (array/push (validator :errors) + {:node ast :msg "blocks may not be empty"}) + (break validator)) + (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- resolve-name-in-script [ctx name] + (when (ctx :^toplevel) (break nil)) + (def node (ctx name)) + (if node node (resolve-name-in-script (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)) + ### XXX TODO: this resolution should ONLY be for userspace, NOT prelude + (def resolved (resolve-name-in-script ctx name)) + (when resolved + (def {:line line :input input} resolved) + (array/push (validator :errors) + {:node ast :msg (string "name " 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- box [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 "wrong number of arguments"}) + (break validator)) + (def rest-min (min ;rest-arities)) + (when (< num-args rest-min) + (array/push (validator :errors) + {:node ast :msg "wrong number of arguments"})) + 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) + :box (box 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 (keys declared) + (array/push (validator :errors) {:node declaration :msg "declared fn, but not defined"}))) + validator) + +(defn valid [ast &opt ctx] + (default ctx @{}) + (set (ctx :^toplevel) true) + (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) +)