a whole lot of a validator

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
+* [x] splats come at the end of list, tuple, and dict patterns
-* no unbound names
+* [x] no unbound names
-* no re-bound names
+* [x] no re-bound names
-* correct imports
+* [ ] no unbound names with `use` forms
-* no unbound names with `use` forms
+* [ ] first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo
-* no circular imports
+* [ ] recur in tail position in `loop` forms
-* first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo
+* [ ] recur not called outside of `loop` forms
-* recur in tail position in `loop` forms
+* [ ] `loop` form arity checking
-* recur not called outside of `loop` forms
+* [ ] arity checking of explicit named function calls
-* arity checking where possible
+* [ ] flag tail calls
- - loop forms
+* [ ] no circular imports DEFERRED
- - try to resolve function name, if you can, check arity of call
+* [ ] 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)
+)