dict pattern matching

janet/interpreter.janet

@@ -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,9 +464,7 @@
 
 (defn- recur [ast ctx] (todo "recur"))
 
-(defn- repeatt [ast ctx] (todo "repeat"))
-
-(defn - testt [ast ctx] (todo "test"))
+(defn- testt [ast ctx] (todo "test"))
 
 (defn- interpret* [ast ctx]
   (print "interpreting node " (ast :type))
@@ -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)
 )
 

janet/parser.janet

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

janet/validate.janet

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