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:

* [ ] ensure called keywords are only called w/ one arg
* [ ] first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo
 - [ ] accept pkg-kws
* [x] validate dict patterns
* [x] compile string-patterns
* [x] `loop` form arity checking
* [x] arity checking of explicit named function calls
* [x] flag tail calls
* [x] no re-bound names
* [x] no unbound names
* [x] no unbound names with `use` forms
* [x] recur in tail position in `loop` forms
* [x] recur not called outside of `loop` forms
* [x] splats come at the end of list, tuple, and dict patterns

Deferred until a later iteration of Ludus:
* [ ] no circular imports DEFERRED
* [ ] correct imports DEFERRED
* [ ] validate `with` forms
)

(try (os/cd "janet") ([_] nil))
(import ./scanner :as s)
(import ./parser :as p)

(defn- new-validator [parser]
 (def ast (parser :ast))
 @{:ast ast
 :errors @[]
 :ctx @{}
 :status @{}}
)

(var validate nil)

(def terminals [:number :keyword :string :bool :nil :placeholder])

(def simple-colls [:list :tuple :set :args])

(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 tail? (status :tail))
 (set (status :tail) false)
 (def parent (validator :ctx))
 (def ctx @{:^parent parent})
 (set (validator :ctx) ctx)
 (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)

(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 [lhs rhs] (ast :data))
 # evaluate the expression first
 # otherwise lhs names will appear bound
 (set (validator :ast) rhs)
 (validate validator)
 (set (validator :ast) lhs)
 (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)

(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)
 (pp ctx)
 validator)

(def types [
 :nil
 :bool
 :number
 :keyword
 :string
 :set
 :tuple
 :dict
 :list
 :fn
 :ref
 :pkg
])

(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 validator))

(defn- str-pattern [validator]
 (def ast (validator :ast))
 (def data (ast :data))
 (def last-term (-> data array/pop string))
 (def grammar @{})
 (def bindings @[])
 (var current 0)
 (each node data
  (when (not (buffer? node))
   (set (validator :ast) node)
   (pattern validator))
  (if (buffer? node)
   (set (grammar (keyword current)) (string node)) 
   (do
    (set (grammar (keyword current))
     ~(<- (to ,(keyword (inc current)))))
    (array/push bindings (node :data))))
  (set current (inc current)))
 (set (grammar (keyword current)) ~(* ,last-term -1))
 (def rules (map keyword (range (length grammar))))
 (set (grammar :main) ~(* ,;rules))
 (set (ast :grammar) grammar)
 (set (ast :compiled) (peg/compile grammar))
 (set (ast :bindings) bindings))

(defn- pair [validator]
 (def ast (validator :ast))
 (def [_ patt] (ast :data))
 (set (validator :ast) patt)
 (pattern validator))

(defn- pattern* [validator]
 (print "PATTERN*")
 (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)
   :dict (simple-coll-pattern validator)
   :splat (splattern validator)
   :typed (typed validator)
   :interpolated (str-pattern validator)
   :pair (pair 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]
 (print "validating clauses in match-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]
 (print "validating in matchh")
 (def ast (validator :ast))
 (def [to-match clauses] (ast :data))
 (print "validating expression:")
 (pp to-match)
 (set (validator :ast) to-match)
 (validate validator)
 (print "validating clauses")
 (match-clauses validator clauses)
 validator)

(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))
  (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))
 (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]
 (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:
# * [ ] ensure properties are on pkgs (if *only* pkgs from root)
(defn- pkg-root [validator])

(defn- tail-call [validator]
 (def ast (validator :ast))
 (when (ast :partial) (break validator))
 (def status (validator :status))
 (when (not (status :tail)) (break validator))
 (def data (ast :data))
 (def args (last data))
 (set (args :tail-call) true))

(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)))
 (when (not the-fn) (break validator))
 (when (= :function (type the-fn)) (break validator))
 (when (= :cfunction (type the-fn) (break validator)))
 (when (not= :fn (the-fn :type)) (break validator))
 (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)
 (pp (get (validator :ctx) "bar"))
 (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- kw-root [validator]
 (def ast (validator :ast))
 (def data (ast :data))
 (def [_ args] data)
 (when (not= :args (args :type))
  (break (array/push (validator :errors)
   {:node args :msg "called keyword expects an argument"})))
 (when (not= 1 (length (args :data)))
  (array/push (validator :errors)
   {:node args :msg "called keywords take one argument"})))

(defn- synthetic [validator]
 (def ast (validator :ast))
 (def data (ast :data))
 (each node data
  (set (validator :ast) node)
  (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 (= ftype :keyword) (kw-root validator))
 # (when (= ltype :args) (tail-call validator))
 (when (and (= ftype :word) (= stype :args))
  (check-arity validator))
 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- 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)

# XXX: do this!
(defn- withh [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]
 (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-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- 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- 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- 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- 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- repeatt [validator]
 (def ast (validator :ast))
 (def [times body] (ast :data))
 (set (validator :ast) times)
 (validate validator)
 (set (validator :ast) body)
 (validate 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))
 (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)
   :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)
   :ref (ref validator)
   (error (string "unknown node type " type)))))

(set validate validate*)

(defn valid [ast &opt ctx]
 (default ctx @{})
 (def validator (new-validator ast))
 (def base-ctx @{:^parent ctx})
 (set (validator :ctx) base-ctx)
 (validate validator))

(import ./base :as b)

# (do
(comment
(def source `
:foo (1, 2)
`)
(def scanned (s/scan source))
(def parsed (p/parse scanned))
(valid parsed b/ctx)
)