Racket implementation of Dataspaces and Syndicate.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

422 lines
14 KiB

;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang racket/base
(provide this-turn
this-facet
this-actor
entity
actor-system
actor-group
object
ref
react
let-event
define-field
stop-actor-system
stop-facet
stop-current-facet
on-start
on-stop
sync!
send!
spawn
spawn/link
begin/dataflow
define/dataflow
stop-on-true
entity/stop-on-retract
this-target
at
assert
once
stop-on
on
during
during/spawn
during*)
(require racket/match)
(require racket/stxparam)
(require (for-syntax racket/base))
(require (for-syntax racket/syntax))
(require (for-syntax syntax/parse))
(require preserves-schema)
(require "actor.rkt")
(require "entity-ref.rkt")
(require "event-expander.rkt")
(require "pattern.rkt")
(require "syntax-classes.rkt")
(define-logger syndicate/object) ;; used by the (object) macro
(define-syntax this-turn
(make-set!-transformer
(lambda (stx)
(syntax-case stx ()
[id
(identifier? #'id)
#'(this-turn*)]))))
(define (this-turn*)
(or (current-turn) (error 'this-turn "Illegal use outside an Actor turn")))
(define-syntax-rule (with-this-turn turn-expr expr ...)
(parameterize ([current-turn turn-expr])
expr ...))
(define-syntax this-facet
(syntax-id-rules ()
[_ (turn-active-facet this-turn)]))
(define-syntax this-actor
(syntax-id-rules ()
[_ (facet-actor this-facet)]))
(define-syntax (actor-system stx)
(syntax-parse stx
[(_ name:<name> expr ...)
#'(make-actor-system #:name name.N (lambda () expr ...))]))
(define-syntax (actor-group stx)
(syntax-parse stx
[(_ name:<name> link:<link?> group-boot-expr ...)
#'(make-actor-group #:name name.N
#:link? link.L
(lambda () group-boot-expr ...))]))
(define-syntax (object stx)
(syntax-parse stx
[(_ name-stx:<name> handler ...)
#`(let ((state (make-hash)))
(define name name-stx.N)
(define (handler-function assertion is-message?)
(-object-clauses name assertion is-message? [] [handler ...]))
(ref (entity #:name name
#:assert (lambda (m h) (-object-assert state handler-function m h))
#:retract (lambda (h) (-object-retract state h))
#:message (lambda (m) (-object-message handler-function m)))))]))
(define (-object-assert state handler-function assertion handle)
(define k (handler-function assertion #f))
(when k (hash-set! state handle k)))
(define (-object-retract state handle)
(define k (hash-ref state handle #f))
(when k
(hash-remove! state handle)
(k)))
(define (-object-message handler-function message)
(define k (handler-function message #t))
(when k
(k)))
(define-syntax (-object-clauses stx)
(syntax-parse stx
[(_ name input is-message? [completed ...]
[])
#'(match input
completed ...
[_
(log-syndicate/object-debug "Unhandled ~a ~v in ~v"
(if is-message? "message" "assertion")
input name)
#f])]
[(_ name input is-message? [completed ...]
[ [#:message pat body+ ...] more ... ])
#'(-object-clauses name
input
is-message?
[ completed ... [(-object-pattern pat) #:when is-message?
body+ ... #f] ]
[more ...])]
[(_ name input is-message? [completed ...]
[ [#:asserted pat body+ ... #:retracted body- ...] more ... ])
#`(-object-clauses name
input
is-message?
[ completed ... [(-object-pattern pat) #:when (not is-message?)
body+ ...
#,(if (null? (syntax->list #'(body- ...)))
#`#f
#`(lambda () body- ...))] ]
[more ...])]
[(_ name input is-message? [completed ...]
[ [#:asserted pat body+ ...] more ... ])
#'(-object-clauses name
input
is-message?
[completed ...]
[ [#:asserted pat body+ ... #:retracted] more ... ])]
[(_ name input is-message? [completed ...]
[ [pat body ...] more ... ])
#'(-object-clauses name
input
is-message?
[completed ...]
[ [#:asserted pat
(define f (react (facet-prevent-inert-check! this-facet) body ...))
#:retracted
(stop-facet f)]
more ... ])]))
(define-match-expander -object-pattern
(lambda (stx)
(syntax-case stx ()
[(_ pat-stx)
(analyse-match-pattern #'pat-stx)])))
(define (ref entity)
(entity-ref this-facet entity '()))
(define-syntax-rule (react setup-expr ...)
(turn-facet! (lambda () setup-expr ...)))
(define-syntax (let-event stx)
(syntax-parse stx
[(_ [] body ...)
#'(begin body ...)]
[(_ [#:do expr e ...] body ...)
#'(begin expr (let-event [e ...] body ...))]
[(_ [e0 e ...] body ...)
#'(react (stop-on e0 (let-event [e ...] body ...)))]))
(define-syntax-rule (define-field id initial-value)
(define id (turn-field! this-turn 'id initial-value)))
(define (stop-actor-system)
(turn-stop-actor-system! this-turn))
(define-syntax stop-facet
(syntax-rules ()
[(_ f) (turn-stop! f)]
[(_ f expr ...) (turn-stop! f (lambda () expr ...))]))
(define-syntax-rule (stop-current-facet expr ...)
(stop-facet this-facet expr ...))
(define-syntax-rule (on-start expr ...)
(facet-on-end-of-turn! this-facet (lambda () expr ...)))
(define-syntax-rule (on-stop expr ...)
(facet-on-stop! this-facet (lambda () expr ...)))
(define-syntax (sync! stx)
(syntax-parse stx
[(_ peer expr ...)
(syntax/loc stx (turn-sync! this-turn peer (lambda (_reply) expr ...)))]))
(define-for-syntax (with-valid-this-target orig-stx result-stx)
;; Invoke this-target transformer for its side effect: when it's
;; illegal to use it, it will signal an error.
(let ((v (syntax-parameter-value #'this-target)))
(when (procedure? v)
(v orig-stx)))
result-stx)
(define-syntax (send! stx)
(syntax-parse stx
[(_ peer assertion)
(syntax/loc stx (turn-message! this-turn peer (->preserve assertion)))]
[(_ assertion)
(with-valid-this-target stx
(syntax/loc stx (send! this-target assertion)))]))
(define-syntax (spawn stx)
(syntax-parse stx
[(_ matches:<matches> condition:<when> name:<name> daemon:<daemon?>)
(raise-syntax-error #f "Need body in spawn")]
[(_ matches:<matches> condition:<when> name:<name> daemon:<daemon?> setup-expr ...)
#'(nested-matches
[[matches.pattern-pieces ... matches.discriminant] ...]
(when condition.E
(turn-spawn! #:name name.N
#:daemon? daemon.D
this-turn
(lambda ()
(syntax-parameterize ([this-target illegal-use-of-this-target])
setup-expr ...)))))]))
(define-syntax (spawn/link stx)
(syntax-parse stx
[(_ matches:<matches> condition:<when> name-stx:<name> daemon:<daemon?> setup-expr ...)
#`(nested-matches
[[matches.pattern-pieces ... matches.discriminant] ...]
(when condition.E
(define name name-stx.N)
(define monitor (ref (entity/stop-on-retract #:name (list name 'monitor-in-parent))))
(define monitor-handle (turn-assert! this-turn monitor 'alive))
(turn-spawn! this-turn
#:name name
#:daemon? daemon.D
#:link
(entity/stop-on-retract #:name (list name 'monitor-in-child))
(lambda ()
(syntax-parameterize ([this-target illegal-use-of-this-target])
setup-expr ...))
(hasheq monitor-handle #t))))]))
(define-syntax nested-matches
(syntax-rules ()
[(_ [] body ...)
(begin body ...)]
[(_ [[p ... e] more ...] body ...)
(match e [p ... (nested-matches [more ...] body ...)] [_ (void)])]))
(define-syntax-rule (begin/dataflow expr ...)
(turn-dataflow! this-turn (lambda () expr ...)))
(define-syntax-rule (define/dataflow id expr)
(begin (define-field id #f)
(begin/dataflow (id expr))))
(define-syntax-rule (stop-on-true test expr ...)
(begin/dataflow
(when test
(stop-current-facet expr ...))))
(define (entity/stop-on-retract #:name [name 'stop-on-retract] [k void])
(entity #:name name #:retract (lambda (_handle) (stop-current-facet (k)))))
;;---------------------------------------------------------------------------
(define-for-syntax orig-insp
(variable-reference->module-declaration-inspector (#%variable-reference)))
(define-for-syntax illegal-use-of-this-target
(lambda (stx)
(raise-syntax-error 'this-target "Illegal use outside an `at` expression" stx)))
(define-syntax-parameter this-target illegal-use-of-this-target)
(define-syntax (at stx)
(syntax-case stx ()
[(_ target-expr items ...)
#`(let ((target target-expr))
(syntax-parameterize ([this-target (make-rename-transformer #'target)])
items ...))]))
(define-syntax assert
(lambda (stx)
(syntax-parse stx
[(_ condition:<when> expr)
(with-valid-this-target stx
(quasisyntax/loc stx
(turn-assert/dataflow! this-turn
this-target
#,(quasisyntax/loc #'expr
(lambda () (if condition.E
(->preserve expr)
(void)))))))])))
(define-syntax-rule (once [event expr ...] ...)
(react (stop-on event expr ...) ...))
(define-syntax-rule (stop-on event expr ...)
(on event (stop-current-facet expr ...)))
(require "schemas/dataspace.rkt")
(define-syntax on
(lambda (stx)
(define disarmed-stx (syntax-disarm stx orig-insp))
(syntax-parse disarmed-stx
[(_ ((~datum message) condition:<when> pat) expr ...)
(quasisyntax/loc stx
(assert #:when condition.E
#,(quasisyntax/loc #'pat
(Observe (:pattern pat)
(ref (entity #:message
(lambda (bindings)
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
expr ...)))))))]
[(_ ((~datum asserted) condition:<when> pat) expr ...)
(quasisyntax/loc stx
(assert #:when condition.E
(Observe (:pattern pat)
(ref (entity #:assert
(lambda (bindings _handle)
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
expr ...))))))]
[(_ ((~datum retracted) condition:<when> pat) expr ...)
(quasisyntax/loc stx
(assert #:when condition.E
(Observe (:pattern pat)
(let ((assertion-map (make-hash)))
(ref (entity #:assert
(lambda (bindings handle)
(hash-set! assertion-map handle bindings))
#:retract
(lambda (handle)
(match-define (list #,@(analyse-pattern-bindings #'pat))
(hash-ref assertion-map handle))
(hash-remove! assertion-map handle)
expr ...)))))))]
[(_ (expander args ...) body ...) #:when (event-expander-id? #'expander)
(event-expander-transform #'(expander [args ...] body ...) (lambda (r) (syntax-rearm r stx)))]
[_
(raise-syntax-error #f "Invalid event pattern")])))
(define-syntax during
(lambda (stx)
(syntax-case stx ()
[(_ pat expr ...)
(quasisyntax/loc stx
(assert (Observe (:pattern pat)
(ref (during* (lambda (bindings)
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
expr ...))))))])))
(define-syntax during/spawn
(lambda (stx)
(syntax-parse stx
[(_ pat expr ...)
(quasisyntax/loc stx
(assert (Observe (:pattern pat)
(ref (during* (lambda (bindings)
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
(spawn/link expr ...)))))))])))
(define (during* f #:name [name '?])
(define assertion-map (make-hash))
(entity #:name name
#:assert
(lambda (value handle)
(hash-set! assertion-map
handle
(react (facet-prevent-inert-check! this-facet)
(f value))))
#:retract
(lambda (handle)
(match (hash-ref assertion-map handle #f)
[#f (void)]
[facet
(hash-remove! assertion-map handle)
(stop-facet facet)]))))
;;---------------------------------------------------------------------------
;;; Local Variables:
;;; eval: (put 'actor-group 'racket-indent-function 0)
;;; eval: (put 'actor-system/dataspace 'racket-indent-function 1)
;;; eval: (put 'at 'racket-indent-function 1)
;;; eval: (put 'object 'racket-indent-function 0)
;;; eval: (put 'on 'racket-indent-function 1)
;;; eval: (put 'react 'racket-indent-function 0)
;;; eval: (put 'send! 'racket-indent-function 1)
;;; eval: (put 'spawn 'racket-indent-function 0)
;;; eval: (put 'stop-on 'racket-indent-function 1)
;;; eval: (put 'stop-on-true 'racket-indent-function 1)
;;; eval: (put 'sync! 'racket-indent-function 1)
;;; End: