syndicate-rkt/syndicate/dataspace.rkt

#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

(provide (all-from-out "schemas/dataspace.rkt")
         (all-from-out "schemas/dataspacePatterns.rkt")
         (all-from-out "schemas/dataspacePatterns.meta.rkt")

         dataspace
         actor-system/dataspace)

(require (for-syntax racket/base))
(require (for-syntax syntax/parse))

(require racket/pretty)
(require racket/match)

(require preserves)

(require "bag.rkt")
(require "actor.rkt")
(require "syntax.rkt")
(require "syntax-classes.rkt")
(require "skeleton.rkt")

(require "schemas/dataspace.rkt")
(require "schemas/dataspacePatterns.rkt")
(require "schemas/dataspacePatterns.meta.rkt")

(define-logger syndicate/dataspace)

(match (getenv "SYNDICATE_COLUMNS")
  [#f (void)]
  [n (pretty-print-columns (string->number n))])

(define (pretty-assertion indent value)
  (define gap (make-string indent #\space))
  (parameterize ((pretty-print-print-line
                  (lambda (line-number port line-length columns)
                    (fprintf port "\n~a" gap)
                    indent)))
    (pretty-format value #:mode 'print)))

(define (dataspace #:name [name (gensym 'dataspace)])
  (define handles (make-hash))
  (define assertions (make-bag))
  (define skeleton (make-empty-skeleton))
  (define ds-e
    (entity #:name name
            #:assert (lambda (value handle)
                       (log-syndicate/dataspace-debug "~v + ~v~a" ds-e handle (pretty-assertion 4 value))
                       (define maybe-observe (parse-Observe value))
                       (hash-set! handles handle (cons value maybe-observe))
                       (when (eq? (bag-change! assertions value +1) 'absent->present)
                         (match maybe-observe
                           [(? eof-object?)
                            (log-syndicate/dataspace-debug "Not an observer:~a" (pretty-assertion 4 value))
                            (void)]
                           [(Observe pat ref)
                            (add-interest! this-turn skeleton pat ref)
                            (log-syndicate/dataspace-debug "Updated index:~a" (pretty-assertion 4 skeleton))
                            ])
                         (add-assertion! this-turn skeleton value)))
            #:retract (lambda (upstream-handle)
                        (match (hash-ref handles upstream-handle #f)
                          [#f (error 'dataspace "Peer retracted unknown handle ~v" upstream-handle)]
                          [(cons value maybe-observe)
                           (log-syndicate/dataspace-debug "~v - ~v~a" ds-e upstream-handle (pretty-assertion 4 value))
                           (hash-remove! handles upstream-handle)
                           (when (eq? (bag-change! assertions value -1) 'present->absent)
                             (remove-assertion! this-turn skeleton value)
                             (match maybe-observe
                               [(? eof-object?) (void)]
                               [(Observe pat ref) (remove-interest! this-turn skeleton pat ref)]))]))
            #:message (lambda (message)
                        (log-syndicate/dataspace-debug "~v !~a" ds-e (pretty-assertion 4 message))
                        (send-assertion! this-turn skeleton message))))
  (ref ds-e))

(define-syntax (actor-system/dataspace stx)
  (syntax-parse stx
    [(_ (ds) name:<name> expr ...)
     #'(actor-system
        #:name name.N
        (facet-prevent-inert-check! this-facet)
        (define ds (dataspace))
        expr ...)]))