syndicate-rkt/syndicate/dataspace.rkt

88 lines
3.6 KiB
Racket

#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021-2024 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 ...)]))