syntax/parse: add #:and and #:post side-clauses

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

@@ -165,7 +165,7 @@ One of @ref[~delimit-cut s] or @ref[~delimit-cut h]:
 
 One of @ref[~post s], @ref[~post h], or @ref[~post a]:
 @itemize[
-@item{@ref[~post a] if the subpattern is a @tech{proper @Apattern}}
+@item{@ref[~post a] if the subpattern is an @tech{@Apattern}}
 @item{@ref[~post h] if the subpattern is a @tech{proper @Hpattern}}
 @item{@ref[~post s] otherwise}
 ]

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

@@ -193,6 +193,8 @@ follows:
 
 @racketgrammar[pattern-directive
                (code:line #:declare pattern-id stxclass maybe-role)
+               (code:line #:post action-pattern)
+               (code:line #:and action-pattern)
                (code:line #:with syntax-pattern expr)
                (code:line #:attr attr-arity-decl expr)
                (code:line #:fail-when condition-expr message-expr)
@@ -239,6 +241,27 @@ pattern may be declared.
 ]
 }
 
+@specsubform[(code:line #:post action-pattern)]{
+
+Executes the given @tech{@Apattern} as a ``post-traversal check''
+after matching the main pattern. That is, the following are
+equivalent:
+@racketblock[
+_main-pattern #:post action-pattern
+_main-pattern #:and (~post action-pattern)
+(~and _main-pattern (~post action-pattern))
+]
+}
+
+@specsubform[(code:line #:and action-pattern)]{
+
+Like @racket[#:post] except that no @racket[~post] wrapper is
+added. That is, the following are equivalent:
+@racketblock[
+_main-pattern #:and action-pattern
+(~and _main-pattern action-pattern)
+]}
+
 @specsubform[(code:line #:with syntax-pattern stx-expr)]{
 
 Evaluates the @racket[stx-expr] in the context of all previous
@@ -254,6 +277,8 @@ implicitly converted to a syntax object. If the the conversion would
 produce @deftech{3D syntax}---that is, syntax that contains unwritable
 values such as procedures, non-prefab structures, etc---then an
 exception is raised instead.
+
+Equivalent to @racket[#:post (~parse syntax-pattern stx-expr)].
 }
 
 @specsubform[(code:line #:attr attr-arity-decl expr)]{
@@ -262,6 +287,8 @@ Evaluates the @racket[expr] in the context of all previous attribute
 bindings and binds it to the given attribute. The value of
 @racket[expr] need not be, or even contain, syntax---see
 @racket[attribute] for details.
+
+Equivalent to @racket[#:and (~bind attr-arity-decl expr)].
 }
 
 @specsubform[(code:line #:fail-when condition-expr message-expr)
@@ -276,12 +303,16 @@ object, it is indicated as the cause of the error.
 If the @racket[message-expr] produces a string it is used as the
 failure message; otherwise the failure is reported in terms of the
 enclosing descriptions.
+
+Equivalent to @racket[#:post (~fail #:when condition-expr message-expr)].
 }
 
 @specsubform[(code:line #:fail-unless condition-expr message-expr)
              #:contracts ([message-expr (or/c string? #f)])]{
 
 Like @racket[#:fail-when] with the condition negated.
+
+Equivalent to @racket[#:post (~fail #:unless condition-expr message-expr)].
 }
 
 @specsubform[(code:line #:when condition-expr)]{
@@ -290,6 +321,8 @@ Evaluates the @racket[condition-expr] in the context of all previous
 attribute bindings. If the value is @racket[#f], the matching process
 backtracks. In other words, @racket[#:when] is like
 @racket[#:fail-unless] without the message argument.
+
+Equivalent to @racket[#:post (~fail #:unless condition-expr #f)].
 }
 
 @specsubform[(code:line #:do [def-or-expr ...])]{
@@ -302,6 +335,8 @@ the expressions of subsequent patterns and clauses.
 There is currently no way to bind attributes using a @racket[#:do]
 block. It is an error to shadow an attribute binding with a definition
 in a @racket[#:do] block.
+
+Equivalent to @racket[#:and (~do def-or-expr ...)].
 }
 
 

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

@@ -416,6 +416,23 @@
        (check-equal? counter 5)
        (void)])))
 
+;; #:and, #:post side-clauses
+
+(test-case "#:and side-clause"
+  (check-exn #rx"non-decreasing"
+             (lambda ()
+               (syntax-parse #'(1 2)
+                 [(a b)
+                  #:and (~fail #:unless (> (syntax-e #'a) (syntax-e #'b)) "non-decreasing")
+                  (void)]))))
+(test-case "#:post side-clause"
+  (check-exn #rx"non-decreasing"
+             (lambda ()
+               (syntax-parse #'(1 2)
+                 [(a b)
+                  #:post (~fail #:unless (> (syntax-e #'a) (syntax-e #'b)) "non-decreasing")
+                  (void)]))))
+
 ;; == Lib tests
 
 ;; static

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

@@ -397,8 +397,7 @@
   (check-pattern
    (cond [(pair? sides)
           (define actions-pattern
-            (create-post-pattern
+            (create-action:and (ord-and-patterns sides (gensym*))))
-             (create-action:and (ord-and-patterns sides (gensym*)))))
           (define and-patterns
             (ord-and-patterns (list pattern (pat:action actions-pattern (pat:any)))
                               (gensym*)))
@@ -423,6 +422,13 @@
 (define (parse-head-pattern stx decls)
   (parse-*-pattern stx decls #t #f))
 
+;; parse-action-pattern : Stx DeclEnv -> ActionPattern
+(define (parse-action-pattern stx decls)
+  (define p (parse-*-pattern stx decls #f #t))
+  (unless (action-pattern? p)
+    (wrong-syntax stx "expected action pattern"))
+  p)
+
 (define ((make-not-shadowed? decls) id)
   ;; Returns #f if id is in literals/datum-literals list.
   ;; Conventions to not shadow pattern-form bindings, under the
@@ -1213,23 +1219,29 @@
     [(cons (list '#:role role-stx _) rest)
      (wrong-syntax role-stx "#:role can only appear immediately after #:declare clause")]
     [(cons (list '#:fail-when fw-stx when-expr msg-expr) rest)
-     (cons (action:fail when-expr msg-expr)
+     (cons (create-post-pattern (action:fail when-expr msg-expr))
            (parse-pattern-sides rest decls))]
     [(cons (list '#:fail-unless fu-stx unless-expr msg-expr) rest)
-     (cons (action:fail #`(not #,unless-expr) msg-expr)
+     (cons (create-post-pattern (action:fail #`(not #,unless-expr) msg-expr))
            (parse-pattern-sides rest decls))]
     [(cons (list '#:when w-stx unless-expr) rest)
-     (cons (action:fail #`(not #,unless-expr) #'#f)
+     (cons (create-post-pattern (action:fail #`(not #,unless-expr) #'#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 (create-action:and
+         (list* (action:do defs)
-                (list (action:do defs)
+                (create-post-pattern
-                      (action:parse (parse-whole-pattern pattern decls2a #:kind 'with) expr)))
+                 (action:parse (parse-whole-pattern pattern decls2a #:kind 'with) expr))
-               (parse-pattern-sides rest decls))))]
+                (parse-pattern-sides rest decls))))]
     [(cons (list '#:attr attr-stx a expr) rest)
-     (cons (action:bind a expr)
+     (cons (action:bind a expr) ;; no POST wrapper, cannot fail
+           (parse-pattern-sides rest decls))]
+    [(cons (list '#:post post-stx pattern) rest)
+     (cons (create-post-pattern (parse-action-pattern pattern decls))
+           (parse-pattern-sides rest decls))]
+    [(cons (list '#:and and-stx pattern) rest)
+     (cons (parse-action-pattern pattern decls) ;; no POST wrapper
            (parse-pattern-sides rest decls))]
     [(cons (list '#:do do-stx stmts) rest)
      (cons (action:do stmts)
@@ -1596,6 +1608,8 @@
         (list '#:when check-expression)
         (list '#:with check-expression check-expression)
         (list '#:attr check-attr-arity check-expression)
+        (list '#:and check-expression)
+        (list '#:post check-expression)
         (list '#:do check-stmt-list)))
 
 ;; fail-directive-table