59 lines
2.0 KiB
Racket
59 lines
2.0 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/function
|
|
racket/list
|
|
syntax/parse
|
|
phc-toolkit/untyped
|
|
(for-syntax racket/base
|
|
syntax/parse
|
|
syntax/parse/experimental/template
|
|
racket/syntax
|
|
phc-toolkit/untyped)
|
|
"parameters.rkt"
|
|
"no-order.rkt")
|
|
|
|
(provide ~global-or
|
|
~global-and
|
|
~global-counter
|
|
aggregate-global-or
|
|
aggregate-global-and
|
|
aggregate-global-counter)
|
|
|
|
(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-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-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-eh-mixin-expander ~global-counter
|
|
(make-~global #'aggregate-global-counter #''occurrence))
|
|
|