add pattern-expanders to syntax/parse

pkgs/racket-pkgs/racket-doc/syntax/scribblings/parse/patterns.scrbl

@@ -1033,3 +1033,46 @@ definition in a @racket[~do] block.
   [(a b (~do (printf "a was ~s\n" #'a)) c:id) 'ok])
 ]
 }
+
+
+
+@;{--------}
+
+@section{Pattern Expanders}
+
+@defproc[(pattern-expander [proc (-> syntax? syntax?)]) pattern-expander?]{
+returns a pattern-expander that uses @racket[proc] to transform the pattern.
+
+@myexamples[
+  (define-syntax ~foo
+    (pattern-expander
+     (syntax-rules ()
+       [(_ pat) pat])))
+]}
+
+@defthing[prop:pattern-expander (struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))]{
+a struct-type property for pattern-expanders.
+
+@myexamples[
+  (begin-for-syntax
+    (struct thing (proc pattern-expander) #:transparent
+      #:property prop:procedure (struct-field-index proc)
+      #:property prop:pattern-expander (λ (this) (thing-pattern-expander this))))
+  (define-syntax ~foo
+    (thing
+     (lambda (stx) #'"I am the macro ~foo")
+     (lambda (stx) #'"I am the pattern-expander ~foo")))
+]}
+
+@defproc[(pattern-expander? [v any/c]) boolean?]{
+returns @racket[#t] if @racket[v] is a pattern expander, otherwise returns @racket[#f].
+}
+
+@defproc[(pattern-expander-proc [pat-exp pattern-expander?]) (-> syntax? syntax?)]{
+returns the transformer procedure used by @racket[pat-exp].
+}
+
+@defproc[(syntax-local-syntax-parse-pattern-introduce [stx syntax?]) syntax?]{
+like @racket[syntax-local-introduce], but for pattern-expanders.
+}
+

pkgs/racket-pkgs/racket-test/tests/stxparse/test.rkt

@@ -542,3 +542,37 @@
       #:attributes (a)
       [pattern ((~seq (~optional :one #:defaults [(a 'bar)])))])
     (void)))
+
+;; from http://lists.racket-lang.org/users/archive/2014-June/063095.html
+(test-case "pattern-expanders"
+  (let ()
+      (define-splicing-syntax-class binding #:literals (=)
+        [pattern (~seq name:id = expr:expr)])
+      
+      (define-syntax ~separated
+        (pattern-expander
+         (lambda (stx)
+           (syntax-case stx ()
+             [(separated sep pat)
+              (with-syntax ([ooo '...])
+                #'((~seq pat (~or (~peek-not _)
+                                  (~seq sep (~peek _))))
+                   ooo))]))))
+      
+      (define-splicing-syntax-class bindings
+        [pattern (~separated (~datum /) b:binding)
+                 #:with (name ...) #'(b.name ...)
+                 #:with (expr ...) #'(b.expr ...)])
+    
+    (define (parse-my-let stx)
+      (syntax-parse stx
+        [(_ bs:bindings body)
+         #'(let ([bs.name bs.expr] ...)
+             body)]))
+    
+    (check-equal? (syntax->datum
+                   (parse-my-let #'(my-let (x = 1 / y = 2 / z = 3)
+                                     (+ x y z))))
+                  (syntax->datum #'(let ([x 1] [y 2] [z 3])
+                                     (+ x y z))))
+    ))

racket/collects/syntax/parse/pre.rkt

@@ -1,10 +1,12 @@
 #lang racket/base
 (require "private/sc.rkt"
          "private/litconv.rkt"
-         "private/lib.rkt")
+         "private/lib.rkt"
+         (for-syntax "private/pattern-expander.rkt"))
 (provide (except-out (all-from-out "private/sc.rkt")
                      define-integrable-syntax-class
                      syntax-parser/template
                      parser/rhs)
          (all-from-out "private/litconv.rkt")
-         (all-from-out "private/lib.rkt"))
+         (all-from-out "private/lib.rkt")
+         (for-syntax (all-from-out "private/pattern-expander.rkt")))

racket/collects/syntax/parse/private/pattern-expander-prop.rkt

@@ -0,0 +1,31 @@
+#lang racket/base
+
+(require racket/contract/base)
+
+(define-values (prop:pattern-expander pattern-expander? get-proc-getter)
+  (make-struct-type-property 'pattern-expander))
+
+(define (pattern-expander-proc pat-expander)
+  (define get-proc (get-proc-getter pat-expander))
+  (get-proc pat-expander))
+
+(define current-syntax-parse-pattern-introducer
+  (make-parameter
+   (lambda (stx)
+     (error 'syntax-local-syntax-parse-pattern-introduce "not expanding syntax-parse pattern"))))
+
+(define (syntax-local-syntax-parse-pattern-introduce stx)
+  ((current-syntax-parse-pattern-introducer) stx))
+
+(provide (contract-out
+          [prop:pattern-expander
+           (struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))]
+          [pattern-expander?
+           (-> any/c boolean?)]
+          [pattern-expander-proc
+           (-> pattern-expander? (-> syntax? syntax?))]
+          [current-syntax-parse-pattern-introducer
+           (parameter/c (-> syntax? syntax?))]
+          [syntax-local-syntax-parse-pattern-introduce
+           (-> syntax? syntax?)]
+          ))

racket/collects/syntax/parse/private/pattern-expander.rkt

@@ -0,0 +1,25 @@
+#lang racket/base
+
+(provide prop:pattern-expander
+         pattern-expander
+         pattern-expander?
+         pattern-expander-proc
+         syntax-local-syntax-parse-pattern-introduce
+         )
+
+(require "pattern-expander-prop.rkt")
+
+(module pattern-expander-struct racket/base
+  (require racket/contract/base)
+  
+  (require (only-in "pattern-expander-prop.rkt" prop:pattern-expander))
+  
+  (struct pattern-expander (proc) #:transparent
+    #:property prop:pattern-expander
+    (λ (this) (pattern-expander-proc this))) ; needs to be wrapped in (λ (this) (_ this))
+  
+  (provide (contract-out
+            [struct pattern-expander ([proc (-> syntax? syntax?)])]
+            )))
+
+(require (only-in 'pattern-expander-struct pattern-expander))

racket/collects/syntax/parse/private/rep.rkt

@@ -17,7 +17,8 @@
          "rep-data.rkt"
          "rep-patterns.rkt"
          syntax/parse/private/residual-ct ;; keep abs. path
-         "kws.rkt")
+         "kws.rkt"
+         "pattern-expander-prop.rkt")
 
 ;; Error reporting
 ;; All entry points should have explicit, mandatory #:context arg
@@ -435,6 +436,8 @@
 
 ;; parse-*-pattern : stx DeclEnv boolean boolean -> Pattern
 (define (parse-*-pattern stx decls allow-head? allow-action?)
+  (define (recur stx)
+    (parse-*-pattern stx decls allow-head? allow-action?))
   (define (check-head! x)
     (unless allow-head?
       (wrong-syntax stx "head pattern not allowed here"))
@@ -449,6 +452,30 @@
                     ~seq ~optional ~! ~bind ~fail ~parse ~do
                     ~post ~peek ~peek-not ~delimit-cut ~commit ~reflect
                     ~splicing-reflect)
+    [id
+     (and (identifier? #'id)
+          (not (safe-name? #'id))
+          (pattern-expander? (syntax-local-value #'id (λ () #f))))
+     (let* ([proc (pattern-expander-proc (syntax-local-value #'id))]
+            [introducer (make-syntax-introducer)]
+            [mstx (introducer (syntax-local-introduce stx))]
+            [mresult (parameterize ([current-syntax-parse-pattern-introducer introducer])
+                       (proc mstx))]
+            [result (syntax-local-introduce (introducer mresult))])
+       (disappeared! #'id)
+       (recur result))]
+    [(id . rst)
+     (and (identifier? #'id)
+          (not (safe-name? #'id))
+          (pattern-expander? (syntax-local-value #'id (λ () #f))))
+     (let* ([proc (pattern-expander-proc (syntax-local-value #'id))]
+            [introducer (make-syntax-introducer)]
+            [mstx (introducer (syntax-local-introduce stx))]
+            [mresult (parameterize ([current-syntax-parse-pattern-introducer introducer])
+                       (proc mstx))]
+            [result (syntax-local-introduce (introducer mresult))])
+       (disappeared! #'id)
+       (recur result))]
     [wildcard
      (wildcard? #'wildcard)
      (begin (disappeared! stx)