Compare commits

..

2 Commits

Author SHA1 Message Date
Scott Richmond
7018949845 a whole lot of a validator 2024-05-13 20:55:36 -04:00
Scott Richmond
68e96bf223 many bugfixes; desugar pairs with word shorthand in dicts 2024-05-13 20:55:21 -04:00
2 changed files with 312 additions and 32 deletions

View File

@ -1,20 +1,15 @@
### A recursive descent parser for Ludus
### We still need to scan some things
(os/cd "janet") # when in repl to do relative imports
#(os/cd "janet") # when in repl to do relative imports
(import ./scanner :as s)
### First, some mutual recursion helpers
(defn unreachable
"A function that errors out if called."
[&] (error "reached the unreachable"))
(defmacro declare
"Forward-declares a function name, so that it can be called in a mutually recursive manner."
[& names]
(def bindings @[])
(loop [name :in names]
(def binding ~(var ,name unreachable))
(def binding ~(var ,name nil))
(array/push bindings binding))
~(upscope ,;bindings))
@ -22,7 +17,7 @@
"Defines a function depended on by another function, that has been forward `declare`d."
[name & forms]
(if-not (dyn name) (error "recursive functions must be declared before they are defined"))
~(set ,name (defn ,name ,;forms)))
~(set ,name (defn- ,name ,;forms)))
### Next: a data structure for a parser
(defn- new-parser
@ -139,7 +134,7 @@
# atoms
(defn- bool [parser]
(expect parser :bool)
(expect parser :true :false)
(def curr (-> parser current))
(def ttype (type curr))
(def value (if (= ttype :true) true false))
@ -194,9 +189,6 @@
{:type :word :data (first-token :lexeme) :token first-token}
:else {:type :error :msg "string interpolations/patterns must be single words"}))
(def foo [{:foo :bar}])
(-> foo first (get :foo))
(defn- is-error? [data]
(cond
(buffer? data) false
@ -360,7 +352,7 @@
(def term (if (check parser :splat)
(do
(advance parser)
(def splatted (try (word-only parser) ([e] e)))
(def splatted (capture word-only parser))
{:type :splat :data splatted :token origin}
)
(capture nonbinding parser)))
@ -412,7 +404,7 @@
(def key (try (kw parser) ([e] e)))
(def value (capture nonbinding parser))
{:type :pair :data [key value] :token origin})
(try (panic parser (string expect "expected dict term, got " (type origin))) ([e] e))
(try (panic parser (string "expected dict term, got " (type origin))) ([e] e))
))
(array/push (ast :data) term)
(try (separators parser) ([e] (array/push (ast :data) e))))
@ -499,12 +491,16 @@
(def origin (current parser))
(def term (case (type origin)
:splat {:type :splat :data (when (check (advance parser) :word) (word-only parser)) :token origin}
:word (capture word-pattern parser)
:word (do
(def word (capture word-pattern parser))
(def name (word :data))
(def key {:type :keyword :data (keyword name) :token origin})
{:type :pair :data [key word] :token origin})
:keyword (do
(def key (capture kw parser))
(def value (capture pattern parser))
{:type :pair :data [key value] :token origin})
(try (panic parser (string expect "expected dict term, got " (type origin))) ([e] e))
(try (panic parser (string "expected dict term, got " (type origin))) ([e] e))
))
(array/push (ast :data) term)
(try (separators parser) ([e] (array/push (ast :data) e))))
@ -743,6 +739,7 @@
(if (check parser :eof)
(error {:type :error :token origin :data data :msg "unclosed brace"}))
(array/push data (capture fn-clause parser)))
(advance parser)
data)
(defn- lambda [parser]
@ -781,6 +778,7 @@
(error {:type :error :token origin :data data :msg "unclosed brace"}))
(array/push data (capture expr parser))
(terminator parser))
(advance parser)
{:type :block :data data :token origin})
### TODO: decide whether this design works
@ -943,7 +941,7 @@
:pkg-name (pkg-name parser)
:recur (recur parser)
:panic (panicc parser)
(panic parser (string expect "expected simple expression, got " (type curr)))
(panic parser (string "expected simple expression, got " (type curr)))
)
)
@ -1017,6 +1015,7 @@
:number (num parser)
:keyword (kw parser)
:string (str parser)
:interpolated (interpolated parser)
:lparen (tup parser)
:lbracket (list parser)
:startdict (dict parser)
@ -1060,6 +1059,12 @@
(capture terminator parser))
{:type :script :data lines :token origin})
(defn parse [scanned]
(def parser (new-parser scanned))
(def ast (script parser))
(set (parser :ast) ast)
parser)
(defn- indent-by [n]
(def indentation @"")
(repeat n (buffer/push indentation ".."))
@ -1081,12 +1086,13 @@
(do
#(comment
(def source `
panic! foo
"foo {bar} baz"
`)
(def scanned (s/scan source))
(def a-parser (new-parser scanned))
(print "\n***NEW PARSE***\n")
(def parsed (toplevel a-parser))
(def a-parser (new-parser scanned))
(def parsed (script a-parser))
# (print (pp-ast parsed))
(pp parsed)
)

View File

@ -4,17 +4,291 @@
Tracking here, before I start writing this code, the kinds of validation we're hoping to accomplish:
* splats come at the end of list, tuple, and dict patterns
* no unbound names
* no re-bound names
* correct imports
* no unbound names with `use` forms
* no circular imports
* first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo
* recur in tail position in `loop` forms
* recur not called outside of `loop` forms
* arity checking where possible
- loop forms
- try to resolve function name, if you can, check arity of call
* [x] splats come at the end of list, tuple, and dict patterns
* [x] no unbound names
* [x] no re-bound names
* [ ] no unbound names with `use` forms
* [ ] first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo
* [ ] recur in tail position in `loop` forms
* [ ] recur not called outside of `loop` forms
* [ ] `loop` form arity checking
* [ ] arity checking of explicit named function calls
* [ ] flag tail calls
* [ ] no circular imports DEFERRED
* [ ] correct imports DEFERRED
)
(import ./recursive :as p)
(import ./scanner :as s)
(defn- new-validator [parser]
(def ast (parser :ast))
@{:ast ast
:errors @[]
:ctx @{}
:status @{}}
)
(var validate nil)
(def terminals [:number :keyword :string :bool :nil])
(def simple-colls [:list :tuple :set])
(defn- simple-coll [validator]
(def ast (validator :ast))
(def data (ast :data))
(each node data
(set (validator :ast) node)
(validate validator))
validator)
(defn- iff [validator]
(def ast (validator :ast))
(def data (ast :data))
(each node data
(set (validator :ast) node)
(validate validator))
validator)
(defn- script [validator]
(def ast (validator :ast))
(def data (ast :data))
(def status (validator :status))
(set (status :toplevel) true)
(each node data
(set (validator :ast) node)
(validate validator))
validator)
(defn- block [validator]
(def ast (validator :ast))
(def data (ast :data))
(def status (validator :status))
(set (status :toplevel) nil)
(def parent (validator :ctx))
(def ctx @{:^parent parent})
(set (validator :ctx) ctx)
(each node data
(set (validator :ast) node)
(validate validator))
(set (validator :ctx) parent)
validator)
(defn- resolve-name [ctx name]
(when (nil? ctx) (break nil))
(def node (get ctx name))
(if node node (resolve-name (get ctx :^parent) name)))
(defn- word [validator]
(def ast (validator :ast))
(def name (ast :data))
(def ctx (validator :ctx))
(def resolved (resolve-name ctx name))
(when (not resolved)
(array/push (validator :errors)
{:node ast :msg "unbound name"}))
validator)
### patterns
(var pattern nil)
(defn- lett [validator]
(def ast (validator :ast))
(def data (ast :data))
(def status (validator :status))
(def pattern (first data))
(def expr (get data 1))
# evaluate the expression first
# otherwise lhs names will appear bound
(set (validator :ast) expr)
(validate validator)
(set (validator :ast) pattern)
(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)
### XXX: to do
(defn- dict-pattern [validator])
(defn- word-pattern [validator]
(def ast (validator :ast))
(def name (ast :data))
(def ctx (validator :ctx))
(when (has-key? ctx name)
(def {:line line :input input} (get-in ctx [name :token]))
(array/push (validator :errors)
{:node ast :msg (string "name is already bound on line "
line " of " input)}))
(set (ctx name) ast)
validator)
(defn- pattern* [validator]
(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)
:splat (splattern validator))))
(defn- match-clauses [validator 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]
(def ast (validator :ast))
(match-clauses validator (ast :data))
validator)
(defn- fnn [validator]
(def ast (validator :ast))
(def name (ast :name))
(when name
(def ctx (validator :ctx))
(def resolved (resolve-name 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))
(match-clauses validator (ast :data))
validator)
(defn- ref [validator]
(def ast (validator :ast))
(def ctx (validator :ctx))
(def expr (ast :data))
(set (validator :ast) expr)
(validate validator)
(def name (ast :name))
(def resolved (resolve-name 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:
# * [ ] arity checking if first term is name that resolves to a function and args aren't partial
# * [ ] ensure properties are on pkgs (prev term in synth is a pkg)
# * [ ] flag tail calls (where last term is not-partial args)
(defn- synthetic [validator]
(def ast (validator :ast))
(def data (ast :data))
(each node data
(set (validator :ast) node)
(validate validator)))
### XXX: todos from parser
(defn- dict [validator])
(defn- whenn [validator])
(defn- withh [validator])
(defn- doo [validator])
(defn- usee [validator])
(defn- pkg [validator])
(defn- ns [validator])
(defn- loop [validator])
(defn- recur [validator])
(defn- repeat [validator])
(defn- panic [validator])
(defn- validate* [validator]
(def ast (validator :ast))
(def type (ast :type))
(print "validating node " type)
(cond
(has-value? terminals type) true
(has-value? simple-colls type) (simple-coll validator)
(case type
: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)
(error (string "unknown node type " type)))))
(set validate validate*)
(set pattern pattern*)
(do
#(comment
(def source `
"foo {bar} baz"
`)
(def scanned (s/scan source))
(def parsed (p/parse scanned))
(def validator (new-validator parsed))
(pp validator)
(validate validator)
)