www

commit 9b90a03c02f33a1b926c946e24a16da448306b2f
parent 53ae6058ffb066dde9ae82c0c5c18e8c7cf785f6
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Tue,  6 Sep 2016 05:36:27 +0200

Added ~whole, which acts like (~and (~seq id ...) . pats), but always provide a default value of '() for id if the match fails

Diffstat:
M
main.rkt
 | 
1
+
M
private/post.rkt
 | 
31
+++++++++++++++++++++++++++++--

2 files changed, 30 insertions(+), 2 deletions(-)
diff --git 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
@@ -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)