[plt-scheme] Using the struct type identifier as a macro [PATCH]

On Mon, 17 Nov 2008, Sam TH wrote:

> as well as add some tests for your new feature?  Probably it would be
> easiest to add them to collects/tests/match/examples.ss .

Added tests in collects/tests/match/example.ss and 
collects/tests/mzscheme/struct.ss

-- vyzo
-------------- next part --------------
Index: collects/scheme/match/parse.ss
===================================================================
--- collects/scheme/match/parse.ss	(revision 12479)
+++ collects/scheme/match/parse.ss	(working copy)
@@ -152,6 +152,10 @@
     [(mcons e1 e2) (make-MPair (parse #'e1) (parse #'e2))]
     [(struct s pats)
      (parse-struct stx cert parse #'s #'pats)]
+    [(type pat ...)
+     (and (identifier? #'type) 
+          (struct-info? (syntax-local-value (cert #'type) (lambda () #f))))
+     (parse-struct stx cert parse #'type #'(pat ...))]
     [(? p q1 qs ...)
      (make-And (cons (make-Pred (cert #'p))
                      (map parse (syntax->list #'(q1 qs ...)))))]
Index: collects/scheme/private/define-struct.ss
===================================================================
--- collects/scheme/private/define-struct.ss	(revision 12479)
+++ collects/scheme/private/define-struct.ss	(working copy)
@@ -26,10 +26,20 @@
                       0 0 #f
                       null (current-inspector)
                       (lambda (v stx)
-                        (raise-syntax-error
-                         #f
-                         "identifier for static struct-type information cannot be used as an expression"
-                         stx))
+                        (let-values (((kons) (cadr (extract-struct-info v))))
+                          (if kons
+                            (if (list? (syntax-e stx))
+                              (datum->syntax stx (cons kons (cdr (syntax-e stx))) stx)
+                              (if (symbol? (syntax-e stx))
+                                kons 
+                                (raise-syntax-error
+                                    #f
+                                  "illegal use of struct-type identifier"
+                                  stx)))
+                            (raise-syntax-error
+                                #f
+                              "identifier for static struct-type information cannot be used as an expression"
+                              stx))))
                       null
                       (lambda (proc info)
                         (if (and (procedure? proc)
Index: collects/scheme/private/struct-info.ss
===================================================================
--- collects/scheme/private/struct-info.ss	(revision 12479)
+++ collects/scheme/private/struct-info.ss	(working copy)
@@ -16,10 +16,20 @@
                       1 0 #f
                       null (current-inspector)
                       (lambda (v stx)
-                        (raise-syntax-error
-                         #f
-                         "identifier for static struct-type information cannot be used as an expression"
-                         stx))
+                        (let-values (((kons) (cadr (extract-struct-info v))))
+                          (if kons
+                            (if (list? (syntax-e stx))
+                              (datum->syntax stx (cons kons (cdr (syntax-e stx))) stx)
+                              (if (symbol? (syntax-e stx))
+                                kons
+                                (raise-syntax-error
+                                    #f
+                                  "illegal use of struct-type identifier"
+                                  stx)))
+                            (raise-syntax-error
+                                #f
+                              "identifier for static struct-type information cannot be used as an expression"
+                              stx))))
                       null
                       (lambda (proc info)
                         (if (and (procedure? proc)
Index: collects/tests/match/examples.ss
===================================================================
--- collects/tests/match/examples.ss	(revision 12479)
+++ collects/tests/match/examples.ss	(working copy)
@@ -51,6 +51,8 @@
 
 (define-struct empt ())
 
+(define-struct T1 (x y))
+(define-struct (T2 T1) (z))
 
 (provide new-tests)
 
@@ -577,5 +579,30 @@
            [(vector a b) a]
            [else 'bad]))
 
+   
+   ;; direct struct expanders
+   (comp 3
+         (match (make-T1 1 2)
+           ((T1 x y) (+ x y))
+           (else #f)))
+   
+   (comp 3
+         (match (make-T2 1 2 3)
+           ((T1 x y) (+ x y))
+           (else #f)))
+   
+   (comp 6
+         (match (make-T2 1 2 3)
+           ((T2 x y z) (+ x y z))
+           (else #f)))
+   
+   (comp 'yes
+         (match 'foo
+           ((T1 x y) (+ x y))
+           (else 'yes)))
+   
+   (comp 'yes (with-handlers ((exn:fail:syntax? (lambda _ 'yes)))
+                (expand (quote-syntax (match 'foo ((T1 x) x))))))
+   
 
    ))
Index: collects/tests/mzscheme/struct.ss
===================================================================
--- collects/tests/mzscheme/struct.ss	(revision 12479)
+++ collects/tests/mzscheme/struct.ss	(working copy)
@@ -430,6 +430,8 @@
 (test #f struct? ai)
 (test 1 a-b ai)
 (test 2 a-c ai)
+(test #t procedure? a)
+(test #t a? (a 1 2))
 (define ai2 (make-a 1 2))
 (set-a-b! ai2 3)
 (set-a-c! ai2 4)