From 4f7e3353d156fded2062748c7036b20a22e17948 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Fri, 23 Sep 2016 17:06:29 +0200
Subject: [PATCH] Added eh-first-accumulate, fixed the behaviour of
~maybe/empty and ~named-seq by using it.
---
private/no-order.rkt | 12 ++++++++----
private/parameters.rkt | 5 ++++-
private/pre.rkt | 22 ++++++++++++++--------
3 files changed, 26 insertions(+), 13 deletions(-)
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