345 lines
12 KiB
Racket
345 lines
12 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
|
|
object
|
|
|
|
ref
|
|
react
|
|
react/suspend
|
|
until
|
|
define-field
|
|
stop-facet
|
|
stop-current-facet
|
|
on-start
|
|
on-stop
|
|
sync!
|
|
send!
|
|
spawn
|
|
spawn/link
|
|
|
|
begin/dataflow
|
|
define/dataflow
|
|
stop-when-true
|
|
entity/stop-on-retract
|
|
|
|
this-target
|
|
at
|
|
assert
|
|
stop-when
|
|
(rename-out [event:when when])
|
|
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 (prefix-in actor: "actor.rkt"))
|
|
(require "entity-ref.rkt")
|
|
|
|
(require "event-expander.rkt")
|
|
(require "pattern.rkt")
|
|
(require "syntax-classes.rkt")
|
|
|
|
(define-syntax this-turn
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[id
|
|
(identifier? #'id)
|
|
#'(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 ...)
|
|
#'(actor:actor-system #:name name.N (lambda () expr ...))]))
|
|
|
|
(define-syntax (object stx)
|
|
(syntax-parse stx
|
|
[(_ name:<name> handler ...)
|
|
#`(let ((state (make-hash)))
|
|
(define (handler-function assertion)
|
|
(-object-clauses assertion [] [handler ...]))
|
|
(ref (entity #:name name.N
|
|
#: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))
|
|
(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))
|
|
(when k
|
|
(k)))
|
|
|
|
(define-syntax (-object-clauses stx)
|
|
(syntax-parse stx
|
|
[(_ input [completed ...] [])
|
|
#'(match input
|
|
completed ...
|
|
[_ #f])]
|
|
|
|
[(_ input [completed ...] [ [#:spawn pat body ...] more ... ])
|
|
#'(-object-clauses input
|
|
[completed ...]
|
|
[ [#:during pat (spawn/link body ...)] more ... ])]
|
|
|
|
[(_ input [completed ...] [ [#:asserted pat body+ ... #:retracted body- ...] more ... ])
|
|
#`(-object-clauses input
|
|
[ completed ... [(-object-pattern pat)
|
|
body+ ...
|
|
#,(if (null? (syntax->list #'(body- ...)))
|
|
#`#f
|
|
#`(lambda () body- ...))] ]
|
|
[more ...])]
|
|
|
|
[(_ input [completed ...] [ [#:asserted pat body+ ...] more ... ])
|
|
#'(-object-clauses input
|
|
[completed ...]
|
|
[ [#:asserted pat body+ ... #:retracted] more ... ])]
|
|
|
|
[(_ input [completed ...] [ [pat body ...] more ... ])
|
|
#'(-object-clauses input
|
|
[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! this-turn (lambda () setup-expr ...)))
|
|
|
|
(define-syntax-rule (react/suspend (resume-parent) setup-expr ...)
|
|
(suspend-turn (lambda (resume-parent) (react setup-expr ...))))
|
|
|
|
(define-syntax-rule (until ds event body ...)
|
|
(react/suspend (continue)
|
|
(at ds (stop-when event (continue (void))))
|
|
body ...))
|
|
|
|
(define-syntax-rule (define-field id initial-value)
|
|
(define id (turn-field! this-turn 'id initial-value)))
|
|
|
|
(define-syntax stop-facet
|
|
(syntax-rules ()
|
|
[(_ f) (turn-stop! this-turn f)]
|
|
[(_ f expr ...) (turn-stop! this-turn 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-rule (sync! peer expr ...)
|
|
(turn-sync! this-turn peer (lambda (_reply) expr ...)))
|
|
|
|
(define-syntax-rule (send! peer assertion)
|
|
(turn-message! this-turn peer (->preserve assertion)))
|
|
|
|
(define-syntax (spawn stx)
|
|
(syntax-parse stx
|
|
[(_ name:<name> daemon:<daemon?>)
|
|
(raise-syntax-error #f "Need body in spawn")]
|
|
[(_ name:<name> daemon:<daemon?> setup-expr ...)
|
|
#'(turn-spawn! #:name name.N
|
|
#:daemon? daemon.D
|
|
this-turn
|
|
(lambda () setup-expr ...))]))
|
|
|
|
(define-syntax (spawn/link stx)
|
|
(syntax-parse stx
|
|
[(_ name-stx:<name> daemon:<daemon?> setup-expr ...)
|
|
#`(begin
|
|
(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 () setup-expr ...)
|
|
(hasheq monitor-handle #t)))]))
|
|
|
|
(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-when-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-syntax-parameter this-target
|
|
(lambda (stx)
|
|
(raise-syntax-error #f "Illegal use outside an `at` expression" stx)))
|
|
|
|
(define-syntax (at stx)
|
|
(syntax-case stx ()
|
|
[(_ target-expr items ...)
|
|
#`(let ((target target-expr))
|
|
(syntax-parameterize ([this-target (make-rename-transformer #'target)])
|
|
#,@(for/list [(item-stx (in-list (syntax->list #'(items ...))))]
|
|
(let loop ((item-stx item-stx))
|
|
(define disarmed-item-stx (syntax-disarm item-stx orig-insp))
|
|
(syntax-case disarmed-item-stx ()
|
|
[(expander args ...)
|
|
(event-expander-id? #'expander)
|
|
(event-expander-transform disarmed-item-stx
|
|
(lambda (r) (loop (syntax-rearm r item-stx))))]
|
|
[_
|
|
item-stx])))))]))
|
|
|
|
(define-event-expander assert
|
|
(lambda (stx)
|
|
(syntax-parse stx
|
|
[(_ condition:<when> expr)
|
|
#`(turn-assert/dataflow! this-turn
|
|
this-target
|
|
(lambda ()
|
|
(if condition.E
|
|
(->preserve expr)
|
|
(void))))])))
|
|
|
|
(define-event-expander stop-when
|
|
(syntax-rules ()
|
|
[(_ event expr ...)
|
|
(event:when event (stop-current-facet expr ...))]))
|
|
|
|
(require "schemas/gen/dataspace.rkt")
|
|
|
|
(define-event-expander event:when
|
|
(lambda (stx)
|
|
(syntax-case stx (message asserted retracted)
|
|
[(_ (message pat) expr ...)
|
|
#`(assert (Observe (:pattern pat)
|
|
(ref (entity #:message
|
|
(lambda (bindings)
|
|
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
|
|
expr ...)))))]
|
|
[(_ (asserted pat) expr ...)
|
|
#`(assert (Observe (:pattern pat)
|
|
(ref (entity #:assert
|
|
(lambda (bindings _handle)
|
|
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
|
|
expr ...)))))]
|
|
[(_ (retracted pat) expr ...)
|
|
#`(assert (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 ...))))))]))
|
|
(syntax-rules ()
|
|
[(_ test expr ...)
|
|
(when test expr ...)]))
|
|
|
|
(define-event-expander during
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ pat expr ...)
|
|
#`(assert (Observe (:pattern pat)
|
|
(ref (during* (lambda (bindings)
|
|
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
|
|
expr ...)))))])))
|
|
|
|
(define-event-expander during/spawn
|
|
(lambda (stx)
|
|
(syntax-parse stx
|
|
[(_ pat name-stx:<name> daemon:<daemon?> expr ...)
|
|
#`(assert (Observe (:pattern pat)
|
|
(ref (during* (lambda (bindings)
|
|
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
|
|
(spawn/link #:name name-stx.N #:daemon? daemon.D 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-system/dataspace 'racket-indent-function 1)
|
|
;;; eval: (put 'at 'racket-indent-function 1)
|
|
;;; eval: (put 'object 'racket-indent-function 0)
|
|
;;; eval: (put 'react 'racket-indent-function 0)
|
|
;;; eval: (put 'spawn 'racket-indent-function 0)
|
|
;;; eval: (put 'stop-when 'racket-indent-function 1)
|
|
;;; eval: (put 'stop-when-true 'racket-indent-function 1)
|
|
;;; End:
|