From ac9d2d8d9e509be22d8f8c25177f6e050b2d372c Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Wed, 6 Jan 2010 16:41:17 +0000
Subject: [PATCH] Support prefab struct literals in quasipatterns. Fixes PR
 10050.

svn: r17495
---
 collects/scheme/match/compiler.ss    | 34 ++++++++++++++++++++--------
 collects/scheme/match/parse-quasi.ss | 10 ++++++++
 collects/scheme/match/patterns.ss    |  7 ++++++
 collects/tests/match/examples.ss     | 20 +++++++++++++++-
 4 files changed, 61 insertions(+), 10 deletions(-)

diff --git a/collects/scheme/match/compiler.ss b/collects/scheme/match/compiler.ss
index 5413a5d8e9..ab4fa32790 100644
--- a/collects/scheme/match/compiler.ss
+++ b/collects/scheme/match/compiler.ss
@@ -8,7 +8,8 @@
          "reorder.ss"
          scheme/struct-info
          scheme/stxparam
-         scheme/nest)
+         scheme/nest
+         unstable/syntax)
 
 (provide compile*)
 
@@ -43,12 +44,12 @@
                                  esc)])
       #`[(#,predicate-stx #,x) rhs]))
   (define (compile-con-pat accs pred pat-acc)
-    (with-syntax ([(tmps ...) (generate-temporaries accs)])
-      (with-syntax ([(accs ...) accs]
-                    [pred pred]
-                    [body (compile*
-                           (append (syntax->list #'(tmps ...)) xs)
-                           (map (lambda (row)
+    (with-syntax* ([(tmps ...) (generate-temporaries accs)]
+                   [(accs ...) accs]
+                   [pred pred]
+                   [body (compile*
+                          (append (syntax->list #'(tmps ...)) xs)
+                          (map (lambda (row)
                                   (define-values (p1 ps) (Row-split-pats row))
                                   (make-Row (append (pat-acc p1) ps)
                                             (Row-rhs row)
@@ -56,7 +57,7 @@
                                             (Row-vars-seen row)))
                                 rows)
                            esc)])
-        #`[(pred #,x) (let ([tmps (accs #,x)] ...) body)])))
+      #`[(pred #,x) (let ([tmps (accs #,x)] ...) body)]))
   (cond
     [(eq? 'box k)
      (compile-con-pat (list #'unbox) #'box? (compose list Box-p))]
@@ -116,7 +117,22 @@
             [accs (Struct-accessors s)]
             [pred (Struct-pred s)])
        (compile-con-pat accs pred Struct-ps))]
-    [else (error 'compile "bad key: ~a" k)]))
+    ;; it's a prefab struct
+    [(list? k)
+     (let* ([s (Row-first-pat (car rows))]
+            [key (PrefabStruct-key s)]
+            [pats (PrefabStruct-ps s)])       
+       (with-syntax*
+        ([struct-type-id (syntax-local-lift-expression #`(prefab-key->struct-type '#,key #,(length pats)))]
+         [(_ _ _ acc-proc _ _ _ _) (syntax-local-lift-values-expression 8 #`(struct-type-info struct-type-id))])
+        (compile-con-pat
+         (for/list ([p pats]
+                    [i (in-naturals)])
+           #`(make-struct-field-accessor acc-proc #,i)
+           #;#`(lambda (val) (acc-proc val #,i)))
+         #`(struct-type-make-predicate struct-type-id)
+         PrefabStruct-ps)))]
+    [else (error 'match-compile "bad key: ~a" k)]))
 
 
 ;; produces the syntax for a let clause
diff --git a/collects/scheme/match/parse-quasi.ss b/collects/scheme/match/parse-quasi.ss
index 62bea52f73..4115b58d7c 100644
--- a/collects/scheme/match/parse-quasi.ss
+++ b/collects/scheme/match/parse-quasi.ss
@@ -57,6 +57,16 @@
         (pq #'rest)
         #f))]
     [(a . b) (make-Pair (pq #'a) (pq #'b))]
+    ;; prefab structs
+    [struct
+     (prefab-struct-key (syntax-e #'struct))
+     (let ([key (prefab-struct-key (syntax-e #'struct))]
+           [pats (cdr (vector->list (struct->vector (syntax-e #'struct))))])
+       (make-And (list (make-Pred #`(struct-type-make-predicate (prefab-key->struct-type '#,key #,(length pats))))
+                       (make-App #'struct->vector
+                                 (make-Vector (cons (make-Dummy #f) (map pq pats))))))
+       #;
+       (make-PrefabStruct key (map pq pats)))]
     ;; the hard cases
     [#(p ...)
      (ormap (lambda (p)
diff --git a/collects/scheme/match/patterns.ss b/collects/scheme/match/patterns.ss
index 4ddbb9916d..f133ff8904 100644
--- a/collects/scheme/match/patterns.ss
+++ b/collects/scheme/match/patterns.ss
@@ -59,6 +59,10 @@
 ;; ps is a listof patterns
 (define-struct (Struct CPat) (id pred super accessors ps) #:transparent)
 
+;; ps is a listof patterns
+;; key is a prefab struct key
+(define-struct (PrefabStruct CPat) (key pred accessors ps) #:transparent)
+
 ;; both fields are lists of pats
 (define-struct (HashTable CPat) (key-pats val-pats) #:transparent)
 
@@ -105,6 +109,7 @@
 ;; the result is #f if p is not a constructor pattern
 (define (pat-key p)
   (cond [(Struct? p) (get-key (Struct-id p))]
+        [(PrefabStruct? p) (list (PrefabStruct-key p))]
         [(Box? p) 'box]
         [(Vector? p) 'vector]
         [(Pair? p) 'pair]
@@ -167,6 +172,8 @@
      (merge (map bound-vars (Vector-ps p)))]
     [(Struct? p)
      (merge (map bound-vars (Struct-ps p)))]
+    [(PrefabStruct? p)
+     (merge (map bound-vars (PrefabStruct-ps p)))]
     [(App? p)
      (bound-vars (App-p p))]
     [(Not? p) null]
diff --git a/collects/tests/match/examples.ss b/collects/tests/match/examples.ss
index f041a52fe8..132f459439 100644
--- a/collects/tests/match/examples.ss
+++ b/collects/tests/match/examples.ss
@@ -608,4 +608,22 @@
          (match `(begin 1 2 3)
            [`(begin ,es ... ,en)
             (list es en)]))
-   ))
+
+   (comp '(a b c)
+	 (let ()
+	   
+	   (define-struct foo (a b c) #:prefab)
+	   (match (make-foo 'a 'b 'c)
+		  [`#s(foo ,x ,y ,z)
+		   (list x y z)])))
+   (comp '(a b c)
+	 (let ()
+	   
+	   (define-struct foo (a b c) #:prefab)
+	   (define-struct (bar foo) (d) #:prefab)
+	   (match (make-bar 'a 'b 'c 1)
+		  [`#s((bar foo 3) ,x ,y ,z ,w)
+		      (list x y z)])
+	   ))
+
+))