From 1dce69e23922b5c3edc01ef0798162631bc46888 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Thu, 23 May 2024 19:33:19 -0400 Subject: [PATCH] work on pkgs --- janet/parser.janet | 23 +++++++-- janet/validate.janet | 110 +++++++++++++++++++++++++++++++++++-------- 2 files changed, 110 insertions(+), 23 deletions(-) diff --git a/janet/parser.janet b/janet/parser.janet index 40bf443..3950f25 100644 --- a/janet/parser.janet +++ b/janet/parser.janet @@ -843,6 +843,13 @@ (advance parser) {:type :pkg-name :data (origin :lexeme) :token origin}) + +(defn- pkg-name-only [parser] + (expect parser :pkg-name) + (def origin (current parser)) + (advance parser) + {:type :pkg-name :data (origin :lexeme) :token origin}) + (defn- usee [parser] (def origin (current parser)) (expect parser :use) (advance parser) @@ -866,12 +873,19 @@ (array/push (parser :errors) err) (error err)) (case (-> parser current type) + :pkg-name (do + (def origin (current parser)) + (def value (pkg-name-only parser)) + (def key (keyword (value :data))) + (def pkg-kw-ast {:type :pkg-kw :data key :token origin}) + (array/push data {:type :pkg-pair :data [pkg-kw-ast value] :token origin})) :keyword (do (def origin (current parser)) (def key (capture kw parser)) (def value (capture simple parser)) (array/push data {:type :pair :data [key value] :token origin})) :word (do + (def origin (current parser)) (def value (word-only parser)) (def key (keyword (value :data))) (def kw-ast {:type :keyword :data key :token origin}) @@ -1113,19 +1127,20 @@ ) -(do -# (comment +# (do +(comment (def source ` -pkg Foo {foo, bar, :baz 42} +pkg Baz {Foo, Bar} `) (def scanned (s/scan source)) (print "\n***NEW PARSE***\n") (def a-parser (new-parser scanned)) -(def parsed (toplevel a-parser)) +(def parsed (script a-parser)) # (print (pp-ast parsed)) # (pp scanned) (pp parsed) +(pp (a-parser :errors)) # (def cleaned (get-in parsed [:data 2])) # (pp cleaned) ) diff --git a/janet/validate.janet b/janet/validate.janet index 388949a..701af02 100644 --- a/janet/validate.janet +++ b/janet/validate.janet @@ -4,7 +4,7 @@ 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 +* [x] 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 @@ -25,6 +25,8 @@ Deferred until a later iteration of Ludus: * [ ] validate `with` forms ) +(def- package-registry @{}) + (try (os/cd "janet") ([_] nil)) (import ./scanner :as s) (import ./parser :as p) @@ -39,7 +41,7 @@ Deferred until a later iteration of Ludus: (var validate nil) -(def terminals [:number :keyword :string :bool :nil :placeholder]) +(def terminals [:number :string :bool :nil :placeholder]) (def simple-colls [:list :tuple :set :args]) @@ -330,16 +332,42 @@ Deferred until a later iteration of Ludus: ### TODO: # * [ ] ensure properties are on pkgs (if *only* pkgs from root) -(defn- pkg-root [validator]) -(defn- tail-call [validator] +(defn- pkg-root [validator] + (print "validating pkg-root access") (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)) + (def ctx (validator :ctx)) + (def terms (ast :data)) + (def pkg-name ((first terms) :data)) + (def the-pkg (resolve-name ctx pkg-name)) + (when (not the-pkg) + (array/push (validator :errors) + {:node ast :msg "unbound pkg name"}) + (break validator)) + (def member (get terms 1)) + (def accessed (case (member :type) + :keyword (get-in the-pkg [:pkg (member :data)]) + :pkg-kw (get-in the-pkg [:pkg (member :data)]) + :args (do + (array/push (validator :errors) + {:node member :msg "cannot call a pkg"} + (break validator))))) + (when (not accessed) + (print "no member " (member :data) " on " pkg-name) + (array/push (validator :errors) + {:node member :msg "invalid pkg access"}) + (break validator)) + # TODO: validate nested pkg access + ) + +# (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)) @@ -386,13 +414,17 @@ Deferred until a later iteration of Ludus: (defn- synthetic [validator] (def ast (validator :ast)) (def data (ast :data)) + (def status (validator :status)) + (def ftype ((first data) :type)) + (def stype ((get data 1) :type)) + (def ltype ((last data) :type)) + (set (status :pkg-access?) nil) + (when (= ftype :pkg-name) + (set (status :pkg-access?) true)) (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) @@ -468,6 +500,10 @@ Deferred until a later iteration of Ludus: (defn- pkg-entry [validator pkg] (def ast (validator :ast)) + (def status (validator :status)) + (when (= :pkg-pair (ast :type)) + (set (status :pkg-access?) true)) + (def data (ast :data)) (def [key value] (ast :data)) (print "PKG ENTRY***") (pp key) @@ -476,9 +512,13 @@ Deferred until a later iteration of Ludus: (validate validator) (set (validator :ast) value) (validate validator) + (def entry (if (= :pkg-name (value :type)) + (resolve-name (value :name) (validator :ctx)) + value)) + (set (status :pkg-access?) nil) (def kw (key :data)) (pp kw) - (set (pkg kw) value) + (set (pkg kw) entry) (pp pkg) validator) @@ -605,14 +645,41 @@ Deferred until a later iteration of Ludus: {:node ast :msg "unbound name"})) validator) +(defn- pkg-kw [validator] + (print "validating pkg-kw") + (def ast (validator :ast)) + (def pkg-access? (get-in validator [:status :pkg-access?])) + (print "pkg-access? " pkg-access?) + (when (not pkg-access?) + (array/push (validator :errors) + {:node ast :msg "cannot use pkg-kw here"})) + validator) + +(defn- pkg-pair [validator] + (print "validating pkg-pair") + (def ast (validator :ast)) + (def status (validator :status)) + (def [_ pkg] (ast :data)) + (set (status :pkg-access?) true) + (set (validator :ast) pkg) + (validate validator) + (set (status :pkg-access?) nil) + validator) + +(defn- kw [validator] + (def status (validator :status)) + (set (status :pkg-access?) nil) + validator) + (defn- validate* [validator] (def ast (validator :ast)) (def type (ast :type)) (print "validating node " type) (cond - (has-value? terminals type) true + (has-value? terminals type) validator (has-value? simple-colls type) (simple-coll validator) (case type + :keyword (kw validator) :if (iff validator) :let (lett validator) :script (script validator) @@ -630,9 +697,11 @@ Deferred until a later iteration of Ludus: :when (whenn validator) :splat (splat validator) :pair (pair validator) + :pkg-pair (pkg-pair validator) :ns (ns validator) :pkg (pkg validator) :pkg-name (pkg-name validator) + :pkg-kw (pkg-kw validator) :use (usee validator) :loop (loopp validator) :recur (recur validator) @@ -650,12 +719,15 @@ Deferred until a later iteration of Ludus: (import ./base :as b) -# (do -(comment +(do +# (comment (def source ` -:foo (1, 2) +let foo = 1 +pkg Foo {foo} +pkg Baz {Foo} +Foo :Baz `) (def scanned (s/scan source)) (def parsed (p/parse scanned)) -(valid parsed b/ctx) +(def validated (valid parsed b/ctx)) )