syntax/parse: fix opaque head patterns and splicing syntax classes

closes PR 12537

collects/syntax/parse/private/parse.rkt

@@ -267,7 +267,7 @@ Conventions:
                   ;; Update the prompt, if required
                   ;; FIXME: can be optimized away if no cut immediately within variants...
                   (with-maybe-delimit-cut delimit-cut?
-                    (parse:variants x cx relsattrs variants splicing?
+                    (parse:variants x cx relsattrs variants splicing? transparent?
                                     pr es success cp0 commit?))))))))]))
 
 ;; (with-maybe-delimit-cut bool expr)
@@ -281,27 +281,33 @@ Conventions:
 ;; (parse:variants x cx relsattrs variants splicing? pr es success cp0) : expr[Ans]
 (define-syntax (parse:variants stx)
   (syntax-case stx ()
-    [(parse:variants x cx relsattrs () splicing? pr es success cp0 commit?)
+    [(parse:variants x cx relsattrs () splicing? transparent?
+                     pr es success cp0 commit?)
      ;; Special case: no variants
      #'(fail (failure pr es))]
-    [(parse:variants x cx relsattrs (variant ...) splicing? pr es success cp0 commit?)
+    [(parse:variants x cx relsattrs (variant ...) splicing? transparent?
-     #'(try (parse:variant x cx relsattrs variant splicing? pr es success cp0 commit?) ...)]))
+                     pr es success cp0 commit?)
+     #'(try (parse:variant x cx relsattrs variant splicing? transparent?
+                           pr es success cp0 commit?) ...)]))
 
 ;; (parse:variant x cx relsattrs variant splicing? pr es success cp0) : expr[Ans]
 (define-syntax (parse:variant stx)
   (syntax-case stx ()
-    [(parse:variant x cx relsattrs variant #f pr es success cp0 commit?)
+    [(parse:variant x cx relsattrs variant #f _ pr es success cp0 commit?)
      (with-syntax ([#s(variant _ _ pattern (def ...)) #'variant])
        #`(let ()
            def ...
            (parse:S x cx pattern pr es
-                    (variant-success relsattrs variant () success cp0 commit?))))]
+                    (variant-success relsattrs variant
-    [(parse:variant x cx relsattrs variant #t pr es success cp0 commit?)
+                                     ()
+                                     success cp0 commit?))))]
+    [(parse:variant x cx relsattrs variant #t transparent? pr es success cp0 commit?)
      (with-syntax ([#s(variant _ _ pattern (def ...)) #'variant])
        #`(let ()
            def ...
            (parse:H x cx rest-x rest-cx rest-pr pattern pr es
-                    (variant-success relsattrs variant (rest-x rest-cx rest-pr)
+                    (variant-success relsattrs variant
+                                     (rest-x rest-cx (if 'transparent? rest-pr (ps-pop-opaque rest-pr)))
                                      success cp0 commit?))))]))
 
 ;; (variant-success relsattrs variant (also:id ...) success bool) : expr[Ans]
@@ -666,8 +672,11 @@ Conventions:
     [(parse:H x cx rest-x rest-cx rest-pr head pr es k)
      (syntax-case #'head ()
        [#s(hpat:describe _ description transparent? pattern)
-        #`(let ([es (cons (expect:thing description transparent?) es)])
+        #`(let ([es* (cons (expect:thing description transparent?) es)]
-            (parse:H x cx rest-x rest-cx rest-pr pattern pr es k))]
+                [pr (if 'transparent? pr (ps-add-opaque pr))])
+            (parse:H x cx rest-x rest-cx rest-pr pattern pr es*
+                     (let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))])
+                       k)))]
        [#s(hpat:var _attrs name parser argu (nested-a ...) attr-count commit?)
         (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
                       [(name-attr ...)

collects/syntax/parse/private/runtime-progress.rkt

@@ -14,6 +14,7 @@
          ps-add-opaque
 
          invert-ps
+         ps-pop-opaque
          ps->stx+index
          ps-context-syntax
          ps-difference
@@ -152,6 +153,14 @@ Interpretation: Inner PS structures are applied first.
 (define (invert-ps ps)
   (reverse (ps-truncate-opaque ps)))
 
+;; ps-pop-opaque : PS -> IPS
+(define (ps-pop-opaque ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons 'opaque ps*))
+     (cons n ps*)]
+    [(cons 'opaque ps*)
+     ps*]
+    [_ (error 'ps-pop-opaque "opaque marker not found: ~e" ps)]))
 
 ;; ==== Failure ====
 
@@ -202,7 +211,7 @@ The *-marked variants can only occur at the top of the stack.
          expect->sexpr)
 
 (define (failureset->sexpr fs)
-  (let ([fs (flatten fs null)])
+  (let ([fs (flatten fs)])
     (case (length fs)
       ((1) (failure->sexpr (car fs)))
       (else `(union ,@(map failure->sexpr fs))))))

collects/syntax/parse/private/runtime-report.rkt

@@ -5,7 +5,8 @@
                     syntax-patterns-fail)
          "kws.rkt")
 (provide syntax-patterns-fail
-         current-failure-handler)
+         current-failure-handler
+         maximal-failures)
 
 #|
 Note: there is a cyclic dependence between residual.rkt and this module,

collects/tests/stxparse/test.rkt

@@ -395,3 +395,67 @@
                 [(_ 1 ... . after-ones:expr)
                  (syntax? #'after-ones)]))
   (void))
+
+(begin
+  ;; from samth 2/4/2012
+  ;; opaque head patterns used to propagate progress *with opaque marker* to tail
+  (test-case "opaque H, ok"
+    (check-equal? (syntax-parse #'(a b)
+                    [((~describe #:opaque "x" (~seq x)) y:id) 'ok])
+                  'ok))
+  (test-case "opaque splicing stxclass, ok"
+    (check-equal? (let ()
+                    (define-splicing-syntax-class foo
+                      #:opaque
+                      #:description "foo"
+                      (pattern (~seq x)))
+                    (syntax-parse #'(a b)
+                      [(f:foo y:id) 'ok]))
+                  'ok))
+
+  (test-case "opaque empty H, ok"
+    (check-equal? (syntax-parse #'(b)
+                    [((~describe #:opaque "x" (~seq)) y:id) 'ok])
+                  'ok))
+  (test-case "opaque empty splicing stxclass, ok"
+    (check-equal? (let ()
+                    (define-splicing-syntax-class foo
+                      #:opaque
+                      #:description "foo"
+                      (pattern (~seq)))
+                    (syntax-parse #'(b)
+                      [(f:foo y:id) 'ok]))
+                  'ok))
+
+  (tcerr "extent of opaque in H pattern"
+    (syntax-parse #'(a b)
+      [((~describe #:opaque "x" (~seq x)) y:nat) (void)])
+    (not #rx"expected x") ;; y:nat was incorrectly considered part of opaque region
+    #rx"expected exact-nonnegative-integer")
+  (tcerr "extent of opaque in splicing stxclass"
+    (let ()
+      (define-splicing-syntax-class foo
+        #:description "foo"
+        #:opaque
+        (pattern (~seq x)))
+      (syntax-parse #'(a b)
+        [(f:foo n:nat) (void)]))
+    (not #rx"expected foo") ;; y:nat was incorrectly considered part of opaque region
+    #rx"expected exact-nonnegative-integer")
+
+  (tcerr "extent of opaque in empty H pattern"
+    (syntax-parse #'(b)
+      [((~describe #:opaque "x" (~seq)) y:nat) (void)])
+    (not #rx"expected x") ;; y:nat was incorrectly considered part of opaque region
+    #rx"expected exact-nonnegative-integer")
+  (tcerr "extent of opaque in empty splicing stxclass"
+    (let ()
+      (define-splicing-syntax-class foo
+        #:description "foo"
+        #:opaque
+        (pattern (~seq)))
+      (syntax-parse #'(b)
+        [(f:foo n:nat) (void)]))
+    (not #rx"expected foo") ;; y:nat was incorrectly considered part of opaque region
+    #rx"expected exact-nonnegative-integer")
+  )