Queries
This commit is contained in:
parent
9fe2f923bc
commit
1fb116630e
|
@ -5,9 +5,11 @@
|
|||
|
||||
(provide (all-from-out racket/base)
|
||||
(all-from-out racket/match)
|
||||
(all-from-out racket/set)
|
||||
(all-from-out "main.rkt")
|
||||
(all-from-out "dataspace.rkt"))
|
||||
|
||||
(require racket/match)
|
||||
(require racket/set)
|
||||
(require "main.rkt")
|
||||
(require "dataspace.rkt")
|
||||
|
|
|
@ -6,6 +6,7 @@
|
|||
(provide (except-out (all-from-out "actor.rkt") current-turn)
|
||||
(struct-out entity-ref)
|
||||
(all-from-out "syntax.rkt")
|
||||
(all-from-out "query.rkt")
|
||||
(all-from-out "service.rkt")
|
||||
(all-from-out "event-expander.rkt")
|
||||
(all-from-out preserves)
|
||||
|
@ -19,6 +20,7 @@
|
|||
(require "actor.rkt")
|
||||
(require "entity-ref.rkt")
|
||||
(require "syntax.rkt")
|
||||
(require "query.rkt")
|
||||
(require "service.rkt")
|
||||
(require "event-expander.rkt")
|
||||
(require preserves)
|
||||
|
|
|
@ -0,0 +1,155 @@
|
|||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||
;;; SPDX-FileCopyrightText: Copyright © 2016-2021 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/gen/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)
|
||||
(match-define (list #,@(analyse-pattern-bindings #'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
|
||||
(match-define (list #,@(analyse-pattern-bindings #'P)) bindings)
|
||||
(define v expr)
|
||||
(define-values (bag1 outcome1) (bag-change (F) v 1))
|
||||
(F bag1)
|
||||
(when (eq? outcome1 'absent->present) on-add.expr)
|
||||
#:retracted
|
||||
(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
|
||||
(match-define (list #,@(analyse-pattern-bindings #'P)) bindings)
|
||||
(define v expr)
|
||||
(when (eq? (bag-change! b v 1) 'absent->present)
|
||||
(F (set-add (F) v))
|
||||
on-add.expr)
|
||||
#:retracted
|
||||
(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
|
||||
(match-define (list #,@(analyse-pattern-bindings #'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
|
||||
#:retracted
|
||||
(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
|
||||
(react (define name (op query-result args ...)) ...
|
||||
(sync! this-target
|
||||
(stop-current-facet body ...))))]))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'let/query 'racket-indent-function 1)
|
||||
;;; End:
|
Loading…
Reference in New Issue