157 lines
6.1 KiB
Racket
157 lines
6.1 KiB
Racket
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2016-2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
#lang racket/base
|
|
;;; Long-running and immediate queries over dataspace contents.
|
|
|
|
(provide query-value
|
|
query-count
|
|
query-set
|
|
query-hash
|
|
query-value*
|
|
query-count*
|
|
query-set*
|
|
query-hash*
|
|
define/query-value
|
|
define/query-count
|
|
define/query-set
|
|
define/query-hash
|
|
|
|
let/query)
|
|
|
|
(require (for-syntax racket/base))
|
|
(require (for-syntax syntax/parse))
|
|
|
|
(require racket/match)
|
|
(require racket/set)
|
|
|
|
(require "pattern.rkt")
|
|
(require "syntax.rkt")
|
|
(require "bag.rkt")
|
|
|
|
(require "schemas/dataspace.rkt")
|
|
|
|
(begin-for-syntax
|
|
(define-splicing-syntax-class on-add
|
|
(pattern (~optional (~seq #:on-add expr) #:defaults ([expr #'#f]))))
|
|
(define-splicing-syntax-class on-remove
|
|
(pattern (~optional (~seq #:on-remove expr) #:defaults ([expr #'#f])))))
|
|
|
|
(define-syntax-rule (-define-query (query-name field-name query-args ...) init query*-name)
|
|
(define-syntax-rule (query-name field-name query-args ...)
|
|
(let()
|
|
(define-field field-name init)
|
|
(query*-name field-name query-args ...)
|
|
field-name)))
|
|
|
|
(-define-query (query-value field-name absent-expr args ...) absent-expr query-value*)
|
|
|
|
(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 ((F field-name) (assertion-count 0))
|
|
(assert
|
|
(Observe (:pattern P)
|
|
(ref (entity #:name 'field-name
|
|
#:assert
|
|
(lambda (bindings handle)
|
|
(pattern-binding-let [P bindings]
|
|
(set! assertion-count (+ assertion-count 1))
|
|
(F expr)
|
|
on-add.expr))
|
|
#:retract
|
|
(lambda (_handle)
|
|
(set! assertion-count (- assertion-count 1))
|
|
(when (zero? assertion-count)
|
|
(F absent-expr)
|
|
on-remove.expr))))))))]))
|
|
|
|
(-define-query (query-count field-name args ...) (bag) query-count*)
|
|
|
|
(define-syntax (query-count* stx)
|
|
(syntax-parse stx
|
|
[(_ field-name P expr on-add:on-add on-remove:on-remove)
|
|
(quasisyntax/loc stx
|
|
(let ((F field-name))
|
|
(assert
|
|
(Observe (:pattern P)
|
|
(object #:name 'field-name
|
|
[#:asserted* bindings
|
|
(pattern-binding-let [P bindings]
|
|
(define v expr)
|
|
(define-values (bag1 outcome1) (bag-change (F) v 1))
|
|
(F bag1)
|
|
(when (eq? outcome1 'absent->present) on-add.expr)
|
|
(lambda ()
|
|
(define-values (bag2 outcome2) (bag-change (F) v -1))
|
|
(F bag2)
|
|
(when (eq? outcome2 'present->absent) on-remove.expr)))])))))]))
|
|
|
|
(-define-query (query-set field-name args ...) (set) query-set*)
|
|
|
|
(define-syntax (query-set* stx)
|
|
(syntax-parse stx
|
|
[(_ field-name P expr on-add:on-add on-remove:on-remove)
|
|
(quasisyntax/loc stx
|
|
(let ((F field-name)
|
|
(b (make-bag)))
|
|
(assert
|
|
(Observe (:pattern P)
|
|
(object #:name 'field-name
|
|
[#:asserted* bindings
|
|
(pattern-binding-let [P bindings]
|
|
(define v expr)
|
|
(when (eq? (bag-change! b v 1) 'absent->present)
|
|
(F (set-add (F) v))
|
|
on-add.expr)
|
|
(lambda ()
|
|
(when (eq? (bag-change! b v -1) 'present->absent)
|
|
(F (set-remove (F) v))
|
|
on-remove.expr)))])))))]))
|
|
|
|
(-define-query (query-hash field-name args ...) (hash) query-hash*)
|
|
|
|
(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 ((F field-name))
|
|
(assert
|
|
(Observe (:pattern P)
|
|
(object #:name 'field-name
|
|
[#:asserted* bindings
|
|
(pattern-binding-let [P bindings]
|
|
(define k key-expr)
|
|
(define v value-expr)
|
|
(when (hash-has-key? (F) k)
|
|
(log-warning
|
|
"query-hash: field ~s with pattern ~s: overwriting existing entry ~s"
|
|
'field-name
|
|
'P
|
|
k))
|
|
(F (hash-set (F) k v))
|
|
on-add.expr
|
|
(lambda ()
|
|
(F (hash-remove (F) k))
|
|
on-remove.expr))])))))]))
|
|
|
|
(define-syntax-rule (define/query-value id ae P x ...) (define id (query-value id ae P x ...)))
|
|
(define-syntax-rule (define/query-count id P x ...) (define id (query-count 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 (let/query stx)
|
|
(syntax-case stx ()
|
|
[(_ ((name (op args ...)) ...) body ...)
|
|
(syntax/loc stx
|
|
(begin (react (define name (op query-result args ...)) ...
|
|
(sync! this-target
|
|
(stop-current-facet body ...)))
|
|
(void)))]))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
;;; Local Variables:
|
|
;;; eval: (put 'let/query 'racket-indent-function 1)
|
|
;;; End:
|