syntax/parse: add description-if-constant field to stxclass

Also remove (inline) options, integrate structs and improve comments.

racket/collects/syntax/parse/experimental/provide.rkt

@@ -61,7 +61,7 @@
                (join-sep (map kw->string maxkws*) "," "and")
                (join-sep (map kw->string maxkws) "," "and")))
         (with-syntax ([scname scname]
-                      [#s(stxclass name arity attrs parser splicing? options integrate)
+                      [#s(stxclass name arity attrs parser splicing? commit? delimit? inline desc)
                        stxclass]
                       [#s(ctcrec (mpc ...) (mkw ...) (mkwc ...)
                                  (opc ...) (okw ...) (okwc ...))
@@ -100,8 +100,8 @@
                      'attrs
                      (quote-syntax contracted-parser)
                      'splicing?
-                     'options
+                     'commit? 'delimit?
-                     #f)) ;; must disable integration
+                     #f 'desc)) ;; must disable integration
                   (provide (rename-out [contracted-scname scname])))))))])))
 
 (define-syntax (provide-syntax-class/contract stx)

racket/collects/syntax/parse/experimental/specialize.rkt

@@ -27,15 +27,17 @@
                           [splicing? (stxclass-splicing? target)]
                           [arity arity]
                           [attrs (stxclass-attrs target)]
-                          [options (stxclass-options target)]
+                          [commit? (stxclass-commit? target)]
+                          [delimit-cut? (stxclass-delimit-cut? target)]
                           [target-parser (stxclass-parser target)]
+                          [desc (stxclass-desc target)]
                           [argu argu])
               #`(begin (define-syntax name
                          (stxclass 'name 'arity 'attrs
                                    (quote-syntax parser)
                                    'splicing?
-                                   options
+                                   'commit? 'delimit-cut?
-                                   #f))
+                                   #f 'desc))
                        (define-values (parser)
                          (lambda (x cx pr es fh0 cp0 rl success . formals)
                            (app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))])))

racket/collects/syntax/parse/experimental/splicing.rkt

@@ -58,8 +58,8 @@
                      (sort-sattrs '(#s(attr a.name a.depth #f) ...))
                      (quote-syntax parser)
                      #t
-                     #s(options #t #t)
+                     #t #t
-                     #f)))]))
+                     #f #f)))]))
 
 (define (mk-permute unsorted-attrs)
   (let ([sorted-attrs

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

@@ -34,6 +34,18 @@
          (for-syntax rhs->parser))
 
 (begin-for-syntax
+ ;; constant-desc : Syntax -> String/#f
+ (define (constant-desc stx)
+   (syntax-case stx (quote)
+     [(quote datum)
+      (let ([d (syntax-e #'datum)])
+        (and (string? d) d))]
+     [expr
+      (let ([d (syntax-e #'expr)])
+        (and (string? d)
+             (free-identifier=? #'#%datum (datum->syntax #'expr '#%datum))
+             d))]))
+
  (define (tx:define-*-syntax-class stx splicing?)
    (syntax-case stx ()
      [(_ header . rhss)
@@ -44,17 +56,22 @@
           (let ([the-rhs (parse-rhs #'rhss #f splicing? #:context stx)])
             (with-syntax ([name name]
                           [formals formals]
+                          [desc (cond [(rhs-description the-rhs) => constant-desc]
+                                      [else (symbol->string (syntax-e name))])]
                           [parser (generate-temporary (format-symbol "parse-~a" name))]
                           [arity arity]
                           [attrs (rhs-attrs the-rhs)]
-                          [options (rhs-options the-rhs)])
+                          [commit? (rhs-commit? the-rhs)]
+                          [delimit-cut? (rhs-delimit-cut? the-rhs)])
               #`(begin (define-syntax name
                          (stxclass 'name 'arity
                                    'attrs
                                    (quote-syntax parser)
                                    '#,splicing?
-                                   options
+                                   'commit?
-                                   #f))
+                                   'delimit-cut?
+                                   #f
+                                   'desc))
                        (define-values (parser)
                          (parser/rhs name formals attrs rhss #,splicing? #,stx)))))))])))
 
@@ -72,8 +89,10 @@
                   (stxclass 'name no-arity '()
                             (quote-syntax parser)
                             #f
-                            '#s(options #t #t)
+                            #t
-                            (integrate (quote-syntax predicate) 'description)))
+                            #t
+                            (quote-syntax predicate)
+                            'description))
                 (define (parser x cx pr es fh0 cp0 rl success)
                   (if (predicate x)
                       (success fh0)
@@ -95,7 +114,7 @@
  (define (rhs->parser name formals relsattrs the-rhs splicing?)
    (define-values (transparent? description variants defs commit? delimit-cut?)
      (match the-rhs
-       [(rhs _ _ transparent? description variants defs (options commit? delimit-cut?) _)
+       [(rhs _ transparent? description variants defs commit? delimit-cut? _)
         (values transparent? description variants defs commit? delimit-cut?)]))
    (define vdefss (map variant-definitions variants))
    (define formals* (rewrite-formals formals #'x #'rl))

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

@@ -9,8 +9,6 @@
          "kws.rkt")
 ;; from residual.rkt
 (provide (struct-out stxclass)
-         (struct-out options)
-         (struct-out integrate)
          (struct-out conventions)
          (struct-out literalset)
          (struct-out eh-alternative-set)
@@ -18,8 +16,6 @@
 ;; from here
 (provide stxclass/s?
          stxclass/h?
-         stxclass-commit?
-         stxclass-delimit-cut?
          (struct-out rhs)
          (struct-out variant))
 
@@ -28,18 +24,17 @@
 (define (stxclass/h? x)
   (and (stxclass? x) (stxclass-splicing? x)))
 
-(define (stxclass-commit? x)
+;; An RHS is #s(rhs SAttrs Bool Stx/#f Variants Stxs Bool Bool Id/#f)
-  (options-commit? (stxclass-options x)))
+(define-struct rhs
-(define (stxclass-delimit-cut? x)
+  (attrs        ;; (Listof Sattr)
-  (options-delimit-cut? (stxclass-options x)))
+   transparent? ;; Bool
-
+   description  ;; Syntax/#f
-#|
+   variants     ;; (Listof Variant)
-An RHS is
+   definitions  ;; (Listof Stx), aux definitions from txlifts, local conventions?, etc
-  #s(rhs stx (listof SAttr) bool stx/#f (listof Variant) (listof stx) Options Integrate/#f)
+   commit?      ;; Bool
-definitions: auxiliary definitions from #:declare
+   delimit-cut? ;; Bool
-|#
+   pred         ;; ???
-(define-struct rhs (ostx attrs transparent? description variants definitions options integrate)
+   ) #:prefab)
-  #:prefab)
 
 #|
 A Variant is
@@ -50,7 +45,7 @@ A Variant is
 ;; make-dummy-stxclass : identifier -> SC
 ;; Dummy stxclass for calculating attributes of recursive stxclasses.
 (define (make-dummy-stxclass name)
-  (make stxclass (syntax-e name) #f null #f #f #s(options #f #t) #f))
+  (make stxclass (syntax-e name) #f null #f #f #f #t #f #f))
 
 ;; Environments
 

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

@@ -164,7 +164,7 @@
    (lambda ()
      (parameterize ((current-syntax-context ctx))
        (define-values (rest description transp? attributes auto-nested? colon-notation?
-                            decls defs options)
+                            decls defs commit? delimit-cut?)
          (parse-rhs/part1 stx splicing? (and expected-attrs #t)))
        (define variants
          (parameterize ((stxclass-lookup-config
@@ -176,9 +176,9 @@
        (let ([sattrs
               (or attributes
                   (intersect-sattrss (map variant-attrs variants)))])
-         (make rhs stx sattrs transp? description variants 
+         (make rhs sattrs transp? description variants 
                (append (get-txlifts-as-definitions) defs)
-               options #f))))))
+               commit? delimit-cut? #f))))))
 
 (define (parse-rhs/part1 stx splicing? strict?)
   (define-values (chunks rest)
@@ -199,7 +199,7 @@
   (define attributes (options-select-value chunks '#:attributes #:default #f))
   (define-values (decls defs) (get-decls+defs chunks strict?))
   (values rest description transparent? attributes auto-nested? colon-notation?
-          decls defs (options commit? delimit-cut?)))
+          decls defs commit? delimit-cut?))
 
 ;; ----
 
@@ -757,9 +757,9 @@
   ;; if parser* not #f, overrides sc parser
   (check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc))
   (cond [(and (stxclass/s? sc)
-              (stxclass-integrate sc)
+              (stxclass-inline sc)
               (equal? argu no-arguments))
-         (parse-pat:id/s/integrate name (stxclass-integrate sc) role)]
+         (parse-pat:id/s/integrate name (stxclass-inline sc) (stxclass-desc sc) role)]
         [(stxclass/s? sc)
          (parse-pat:id/s name
                          (or parser* (stxclass-parser sc))
@@ -784,11 +784,9 @@
   (define bind (name->bind name))
   (pat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role))
 
-(define (parse-pat:id/s/integrate name integrate role)
+(define (parse-pat:id/s/integrate name predicate description role)
   (define bind (name->bind name))
-  (let ([predicate (integrate-predicate integrate)]
+  (pat:integrated bind predicate description role))
-        [description (integrate-description integrate)])
-    (pat:integrated bind predicate description role)))
 
 (define (parse-pat:id/h name parser argu attrs commit? pfx role)
   (define prefix (name->prefix name pfx))

racket/collects/syntax/parse/private/residual-ct.rkt

@@ -1,8 +1,6 @@
 #lang racket/base
 (provide (struct-out attr)
          (struct-out stxclass)
-         (struct-out options)
-         (struct-out integrate)
          (struct-out conventions)
          (struct-out literalset)
          (struct-out lse:lit)
@@ -29,20 +27,18 @@
 
 ;; == from rep-data.rkt
 
-#|
+;; A stxclass is #s(stxclass Symbol Symbols SAttrs Id Bool Bool BoolOptions Id/#f String/#f)
-A stxclass is
+(define-struct stxclass
-  #s(stxclass symbol (listof symbol) (list-of SAttr) identifier bool Options Integrate/#f)
+  (name         ;; Symbol
-where Options = #s(options boolean boolean)
+   arity        ;; Arity (defined in kws.rkt)
-      Integrate = #s(integrate id string)
+   attrs        ;; (Listof SAttr)
-Arity is defined in kws.rkt
+   parser       ;; Id, reference to parser (see parse.rkt for parser signature)
-|#
+   splicing?    ;; Bool
-(define-struct stxclass (name arity attrs parser splicing? options integrate)
+   commit?      ;; Bool
-  #:prefab)
+   delimit-cut? ;; Bool
-
+   inline       ;; Id/#f, reference to a predicate
-(define-struct options (commit? delimit-cut?)
+   desc         ;; String/#f, String = known constant description
-  #:prefab)
+   ) #:prefab)
-(define-struct integrate (predicate description)
-  #:prefab)
 
 #|
 A Conventions is