From 9b90a03c02f33a1b926c946e24a16da448306b2f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Tue, 6 Sep 2016 05:36:27 +0200
Subject: [PATCH] Added ~whole, which acts like (~and (~seq id ...) . pats),
but always provide a default value of '() for id if the match fails
---
main.rkt | 1 +
private/post.rkt | 31 +++++++++++++++++++++++++++++--
2 files changed, 30 insertions(+), 2 deletions(-)
diff --git a/main.rkt b/main.rkt
index f8f976a..f4264c7 100644
--- a/main.rkt
+++ b/main.rkt
@@ -18,6 +18,7 @@
~mixin
~post-check
~post-fail
+ ~whole
~nop
~optional/else
~global-or
diff --git a/private/post.rkt b/private/post.rkt
index 3d8a31a..f62335e 100644
--- a/private/post.rkt
+++ b/private/post.rkt
@@ -10,7 +10,8 @@
(provide ~nop
~post-check
- ~post-fail)
+ ~post-fail
+ ~whole)
(define-syntax ~nop
(pattern-expander
@@ -26,10 +27,36 @@
(begin (eh-post-accumulate! '~post-check #'post)
#'(~nop))])))
+#;(define-eh-mixin-expander ~defaults
+ (λ (stx)
+ (syntax-case stx ()
+ [(_ ([a v] ...) . pats)
+ (let ()
+ (define/with-syntax clause-present (get-new-clause!))
+ (eh-post-accumulate! '~defaults
+ #'(~bind [a (or (attribute clause-present) v)]
+ ...))
+ #'(~and (~bind [clause-present #t]) . pats))])))
+
+(define-eh-mixin-expander ~whole
+ (λ (stx)
+ (syntax-case stx ()
+ [(_ id . pats)
+ (let ()
+ (define/with-syntax clause-present (get-new-clause!))
+ (define/with-syntax clause (get-new-clause!))
+ (eh-post-accumulate! '~whole
+ #'(~bind [(id 1) (if (attribute clause-present)
+ (attribute clause)
+ (list))]))
+ #'(~and (~bind [clause-present #t])
+ (~seq clause (... ...))
+ (~seq . pats)))])))
+
(define-for-syntax (post-fail stx)
(syntax-case stx ()
[(_ message #:when condition)
- (begin
+ (let ()
(define/with-syntax clause-present (get-new-clause!))
(eh-post-accumulate! '~post-fail
#`(~fail #:when (and (attribute clause-present)