;;; 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: