make progress: many things
This commit is contained in:
parent
ec43aa3c67
commit
5fbafbac94
|
@ -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)
|
||||||
)
|
)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user