syntax/parse: parse side clauses directly as action patterns

Eliminates the clause:* structures.

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

@@ -712,8 +712,8 @@ Conventions:
           #`(parse:A x cx #,action pr es #,k))]
        [#s(action:cut)
         #'(with ([fail-handler cut-prompt]) k)]
-       [#s(action:bind (side ...))
+       [#s(action:bind a expr)
-        #'(bind/sides (side ...) k)]
+        #'(let-attributes ([a (wrap-user-code expr)]) k)]
        [#s(action:fail condition message)
         #`(let ([c (wrap-user-code condition)])
             (if c
@@ -735,17 +735,6 @@ Conventions:
         #'(let ([pr* (ps-add-post pr)])
             (parse:A x cx pattern pr* es k))])]))
 
-;; (bind/sides clauses k) : expr[Ans]
-;; In k: attrs(clauses) are bound.
-(define-syntax (bind/sides stx)
-  (syntax-case stx ()
-    [(_ (side ...) k)
-     (for/fold ([k #'k]) ([side (in-list (reverse (syntax->list #'(side ...))))])
-       (syntax-case side ()
-         [#s(clause:attr a expr)
-            #`(let-attributes ([a (wrap-user-code expr)])
-                #,k)]))]))
-
 (begin-for-syntax
  ;; convert-list-pattern : ListPattern id -> SinglePattern
  ;; Converts '() datum pattern at end of list to bind (cons stx index)
@@ -1017,7 +1006,7 @@ Conventions:
   (syntax-case stx ()
     [(_ a #s(rep:optional _ _ defaults) v)
      (with-syntax ([#s(attr name _ _) #'a]
-                   [(#s(clause:attr da de) ...) #'defaults])
+                   [(#s(action:bind da de) ...) #'defaults])
        (let ([default
               (for/or ([da (in-list (syntax->list #'(da ...)))]
                        [de (in-list (syntax->list #'(de ...)))])

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

@@ -24,11 +24,7 @@
          stxclass-commit?
          stxclass-delimit-cut?
          (struct-out rhs)
-         (struct-out variant)
+         (struct-out variant))
-         (struct-out clause:fail)
-         (struct-out clause:with)
-         (struct-out clause:attr)
-         (struct-out clause:do))
 
 (define (stxclass/s? x)
   (and (stxclass? x) (not (stxclass-splicing? x))))
@@ -54,10 +50,6 @@ A Variant is
 |#
 (define-struct variant (ostx attrs pattern definitions) #:prefab)
 
-#|
-SideClause is defined in rep-patterns
-|#
-
 ;; make-dummy-stxclass : identifier -> SC
 ;; Dummy stxclass for calculating attributes of recursive stxclasses.
 (define (make-dummy-stxclass name)
@@ -200,9 +192,6 @@ expressions are duplicated, and may be evaluated in different scopes.
 (define DeclEntry/c 
   (or/c den:lit? den:datum-lit? den:class? den:magic-class? den:parser? den:delayed?))
 
-(define SideClause/c
-  (or/c clause:fail? clause:with? clause:attr? clause:do?))
-
 ;; ct-phase = syntax, expr that computes absolute phase
 ;;   usually = #'(syntax-local-phase-level)
 (define ct-phase/c syntax?)
@@ -218,7 +207,6 @@ expressions are duplicated, and may be evaluated in different scopes.
 (provide/contract
  [DeclEnv/c contract?]
  [DeclEntry/c contract?]
- [SideClause/c contract?]
  [ct-phase/c contract?]
 
  [make-dummy-stxclass (-> identifier? stxclass?)]

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

@@ -72,17 +72,20 @@ A ListPattern is a subtype of SinglePattern; one of
 A ActionPattern is one of
   (action:cut)
   (action:fail stx stx)
-  (action:bind (listof clause:attr))
+  (action:bind IAttr Stx)
   (action:and (listof ActionPattern))
   (action:parse SinglePattern stx)
   (action:do (listof stx))
   (action:ord ActionPattern UninternedSymbol Nat)
   (action:post ActionPattern)
+
+A BindAction is (action:bind IAttr Stx)
+A SideClause is just an ActionPattern
 |#
 
 (define-struct action:cut () #:prefab)
 (define-struct action:fail (when message) #:prefab)
-(define-struct action:bind (clauses) #:prefab)
+(define-struct action:bind (attr expr) #:prefab)
 (define-struct action:and (patterns) #:prefab)
 (define-struct action:parse (pattern expr) #:prefab)
 (define-struct action:do (stmts) #:prefab)
@@ -122,11 +125,11 @@ A HeadPattern is one of
 
 #|
 An EllipsisHeadPattern is
-  (ehpat Base HeadPattern RepConstraint)
+  (ehpat (Listof IAttr) HeadPattern RepConstraint)
 
 A RepConstraint is one of
   (rep:once stx stx stx)
-  (rep:optional stx stx (listof clause:attr))
+  (rep:optional stx stx (listof BindAction))
   (rep:bounds nat/#f nat/#f stx stx stx)
   #f
 |#
@@ -136,19 +139,6 @@ A RepConstraint is one of
 (define-struct rep:optional (name over-message defaults) #:prefab)
 (define-struct rep:bounds (min max name under-message over-message) #:prefab)
 
-
-#|
-A SideClause is one of
-  (clause:fail stx stx)
-  (clause:with pattern stx (listof stx))
-  (clause:attr IAttr stx)
-  (clause:do (listof stx))
-|#
-(define-struct clause:fail (condition message) #:prefab)
-(define-struct clause:with (pattern expr definitions) #:prefab)
-(define-struct clause:attr (attr expr) #:prefab)
-(define-struct clause:do (stmts) #:prefab)
-
 (define (pattern? x)
   (or (pat:any? x)
       (pat:svar? x)
@@ -273,8 +263,8 @@ A SideClause is one of
      null]
     [(action:fail _ _)
      null]
-    [(action:bind clauses)
+    [(action:bind attr expr)
-     (map clause:attr-attr clauses)]
+     (list attr)]
     [(action:and ps)
      (append-iattrs (map pattern-attrs ps))]
     [(action:parse sp _)
@@ -485,3 +475,9 @@ A SideClause is one of
         [else
          (for/list ([p (in-list patterns)] [index (in-naturals)])
            (create-ord-pattern p group index))]))
+
+;; create-action:and : (Listof ActionPattern) -> ActionPattern
+(define (create-action:and actions)
+  (match actions
+    [(list action) action]
+    [_ (action:and actions)]))

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

@@ -372,13 +372,6 @@
            [pattern (combine-pattern+sides pattern0 sides splicing?)])
       (values rest pattern defs))))
 
-(define (side-clauses-attrss clauses)
-  (for/list ([c (in-list clauses)]
-             #:when (or (clause:with? c) (clause:attr? c)))
-    (if (clause:with? c)
-        (pattern-attrs (clause:with-pattern c))
-        (list (clause:attr-attr c)))))
-
 ;; parse-whole-pattern : stx DeclEnv boolean -> Pattern
 ;; kind is either 'main or 'with, indicates what kind of pattern declare affects
 (define (parse-whole-pattern stx decls [splicing? #f]
@@ -404,12 +397,9 @@
 (define (combine-pattern+sides pattern sides splicing?)
   (check-pattern
    (cond [(pair? sides)
-          (define group (gensym*))
           (define actions-pattern
             (create-post-pattern
-             (action:and
+             (create-action:and (ord-and-patterns sides (gensym*)))))
-              (for/list ([side (in-list sides)] [index (in-naturals)])
-                (create-ord-pattern (side-clause->pattern side) group index)))))
           (define and-patterns
             (ord-and-patterns (list pattern (pat:action actions-pattern (pat:any)))
                               (gensym*)))
@@ -417,19 +407,6 @@
                 [else (pat:and and-patterns)])]
          [else pattern])))
 
-;; side-clause->pattern : SideClause -> ActionPattern
-(define (side-clause->pattern side)
-  (match side
-    [(clause:fail condition message)
-     (action:fail condition message)]
-    [(clause:with wpat expr defs)
-     (let ([ap (action:parse wpat expr)])
-       (if (pair? defs) (action:and (list (action:do defs) ap)) ap))]
-    [(clause:attr attr expr)
-     (action:bind (list side))]
-    [(clause:do stmts)
-     (action:do stmts)]))
-
 ;; gensym* : -> UninternedSymbol
 ;; Like gensym, but with deterministic name from compilation-local counter.
 (define gensym*-counter 0)
@@ -1022,7 +999,7 @@
   (syntax-case stx ()
     [(_ clause ...)
      (let ([clauses (check-bind-clause-list #'(clause ...) stx)])
-       (action:bind clauses))]))
+       (create-action:and clauses))]))
 
 (define (parse-pat:fail stx decls)
   (syntax-case stx ()
@@ -1097,11 +1074,11 @@
     (parse*-optional-pattern stx decls h-optional-directive-table))
   (create-hpat:or
    (list head
-         (hpat:action (action:bind defaults)
+         (hpat:action (create-action:and defaults)
                       (hpat:seq (pat:datum '()))))))
 
 ;; parse*-optional-pattern : stx DeclEnv table
-;;                        -> (values Syntax HeadPattern IAttrs Stx Stx Defaults)
+;;                        -> (values Syntax HeadPattern IAttrs Stx Stx (Listof BindClause))
 (define (parse*-optional-pattern stx decls optional-directive-table)
   (syntax-case stx ()
     [(_ p . options)
@@ -1118,7 +1095,7 @@
               (options-select-value chunks '#:defaults #:default '())]
             [pattern-iattrs (pattern-attrs head)]
             [defaults-iattrs
-             (append-iattrs (side-clauses-attrss defaults))]
+             (append-iattrs (map pattern-attrs defaults))]
             [all-iattrs
              (union-iattrs (list pattern-iattrs defaults-iattrs))])
        (when (eq? (stxclass-lookup-config) 'yes)
@@ -1212,10 +1189,9 @@
       (parse-pattern-sides chunks2 decls))
     (define-values (decls3 defs)
       (decls-create-defs decls2))
-    (values rest decls3 defs (parse-pattern-sides chunks2 decls))))
+    (values rest decls3 defs sides)))
 
-;; parse-pattern-sides : (listof chunk) DeclEnv
+;; parse-pattern-sides : (listof chunk) DeclEnv -> (listof SideClause)
-;;                    -> (listof SideClause/c)
 ;; Invariant: decls contains only literals bindings
 (define (parse-pattern-sides chunks decls)
   (match chunks
@@ -1223,28 +1199,28 @@
      (wrong-syntax declare-stx
                    "#:declare can only appear immediately after pattern or #:with clause")]
     [(cons (list '#:role role-stx _) rest)
-     (wrong-syntax role-stx
+     (wrong-syntax role-stx "#:role can only appear immediately after #:declare clause")]
-                   "#:role can only appear immediately after #:declare clause")]
+    [(cons (list '#:fail-when fw-stx when-expr msg-expr) rest)
-    [(cons (list '#:fail-when fw-stx when-condition expr) rest)
+     (cons (action:fail when-expr msg-expr)
-     (cons (make clause:fail when-condition expr)
            (parse-pattern-sides rest decls))]
-    [(cons (list '#:fail-unless fu-stx unless-condition expr) rest)
+    [(cons (list '#:fail-unless fu-stx unless-expr msg-expr) rest)
-     (cons (make clause:fail #`(not #,unless-condition) expr)
+     (cons (action:fail #`(not #,unless-expr) msg-expr)
            (parse-pattern-sides rest decls))]
-    [(cons (list '#:when w-stx unless-condition) rest)
+    [(cons (list '#:when w-stx unless-expr) rest)
-     ;; Bleh: when is basically fail-unless without the msg argument
+     (cons (action:fail #`(not #,unless-expr) #'#f)
-     (cons (make clause:fail #`(not #,unless-condition) #'#f)
            (parse-pattern-sides rest decls))]
     [(cons (list '#:with with-stx pattern expr) rest)
      (let-values ([(decls2 rest) (grab-decls rest decls)])
        (let-values ([(decls2a defs) (decls-create-defs decls2)])
-         (cons (make clause:with (parse-whole-pattern pattern decls2a #:kind 'with) expr defs)
+         (cons (create-action:and
+                (list (action:do defs)
+                      (action:parse (parse-whole-pattern pattern decls2a #:kind 'with) expr)))
                (parse-pattern-sides rest decls))))]
     [(cons (list '#:attr attr-stx a expr) rest)
-     (cons (make clause:attr a expr)
+     (cons (action:bind a expr)
            (parse-pattern-sides rest decls))]
     [(cons (list '#:do do-stx stmts) rest)
-     (cons (make clause:do stmts)
+     (cons (action:do stmts)
            (parse-pattern-sides rest decls))]
     ['()
      '()]))
@@ -1470,7 +1446,7 @@
 (define (check-bind-clause clause ctx)
   (syntax-case clause ()
     [(attr-decl expr)
-     (make clause:attr (check-attr-arity #'attr-decl ctx) #'expr)]
+     (action:bind (check-attr-arity #'attr-decl ctx) #'expr)]
     [_ (raise-syntax-error #f "expected bind clause" ctx clause)]))
 
 (define (check-stmt-list stx ctx)