WIP on extensible structure options.

structure-options.rkt

@@ -0,0 +1,135 @@
+#lang racket
+
+(require syntax/parse
+         syntax/parse/experimental/eh
+         generic-syntax-expanders
+         syntax/stx
+         (for-syntax syntax/parse
+                     racket/syntax
+                     syntax/stx
+                     racket/pretty)) ;; debug
+
+;; ------------
+;; eh-mixin — TODO: move to phc-toolkit once the PR #7 for reqprov in
+;; generic-syntax-expander is merged. Look for "End eh-mixin" below for the end.
+
+(define-expander-type eh-mixin)
+
+(begin-for-syntax
+  (define eh-post-accumulate (make-parameter #f)))
+
+(define-syntax define-eh-alternative-mixin
+  (syntax-parser
+    [(_ name ((~literal pattern) pat) ... (~optional (~seq #:post post)))
+     (let ()
+       (define/with-syntax mixin (format-id #'name "~a-mixin" #'name))
+       ;(display "post:") (displayln (attribute post))
+       #`(begin
+           (define-eh-mixin-expander mixin
+             (λ (_)
+               #,@(if (attribute post)
+                      #'((unless (eh-post-accumulate)
+                           (raise-syntax-error
+                            'define-eh-alternative-mixin
+                            "#:post used outside of ~no-order"))
+                         (eh-post-accumulate (quote-syntax post)))
+                      #'())
+               (quote-syntax (~or pat ...))))
+           #;(define-eh-alternative-set name
+               #,@(stx-map (λ (p)
+                             #`(pattern #,(expand-all-eh-mixin-expanders p)))
+                           #'(pat ...)))))]))
+
+(define-for-syntax (define-?-syntax-class-with-eh-mixins original-form)
+  (syntax-parser
+    [(_ signature {~and opts {~not ({~literal pattern} . _)}} ...
+        ({~literal pattern} pat . pat-opts) ...)
+     ;((λ (x) (pretty-write (syntax->datum x)) x)
+     #`(#,original-form
+        signature opts ...
+        #,@(stx-map (λ (p po)
+                      #`(pattern #,(expand-all-eh-mixin-expanders p) . #,po))
+                    #'(pat ...)
+                    #'(pat-opts ...)))]))
+
+(define-syntax define-splicing-syntax-class-with-eh-mixins
+  (define-?-syntax-class-with-eh-mixins #'define-splicing-syntax-class))
+
+(define-syntax define-syntax-class-with-eh-mixins
+  (define-?-syntax-class-with-eh-mixins #'define-syntax-class))
+
+
+
+(provide define-splicing-syntax-class-with-eh-mixins
+         define-syntax-class-with-eh-mixins
+         define-eh-alternative-mixin
+         (expander-out eh-mixin))
+
+;; End eh-mixin
+;; ------------
+
+(define-eh-alternative-mixin structure-kw-instance-or-builder
+  (pattern (~optional (~and instance-or-builder
+                            (~or (~and instance #:instance)
+                                 (~and builder #:builder)))
+                      #:name "either #:instance or #:builder")))
+
+(define-eh-alternative-mixin structure-kw-predicate
+  (pattern (~optional (~seq #:? predicate:id)
+                      #:name "#:? predicate")))
+
+(define-eh-alternative-mixin structure-kw-fields
+  (pattern (~once (~seq [field:id] ...)
+                  #:name "[field]"))
+  #:post (~fail #:when (and (attribute instance)
+                            (not (stx-null? #'(field ...))))))
+
+(define-eh-alternative-mixin structure-kw-all
+  (pattern (~or (structure-kw-instance-or-builder-mixin)
+                (structure-kw-predicate-mixin)
+                #;(structure-kw-fields-mixin))))
+
+
+(define-splicing-syntax-class-with-eh-mixins structure-kws
+  (pattern (~seq (structure-kw-all-mixin) ...)))
+
+#;(define-splicing-syntax-class
+    structure-kws
+    (pattern
+     (~and
+      (~seq
+       (~or
+        (~or
+         (~or
+          (~optional
+           (~and
+            instance-or-builder
+            (~or (~and instance #:instance) (~and builder #:builder)))
+           #:name
+           "either #:instance or #:builder"))
+         (~or (~optional (~seq #:? predicate:id)
+                         #:name "#:? predicate"))
+         (~or (~once (~and (~seq (field:id) ...))
+                     #:name "[field] …"))))
+       ...)
+      (~fail #:when (and (attribute instance)
+                         (not (stx-null? #'(field ...))))))))
+
+#;(begin
+    (syntax-parse #'(#:instance #:? p)
+      [(:structure-kws) #'(instance instance-or-builder predicate)])
+
+    (syntax-parse #'(#:builder)
+      [(k:structure-kws) #'(k.builder k.instance-or-builder)])
+
+    (syntax-parse #'()
+      [(:structure-kws) #'()])
+
+    (syntax-parse #'(#:instance #:? p [f1] [f2])
+      [(:structure-kws) #'([field ...] instance)])
+
+    (syntax-parse #'(#:builder [f1] [f2])
+      [(:structure-kws) #'([field ...] builder)]))
+
+#;(syntax-parse #'(#:a)
+    [(:structure-kws) 'err])

structure-options2.rkt

@@ -0,0 +1,85 @@
+#lang racket
+
+(require "structure-options2b.rkt")
+
+
+(define-eh-alternative-mixin structure-kw-instance-or-builder
+  (pattern (~optional (~and instance-or-builder
+                            (~or (~and instance #:instance)
+                                 (~and builder #:builder)))
+                      #:name "either #:instance or #:builder")))
+
+(define-eh-alternative-mixin structure-kw-predicate
+  (pattern (~optional (~seq #:? predicate:id)
+                      #:name "#:? predicate")))
+
+(define-eh-alternative-mixin structure-kw-fields
+  (pattern (~once (~seq [field:id] ...)
+                  #:name "[field]"))
+  #:post (~fail #:when (and (attribute instance)
+                            (not (stx-null? #'(field ...))))))
+
+(define-eh-alternative-mixin structure-kw-all
+  (pattern (~or (structure-kw-instance-or-builder-mixin)
+                (structure-kw-predicate-mixin)
+                (structure-kw-fields-mixin))))
+
+
+#;(define-splicing-syntax-class-with-eh-mixins structure-kws
+    (pattern (~no-order (structure-kw-all-mixin) ...)))
+(define-splicing-syntax-class structure-kws
+  #;(pattern (~no-order (structure-kw-all-mixin)))
+  (pattern (~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")
+              (~once (~seq (field:id) ...) #:name "[field]"))
+             ...)
+            (~fail #:when (and (attribute instance) (not (stx-null? #'(field ...))))))))
+
+#;(define-splicing-syntax-class
+    structure-kws
+    (pattern
+     (~and
+      (~seq
+       (~or
+        (~or
+         (~or
+          (~optional
+           (~and
+            instance-or-builder
+            (~or (~and instance #:instance) (~and builder #:builder)))
+           #:name
+           "either #:instance or #:builder"))
+         (~or (~optional (~seq #:? predicate:id)
+                         #:name "#:? predicate"))
+         (~or (~once (~and (~seq (field:id) ...))
+                     #:name "[field] …"))))
+       ...)
+      (~fail #:when (and (attribute instance)
+                         (not (stx-null? #'(field ...))))))))
+
+#;(begin
+    (syntax-parse #'(#:instance #:? p)
+      [(:structure-kws) #'(instance instance-or-builder predicate)])
+
+    (syntax-parse #'(#:builder)
+      [(k:structure-kws) #'(k.builder k.instance-or-builder)])
+
+    (syntax-parse #'()
+      [(:structure-kws) #'()])
+
+    (syntax-parse #'(#:instance #:? p [f1] [f2])
+      [(:structure-kws) #'([field ...] instance)])
+
+    (syntax-parse #'(#:builder [f1] [f2])
+      [(:structure-kws) #'([field ...] builder)]))
+
+#;(syntax-parse #'(#:a)
+    [(:structure-kws) 'err])

structure-options2b.rkt

@@ -0,0 +1,95 @@
+#lang racket
+
+(require syntax/parse
+         syntax/parse/experimental/eh
+         generic-syntax-expanders
+         syntax/stx
+         (for-syntax syntax/parse
+                     racket/syntax
+                     syntax/stx
+                     racket/pretty)) ;; debug
+
+;; ------------
+;; eh-mixin — TODO: move to phc-toolkit once the PR #7 for reqprov in
+;; generic-syntax-expander is merged. Look for "End eh-mixin" below for the end.
+
+(define-expander-type eh-mixin)
+
+(begin-for-syntax
+  (define eh-post-accumulate (make-parameter #f)))
+
+(define-syntax define-eh-alternative-mixin
+  (syntax-parser
+    [(_ name ((~literal pattern) pat) ... (~optional (~seq #:post post)))
+     (let ()
+       (define/with-syntax mixin (format-id #'name "~a-mixin" #'name))
+       ;(display "post:") (displayln (attribute post))
+       #`(begin
+           (define-eh-mixin-expander mixin
+             (λ (_)
+               #,@(if (attribute post)
+                      #'((unless (eh-post-accumulate)
+                           (raise-syntax-error
+                            'define-eh-alternative-mixin
+                            "#:post used outside of ~no-order"))
+                         ((eh-post-accumulate) (quote-syntax post)))
+                      #'())
+               (quote-syntax (~or pat ...))))
+           #;(define-eh-alternative-set name
+               #,@(stx-map (λ (p)
+                             #`(pattern #,(expand-all-eh-mixin-expanders p)))
+                           #'(pat ...)))))]))
+
+(define-for-syntax (define-?-syntax-class-with-eh-mixins original-form)
+  (syntax-parser
+    [(_ signature {~and opts {~not ({~literal pattern} . _)}} ...
+        ({~literal pattern} pat . pat-opts) ...)
+     ;((λ (x) (pretty-write (syntax->datum x)) x)
+     #`(#,original-form
+        signature opts ...
+        #,@(stx-map (λ (p po)
+                      #`(pattern #,(expand-all-eh-mixin-expanders p) . #,po))
+                    #'(pat ...)
+                    #'(pat-opts ...)))]))
+
+(define-syntax define-splicing-syntax-class-with-eh-mixins
+  (define-?-syntax-class-with-eh-mixins #'define-splicing-syntax-class))
+
+(define-syntax define-syntax-class-with-eh-mixins
+  (define-?-syntax-class-with-eh-mixins #'define-syntax-class))
+
+
+
+(provide define-splicing-syntax-class-with-eh-mixins
+         define-syntax-class-with-eh-mixins
+         define-eh-alternative-mixin
+         (expander-out eh-mixin))
+
+(define-for-syntax (inline-or stx)
+  (syntax-case stx ()
+    [(o . rest)
+     (and (identifier? #'o) (free-identifier=? #'o #'~or))
+     (apply append (stx-map inline-or #'rest))]
+    [x (list #'x)]))
+
+(define-syntax ~no-order
+  (pattern-expander
+   (λ (stx)
+     (syntax-case stx ()
+       [(_ pat ...)
+        ((λ (x) (pretty-write (syntax->datum x)) x)
+         (let ()
+           (define acc '())
+           (define (add-to-acc p)
+             (displayln p)
+             (newline)
+             (set! acc (cons p acc)))
+           (define alts
+             (parameterize ([eh-post-accumulate add-to-acc])
+               (expand-all-eh-mixin-expanders
+                #'(~or pat ...))))
+           #`(~and (~seq (~or . #,(inline-or alts)) (... ...))
+                   #,@acc)))]))))
+
+;; End eh-mixin
+;; ------------

test-reqprov-exp.rkt

@@ -0,0 +1,4 @@
+#lang racket
+
+(require generic-syntax-expanders
+         (expander-in "structure-options.rkt" eh-mixin))