ludus/janet/validate.janet

### A validator for a Ludus AST

(comment

Tracking here, before I start writing this code, the kinds of validation we're hoping to accomplish:

* [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)
)