Split out query-set* etc; add query-value etc
This commit is contained in:
parent
d36ccbb0c2
commit
1334bd3abb
|
@ -27,9 +27,15 @@
|
||||||
|
|
||||||
suspend-script
|
suspend-script
|
||||||
|
|
||||||
|
query-value
|
||||||
query-set
|
query-set
|
||||||
query-hash
|
query-hash
|
||||||
query-hash-set
|
query-hash-set
|
||||||
|
query-value*
|
||||||
|
query-set*
|
||||||
|
query-hash*
|
||||||
|
query-hash-set*
|
||||||
|
define/query-value
|
||||||
define/query-set
|
define/query-set
|
||||||
define/query-hash
|
define/query-hash
|
||||||
define/query-hash-set
|
define/query-hash-set
|
||||||
|
@ -391,29 +397,67 @@
|
||||||
|
|
||||||
(define (schedule-query-handler-stxs maybe-expr-stx)
|
(define (schedule-query-handler-stxs maybe-expr-stx)
|
||||||
(if maybe-expr-stx
|
(if maybe-expr-stx
|
||||||
#`((schedule-script! #:priority *query-handler-priority*
|
(quasisyntax/loc maybe-expr-stx
|
||||||
|
((schedule-script! #:priority *query-handler-priority*
|
||||||
#f
|
#f
|
||||||
(lambda () #,maybe-expr-stx)))
|
(lambda () #,maybe-expr-stx))))
|
||||||
#'())))
|
#'())))
|
||||||
|
|
||||||
|
(define-syntax (query-value stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ field-name absent-expr args ...)
|
||||||
|
(quasisyntax/loc stx
|
||||||
|
(let ()
|
||||||
|
(field [field-name absent-expr])
|
||||||
|
(query-value* field-name absent-expr args ...)))]))
|
||||||
|
|
||||||
|
(define-syntax (query-value* stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ field-name absent-expr P expr on-add:on-add on-remove:on-remove)
|
||||||
|
(quasisyntax/loc stx
|
||||||
|
(let ()
|
||||||
|
(on (asserted P) #:priority *query-priority*
|
||||||
|
#,@(schedule-query-handler-stxs (attribute on-add.expr))
|
||||||
|
(field-name expr))
|
||||||
|
(on (retracted P) #:priority *query-priority*
|
||||||
|
#,@(schedule-query-handler-stxs (attribute on-remove.expr))
|
||||||
|
(field-name absent-expr))
|
||||||
|
field-name))]))
|
||||||
|
|
||||||
(define-syntax (query-set stx)
|
(define-syntax (query-set stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ field-name P expr on-add:on-add on-remove:on-remove)
|
[(_ field-name args ...)
|
||||||
#`(let ()
|
(quasisyntax/loc stx
|
||||||
|
(let ()
|
||||||
(field [field-name (set)])
|
(field [field-name (set)])
|
||||||
|
(query-set* field-name args ...)))]))
|
||||||
|
|
||||||
|
(define-syntax (query-set* stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ field-name P expr on-add:on-add on-remove:on-remove)
|
||||||
|
(quasisyntax/loc stx
|
||||||
|
(let ()
|
||||||
(on (asserted P) #:priority *query-priority*
|
(on (asserted P) #:priority *query-priority*
|
||||||
#,@(schedule-query-handler-stxs (attribute on-add.expr))
|
#,@(schedule-query-handler-stxs (attribute on-add.expr))
|
||||||
(field-name (set-add (field-name) expr)))
|
(field-name (set-add (field-name) expr)))
|
||||||
(on (retracted P) #:priority *query-priority*
|
(on (retracted P) #:priority *query-priority*
|
||||||
#,@(schedule-query-handler-stxs (attribute on-remove.expr))
|
#,@(schedule-query-handler-stxs (attribute on-remove.expr))
|
||||||
(field-name (set-remove (field-name) expr)))
|
(field-name (set-remove (field-name) expr)))
|
||||||
field-name)]))
|
field-name))]))
|
||||||
|
|
||||||
(define-syntax (query-hash stx)
|
(define-syntax (query-hash stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ field-name P key-expr value-expr on-add:on-add on-remove:on-remove)
|
[(_ field-name args ...)
|
||||||
#`(let ()
|
(quasisyntax/loc stx
|
||||||
|
(let ()
|
||||||
(field [field-name (hash)])
|
(field [field-name (hash)])
|
||||||
|
(query-hash* field-name args ...)))]))
|
||||||
|
|
||||||
|
(define-syntax (query-hash* stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ field-name P key-expr value-expr on-add:on-add on-remove:on-remove)
|
||||||
|
(quasisyntax/loc stx
|
||||||
|
(let ()
|
||||||
(on (asserted P) #:priority *query-priority*
|
(on (asserted P) #:priority *query-priority*
|
||||||
(let ((key key-expr))
|
(let ((key key-expr))
|
||||||
(when (hash-has-key? (field-name) key)
|
(when (hash-has-key? (field-name) key)
|
||||||
|
@ -426,21 +470,30 @@
|
||||||
(on (retracted P) #:priority *query-priority*
|
(on (retracted P) #:priority *query-priority*
|
||||||
#,@(schedule-query-handler-stxs (attribute on-remove.expr))
|
#,@(schedule-query-handler-stxs (attribute on-remove.expr))
|
||||||
(field-name (hash-remove (field-name) key-expr)))
|
(field-name (hash-remove (field-name) key-expr)))
|
||||||
field-name)]))
|
field-name))]))
|
||||||
|
|
||||||
(define-syntax (query-hash-set stx)
|
(define-syntax (query-hash-set stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ field-name P key-expr value-expr on-add:on-add on-remove:on-remove)
|
[(_ field-name args ...)
|
||||||
#`(let ()
|
(quasisyntax/loc stx
|
||||||
|
(let ()
|
||||||
(field [field-name (hash)])
|
(field [field-name (hash)])
|
||||||
|
(query-hash-set* field-name args ...)))]))
|
||||||
|
|
||||||
|
(define-syntax (query-hash-set* stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ field-name P key-expr value-expr on-add:on-add on-remove:on-remove)
|
||||||
|
(quasisyntax/loc stx
|
||||||
|
(let ()
|
||||||
(on (asserted P) #:priority *query-priority*
|
(on (asserted P) #:priority *query-priority*
|
||||||
#,@(schedule-query-handler-stxs (attribute on-add.expr))
|
#,@(schedule-query-handler-stxs (attribute on-add.expr))
|
||||||
(field-name (hashset-add (field-name) key-expr value-expr)))
|
(field-name (hashset-add (field-name) key-expr value-expr)))
|
||||||
(on (retracted P) #:priority *query-priority*
|
(on (retracted P) #:priority *query-priority*
|
||||||
#,@(schedule-query-handler-stxs (attribute on-remove.expr))
|
#,@(schedule-query-handler-stxs (attribute on-remove.expr))
|
||||||
(field-name (hashset-remove (field-name) key-expr value-expr)))
|
(field-name (hashset-remove (field-name) key-expr value-expr)))
|
||||||
field-name)]))
|
field-name))]))
|
||||||
|
|
||||||
|
(define-syntax-rule (define/query-value id ae P x ...) (define id (query-value id ae P x ...)))
|
||||||
(define-syntax-rule (define/query-set id P x ...) (define id (query-set id P x ...)))
|
(define-syntax-rule (define/query-set id P x ...) (define id (query-set id P x ...)))
|
||||||
(define-syntax-rule (define/query-hash id P x ...) (define id (query-hash id P x ...)))
|
(define-syntax-rule (define/query-hash id P x ...) (define id (query-hash id P x ...)))
|
||||||
(define-syntax-rule (define/query-hash-set id P x ...) (define id (query-hash-set id P x ...)))
|
(define-syntax-rule (define/query-hash-set id P x ...) (define id (query-hash-set id P x ...)))
|
||||||
|
@ -492,7 +545,7 @@
|
||||||
(error 'asserted
|
(error 'asserted
|
||||||
"Wildcard interest discovered while projecting by ~v at ~a"
|
"Wildcard interest discovered while projecting by ~v at ~a"
|
||||||
proj
|
proj
|
||||||
#,(source-location->string event-stx)))
|
#,(source-location->string P-stx)))
|
||||||
#,(let ((entry-handler-stx
|
#,(let ((entry-handler-stx
|
||||||
(quasisyntax/loc script-stx
|
(quasisyntax/loc script-stx
|
||||||
(let ((instantiated (instantiate-projection proj entry)))
|
(let ((instantiated (instantiate-projection proj entry)))
|
||||||
|
@ -513,7 +566,7 @@
|
||||||
[else
|
[else
|
||||||
(error 'asserted
|
(error 'asserted
|
||||||
"Multiple assertions triggered stop-when at ~a"
|
"Multiple assertions triggered stop-when at ~a"
|
||||||
#,(source-location->string event-stx))]))
|
#,(source-location->string P-stx))]))
|
||||||
#`(for [(entry (in-set entry-set))]
|
#`(for [(entry (in-set entry-set))]
|
||||||
#,entry-handler-stx)))])))))
|
#,entry-handler-stx)))])))))
|
||||||
|
|
||||||
|
|
|
@ -4,6 +4,7 @@
|
||||||
|
|
||||||
(actor #:name 'queryer
|
(actor #:name 'queryer
|
||||||
(forever
|
(forever
|
||||||
|
(define/query-value as-value 'absent `(item ,$a ,$b) (list a b))
|
||||||
(define/query-set as-set `(item ,$a ,$b) (list a b)
|
(define/query-set as-set `(item ,$a ,$b) (list a b)
|
||||||
#:on-add (log-info "as-set adding ~v/~v" a b)
|
#:on-add (log-info "as-set adding ~v/~v" a b)
|
||||||
#:on-remove (log-info "as-set removing ~v/~v" a b))
|
#:on-remove (log-info "as-set removing ~v/~v" a b))
|
||||||
|
@ -12,6 +13,8 @@
|
||||||
|
|
||||||
(on (message 'dump)
|
(on (message 'dump)
|
||||||
(printf "----------------------------------------\n")
|
(printf "----------------------------------------\n")
|
||||||
|
(printf "Queried as-value: ~v\n" (as-value))
|
||||||
|
(newline)
|
||||||
(printf "Queried as-set:\n")
|
(printf "Queried as-set:\n")
|
||||||
(for [(item (as-set))]
|
(for [(item (as-set))]
|
||||||
(match-define (list a b) item)
|
(match-define (list a b) item)
|
||||||
|
|
Loading…
Reference in New Issue