[plt-scheme] Bug or misuse? match-expander ids not properly working (patch)

Hi!

I've encountered a problem while implementing red-black trees:

(define-struct tree
  (color key value left right))

(define empty (make-tree 'black #f #f #f #f))
(define (empty? t) (eq? t empty))


To ease access with the pattern match syntax, I wrote match expanders
for trees as follows:

(define-match-expander T
  (lambda (stx)
    (syntax-case stx ()
      ((T c l (k v) r)
       (syntax/loc stx
         (struct tree (c k v l r))))))
  (lambda (stx)
    (syntax-case stx ()
      ((T c l (k v) r)
       (syntax/loc stx
         (make-tree c k v l r))))))

(define-match-expander R
  (lambda (stx)
    (syntax-case stx ()
      (R (syntax 'red))))
  (lambda (stx)
    (syntax-case stx ()
      (R (syntax 'red)))))

(define-match-expander B
  (lambda (stx)
    (syntax-case stx ()
      (B (syntax 'black))))
  (lambda (stx)
    (syntax-case stx ()
      (B (syntax 'black)))))

(define-match-expander E
  (lambda (stx)
    (syntax-case stx ()
      (E (syntax/loc stx (? empty?)))))
  (lambda (stx)
    (syntax-case stx ()
      (E (syntax/loc stx empty)))))


which should enable one to construct and match trees a la Haskell:

(match (T B E ('a 1) E)
  ((T B E (k v) E)
   "This is a black tree with both subtrees empty."))


However, this doesn't work as I expected.  I.e., "B" and "E" in the
pattern clause above are treated as plain variables, thus matching
anything.  Seemingly match expander ids in pattern match clauses take
effect only when used in "application" form.

So I wrote a patch.

The first portion is irrelevant to this particular issue, but fixes
a bug which inecessarily converts unnamed let syntax to a named one.

The second part is required for the third one to work when only
expander ids are used in match-let etc bindings.

I hope it's accepted.

regards,

diff -ur orig/define-forms.ss ./define-forms.ss
--- orig/define-forms.ss	2009-09-17 12:09:40.000000000 +0900
+++ ./define-forms.ss	2009-11-25 13:23:40.000000000 +0900
@@ -72,7 +72,7 @@
          ;; optimize the all-variable case
          [(_ ([pat exp]...) body ...)
           (andmap pattern-var? (syntax->list #'(pat ...)))
-          (syntax/loc stx (let name ([pat exp] ...) body ...))]
+          (syntax/loc stx (let ([pat exp] ...) body ...))]
          [(_ name ([pat exp]...) body ...)
           (and (identifier? (syntax name))
                (andmap pattern-var? (syntax->list #'(pat ...))))
diff -ur orig/parse-helper.ss ./parse-helper.ss
--- orig/parse-helper.ss	2009-09-17 12:09:40.000000000 +0900
+++ ./parse-helper.ss	2009-11-25 13:44:34.000000000 +0900
@@ -141,10 +141,17 @@
 (define (match:syntax-err stx msg)
   (raise-syntax-error #f msg stx))

+;; match-var? : syntax -> bool
+;; is p an identifier representing a pattern transformer?
+(define (match-var? p)
+  (match-expander?
+   (syntax-local-value ((syntax-local-certifier) p)
+		       (lambda () #f))))
+
 ;; pattern-var? : syntax -> bool
 ;; is p an identifier representing a pattern variable?
 (define (pattern-var? p)
-  (and (identifier? p) (not (ddk? p))))
+  (and (identifier? p) (not (ddk? p)) (not (match-var? p))))

 ;; ddk? : syntax -> number or boolean
 ;; if #f is returned, was not a ddk identifier
diff -ur orig/parse.ss ./parse.ss
--- orig/parse.ss	2009-09-17 12:09:40.000000000 +0900
+++ ./parse.ss	2009-11-25 01:44:44.000000000 +0900
@@ -32,6 +32,13 @@
      (match-expander-transform
       parse/cert cert #'expander stx match-expander-match-xform
       "This expander only works with the legacy match syntax")]
+    [expander
+     (and (identifier? #'expander)
+          (match-expander? (syntax-local-value (cert #'expander)
+                                               (lambda () #f))))
+     (match-expander-transform
+      parse/cert cert #'expander stx match-expander-match-xform
+      "This expander only works with the legacy match syntax")]
     [(var v)
      (identifier? #'v)
      (make-Var #'v)]