syntax/parse: clean up integrable stxclass code

collects/syntax/parse/private/lib.rkt

@@ -1,7 +1,6 @@
 #lang racket/base
 (require "sc.rkt"
          "keywords.rkt"
-         syntax/parse/private/residual ;; keep abs.
          (for-syntax racket/base))
 
 (provide identifier
@@ -22,41 +21,49 @@
          expr
          static)
 
+
+(define (expr-stx? x)
+  (not (keyword-stx? x)))
+
+(define ((stxof pred?) x) (and (syntax? x) (pred? (syntax-e x))))
+(define keyword-stx? (stxof keyword?))
+(define boolean-stx? (stxof boolean?))
+(define string-stx? (stxof string?))
+(define char-stx? (stxof char?))
+(define number-stx? (stxof number?))
+(define integer-stx? (stxof integer?))
+(define exact-integer-stx? (stxof exact-integer?))
+(define exact-nonnegative-integer-stx? (stxof exact-nonnegative-integer?))
+(define exact-positive-integer-stx? (stxof exact-positive-integer?))
+
 ;; == Integrable syntax classes ==
 
 (define-integrable-syntax-class identifier (quote "identifier") identifier?)
 (define-integrable-syntax-class expr (quote "expression") expr-stx?)
 (define-integrable-syntax-class keyword (quote "keyword") keyword-stx?)
-
-;; == Normal syntax classes ==
-
-(define-syntax-rule (define-pred-stxclass name pred)
-  (define-syntax-class name #:attributes () #:opaque #:commit
-    (pattern (~and x (~fail #:unless (pred (syntax-e #'x)))))))
-
-;;(define-pred-stxclass identifier symbol?)
-;;(define-pred-stxclass keyword keyword?)
-(define-pred-stxclass boolean boolean?)
-(define-pred-stxclass character char?)
-
-(define-syntax-class str #:attributes () #:opaque #:commit
-  #:description "string"
-  (pattern (~and x (~fail #:unless (string? (syntax-e #'x))))))
-
-(define-pred-stxclass number number?)
-(define-pred-stxclass integer integer?)
-(define-pred-stxclass exact-integer exact-integer?)
-(define-pred-stxclass exact-nonnegative-integer exact-nonnegative-integer?)
-(define-pred-stxclass exact-positive-integer exact-positive-integer?)
+(define-integrable-syntax-class boolean (quote "boolean") boolean-stx?)
+(define-integrable-syntax-class character (quote "character") char-stx?)
+(define-integrable-syntax-class str (quote "string") string-stx?)
+(define-integrable-syntax-class number (quote "number") number-stx?)
+(define-integrable-syntax-class integer (quote "integer") integer-stx?)
+(define-integrable-syntax-class exact-integer (quote "exact-integer") exact-integer-stx?)
+(define-integrable-syntax-class exact-nonnegative-integer
+  (quote "exact-nonnegative-integer")
+  exact-nonnegative-integer-stx?)
+(define-integrable-syntax-class exact-positive-integer
+  (quote "exact-positive-integer")
+  exact-positive-integer-stx?)
 
 ;; Aliases
 (define-syntax id (make-rename-transformer #'identifier))
 (define-syntax nat (make-rename-transformer #'exact-nonnegative-integer))
 (define-syntax char (make-rename-transformer #'character))
 
+;; == Normal syntax classes ==
+
 (define notfound (box 'notfound))
 
-(define-syntax-class (static pred name)
+(define-syntax-class (static pred [name #f])
   #:attributes (value)
   #:description name
   #:commit

collects/syntax/parse/private/parse.rkt

@@ -563,13 +563,13 @@ Conventions:
        [#s(pat:post attrs pattern)
         #`(let ([pr (ps-add-post pr)])
             (parse:S x cx pattern pr es k))]
-       [#s(pat:integrated _attrs name argu predicate description)
+       [#s(pat:integrated _attrs name predicate description)
         (with-syntax ([(name-attr ...)
                        (if (identifier? #'name)
                            #'([#s(attr name 0 #t) x*])
                            #'())])
           #'(let ([x* (datum->syntax cx x cx)])
-              (if (app-argu predicate x* argu)
+              (if (predicate x*)
                   (let-attributes (name-attr ...) k)
                   (let ([es (cons (expect:thing 'description #t) es)])
                     (fail (failure pr es))))))])]))
@@ -818,7 +818,7 @@ Conventions:
            (else (fail result))))]
     ;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr
     [(parse:dots x cx (#s(ehpat (attr0)
-                                #s(pat:integrated _attrs _name _argu pred? desc)
+                                #s(pat:integrated _attrs _name pred? desc)
                                 #f))
                  #s(pat:datum () ()) pr es k)
      #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc)])

collects/syntax/parse/private/rep-patterns.rkt

@@ -40,7 +40,7 @@ A SinglePattern is one of
   (pat:commit Base SinglePattern)
   (pat:reflect Base stx Arguments (listof SAttr) id (listof IAttr))
   (pat:post Base SinglePattern)
-  (pat:integrated Base id/#f Arguments id string)
+  (pat:integrated Base id/#f id string)
 
 A ListPattern is a subtype of SinglePattern; one of
   (pat:datum Base '())
@@ -69,7 +69,7 @@ A ListPattern is a subtype of SinglePattern; one of
 (define-struct pat:commit (attrs pattern) #:prefab)
 (define-struct pat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab)
 (define-struct pat:post (attrs pattern) #:prefab)
-(define-struct pat:integrated (attrs name argu predicate description) #:prefab)
+(define-struct pat:integrated (attrs name predicate description) #:prefab)
 
 #|
 A ActionPattern is one of
@@ -306,9 +306,9 @@ A SideClause is one of
 (define (create-pat:post pattern)
   (make pat:post (pattern-attrs pattern) pattern))
 
-(define (create-pat:integrated name argu predicate description)
+(define (create-pat:integrated name predicate description)
   (let ([attrs (if name (list (make attr name 0 #t)) null)])
-    (make pat:integrated attrs name argu predicate description)))
+    (make pat:integrated attrs name predicate description)))
 
 ;; ----
 

collects/syntax/parse/private/rep.rkt

@@ -704,8 +704,8 @@
 (define (parse-pat:var* stx allow-head? name sc argu [pfx "."])
   (check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc))
   (cond [(stxclass/s? sc)
-         (if (and (stxclass-integrate sc) (null? (arguments-kws argu)))
-             (parse-pat:id/s/integrate name (stxclass-integrate sc) argu)
+         (if (and (stxclass-integrate sc) (equal? argu no-arguments))
+             (parse-pat:id/s/integrate name (stxclass-integrate sc))
              (parse-pat:id/s name
                              (stxclass-parser sc)
                              argu
@@ -727,9 +727,9 @@
   (define bind (name->bind name))
   (create-pat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit?))
 
-(define (parse-pat:id/s/integrate name integrate argu)
+(define (parse-pat:id/s/integrate name integrate)
   (define bind (name->bind name))
-  (create-pat:integrated bind argu
+  (create-pat:integrated bind
                          (integrate-predicate integrate)
                          (integrate-description integrate)))
 

collects/syntax/parse/private/residual.rkt

@@ -193,21 +193,11 @@
  ["runtime-report.rkt"
   (syntax-patterns-fail)])
 
-;; == predicates and parsers
-
-(provide keyword-stx?
-         expr-stx?
-         predicate-ellipsis-parser)
-
-(define (keyword-stx? x)
-  (and (syntax? x) (keyword? (syntax-e x))))
-
-(define (expr-stx? x)
-  (not (keyword-stx? x)))
-
-;; Specialized ellipsis parser
+;; == specialized ellipsis parser
 ;; returns (values 'ok attr-values) or (values 'fail failure)
 
+(provide predicate-ellipsis-parser)
+
 (define (predicate-ellipsis-parser x cx pr es pred? desc)
   (let ([elems (stx->list x)])
     (if (and elems (andmap pred? elems))