diff --git a/structure-options2.rkt b/structure-options2.rkt index 9dcfcc5..395d426 100644 --- a/structure-options2.rkt +++ b/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] ... - (~post-fail instance-no-values-error - #:when (and (attribute instance) - (not (stx-null? #'(field ...)))))) - #:name "[field]"))) + (pattern + (~optional (~and + (~seq clause42 ...) + ;; can't use #f, because of the bug + ;; 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)) - (~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))))) + (pattern (~no-order (structure-kw-all-mixin)))) +#| (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 - (syntax-parse #'() - [(:structure-kws) #'()])) - '()) +(test-exn + "Check that () is rejected, as it has neither #:instance nor #:builder" + (regexp (regexp-quote empty-err)) + (λ () + (syntax-parse #'() + [(:structure-kws) #'()]))) -;; This one is appropriately rejected :) -(check-exn (regexp (regexp-quote instance-no-values-error)) - (λ () - (syntax-parse #'(#:instance [f1] [f2]) - [(:structure-kws) #'([field ...] instance)]))) +(test-exn + "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" - (λ () - (syntax-parse #'(#:a) - [(:structure-kws) 'err]))) \ No newline at end of file +#;(check-exn #px"unexpected term" + (λ () + (syntax-parse #'(#:instance #:a) + [(:structure-kws) 'err]))) \ No newline at end of file diff --git a/structure-options2b.rkt b/structure-options2b.rkt index ecca1be..d195e5b 100644 --- a/structure-options2b.rkt +++ b/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) - (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 +;; TODO: ~no-order should also be a eh-mixin-expander, so that when there are +;; nested ~no-order, the ~post-fail is caught by the nearest ~no-order. (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]) - #;(expand-no-order-clauses #'(~or pat ...)) + (parameterize ([eh-post-accumulate add-to-acc] + [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) - (raise-syntax-error - '~post-fail - "~post-fail cannot be used directly as an ellipsis-head pattern")) - (define/with-syntax clause-present (gensym 'clause)) + (define/with-syntax clause-present + (string->symbol (format "clause~a" ((clause-counter))))) (eh-post-accumulate! '~post-fail - #`(~fail #:when (and (attribute (~bind [clause-present #t]) - #;#,(current-no-order-clause)) + #`(~fail #:when (and (attribute clause-present) condition) message)) - #'(~do))] + #'(~bind [clause-present #t]))] [(self #:when condition message) (parse #'(self message #:when condition))])) parse))