Refactor ~global-*

private/global.rkt

@@ -19,39 +19,40 @@
          aggregate-global-and
          aggregate-global-counter)
 
-(define-syntax/parse (define-~global global-name (~optional default) f)
+(define-for-syntax (make-~global f [default #f])
-  (define use-default-v? (syntax-e #'default-v?))
+  (syntax-parser
-  (template
+    [(_ (~or [name v] (~and name
-   (define-eh-mixin-expander global-name
+                            (~fail #:unless default)
-     (syntax-parser
+                            (~bind [v default])))
-       [(_ (?? (~or [name v] (~and name (~bind [v default])))
+        . pats)
-               [name v])
+     #:with clause-value (get-new-clause!)
-           . pat)
+     (eh-post-group! '~global-name
-        (define/with-syntax clause-value (get-new-clause!))
+                     #'name
-        (eh-post-group! '~global-name
+                     f
-                        #'name ;(syntax-e #'name)
+                     #'clause-value)
-                        #'f
+     ;; protect the values inside an immutable box, so that a #f can be
-                        #'clause-value)
+     ;; distinguished from a failed match.
-        ;; protect the values inside an immutable box, so that a #f can be
+     #'(~and (~bind [clause-value (box-immutable v)])
-        ;; distinguished from a failed match.
+             . pats)]))
-        #'(~and (~bind [clause-value (box-immutable v)])
-                . pat)]))))
 
 (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))