Works, but needs cleanup for the ~optional.

structure-options2.rkt

@@ -27,15 +27,53 @@
   (pattern (~optional (~seq #:? predicate:id)
                       #:name "#:? predicate")))
 
-(define-and-for-syntax instance-no-values-error
+(define-and-for-syntax no-values-err
   (~a "The #:instance keyword implies the use of [field value],"
       " [field : type value] or [field value : type]."))
+
+(define-and-for-syntax values-err
+  (~a "The #:builder keyword implies the use of [field], field"
+      " or [field : type]."))
+
+(define-and-for-syntax empty-err
+  (~a "If no fields are specified, then either #:builder or #:instance"
+      " must be present"))
+
 (define-eh-alternative-mixin structure-kw-fields
-  (pattern (~once (~seq [field:id] ...
+  (pattern
-                        (~post-fail instance-no-values-error
+   (~optional (~and
-                                    #:when (and (attribute instance)
+               (~seq clause42 ...)
-                                                (not (stx-null? #'(field ...))))))
+               ;; can't use #f, because of the bug
-                  #:name "[field]")))
+               ;; https://github.com/racket/racket/issues/1437
+               (~bind [clause42-match? 1])
+               (~or (~seq (~or-bug [field:id] field:id) …+
+                          (~post-fail no-values-err #:when (attribute instance)))
+                    (~seq [field:id : type] …+
+                          (~post-fail no-values-err #:when (attribute instance)))
+                    (~seq [field:id value:expr] …+
+                          (~post-fail values-err #:when (attribute builder)))
+                    (~seq (~or-bug [field:id value:expr : type]
+                                   [field:id : type value:expr])
+                          …+
+                          (~post-fail values-err #:when (attribute builder)))))
+              #:defaults ([(field 1) #'()]
+                          [(clause42 1) #'()]
+                          [clause42-match?
+                           (begin (syntax-parse #'dummy
+                                    [(~and dummy
+                                           (~post-check (~fail #:when
+                                                               (and (= (attribute clause42-match?) 0)
+                                                                    (and (not (attribute builder))
+                                                                         (not (attribute instance))))
+                                                               empty-err)))
+                                     #'()])
+                                  0)])
+              #;(~post-fail empty-err
+                            #:when (and (not (attribute builder))
+                                        (not (attribute instance))))
+              #:name (~a "field or [field] or [field : type] for #:builder,"
+                         " [field value] or [field : type value]"
+                         " or [field value : type] for #:instance"))))
 
 (define-eh-alternative-mixin structure-kw-all
   (pattern (~or (structure-kw-instance-or-builder-mixin)
@@ -45,28 +83,9 @@
 ;; ---------
 
 (define-splicing-syntax-class structure-kws
-  (pattern #;(~no-order (structure-kw-all-mixin))
+  (pattern (~no-order (structure-kw-all-mixin))))
-           (~delimit-cut
-            (~and
-             (~seq
-              (~or
-               (~optional
-                (~and
-                 instance-or-builder
-                 (~or (~and instance #:instance) (~and builder #:builder)))
-                #:name
-                "either #:instance or #:builder")
-               (~optional (~seq #:? predicate:id) #:name "#:? predicate")
-               (~optional (~seq (field:id) ...+ (~bind [clause178673 #t]))
-                          #:name "[field]"))
-              ...)
-             ~!
-             (~fail
-              #:when
-              (and (attribute clause178673)
-                   (and (attribute instance)))
-              instance-no-values-error)))))
 
+#|
 (check-equal? (syntax->datum
                (syntax-parse #'(#:instance #:? p)
                  [(:structure-kws) #'(instance instance-or-builder predicate)]))
@@ -77,24 +96,34 @@
                  [(k:structure-kws) #'(k.builder k.instance-or-builder)]))
               '(#:builder #:builder))
 
-(check-equal? (syntax->datum
+(test-exn
+ "Check that () is rejected, as it has neither #:instance nor #:builder"
+ (regexp (regexp-quote empty-err))
+ (λ ()
    (syntax-parse #'()
-                 [(:structure-kws) #'()]))
+     [(:structure-kws) #'()])))
-              '())
 
-;; This one is appropriately rejected :)
+(test-exn
-(check-exn (regexp (regexp-quote instance-no-values-error))
+ "Check that (#:instance [f1] [f2]) is rejected, as #:instance conflicts with
+builder-style field declarations"
+ (regexp (regexp-quote no-values-err))
  (λ ()
    (syntax-parse #'(#:instance [f1] [f2])
      [(:structure-kws) #'([field ...] instance)])))
+|#
 
 (check-equal? (syntax->datum
                (syntax-parse #'(#:builder #:? p [f1] [f2])
                  [(:structure-kws) #'([field ...] builder)]))
               '([f1 f2] #:builder))
 
+(check-equal?  (syntax-parse #'([f1] [f2]); #:? p 
+                 [(:structure-kws) (cons (attribute builder)
+                                         (syntax->datum #'([field ...])))])
+               '(#f [f1 f2]))
+
 ;; This one is appropriately rejected
-(check-exn #px"unexpected term"
+#;(check-exn #px"unexpected term"
              (λ ()
-             (syntax-parse #'(#:a)
+               (syntax-parse #'(#:instance #:a)
                  [(:structure-kws) 'err])))

structure-options2b.rkt

@@ -16,7 +16,8 @@
  (expander-out eh-mixin)
  ~no-order
  ~post-check
- ~post-fail)
+ ~post-fail
+ ~nop)
 
 ;; ------------
 ;; eh-mixin — TODO: move to phc-toolkit once the PR #7 for reqprov in
@@ -25,7 +26,7 @@
 (define-expander-type eh-mixin)
 
 (define-for-syntax eh-post-accumulate (make-parameter #f))
-#;(define-for-syntax current-no-order-clause (make-parameter #f))
+(define-for-syntax clause-counter (make-parameter #f))
 
 (define-syntax define-eh-alternative-mixin
   (syntax-parser
@@ -49,28 +50,8 @@
      (apply append (stx-map inline-or #'rest))]
     [x (list #'x)]))
 
-#;(define-for-syntax (expand-no-order-clauses/tree x)
+;; TODO: ~no-order should also be a eh-mixin-expander, so that when there are
-    (cond
+;; nested ~no-order, the ~post-fail is caught by the nearest ~no-order.
-      [(syntax? x) (datum->syntax x
-                                  (expand-no-order-clauses/tree (syntax-e x))
-                                  x
-                                  x)]))
-
-#;(define-for-syntax (expand-no-order-clauses stx)
-    (syntax-case stx (~or)
-      [(~or pat ...) (append-map expand-no-order-clauses
-                                 (syntax->list #'(pat ...)))]
-      [(exp . args)
-       (let ([slv (syntax-local-value #'exp (λ _ #f))])
-         (and slv (expander? slv) (eh-mixin-expander? slv)))
-       (let* ([slv (syntax-local-value #'exp (λ _ #f))]
-              [transformer (expander-transformer slv)])
-         (expand-no-order-clauses (transformer stx)))]
-      [pat (parameterize ([current-no-order-clause #`#,(gensym 'clause)])
-             (list (expand-all-eh-mixin-expanders #'pat)))]))
-
-;; TODO: ~no-order should also be a eh-mixin-expander, so that nested ~post-fail
-;; are caught 
 (define-syntax ~no-order
   (pattern-expander
    (λ (stx)
@@ -79,17 +60,25 @@
         ((λ (x) (pretty-write (syntax->datum x)) (newline) x)
          (let ()
            (define acc '())
+           (define counter 0)
+           (define (increment-counter)
+             (begin0 counter
+                     (set! counter (add1 counter))))
            (define (add-to-acc p)
-             (set! acc (cons p #;(replace-context #'self p) acc)))
+             (set! acc (cons p acc)))
            (define alts
-             (parameterize ([eh-post-accumulate add-to-acc])
+             (parameterize ([eh-post-accumulate add-to-acc]
-               #;(expand-no-order-clauses #'(~or pat ...))
+                            [clause-counter increment-counter])
                (inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
            #`(~delimit-cut
               (~and (~seq (~or . #,alts) (... ...))
                     ~!
                     #,@acc))))]))))
 
+(define-syntax ~nop
+  (pattern-expander
+   (λ/syntax-case (_) () #'(~do))))
+
 (define-for-syntax (eh-post-accumulate! name p)
   (unless (eh-post-accumulate)
     (raise-syntax-error
@@ -107,7 +96,7 @@
       [(_ post)
        (begin
          (eh-post-accumulate! '~post-check #'post)
-         #'(~do))])))
+         #'(~nop))])))
 
 (define-eh-mixin-expander ~post-fail
   (let ()
@@ -115,18 +104,14 @@
       (syntax-case stx ()
         [(_ message #:when condition)
          (begin
-           #;(unless (current-no-order-clause)
+           (define/with-syntax clause-present
-               (raise-syntax-error
+             (string->symbol (format "clause~a" ((clause-counter)))))
-                '~post-fail
-                "~post-fail cannot be used directly as an ellipsis-head pattern"))
-           (define/with-syntax clause-present (gensym 'clause))
            (eh-post-accumulate!
             '~post-fail
-            #`(~fail #:when (and (attribute (~bind [clause-present #t])
+            #`(~fail #:when (and (attribute clause-present)
-                                            #;#,(current-no-order-clause))
                                  condition)
                      message))
-           #'(~do))]
+           #'(~bind [clause-present #t]))]
         [(self #:when condition message)
          (parse #'(self message #:when condition))]))
     parse))