syntax/parse: added define-syntax-class/specialize

collects/syntax/parse/experimental/specialize.rkt

@@ -0,0 +1,39 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/syntax
+                     "../private/kws.rkt"
+                     "../private/rep-data.rkt"
+                     "../private/rep.rkt")
+         "../private/runtime.rkt")
+(provide define-syntax-class/specialize)
+
+(define-syntax (define-syntax-class/specialize stx)
+  (syntax-case stx ()
+    [(dscs header sc-expr)
+     (let-values ([(name formals arity)
+                   (let ([p (check-stxclass-header #'header stx)])
+                     (values (car p) (cadr p) (caddr p)))]
+                  [(target-scname argu)
+                   (let ([p (check-stxclass-application #'sc-expr stx)])
+                     (values (car p) (cdr p)))])
+       (let* ([pos-count (length (arguments-pargs argu))]
+              [kws (arguments-kws argu)]
+              [target (get-stxclass/check-arity target-scname target-scname pos-count kws)])
+         (with-syntax ([name name]
+                       [formals formals]
+                       [parser (generate-temporary (format-symbol "parser-~a" #'name))]
+                       [splicing? (stxclass-splicing? target)]
+                       [arity arity]
+                       [attrs (stxclass-attrs target)]
+                       [options (stxclass-options target)]
+                       [target-parser (stxclass-parser target)]
+                       [argu argu])
+           #`(begin (define-syntax name
+                      (stxclass 'name 'arity 'attrs
+                                (quote-syntax parser)
+                                'splicing?
+                                options
+                                #f))
+                    (define-values (parser)
+                      (lambda (x cx pr es fh0 cp0 success . formals)
+                        (app-argu target-parser x cx pr es fh0 cp0 success argu)))))))]))

collects/syntax/scribblings/parse/experimental.scrbl

@@ -255,3 +255,27 @@ their attributes with @scheme[name].
   [(_ (~eh-var x ext-options) ...)
    #'(x.s.a (x.s.b ...) ((x.c1 x.c2) ...))])
 ]
+
+
+@section{Syntax class specialization}
+
+@defmodule[syntax/parse/experimental/specialize]
+
+@defform/subs[(define-syntax-class/specialize header syntax-class-use)
+              ([header id
+                       (id . kw-formals)]
+               [syntax-class-use target-stxclass-id
+                                 (target-stxclass-id arg ...)])]{
+
+Defines @racket[id] as a syntax class with the same attributes,
+options (eg, @racket[#:commit], @racket[#:no-delimit-cut]), and
+patterns as @racket[target-stxclass-id] but with the given
+@racket[arg]s supplied.
+
+@examples[#:eval the-eval
+(define-syntax-class/specialize nat>10 (nat> 10))
+
+(syntax-parse #'(11 12) [(n:nat>10 ...) 'ok])
+(syntax-parse #'(8 9) [(n:nat>10 ...) 'ok])
+]
+}

collects/syntax/scribblings/parse/parse-common.rkt

@@ -34,6 +34,7 @@
                                              syntax/parse/experimental/splicing
                                              syntax/parse/experimental/contract
                                              syntax/parse/experimental/reflect
+                                             syntax/parse/experimental/specialize
                                              syntax/parse/experimental/eh)])
                                  `((for-syntax racket/base ,@mods)
                                    ,@mods)))))
@@ -102,6 +103,7 @@
                     syntax/parse/experimental/splicing
                     syntax/parse/experimental/reflect
                     syntax/parse/experimental/provide
+                    syntax/parse/experimental/specialize
                     syntax/parse/experimental/eh
                     "parse-dummy-bindings.rkt"))
 (provide (for-label (all-from-out racket/base)
@@ -112,5 +114,6 @@
                     (all-from-out syntax/parse/experimental/splicing)
                     (all-from-out syntax/parse/experimental/reflect)
                     (all-from-out syntax/parse/experimental/provide)
+                    (all-from-out syntax/parse/experimental/specialize)
                     (all-from-out syntax/parse/experimental/eh)
                     (all-from-out "parse-dummy-bindings.rkt")))

collects/tests/stxparse/test-exp.rkt

@@ -5,6 +5,7 @@
          syntax/parse/experimental/reflect
          syntax/parse/experimental/splicing
          syntax/parse/experimental/eh
+         syntax/parse/experimental/specialize
          "setup.rkt"
          (for-syntax syntax/parse))
 
@@ -77,3 +78,24 @@
 
 (terx (1) (f:foo)
       #rx"expected foo")
+
+;; Specialization
+
+(define-syntax-class/specialize nat>10 (nat> 10))
+
+(tok (11 23 45) (n:nat>10 ...))
+(terx (11 10 9) (n:nat>10 ...)
+      #rx"expected natural number greater than 10")
+
+(tcerr "specialize preserves #:no-delimit-cut"
+       (let ()
+         (define-syntax-class a #:no-delimit-cut (pattern _))
+         (define-syntax-class/specialize b a)
+         (syntax-parse #'12 [(~not x:b) (void)]))
+       #rx"syntax class with #:no-delimit-cut option not allowed within ~not pattern")
+
+(test-case "specialize preserves lack of #:no-delimit-cut"
+  (let ()
+    (define-syntax-class a (pattern _:id))
+    (define-syntax-class/specialize b a)
+    (syntax-parse #'12 [(~not x:b) (void)])))