diff --git a/janet/validate.janet b/janet/validate.janet index 5f803f9..ca1e408 100644 --- a/janet/validate.janet +++ b/janet/validate.janet @@ -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] no unbound 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 -* [ ] 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 +* [x] recur in tail position in `loop` forms +* [x] recur not called outside of `loop` forms +* [x] `loop` form arity checking +* [x] arity checking of explicit named function calls * [ ] flag tail calls Imports are for a later iteration of Ludus: @@ -35,9 +35,9 @@ Imports are for a later iteration of Ludus: (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] (def ast (validator :ast)) @@ -70,12 +70,17 @@ Imports are for a later iteration of Ludus: (def data (ast :data)) (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) - (each node data - (set (validator :ast) node) + (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) @@ -100,15 +105,12 @@ Imports are for a later iteration of Ludus: (defn- lett [validator] (def ast (validator :ast)) - (def data (ast :data)) - (def status (validator :status)) - (def pattern (first data)) - (def expr (get data 1)) + (def [lhs rhs] (ast :data)) # evaluate the expression first # otherwise lhs names will appear bound - (set (validator :ast) expr) + (set (validator :ast) rhs) (validate validator) - (set (validator :ast) pattern) + (set (validator :ast) lhs) (pattern validator) validator) @@ -151,13 +153,14 @@ Imports are for a later iteration of Ludus: {:node ast :msg (string "name is already bound on line " line " of " input)})) (set (ctx name) ast) + (pp ctx) validator) (def types [ :nil + :bool :number :keyword - :bool :string :set :tuple @@ -166,11 +169,20 @@ Imports are for a later iteration of Ludus: :fn :ref :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] + (print "PATTERN*") (def ast (validator :ast)) (def type (ast :type)) (print "validating pattern " type) @@ -183,7 +195,15 @@ Imports are for a later iteration of Ludus: :word (word-pattern validator) :list (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] (each clause clauses @@ -210,6 +230,10 @@ Imports are for a later iteration of Ludus: (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 (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)})) (set (ctx name) ast)) (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) (defn- ref [validator] @@ -245,40 +286,260 @@ Imports are for a later iteration of Ludus: (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 (if *only* pkgs from root) +(defn- pkg-root [validator]) + # * [ ] 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] (def ast (validator :ast)) (def data (ast :data)) (each node data (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 -(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- 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] (def ast (validator :ast)) @@ -297,19 +558,37 @@ Imports are for a later iteration of Ludus: :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) + :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))))) (set validate validate*) -(set pattern pattern*) (do #(comment (def source ` -"foo {bar} baz" +fn foo { + () -> :bar + (x) -> :foo + (x, y, ...z) -> :baz +} +foo (4) `) (def scanned (s/scan source)) (def parsed (p/parse scanned)) (def validator (new-validator parsed)) (pp validator) -(validate validator) +((validate validator) :errors) )