From 557c91a67815aed5830064887cc885b28f945c95 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Mon, 5 Sep 2016 02:19:37 +0200
Subject: [PATCH] Refactor ~global-*

---
 private/global.rkt | 41 +++++++++++++++++++++--------------------
 1 file changed, 21 insertions(+), 20 deletions(-)

diff --git a/private/global.rkt b/private/global.rkt
index 5562e8b..656b0de 100644
--- a/private/global.rkt
+++ b/private/global.rkt
@@ -19,39 +19,40 @@
          aggregate-global-and
          aggregate-global-counter)
 
-(define-syntax/parse (define-~global global-name (~optional default) f)
-  (define use-default-v? (syntax-e #'default-v?))
-  (template
-   (define-eh-mixin-expander global-name
-     (syntax-parser
-       [(_ (?? (~or [name v] (~and name (~bind [v default])))
-               [name v])
-           . pat)
-        (define/with-syntax clause-value (get-new-clause!))
-        (eh-post-group! '~global-name
-                        #'name ;(syntax-e #'name)
-                        #'f
-                        #'clause-value)
-        ;; protect the values inside an immutable box, so that a #f can be
-        ;; distinguished from a failed match.
-        #'(~and (~bind [clause-value (box-immutable v)])
-                . pat)]))))
+(define-for-syntax (make-~global f [default #f])
+  (syntax-parser
+    [(_ (~or [name v] (~and name
+                            (~fail #:unless default)
+                            (~bind [v default])))
+        . pats)
+     #:with clause-value (get-new-clause!)
+     (eh-post-group! '~global-name
+                     #'name
+                     f
+                     #'clause-value)
+     ;; protect the values inside an immutable box, so that a #f can be
+     ;; distinguished from a failed match.
+     #'(~and (~bind [clause-value (box-immutable v)])
+             . pats)]))
 
 (define (aggregate-global-or . bs)
   (ormap unbox ;; remove the layer of protection
          (filter identity ;; remove failed bindings
                  (flatten bs)))) ;; don't care about ellipsis nesting
-(define-~global ~global-or #'#t aggregate-global-or)
+(define-eh-mixin-expander ~global-or
+  (make-~global #'aggregate-global-or #'#t))
 
 (define (aggregate-global-and . bs)
   (andmap unbox ;; remove the layer of protection
           (cons (box-immutable 'none) ;; default value when no bindings matched
                 (filter identity ;; remove failed bindings
                         (flatten bs))))) ;; don't care about ellipsis nesting
-(define-~global ~global-and aggregate-global-and)
+(define-eh-mixin-expander ~global-and
+  (make-~global #'aggregate-global-and))
 
 (define (aggregate-global-counter . bs)
   (length (filter identity ;; remove failed bindings
                   (flatten bs)))) ;; don't care about ellipsis nesting
-(define-~global ~global-counter #''occurrence aggregate-global-counter)
+(define-eh-mixin-expander ~global-counter
+  (make-~global #'aggregate-global-counter #''occurrence))