Compare commits

...

4 Commits

Author SHA1 Message Date
Scott Richmond
5fbafbac94 make progress: many things 2024-05-14 18:41:21 -04:00
Scott Richmond
ec43aa3c67 accept newlines after arrows in fn clauses; make some asts mutable for validation 2024-05-14 18:41:07 -04:00
Scott Richmond
3225ea2472 improve pkg 2024-05-14 13:46:13 -04:00
Scott Richmond
67cd9d479b keywords must start with lower case 2024-05-14 13:45:41 -04:00
3 changed files with 334 additions and 45 deletions

View File

@ -701,6 +701,7 @@
(print "parsed guard") (print "parsed guard")
(expect parser :arrow) (advance parser) (expect parser :arrow) (advance parser)
(print "parsed arrow") (print "parsed arrow")
(accept-many parser :newline)
(def rhs (nonbinding parser)) (def rhs (nonbinding parser))
(print "parsed rhs") (print "parsed rhs")
[[lhs guard rhs]] [[lhs guard rhs]]
@ -718,6 +719,7 @@
(advance parser) (advance parser)
(simple parser))) (simple parser)))
(expect parser :arrow) (advance parser) (expect parser :arrow) (advance parser)
(accept-many parser :newline)
(def rhs (nonbinding parser)) (def rhs (nonbinding parser))
(terminator parser) (terminator parser)
[lhs guard rhs]) [lhs guard rhs])
@ -745,7 +747,7 @@
(defn- lambda [parser] (defn- lambda [parser]
(def origin (current parser)) (def origin (current parser))
(expect parser :fn) (advance parser) (expect parser :fn) (advance parser)
{:type :fn :data (fn-simple parser) :token origin}) @{:type :fn :data (fn-simple parser) :token origin})
(defn- fnn [parser] (defn- fnn [parser]
(if (= :lparen (-> parser peek type)) (break (lambda parser))) (if (= :lparen (-> parser peek type)) (break (lambda parser)))
@ -764,7 +766,7 @@
:lbrace (fn-clauses parser) :lbrace (fn-clauses parser)
:lparen (fn-simple parser) :lparen (fn-simple parser)
(panic parser (string "expected clause or clauses, got " (-> current parser type))))) (panic parser (string "expected clause or clauses, got " (-> current parser type)))))
{:type :fn :name name :data data :token origin}) @{:type :fn :name name :data data :token origin})
([err] err))) ([err] err)))
### compoound forms ### compoound forms
@ -846,10 +848,15 @@
(def key (capture kw parser)) (def key (capture kw parser))
(def value (capture simple parser)) (def value (capture simple parser))
(array/push data {:type :pair :data [key value] :token origin})) (array/push data {:type :pair :data [key value] :token origin}))
:word (array/push (capture word-only parser)) :word (do
(panic parser "expected dict term")) (def value (word-only parser))
(def key (keyword (value :data)))
(def kw-ast {:type :keyword :data key :token origin})
(array/push data {:type :pair :data [key value] :token origin}))
(panic parser "expected pkg term"))
(terminator parser)) (terminator parser))
{:type :pkg :data data :token origin :name name}) (advance parser)
@{:type :pkg :data data :token origin :name name})
([err] err))) ([err] err)))
(defn- ns [parser] (defn- ns [parser]
@ -859,7 +866,7 @@
(expect parser :ns) (advance parser) (expect parser :ns) (advance parser)
(def name (-> parser pkg-name (get :data))) (def name (-> parser pkg-name (get :data)))
(def body (block parser)) (def body (block parser))
{:type :ns :data body :name name :token origin}) @{:type :ns :data body :name name :token origin})
([err] err))) ([err] err)))
(defn- importt [parser] (defn- importt [parser]
@ -890,7 +897,7 @@
:lparen (fn-simple parser) :lparen (fn-simple parser)
:lbrace (fn-clauses parser) :lbrace (fn-clauses parser)
)) ))
{:type :loop :data [args clauses] :token origin}) @{:type :loop :data [args clauses] :token origin})
(defn- recur [parser] (defn- recur [parser]
(def origin (current parser)) (def origin (current parser))
@ -1086,14 +1093,15 @@
(do (do
#(comment #(comment
(def source ` (def source `
"foo {bar} baz" loop (1, 2) with (x, y) -> :bar
`) `)
(def scanned (s/scan source)) (def scanned (s/scan source))
(print "\n***NEW PARSE***\n") (print "\n***NEW PARSE***\n")
(def a-parser (new-parser scanned)) (def a-parser (new-parser scanned))
(def parsed (script a-parser)) (def parsed (toplevel a-parser))
# (print (pp-ast parsed)) # (print (pp-ast parsed))
(pp scanned)
(pp parsed) (pp parsed)
) )

View File

@ -14,6 +14,7 @@
"nil" :nil ## impl -> literal word "nil" :nil ## impl -> literal word
"ns" :ns ## impl "ns" :ns ## impl
"panic!" :panic ## impl (should _not_ be a function) "panic!" :panic ## impl (should _not_ be a function)
"pkg" :pkg
"recur" :recur ## impl "recur" :recur ## impl
"ref" :ref ## impl "ref" :ref ## impl
"then" :then ## impl "then" :then ## impl
@ -295,8 +296,9 @@
"&" (add-comment char scanner) "&" (add-comment char scanner)
## keywords ## keywords
# XXX: make sure we want only lower-only keywords
":" (cond ":" (cond
(alpha? next) (add-keyword scanner) (lower? next) (add-keyword scanner)
:else (add-error scanner (string "Expected keyword. Got " char next))) :else (add-error scanner (string "Expected keyword. Got " char next)))
## splats ## splats

View File

@ -7,12 +7,12 @@ Tracking here, before I start writing this code, the kinds of validation we're h
* [x] splats come at the end of list, tuple, and dict patterns * [x] splats come at the end of list, tuple, and dict patterns
* [x] no unbound names * [x] no unbound names
* [x] no re-bound names * [x] no re-bound names
* [ ] no unbound names with `use` forms * [x] no unbound names with `use` forms
* [ ] first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo * [ ] first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo
* [ ] recur in tail position in `loop` forms * [x] recur in tail position in `loop` forms
* [ ] recur not called outside of `loop` forms * [x] recur not called outside of `loop` forms
* [ ] `loop` form arity checking * [x] `loop` form arity checking
* [ ] arity checking of explicit named function calls * [x] arity checking of explicit named function calls
* [ ] flag tail calls * [ ] flag tail calls
Imports are for a later iteration of Ludus: Imports are for a later iteration of Ludus:
@ -35,9 +35,9 @@ Imports are for a later iteration of Ludus:
(var validate nil) (var validate nil)
(def terminals [:number :keyword :string :bool :nil]) (def terminals [:number :keyword :string :bool :nil :placeholder])
(def simple-colls [:list :tuple :set]) (def simple-colls [:list :tuple :set :args])
(defn- simple-coll [validator] (defn- simple-coll [validator]
(def ast (validator :ast)) (def ast (validator :ast))
@ -70,12 +70,17 @@ Imports are for a later iteration of Ludus:
(def data (ast :data)) (def data (ast :data))
(def status (validator :status)) (def status (validator :status))
(set (status :toplevel) nil) (set (status :toplevel) nil)
(def tail? (status :tail))
(set (status :tail) false)
(def parent (validator :ctx)) (def parent (validator :ctx))
(def ctx @{:^parent parent}) (def ctx @{:^parent parent})
(set (validator :ctx) ctx) (set (validator :ctx) ctx)
(each node data (for i 0 (-> data length dec)
(set (validator :ast) node) (set (validator :ast) (data i))
(validate validator)) (validate validator))
(set (status :tail) tail?)
(set (validator :ast) (last data))
(validate validator)
(set (validator :ctx) parent) (set (validator :ctx) parent)
validator) validator)
@ -100,15 +105,12 @@ Imports are for a later iteration of Ludus:
(defn- lett [validator] (defn- lett [validator]
(def ast (validator :ast)) (def ast (validator :ast))
(def data (ast :data)) (def [lhs rhs] (ast :data))
(def status (validator :status))
(def pattern (first data))
(def expr (get data 1))
# evaluate the expression first # evaluate the expression first
# otherwise lhs names will appear bound # otherwise lhs names will appear bound
(set (validator :ast) expr) (set (validator :ast) rhs)
(validate validator) (validate validator)
(set (validator :ast) pattern) (set (validator :ast) lhs)
(pattern validator) (pattern validator)
validator) validator)
@ -151,13 +153,14 @@ Imports are for a later iteration of Ludus:
{:node ast :msg (string "name is already bound on line " {:node ast :msg (string "name is already bound on line "
line " of " input)})) line " of " input)}))
(set (ctx name) ast) (set (ctx name) ast)
(pp ctx)
validator) validator)
(def types [ (def types [
:nil :nil
:bool
:number :number
:keyword :keyword
:bool
:string :string
:set :set
:tuple :tuple
@ -166,11 +169,20 @@ Imports are for a later iteration of Ludus:
:fn :fn
:ref :ref
:pkg :pkg
:ns
:
]) ])
(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 word))
(defn- pattern* [validator] (defn- pattern* [validator]
(print "PATTERN*")
(def ast (validator :ast)) (def ast (validator :ast))
(def type (ast :type)) (def type (ast :type))
(print "validating pattern " type) (print "validating pattern " type)
@ -183,7 +195,15 @@ Imports are for a later iteration of Ludus:
:word (word-pattern validator) :word (word-pattern validator)
:list (simple-coll-pattern validator) :list (simple-coll-pattern validator)
:tuple (simple-coll-pattern validator) :tuple (simple-coll-pattern validator)
:splat (splattern validator)))) :splat (splattern validator)
:typed (typed 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] (defn- match-clauses [validator clauses]
(each clause clauses (each clause clauses
@ -210,6 +230,10 @@ Imports are for a later iteration of Ludus:
(defn- fnn [validator] (defn- fnn [validator]
(def ast (validator :ast)) (def ast (validator :ast))
(def name (ast :name)) (def name (ast :name))
(print "function name: " name)
(def status (validator :status))
(def tail? (status :tail))
(set (status :tail) true)
(when name (when name
(def ctx (validator :ctx)) (def ctx (validator :ctx))
(def resolved (resolve-name ctx name)) (def resolved (resolve-name ctx name))
@ -219,6 +243,23 @@ Imports are for a later iteration of Ludus:
{:node ast :msg (string "name is already bound on line " line " of " input)})) {:node ast :msg (string "name is already bound on line " line " of " input)}))
(set (ctx name) ast)) (set (ctx name) ast))
(match-clauses validator (ast :data)) (match-clauses validator (ast :data))
(set (status :tail) tail?)
(def clauses (ast :data))
(def rest-arities @{})
(def arities @{:rest rest-arities})
(each clause clauses
(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) validator)
(defn- ref [validator] (defn- ref [validator]
@ -245,40 +286,260 @@ Imports are for a later iteration of Ludus:
(validate validator)))) (validate validator))))
### TODO: ### TODO:
# * [ ] arity checking if first term is name that resolves to a function and args aren't partial
# * [ ] ensure properties are on pkgs (if *only* pkgs from root) # * [ ] ensure properties are on pkgs (if *only* pkgs from root)
(defn- pkg-root [validator])
# * [ ] flag tail calls (where last term is not-partial args) # * [ ] flag tail calls (where last term is not-partial args)
(defn- tail-call [validator])
# * [ ] arity checking if first term is name that resolves to a function and args aren't partial
# XXX: now just check number of args against arity map
(defn- check-arity [validator]
(def ast (validator :ast))
(when (ast :partial) (break validator))
(def ctx (validator :ctx))
(def data (ast :data))
(def fn-word (first data))
(def the-fn (resolve-name ctx (fn-word :data)))
(print "fn name: " (the-fn :name))
(def arities (the-fn :arities))
(print "arities: ")
(pp arities)
(def args (get data 1))
(def num-args (length (args :data)))
(print "called with #args " num-args)
(when (has-key? arities num-args) (break validator))
(def rest-arities (keys (arities :rest)))
(when (empty? rest-arities)
(array/push (validator :errors)
{:node ast :msg "mismatched arity"})
(break validator))
(def rest-min (min ;rest-arities))
(when (< num-args rest-min)
(array/push (validator :errors)
{:node ast :msg "mismatched arity"}))
validator)
(defn- synthetic [validator] (defn- synthetic [validator]
(def ast (validator :ast)) (def ast (validator :ast))
(def data (ast :data)) (def data (ast :data))
(each node data (each node data
(set (validator :ast) node) (set (validator :ast) node)
(validate validator))) (validate validator))
(set (validator :ast) ast)
(def ftype ((first data) :type))
(def stype ((get data 1) :type))
(def ltype ((last data) :type))
(print "ftype " ftype)
(print "stype " stype)
(print "ltype " ltype)
(when (= ftype :pkg-name) (pkg-root validator))
(when (= ltype :args) (tail-call validator))
(when (and (= ftype :word) (= stype :args))
(check-arity validator))
validator)
### XXX: todos from parser ### XXX: todos from parser
(defn- dict [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- whenn [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)
(defn- withh [validator]) (defn- withh [validator])
(defn- doo [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]) (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 [validator]) (defn- pkg-entry [validator pkg]
(def ast (validator :ast))
(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 kw (key :data))
(pp kw)
(set (pkg kw) value)
(pp pkg)
validator)
(defn- ns [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- loop [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- recur [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- repeat [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- panic [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- testt [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- validate* [validator] (defn- validate* [validator]
(def ast (validator :ast)) (def ast (validator :ast))
@ -297,19 +558,37 @@ Imports are for a later iteration of Ludus:
:match (matchh validator) :match (matchh validator)
:interpolated (interpolated validator) :interpolated (interpolated validator)
:synthetic (synthetic 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)
:ns (ns validator)
:pkg (pkg validator)
:pkg-name (pkg-name validator)
:use (usee validator)
:loop (loopp validator)
:recur (recur validator)
(error (string "unknown node type " type))))) (error (string "unknown node type " type)))))
(set validate validate*) (set validate validate*)
(set pattern pattern*)
(do (do
#(comment #(comment
(def source ` (def source `
"foo {bar} baz" fn foo {
() -> :bar
(x) -> :foo
(x, y, ...z) -> :baz
}
foo (4)
`) `)
(def scanned (s/scan source)) (def scanned (s/scan source))
(def parsed (p/parse scanned)) (def parsed (p/parse scanned))
(def validator (new-validator parsed)) (def validator (new-validator parsed))
(pp validator) (pp validator)
(validate validator) ((validate validator) :errors)
) )