Compare commits

..

6 Commits

Author SHA1 Message Date
Scott Richmond
1120f21df2 dict pattern matching 2024-05-19 20:19:00 -04:00
Scott Richmond
d249ee0b21 validate dict patterns, by validating pairs 2024-05-19 20:18:39 -04:00
Scott Richmond
e767c319b1 fix dict parsing 2024-05-19 20:18:22 -04:00
Scott Richmond
010b584ef1 partial function application! 2024-05-19 19:35:41 -04:00
Scott Richmond
ba1aa8ed03 comment out repl cruft 2024-05-19 19:35:30 -04:00
Scott Richmond
e5917c6284 partially applied functions don't kill validation 2024-05-19 19:15:22 -04:00
3 changed files with 92 additions and 31 deletions

View File

@ -11,8 +11,8 @@
(defn- todo [msg] (error (string "not yet implemented: " msg)))
(defn- resolve-name [name ctx]
(print "resolving " name " in:")
(pp ctx)
# (print "resolving " name " in:")
# (pp ctx)
(when (not ctx) (break :^not-found))
(if (has-key? ctx name)
(ctx name)
@ -20,7 +20,7 @@
(defn- match-word [word value ctx]
(def name (word :data))
(print "matched " (b/show value) " to " name)
# (print "matched " (b/show value) " to " name)
(set (ctx name) value)
{:success true :ctx ctx})
@ -126,7 +126,49 @@
(set (ctx (bindings i)) (matches i)))
{:success true :ctx ctx})
(defn- match-dict [pattern value ctx] (todo "dict pattern"))
(defn- match-dict [pattern value ctx]
(when (not (table? value))
(break {:success false :miss [pattern value]}))
(def val-size (length value))
(var members (pattern :data))
(def patt-len (length members))
(when (empty? members)
(break (if (empty? value)
{:success true :ctx ctx}
{:success false :miss [pattern value]})))
(var splat nil)
(def splat? (= :splat ((last members) :type)))
(when splat?
(when (< val-size patt-len)
(print "mismatched splatted dict lengths")
(break {:success false :miss [pattern value]}))
(print "splat!")
(set splat (last members))
(set members (slice members 0 (dec patt-len))))
(when (and (not splat?) (not= val-size patt-len))
(print "mismatched dict lengths")
(break {:success false :miss [pattern value]}))
(var success true)
(def matched-keys @[])
(for i 0 (length members)
(def curr-pair (get members i))
(def [curr-key curr-patt] (curr-pair :data))
(def key (interpret curr-key ctx))
(def curr-val (value key))
(def match? (match-pattern curr-patt curr-val ctx))
(array/push matched-keys key)
(when (not (match? :success))
(set success false)
(break)))
(when (and splat? (splat :data) success)
(def rest (merge value))
(each key matched-keys
(set (rest key) nil))
(match-word (splat :data) rest ctx))
(if success
{:success true :ctx ctx}
{:success false :miss [pattern value]}))
(defn- match-pattern* [pattern value &opt ctx]
(print "in match-pattern, matching " value " with:")
@ -321,14 +363,30 @@
(set (ctx name) the-fn))
# TODO
(defn- partial [the-fn args] (todo "partially applied functions"))
(defn- is_placeholder [x] (= x :_))
(defn- call-fn [the-fn args]
(var call-fn nil)
(defn- partial [the-fn partial-args]
(print "calling partially applied function")
(def args (partial-args :args))
(def pos (find-index is_placeholder args))
(def name (string (the-fn :name) "<partial>"))
(fn [missing]
(print "calling function with arg " (b/show missing))
(pp partial-args)
(def full-args (array/slice args))
(set (full-args pos) missing)
(print "all args: " (b/show full-args))
(call-fn the-fn [;full-args])))
(defn- call-fn* [the-fn args]
(print "calling " (b/show the-fn))
(print "with args " (b/show args))
(when (or
(= :function (type the-fn))
(= :cfunction (type the-fn)))
(print "Janet function")
(break (the-fn ;args)))
(def clauses (the-fn :body))
(def len (length clauses))
@ -353,11 +411,11 @@
(set (the-fn :match) match-fn)
(match-fn 0 args))
(set call-fn call-fn*)
(defn- apply-synth-term [prev curr]
(print "applying")
(pp curr)
(print "to")
(pp prev)
(print "applying " (b/show prev))
(print "to" (b/show curr))
(def types [(b/ludus/type prev) (b/ludus/type curr)])
(print "typle:")
(pp types)
@ -406,8 +464,6 @@
(defn- recur [ast ctx] (todo "recur"))
(defn- repeatt [ast ctx] (todo "repeat"))
(defn- testt [ast ctx] (todo "test"))
(defn- interpret* [ast ctx]
@ -483,7 +539,7 @@
(def parsed (p/parse scanned))
(when (has-errors? parsed) (break (parsed :errors)))
(def validated (v/valid parsed b/ctx))
(when (has-errors? validated) (break (validated :errors)))
# (when (has-errors? validated) (break (validated :errors)))
# (def cleaned (get-in parsed [:ast :data 1]))
# (pp cleaned)
(interpret (parsed :ast) @{:^parent b/ctx})
@ -494,9 +550,9 @@
(do
(set source `
let #{:a ay, :b (:ok, bee), ...c} = #{:a 1, :b (:ok, 42), :c 3}
`)
(def result (run))
(b/show result)
# (b/show result)
)

View File

@ -411,7 +411,7 @@
:token origin})
{:type :pair :data [key value] :token origin})
:keyword (do
(def key (capture kw parser))
(def key (capture kw-only parser))
(def value (capture nonbinding parser))
{:type :pair :data [key value] :token origin})
(try (panic parser (string "expected dict term, got " (type origin))) ([e] e))
@ -507,7 +507,7 @@
(def key {:type :keyword :data (keyword name) :token origin})
{:type :pair :data [key word] :token origin})
:keyword (do
(def key (capture kw parser))
(def key (capture kw-only parser))
(def value (capture pattern parser))
{:type :pair :data [key value] :token origin})
(try (panic parser (string "expected dict term, got " (type origin))) ([e] e))
@ -1104,8 +1104,8 @@
)
(do
# (comment
# (do
(comment
(def source `a :b :c
`)
(def scanned (s/scan source))

View File

@ -144,9 +144,6 @@ Deferred until a later iteration of Ludus:
(set (status :last) nil)
validator)
### XXX: to do
(defn- dict-pattern [validator])
(defn- word-pattern [validator]
(def ast (validator :ast))
(def name (ast :data))
@ -210,6 +207,12 @@ Deferred until a later iteration of Ludus:
(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))
@ -224,9 +227,11 @@ Deferred until a later iteration of Ludus:
: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*)
@ -338,14 +343,15 @@ Deferred until a later iteration of Ludus:
(defn- check-arity [validator]
(def ast (validator :ast))
(when (ast :partial) (break validator))
# (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 (= :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: ")
@ -353,6 +359,7 @@ Deferred until a later iteration of Ludus:
(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)
@ -629,17 +636,15 @@ Deferred until a later iteration of Ludus:
(set (validator :ctx) base-ctx)
(validate validator))
(defn foo [] :foo)
(def base {
"foo" foo
})
(import ./base :as b)
(do
# (comment
(def source `
foo ()
let #{a, b} = #{:a 1}
b
`)
(def scanned (s/scan source))
(def parsed (p/parse scanned))
(valid parsed base)
(valid parsed b/ctx)
)