diff --git a/private/no-order.rkt b/private/no-order.rkt index 838bc42..a17bf80 100644 --- a/private/no-order.rkt +++ b/private/no-order.rkt @@ -43,7 +43,7 @@ try-order-point> ~lift-rest ~omitable-lifted-rest ;; Private - (expander-out eh-mixin)) + (expander-out eh-mixin)) ;; Private (define-expander-type eh-mixin) @@ -124,8 +124,10 @@ (define (increment-counter!) (begin0 counter (set! counter (add1 counter)))) - ;; pre-acc and post-acc gather some a-patterns which will be added after + ;; first, pre and post-acc gather a-patterns which will be added after ;; the (~seq (~or ) ...), before and after the ~! cut respectively + (define first-acc '()) + (define (add-to-first! v) (set! first-acc (cons v first-acc))) (define pre-acc '()) (define (add-to-pre! v) (set! pre-acc (cons v pre-acc))) (define post-acc '()) @@ -142,7 +144,8 @@ succeeded-clause) lifted-rest))) ;; expand EH alternatives: - (parameterize ([eh-pre-accumulate add-to-post!] + (parameterize ([eh-first-accumulate add-to-first!] + [eh-pre-accumulate add-to-pre!] [eh-post-group add-to-post-groups!] [eh-post-accumulate add-to-post!] [clause-counter increment-counter!] @@ -221,7 +224,7 @@ 1) (string-append "more than one of the lifted rest" " patterns matched")})))) - ((λ (x) #;(pretty-write (syntax->datum x)) x) + ((λ (x) #;(pretty-write (syntax->datum #`(syntax-parser [#,x 'ok]))) x) #`(~delimit-cut (~and #,(fix-disappeared-uses) whole-clause-pat @@ -237,6 +240,7 @@ (syntax-property xi parse-seq-order-sym-id i))} + #,@(reverse first-acc) #,@(reverse pre-acc) #,@caught-omitable-lifted-rest #,@rest-handlers diff --git a/private/parameters.rkt b/private/parameters.rkt index 31ae5f8..e035f66 100644 --- a/private/parameters.rkt +++ b/private/parameters.rkt @@ -2,7 +2,9 @@ (require (for-syntax racket/base)) -(provide (for-syntax eh-pre-accumulate +(provide (for-syntax eh-first-accumulate + eh-first-accumulate! + eh-pre-accumulate eh-pre-accumulate! eh-post-accumulate eh-post-accumulate! @@ -24,6 +26,7 @@ " used outside of ~seq-no-order"))) (apply (parameter-name) args)))) +(define-dynamic-accumulator-parameter eh-first-accumulate eh-first-accumulate!) (define-dynamic-accumulator-parameter eh-pre-accumulate eh-pre-accumulate!) (define-dynamic-accumulator-parameter eh-post-group eh-post-group!) (define-dynamic-accumulator-parameter eh-post-accumulate eh-post-accumulate!) diff --git a/private/pre.rkt b/private/pre.rkt index 69c20c2..c40237b 100644 --- a/private/pre.rkt +++ b/private/pre.rkt @@ -43,6 +43,7 @@ (define-eh-mixin-expander ~pre-fail pre-fail) +;; TODO: fixme: should happen before the other pre operations (define-eh-mixin-expander ~named-seq (λ (stx) (syntax-case stx () @@ -51,22 +52,27 @@ (let () (define/with-syntax clause-present (get-new-clause!)) (define/with-syntax clause (get-new-clause!)) - (eh-pre-accumulate! '~named-seq - #'(~bind [(id 1) (if (attribute clause-present) - (attribute clause) - (list))])) + (eh-first-accumulate! '~named-seq + #'(~bind [(id 1) (if (attribute clause-present) + (attribute clause) + (list))])) #'(~and (~bind [clause-present #t]) (~seq clause (... ...)) (~seq . pats)))]))) + +;; TODO: fixme: should happen before the other pre operations (define-eh-mixin-expander ~maybe/empty (λ (stx) (syntax-case stx () - [(_ . pats) + [(_ pat …) (let () (define/with-syntax clause-present (get-new-clause!)) - (eh-pre-accumulate! '~maybe/empty - #'(~parse {~no-order {~seq . pats}} - #'(clause (... ...)))) + (define/with-syntax (expanded-pat …) + ;; let the ~post, ~global etc. within pat … be recognized + (expand-all-eh-mixin-expanders #'(pat …))) + (eh-first-accumulate! '~maybe/empty + #'(~parse (expanded-pat …) + #'(clause (... ...)))) #'{~optional {~and {~bind [clause-present #t]} {~seq clause (... ...)}}})]))) \ No newline at end of file