bring in old janet interpreter for doc purposes
This commit is contained in:
Scott Richmond
parent
d20c453180
commit
2353b6eb9a
338
janet/base.janet
Normal file
338
janet/base.janet
Normal file
|
|
@ -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))
|
||||
|
||||
132
janet/doc.janet
Normal file
132
janet/doc.janet
Normal file
|
|
@ -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)
|
||||
140
janet/errors.janet
Normal file
140
janet/errors.janet
Normal file
|
|
@ -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)
|
||||
657
janet/interpreter.janet
Normal file
657
janet/interpreter.janet
Normal file
|
|
@ -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))
|
||||
# )
|
||||
|
||||
131
janet/json.janet
Normal file
131
janet/json.janet
Normal file
|
|
@ -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))))
|
||||
110
janet/ludus.janet
Normal file
110
janet/ludus.janet
Normal file
|
|
@ -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))
|
||||
)
|
||||
|
||||
1181
janet/parser.janet
Normal file
1181
janet/parser.janet
Normal file
File diff suppressed because it is too large
Load Diff
42
janet/prelude.janet
Normal file
42
janet/prelude.janet
Normal file
|
|
@ -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)))
|
||||
|
||||
9
janet/project.janet
Normal file
9
janet/project.janet
Normal file
|
|
@ -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"])
|
||||
355
janet/scanner.janet
Normal file
355
janet/scanner.janet
Normal file
|
|
@ -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)))
|
||||
793
janet/validate.janet
Normal file
793
janet/validate.janet
Normal file
|
|
@ -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)
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user