423 lines
14 KiB
Racket
423 lines
14 KiB
Racket
;;; 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:
|