From 5deab18356a228b2d0a46ccee25dff7bf0b9bf6e Mon Sep 17 00:00:00 2001
From: Scott Richmond <kredati@users.noreply.github.com>
Date: Sat, 18 May 2024 17:43:21 -0400
Subject: [PATCH] string patterns should now be working

---
 janet/interpreter.janet | 39 ++++++++++++++++++++++++++++++++-------
 janet/validate.janet    |  6 +++---
 2 files changed, 35 insertions(+), 10 deletions(-)

diff --git a/janet/interpreter.janet b/janet/interpreter.janet
index 7def00f..1e88f63 100644
--- a/janet/interpreter.janet
+++ b/janet/interpreter.janet
@@ -47,7 +47,7 @@
   (def splat? (= :splat ((last members) :type)))
   (when splat?
     (when (< val-len patt-len)
-      (print "mismatched splatted tuple lenghts")
+      (print "mismatched splatted tuple lengths")
       (break {:success false :miss [pattern value]}))
     (print "splat!")
     (set splat (last members))
@@ -75,7 +75,6 @@
     {:success true :ctx ctx}
     {:success false :miss [pattern value]}))
 
-
 (defn- match-list [pattern value ctx]
   (when (not (array? value))
     (break {:success false :miss [pattern value]}))
@@ -86,13 +85,13 @@
   (def splat? (= :splat ((last members) :type)))
   (when splat?
     (when (< val-len patt-len)
-      (print "mismatched splatted tuple lenghts")
+      (print "mismatched splatted list 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-len patt-len))
-    (print "mismatched tuple lengths")
+    (print "mismatched list lengths")
     (break {:success false :miss [pattern value]}))
   (var curr-mem :^nothing)
   (var curr-val :^nothing)
@@ -100,7 +99,7 @@
   (for i 0 (length members)
     (set curr-mem (get members i))
     (set curr-val (get value i))
-    (print "in tuple, matching " curr-val " with ")
+    (print "in list, matching " curr-val " with ")
     (pp curr-mem)
     (def match? (match-pattern curr-mem curr-val ctx))
     (pp match?)
@@ -114,6 +113,21 @@
     {:success true :ctx ctx}
     {:success false :miss [pattern value]}))
 
+(defn- match-string [pattern value ctx]
+  (when (not (string? value))
+    (break {:success false :miss [pattern value]}))
+  (def {:compiled compiled :bindings bindings} pattern)
+  (print "matching " value " with")
+  (pp (pattern :grammar))
+  (def matches (peg/match compiled value))
+  (when (not matches) 
+    (break {:success false :miss [pattern value]}))
+  (when (not= (length matches) (length bindings))
+    (error "oops: different number of matches and bindings"))
+  (for i 0 (length matches)
+    (set (ctx (bindings i)) (matches i)))
+  {:success true :ctx ctx})
+
 (defn- match-pattern* [pattern value &opt ctx]
   (print "in match-pattern, matching " value " with:")
   (pp pattern)
@@ -136,6 +150,7 @@
     :tuple (match-tuple pattern value ctx)
     :list (match-list pattern value ctx)
     # TODO: string-patterns
+    :interpolated (match-string pattern value ctx)
 
     :typed (typed pattern value ctx)
   ))
@@ -386,10 +401,20 @@
 
 (do 
 (set source `
-match "foo" with {
-  "f{ooo}o" -> ooo
+match "foooooo" with {
+  "f{foo}{bar}{baz}" -> (foo, bar, baz)
   _ -> :nope
 }
 `)
 (run)
 )
+
+(def g @{:0 "f" :1 '(<- (to :2)) :2 "o" :3 -1
+  :main '(* :0 :1 :2 :3)})
+
+(def f '{:0 "b" :1 (<- (to :2)) :2 (* "" -1)
+  :main (* :0 :1 :2)})
+
+(def h ~(* (<- (to "a")) "a" -1))
+
+(peg/match f "barrr")
diff --git a/janet/validate.janet b/janet/validate.janet
index 2eb225e..8ea9849 100644
--- a/janet/validate.janet
+++ b/janet/validate.janet
@@ -187,7 +187,7 @@ Imports are for a later iteration of Ludus:
 (defn- str-pattern [validator]
  (def ast (validator :ast))
  (def data (ast :data))
- (array/pop data)
+ (def last-term (-> data array/pop string))
  (def grammar @{})
  (def bindings @[])
  (var current 0)
@@ -202,9 +202,9 @@ Imports are for a later iteration of Ludus:
      ~(<- (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 (keyword current)) -1)
- (set (grammar :main) ~(sequence ,;rules))
+ (set (grammar :main) ~(* ,;rules))
  (set (ast :grammar) grammar)
  (set (ast :compiled) (peg/compile grammar))
  (set (ast :bindings) bindings))