match2: destructure persistent-map / persistent-vector / persistent-set

ober

fd33fe5b9447247fcbf08eacbbab8edb64c90761

diff --git a/lib/std/match2.sls b/lib/std/match2.sls
index ea28ac2..72e56a3 100644
--- a/lib/std/match2.sls
+++ b/lib/std/match2.sls
@@ -47,7 +47,10 @@
     match
     define-match-type)
 
-  (import (chezscheme))
+  (import (chezscheme)
+          (only (std pmap) persistent-map? persistent-map-has? persistent-map-ref)
+          (only (std pvec) persistent-vector? persistent-vector-length persistent-vector-ref)
+          (only (std pset) persistent-set? persistent-set-contains?))
 
   ;; ========== Global Registries ==========
 
@@ -293,6 +296,67 @@
                    #,(compile-pat sub #`(unbox #,val) success fail)
                    #,fail))]
 
+            ;; (persistent-map | pmap | imap k1 p1 k2 p2 ...) — pmap destructure.
+            ;; Alternating key/value-pattern pairs. Keys are evaluated as
+            ;; expressions at match time (usually 'quoted symbols or literals).
+            ;; Compiles to persistent-map? guard + N persistent-map-has? +
+            ;; persistent-map-ref lookups, short-circuiting on first missing
+            ;; key. Subpatterns see the referenced value and can themselves
+            ;; be further patterns.
+            [(and (pair? d) (symbol? (car d))
+                  (memq (car d) '(persistent-map pmap imap))
+                  (even? (length (cdr d))))
+             (let ([chain
+                    (let loop ([kps (cdr (syntax->list pat))] [inner success])
+                      (if (null? kps)
+                        inner
+                        (let ([k (car kps)]
+                              [p (cadr kps)]
+                              [rest (cddr kps)])
+                          (let ([slot (car (generate-temporaries '(pm-slot)))])
+                            #`(if (persistent-map-has? #,val #,k)
+                                  (let ([#,slot (persistent-map-ref #,val #,k)])
+                                    #,(compile-pat p slot
+                                        (loop rest inner)
+                                        fail))
+                                  #,fail)))))])
+               #`(if (persistent-map? #,val) #,chain #,fail))]
+
+            ;; (persistent-vector | pvec | ivec p1 p2 ...) — pvec destructure.
+            ;; Length must match exactly (no rest-pattern support yet).
+            ;; Compiles to length check + N persistent-vector-ref lookups.
+            [(and (pair? d) (symbol? (car d))
+                  (memq (car d) '(persistent-vector pvec ivec)))
+             (let* ([pats (cdr (syntax->list pat))]
+                    [n (length pats)])
+               (let compile-pv ([pats pats] [i 0] [inner success])
+                 (if (null? pats)
+                   #`(if (and (persistent-vector? #,val)
+                              (= (persistent-vector-length #,val) #,n))
+                         #,inner
+                         #,fail)
+                   (compile-pv
+                     (cdr pats) (+ i 1)
+                     (compile-pat (car pats)
+                       #`(persistent-vector-ref #,val #,i)
+                       inner fail)))))]
+
+            ;; (persistent-set | pset x1 x2 ...) — pset membership check.
+            ;; All listed elements must be members. Size can still be larger
+            ;; (superset allowed) — tighter shape checks are explicit via
+            ;; (and (? predicate) ...). Elements are evaluated, not bound.
+            [(and (pair? d) (symbol? (car d))
+                  (memq (car d) '(persistent-set pset)))
+             (let ([elems (cdr (syntax->list pat))])
+               (let ([chain
+                      (let loop ([es elems] [inner success])
+                        (if (null? es)
+                          inner
+                          #`(if (persistent-set-contains? #,val #,(car es))
+                                #,(loop (cdr es) inner)
+                                #,fail)))])
+                 #`(if (persistent-set? #,val) #,chain #,fail)))]
+
             ;; (name p1 ...) — struct type or active pattern (runtime dispatch)
             [(and (pair? d) (symbol? (car d)))
              (let* ([parts    (syntax->list pat)]
diff --git a/tests/test-match2-persistent.ss b/tests/test-match2-persistent.ss
new file mode 100644
index 0000000..0eab2a1
--- /dev/null
+++ b/tests/test-match2-persistent.ss
@@ -0,0 +1,228 @@
+#!chezscheme
+;;; Tests for match2 destructuring on persistent collections.
+;;; Phase 27 of Round 4.
+;;;
+;;; Pattern forms added:
+;;;   (pmap k1 p1 k2 p2 ...)   → pmap? guard + has?/ref per key
+;;;   (pvec p1 p2 ...)         → pvec? + exact length + ref per index
+;;;   (pset x1 x2 ...)         → pset? + contains? per element
+;;;
+;;; Aliases: persistent-map/pmap/imap, persistent-vector/pvec/ivec,
+;;;          persistent-set/pset.
+
+(import (chezscheme) (std match2) (std pmap) (std pvec) (std pset))
+
+(define pass 0)
+(define fail 0)
+
+(define-syntax test
+  (syntax-rules ()
+    [(_ name expr expected)
+     (guard (exn [#t (set! fail (+ fail 1))
+                     (printf "FAIL ~a: ~a~%" name
+                       (if (message-condition? exn) (condition-message exn) exn))])
+       (let ([got expr])
+         (if (equal? got expected)
+             (begin (set! pass (+ pass 1)) (printf "  ok ~a~%" name))
+             (begin (set! fail (+ fail 1))
+                    (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))]))
+
+(printf "--- Round 4 Phase 27: match2 persistent destructuring ---~%~%")
+
+;;; ========== pmap patterns ==========
+
+(test "pmap simple extract"
+  (let ([m (make-persistent-map 'a 1 'b 2)])
+    (match m
+      ((pmap 'a a 'b b) (list a b))
+      (_ 'no-match)))
+  '(1 2))
+
+(test "pmap missing key falls through"
+  (let ([m (make-persistent-map 'a 1)])
+    (match m
+      ((pmap 'missing x) x)
+      (_ 'miss)))
+  'miss)
+
+(test "pmap non-pmap value falls through"
+  ;; Critical: must NOT crash on non-pmap value.
+  (match '(1 2 3)
+    ((pmap 'a x) x)
+    (_ 'not-pm))
+  'not-pm)
+
+(test "pmap nil value falls through"
+  (match #f
+    ((pmap 'a x) x)
+    (_ 'not-pm))
+  'not-pm)
+
+(test "pmap alias persistent-map"
+  (let ([m (make-persistent-map 'x 42)])
+    (match m ((persistent-map 'x n) n) (_ #f)))
+  42)
+
+(test "pmap alias imap"
+  (let ([m (make-persistent-map 'y 99)])
+    (match m ((imap 'y n) n) (_ #f)))
+  99)
+
+(test "pmap nested pmap value"
+  (let ([m (make-persistent-map 'outer (make-persistent-map 'inner 'found))])
+    (match m
+      ((pmap 'outer (pmap 'inner v)) v)
+      (_ 'no)))
+  'found)
+
+(test "pmap with predicate subpattern"
+  (let ([m (make-persistent-map 'n 5)])
+    (match m
+      ((pmap 'n (and (? number?) n)) (+ n 1))
+      (_ 'no)))
+  6)
+
+(test "pmap with guard"
+  (let ([m (make-persistent-map 'age 30)])
+    (match m
+      ((pmap 'age a) (where (>= a 18)) 'adult)
+      (_ 'minor)))
+  'adult)
+
+(test "pmap guard fails → fall through"
+  (let ([m (make-persistent-map 'age 10)])
+    (match m
+      ((pmap 'age a) (where (>= a 18)) 'adult)
+      (_ 'minor)))
+  'minor)
+
+(test "pmap empty pattern (type-only check)"
+  (match (make-persistent-map) ((pmap) 'yes) (_ 'no))
+  'yes)
+
+(test "pmap empty pattern rejects non-pmap"
+  (match '() ((pmap) 'yes) (_ 'no))
+  'no)
+
+;;; ========== pvec patterns ==========
+
+(test "pvec simple extract"
+  (let ([v (persistent-vector 10 20 30)])
+    (match v
+      ((pvec a b c) (list a b c))
+      (_ 'no)))
+  '(10 20 30))
+
+(test "pvec length mismatch falls through"
+  (let ([v (persistent-vector 1 2 3)])
+    (match v
+      ((pvec a b) (list a b))
+      (_ 'wrong-length)))
+  'wrong-length)
+
+(test "pvec non-pvec value falls through"
+  (match '(1 2 3)
+    ((pvec a b c) (list a b c))
+    (_ 'not-pv))
+  'not-pv)
+
+(test "pvec empty"
+  (match (persistent-vector) ((pvec) 'empty) (_ 'no))
+  'empty)
+
+(test "pvec alias persistent-vector"
+  (let ([v (persistent-vector 'a 'b)])
+    (match v
+      ((persistent-vector x y) (list x y))
+      (_ 'no)))
+  '(a b))
+
+(test "pvec alias ivec"
+  (let ([v (persistent-vector 7 8)])
+    (match v ((ivec x y) (+ x y)) (_ #f)))
+  15)
+
+(test "pvec nested"
+  (let ([v (persistent-vector (persistent-vector 1 2) (persistent-vector 3 4))])
+    (match v
+      ((pvec (pvec a b) (pvec c d)) (list a b c d))
+      (_ 'no)))
+  '(1 2 3 4))
+
+;;; ========== pset patterns ==========
+
+(test "pset contains both"
+  (let ([s (make-persistent-set 'red 'blue 'green)])
+    (match s
+      ((pset 'red 'blue) 'both-in)
+      (_ 'no)))
+  'both-in)
+
+(test "pset missing falls through"
+  (let ([s (make-persistent-set 'red)])
+    (match s
+      ((pset 'yellow) 'has-yellow)
+      (_ 'no-yellow)))
+  'no-yellow)
+
+(test "pset non-pset value falls through"
+  (match '(red)
+    ((pset 'red) 'yes)
+    (_ 'not-ps))
+  'not-ps)
+
+(test "pset empty (type-only)"
+  (match (make-persistent-set) ((pset) 'ok) (_ 'no))
+  'ok)
+
+(test "pset empty rejects non-pset"
+  (match 42 ((pset) 'ok) (_ 'no))
+  'no)
+
+;;; ========== Mixed nesting ==========
+
+(test "pmap of pvec"
+  (let ([m (make-persistent-map 'xs (persistent-vector 1 2 3))])
+    (match m
+      ((pmap 'xs (pvec a b c)) (+ a b c))
+      (_ 'no)))
+  6)
+
+(test "pvec of pmap"
+  (let ([v (persistent-vector (make-persistent-map 'n 7))])
+    (match v
+      ((pvec (pmap 'n x)) x)
+      (_ 'no)))
+  7)
+
+(test "pmap of pset"
+  (let ([m (make-persistent-map 'tags (make-persistent-set 'a 'b))])
+    (match m
+      ((pmap 'tags (pset 'a)) 'has-a)
+      (_ 'no)))
+  'has-a)
+
+;;; ========== Regression — non-persistent patterns still work ==========
+
+(test "regression list pattern still works"
+  (match '(1 2 3)
+    ((list a b c) (+ a b c))
+    (_ 'no))
+  6)
+
+(test "regression vector pattern still works"
+  (match (vector 1 2)
+    ((vector a b) (list a b))
+    (_ 'no))
+  '(1 2))
+
+(test "regression cons pattern still works"
+  (match '(1 . 2)
+    ((cons a b) (list a b))
+    (_ 'no))
+  '(1 2))
+
+(printf "~%--- Results: ~a/~a passed, ~a failed ---~%"
+  pass (+ pass fail) fail)
+
+(exit (if (= fail 0) 0 1))