diff --git a/janet/validate.janet b/janet/validate.janet index 1113699..5395d91 100644 --- a/janet/validate.janet +++ b/janet/validate.janet @@ -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) +)