Implemented partial order with ~order-point, order-point< and order-point>. Fixed bug with unwanted scope which prevented the attributes from being visible when a mixin was used directly within syntax-parse.

main.rkt

@@ -7,7 +7,12 @@
          "private/global.rkt"
          "private/optional.rkt"
          "private/mixin.rkt"
-         (for-template "private/define-syntax+simple-api.rkt"))
+         (for-template "private/define-syntax+simple-api.rkt")
+         syntax/parse)
+
+;; from syntax/parse, so that define-eh-alternative-mixin can recognize uses of
+;; (pattern …)
+(provide pattern)
 
 (provide #;define-splicing-syntax-class-with-eh-mixins
          #;define-syntax-class-with-eh-mixins
@@ -15,6 +20,9 @@
          (expander-out eh-mixin)
          ~seq-no-order
          ~no-order
+         ~order-point
+         order-point<
+         order-point>
          ~mixin
          ~post-check
          ~post-fail

private/no-order.rkt

@@ -33,6 +33,9 @@
 (provide define-eh-alternative-mixin
          ~seq-no-order
          ~no-order
+         ~order-point
+         order-point<
+         order-point>
          (expander-out eh-mixin))
 
 (define-expander-type eh-mixin)
@@ -44,7 +47,8 @@
      #`(begin
          (define-eh-mixin-expander name
            (λ (_)
-             (quote-syntax (~or pat ...))))
+             (syntax-local-syntax-parse-pattern-introduce
+              (quote-syntax (~or pat ...)))))
          #,@(if (attribute splicing-name)
                 #'((define-splicing-syntax-class splicing-name
                      (pattern {~seq-no-order {name}})))
@@ -57,6 +61,15 @@
      (apply append (stx-map inline-or #'rest))]
     [x (list #'x)]))
 
+(define-for-syntax parse-seq-order-sym-introducer (make-syntax-introducer))
+
+(define-for-syntax (fix-disappeared-uses)
+  ;; Fix for https://github.com/racket/racket/issues/1452
+  (let ([dis (current-recorded-disappeared-uses)])
+    #`{~do #,(with-disappeared-uses
+              (record-disappeared-uses dis)
+              #'(void))}))
+
 ;; TODO: ~seq-no-order should also be a eh-mixin-expander, so that when there
 ;; are nested ~seq-no-order, the ~post-fail is caught by the nearest
 ;; ~seq-no-order.
@@ -80,12 +93,11 @@
            (define (add-to-post-groups! . v)
              (set! post-groups-acc (cons v post-groups-acc)))
            ;; expand EH alternatives:
-           (define alts
            (parameterize ([eh-post-accumulate add-to-post!]
                           [eh-post-group add-to-post-groups!]
                           [clause-counter increment-counter])
-               ;(inline-or
+             (define alts
-               (expand-all-eh-mixin-expanders #'(~or pat ...))))
+               (expand-all-eh-mixin-expanders #'(~or pat ...)))
              (define post-group-bindings
                (for/list ([group (group-by car
                                            post-groups-acc
@@ -99,13 +111,53 @@
                  (define/with-syntax f (second (car group)))
                  #`[name (f . #,(map (λ (i) #`(attribute #,(third i)))
                                      group))]))
+             (define/with-syntax whole-clause (get-new-clause!))
+             (define/with-syntax parse-seq-order-sym-id
+               (datum->syntax (parse-seq-order-sym-introducer
+                               (syntax-local-introduce #'here))
+                              'parse-seq-order-sym))
              #`(~delimit-cut
-              (~and (~seq #,alts (... ...)) ;;(~or . #,alts)
+                (~and #,(fix-disappeared-uses)
+                      {~seq whole-clause (… …)}
+                      {~do (define parse-seq-order-sym-id
+                             (gensym 'parse-seq-order))}
+                      {~parse ({~seq #,alts (… …)})
+                              #`#,(for/list
+                                      ([xi (in-syntax #'(whole-clause (… …)))]
+                                       [i (in-naturals)])
+                                    ;; Add a syntax property before parsing,
+                                    ;; to track the position of matched elements
+                                    ;; using ~order-point
+                                    (syntax-property xi
+                                                     parse-seq-order-sym-id
+                                                     i))}
                       ~!
                       (~bind #,@post-group-bindings)
-                    #,@post-acc))))]))))
+                      #,@post-acc)))))]))))
 
 (define-syntax ~no-order
   (pattern-expander
    (λ/syntax-case (_ . rest) ()
      #'({~seq-no-order . rest}))))
+
+(define-eh-mixin-expander ~order-point
+  (λ (stx)
+    (define/with-syntax clause-point (get-new-clause!))
+    (define/with-syntax parse-seq-order-sym-id
+      (datum->syntax (parse-seq-order-sym-introducer
+                      (syntax-local-introduce #'here))
+                     'parse-seq-order-sym))
+    (syntax-case stx ()
+      [(_ point-name pat …)
+       #'(~and (~seq clause-point _ (… …))
+               (~bind [point-name (syntax-property #'clause-point
+                                                   parse-seq-order-sym-id)])
+               {~seq pat …})])))
+
+(define-syntax-rule (order-point< a b)
+  (and (attribute a) (attribute b)
+       (< (attribute a) (attribute b))))
+
+(define-syntax-rule (order-point> a b)
+  (and (attribute a) (attribute b)
+       (> (attribute a) (attribute b))))

private/parameters.rkt

@@ -30,6 +30,8 @@
 
 (define-for-syntax clause-counter (make-parameter #f))
 (define-for-syntax (get-new-clause!)
+  (unless clause-counter
+    (error "Use get-new-clause! within (parameterize ([clause-counter …]) …)"))
   (datum->syntax #'here
                  ;; keep the spaces, they allow us to recognize clauses later.
                  (string->symbol (format " -clause-~a " ((clause-counter))))))

test/test-order-point.rkt

@@ -0,0 +1,44 @@
+#lang racket
+
+(require syntax/parse
+         extensible-parser-specifications
+         phc-toolkit/untyped
+         rackunit)
+
+(define-syntax-class abc-order
+  (pattern
+   {~no-order
+    {~optional {~order-point a-point #:a
+                 {~post-fail "#:a must appear after #:b"
+                             #:when (order-point> a-point b-point)}}}
+    {~optional {~order-point b-point #:b}}
+    {~optional {~order-point c-point #:c}}}))
+
+(define-syntax-rule (check-parse-abc stx)
+  (check-true (syntax-parse stx
+                [:abc-order #t]
+                [_ #f])))
+
+(define-syntax-rule (check-fail-abc stx exn)
+  (check-exn exn
+             (λ ()
+               (syntax-parse stx
+                 [:abc-order 'ok]))))
+
+(check-parse-abc #'(#:a))
+(check-parse-abc #'(#:b))
+(check-parse-abc #'(#:c))
+(check-parse-abc #'(#:a #:b))
+(check-parse-abc #'(#:c #:a))
+(check-parse-abc #'(#:a #:c))
+(check-parse-abc #'(#:c #:b))
+(check-parse-abc #'(#:b #:c))
+(check-parse-abc #'(#:c #:a #:b))
+(check-parse-abc #'(#:a #:c #:b))
+(check-parse-abc #'(#:a #:b #:c))
+(check-fail-abc #'(#:b #:a) #px"#:a must appear after #:b")
+(check-fail-abc #'(#:c #:b #:a) #px"#:a must appear after #:b")
+(check-fail-abc #'(#:b #:c #:a) #px"#:a must appear after #:b")
+(check-fail-abc #'(#:b #:a #:c) #px"#:a must appear after #:b")
+(check-fail-abc #'(#:a #:a) #px"unexpected term")
+(check-fail-abc #'(#:c #:c) #px"unexpected term")

test/test-scopes-mixin-in-syntax-parser.rkt

@@ -0,0 +1,21 @@
+#lang racket
+(require phc-toolkit/untyped
+         extensible-parser-specifications
+         syntax/parse
+         rackunit)
+
+(define-eh-alternative-mixin props-mixin
+  (pattern
+   (~optional (~seq #:foo bar))))
+
+(define test
+  (syntax-parser
+    [(~no-order {~mixin props-mixin})
+     (attribute bar)]))
+
+(test-equal?
+ "Without the bugfix, the pattern variable \"bar\" above had the wrong scopes,
+and couldn't be used with (attribute bar), and #'bar just gave #'bar instead of
+producing #'42"
+ (syntax-e (test #'(#:foo bar)))
+ 42)