WIP on ~no-order. Before cleaning up implementation of ~post-fail.

structure-options2.rkt

@@ -1,7 +1,21 @@
 #lang racket
 
+(require racket/require
+         syntax/parse
+         (subtract-in syntax/stx phc-toolkit/untyped)
+         rackunit
+         racket/format
+         phc-toolkit/untyped
+         (for-syntax syntax/parse
+                     syntax/stx
+                     racket/format))
+
 (require "structure-options2b.rkt")
 
+(provide structure-kw-instance-or-builder-mixin
+         structure-kw-predicate-mixin
+         structure-kw-fields-mixin
+         structure-kw-all-mixin)
 
 (define-eh-alternative-mixin structure-kw-instance-or-builder
   (pattern (~optional (~and instance-or-builder
@@ -13,23 +27,27 @@
   (pattern (~optional (~seq #:? predicate:id)
                       #:name "#:? predicate")))
 
+(define-and-for-syntax instance-no-values-error
+  (~a "The #:instance keyword implies the use of [field value],"
+      " [field : type value] or [field value : type]."))
 (define-eh-alternative-mixin structure-kw-fields
-  (pattern (~once (~seq [field:id] ...)
+  (pattern (~once (~seq [field:id] ...
-                  #:name "[field]"))
+                        (~post-fail instance-no-values-error
-  #:post (~fail #:when (and (attribute instance)
+                                    #:when (and (attribute instance)
                                                 (not (stx-null? #'(field ...))))))
+                  #:name "[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 #;(~no-order (structure-kw-all-mixin))
-  (pattern (~and
+           (~delimit-cut
+            (~and
              (~seq
               (~or
                (~optional
@@ -39,47 +57,44 @@
                 #:name
                 "either #:instance or #:builder")
                (~optional (~seq #:? predicate:id) #:name "#:? predicate")
-              (~once (~seq (field:id) ...) #:name "[field]"))
+               (~optional (~seq (field:id) ...+ (~bind [clause178673 #t]))
+                          #:name "[field]"))
               ...)
-            (~fail #:when (and (attribute instance) (not (stx-null? #'(field ...))))))))
+             ~!
+             (~fail
+              #:when
+              (and (attribute clause178673)
+                   (and (attribute instance)))
+              instance-no-values-error)))))
 
-#;(define-splicing-syntax-class
+(check-equal? (syntax->datum
-    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)])
+                 [(:structure-kws) #'(instance instance-or-builder predicate)]))
+              '(#:instance #:instance p))
 
+(check-equal? (syntax->datum
                (syntax-parse #'(#:builder)
-      [(k:structure-kws) #'(k.builder k.instance-or-builder)])
+                 [(k:structure-kws) #'(k.builder k.instance-or-builder)]))
+              '(#:builder #:builder))
 
+(check-equal? (syntax->datum
                (syntax-parse #'()
-      [(:structure-kws) #'()])
+                 [(:structure-kws) #'()]))
+              '())
 
-    (syntax-parse #'(#:instance #:? p [f1] [f2])
+;; This one is appropriately rejected :)
-      [(:structure-kws) #'([field ...] instance)])
+(check-exn (regexp (regexp-quote instance-no-values-error))
+           (λ ()
+             (syntax-parse #'(#:instance [f1] [f2])
+               [(:structure-kws) #'([field ...] instance)])))
 
-    (syntax-parse #'(#:builder [f1] [f2])
+(check-equal? (syntax->datum
+               (syntax-parse #'(#:builder #:? p [f1] [f2])
                  [(:structure-kws) #'([field ...] builder)]))
+              '([f1 f2] #:builder))
 
-#;(syntax-parse #'(#:a)
+;; This one is appropriately rejected
-    [(:structure-kws) 'err])
+(check-exn #px"unexpected term"
+           (λ ()
+             (syntax-parse #'(#:a)
+               [(:structure-kws) 'err])))

structure-options2b.rkt

@@ -3,67 +3,44 @@
 (require syntax/parse
          syntax/parse/experimental/eh
          generic-syntax-expanders
-         syntax/stx
          (for-syntax syntax/parse
                      racket/syntax
-                     syntax/stx
+                     phc-toolkit/untyped
-                     racket/pretty)) ;; debug
+                     racket/list
+                     generic-syntax-expanders
+                     racket/pretty))
+
+(provide ;define-splicing-syntax-class-with-eh-mixins
+ ;define-syntax-class-with-eh-mixins
+ define-eh-alternative-mixin
+ (expander-out eh-mixin)
+ ~no-order
+ ~post-check
+ ~post-fail)
 
 ;; ------------
 ;; 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.
+;; generic-syntax-expander is merged.
 
 (define-expander-type eh-mixin)
 
-(begin-for-syntax
+(define-for-syntax eh-post-accumulate (make-parameter #f))
-  (define eh-post-accumulate (make-parameter #f)))
+#;(define-for-syntax current-no-order-clause (make-parameter #f))
 
 (define-syntax define-eh-alternative-mixin
   (syntax-parser
-    [(_ name ((~literal pattern) pat) ... (~optional (~seq #:post post)))
+    [(_ name ((~literal pattern) pat) ...)
      (let ()
        (define/with-syntax mixin (format-id #'name "~a-mixin" #'name))
-       ;(display "post:") (displayln (attribute post))
+       (define-temp-ids "~a/clause" (pat ...))
-       #`(begin
+       #'(define-eh-mixin-expander mixin
-           (define-eh-mixin-expander mixin
            (λ (_)
-               #,@(if (attribute post)
+             (quote-syntax (~or pat ...))
-                      #'((unless (eh-post-accumulate)
+             #;#`(~or #,(parameterize ([current-no-order-clause #'pat/clause])
-                           (raise-syntax-error
+                          (quote-syntax pat))
-                            '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 ()
@@ -72,24 +49,91 @@
      (apply append (stx-map inline-or #'rest))]
     [x (list #'x)]))
 
+#;(define-for-syntax (expand-no-order-clauses/tree x)
+    (cond
+      [(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)
      (syntax-case stx ()
-       [(_ pat ...)
+       [(self pat ...)
-        ((λ (x) (pretty-write (syntax->datum x)) x)
+        ((λ (x) (pretty-write (syntax->datum x)) (newline) x)
          (let ()
            (define acc '())
            (define (add-to-acc p)
-             (displayln p)
+             (set! acc (cons p #;(replace-context #'self p) acc)))
-             (newline)
-             (set! acc (cons p acc)))
            (define alts
              (parameterize ([eh-post-accumulate add-to-acc])
-               (expand-all-eh-mixin-expanders
+               #;(expand-no-order-clauses #'(~or pat ...))
-                #'(~or pat ...))))
+               (inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
-           #`(~and (~seq (~or . #,(inline-or alts)) (... ...))
+           #`(~delimit-cut
-                   #,@acc)))]))))
+              (~and (~seq (~or . #,alts) (... ...))
+                    ~!
+                    #,@acc))))]))))
 
-;; End eh-mixin
+(define-for-syntax (eh-post-accumulate! name p)
-;; ------------
+  (unless (eh-post-accumulate)
+    (raise-syntax-error
+     name
+     (string-append (symbol->string name) " used outside of ~no-order")))
+  ((eh-post-accumulate) p))
+
+(define-eh-mixin-expander ~post-check
+  (λ (stx)
+    (syntax-case stx ()
+      [(_ pat post)
+       (begin
+         (eh-post-accumulate! '~post-check #'post)
+         #'pat)]
+      [(_ post)
+       (begin
+         (eh-post-accumulate! '~post-check #'post)
+         #'(~do))])))
+
+(define-eh-mixin-expander ~post-fail
+  (let ()
+    (define (parse stx)
+      (syntax-case stx ()
+        [(_ message #:when condition)
+         (begin
+           #;(unless (current-no-order-clause)
+               (raise-syntax-error
+                '~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])
+                                            #;#,(current-no-order-clause))
+                                 condition)
+                     message))
+           #'(~do))]
+        [(self #:when condition message)
+         (parse #'(self message #:when condition))]))
+    parse))
+
+(define-syntax ~mutex
+  (pattern-expander
+   (λ (stx)
+     (syntax-case stx ()
+       [(self (mutex:id ...) pat ...)
+        #'(???)]))))