From 5fbafbac94a98453bf0a9ee96379fec98e05caea Mon Sep 17 00:00:00 2001
From: Scott Richmond <kredati@users.noreply.github.com>
Date: Tue, 14 May 2024 18:41:21 -0400
Subject: [PATCH] make progress: many things

---
 janet/validate.janet | 349 ++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 314 insertions(+), 35 deletions(-)

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