236 lines
7.7 KiB
Racket
236 lines
7.7 KiB
Racket
#lang racket/base
|
|
|
|
(provide this-turn
|
|
this-facet
|
|
this-actor
|
|
|
|
action
|
|
|
|
entity
|
|
actor-system
|
|
|
|
with-fresh-turn
|
|
ref
|
|
react
|
|
define-field
|
|
stop-facet
|
|
stop-current-facet
|
|
on-start
|
|
on-stop
|
|
sync!
|
|
send!
|
|
spawn
|
|
|
|
begin/dataflow
|
|
define/dataflow
|
|
stop-when-true
|
|
|
|
this-target
|
|
at
|
|
assert
|
|
stop-when
|
|
(rename-out [event:when when])
|
|
during
|
|
during*)
|
|
|
|
(require racket/match)
|
|
(require racket/stxparam)
|
|
(require (for-syntax racket/base))
|
|
(require (for-syntax racket/syntax))
|
|
|
|
(require "actor.rkt")
|
|
(require (prefix-in actor: "actor.rkt"))
|
|
|
|
(require "event-expander.rkt")
|
|
(require "pattern.rkt")
|
|
|
|
(define-syntax-parameter this-turn
|
|
(lambda (stx)
|
|
(raise-syntax-error #f "Illegal use outside an Actor turn" stx)))
|
|
|
|
(define-syntax-rule (with-this-turn id expr ...)
|
|
(syntax-parameterize ([this-turn (make-rename-transformer #'id)])
|
|
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-rule (action formals expr ...)
|
|
(lambda (turn . formals)
|
|
(with-this-turn turn expr ...)))
|
|
|
|
(define-syntax actor-system
|
|
(syntax-rules ()
|
|
[(_ #:name name expr ...)
|
|
(actor:actor-system #:name name (action () expr ...))]
|
|
[(_ expr ...)
|
|
(actor:actor-system (action () expr ...))]))
|
|
|
|
(define-syntax-rule (with-fresh-turn expr ...)
|
|
(turn-freshen this-turn (action () expr ...)))
|
|
|
|
(define-syntax-rule (ref e)
|
|
(turn-ref this-turn e))
|
|
|
|
(define-syntax-rule (react setup-expr ...)
|
|
(turn-facet! this-turn (action () setup-expr ...)))
|
|
|
|
(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 (action () expr ...))]))
|
|
|
|
(define-syntax-rule (stop-current-facet expr ...)
|
|
(stop-facet this-facet expr ...))
|
|
|
|
(define-syntax-rule (on-start expr ...)
|
|
;; TODO: delay to end of turn (?)
|
|
(begin expr ...))
|
|
|
|
(define-syntax-rule (on-stop expr ...)
|
|
(facet-on-stop! this-facet (action () expr ...)))
|
|
|
|
(define-syntax-rule (sync! peer expr ...)
|
|
(turn-sync! this-turn peer (action (_reply) expr ...)))
|
|
|
|
(define-syntax-rule (send! peer assertion)
|
|
(turn-message! this-turn peer (:template assertion)))
|
|
|
|
(define-syntax spawn
|
|
(syntax-rules ()
|
|
[(_ #:name name setup-expr ...)
|
|
(turn-spawn! #:name name this-turn (action () setup-expr ...))]
|
|
[(_ setup-expr ...)
|
|
(turn-spawn! this-turn (action () setup-expr ...))]))
|
|
|
|
(define-syntax-rule (begin/dataflow expr ...)
|
|
(turn-dataflow! this-turn (action () 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-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 Actor turn" 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
|
|
(syntax-rules ()
|
|
[(_ expr)
|
|
(turn-assert/dataflow! this-turn this-target (action () (:template expr)))]))
|
|
|
|
(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
|
|
(action (bindings)
|
|
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
|
|
expr ...)))))]
|
|
[(_ (asserted pat) expr ...)
|
|
#`(assert (Observe (:pattern pat)
|
|
(ref (entity #:assert
|
|
(action (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
|
|
(action (bindings handle)
|
|
(hash-set! assertion-map handle bindings))
|
|
#:retract
|
|
(action (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* (action (bindings)
|
|
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
|
|
expr ...)))))])))
|
|
|
|
(define (during* f)
|
|
(define assertion-map (make-hash))
|
|
(entity #:assert
|
|
(action (value handle)
|
|
(let ((facet (react (facet-prevent-inert-check! this-facet)
|
|
(f this-turn value))))
|
|
(match (hash-ref assertion-map handle #f)
|
|
[#f
|
|
(hash-set! assertion-map handle facet)]
|
|
['dead
|
|
(hash-remove! assertion-map handle)
|
|
(stop-facet facet)]
|
|
[_
|
|
(error 'during "Duplicate assertion handle ~a" handle)])))
|
|
#:retract
|
|
(action (handle)
|
|
(match (hash-ref assertion-map handle #f)
|
|
[#f
|
|
(hash-set! assertion-map handle 'dead)]
|
|
['dead
|
|
(error 'during "Duplicate retraction handle ~a" handle)]
|
|
[facet
|
|
(hash-remove! assertion-map handle)
|
|
(stop-facet facet)]))))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
;;; Local Variables:
|
|
;;; eval: (put 'action 'racket-indent-function 1)
|
|
;;; eval: (put 'at 'racket-indent-function 1)
|
|
;;; eval: (put 'stop-when 'racket-indent-function 1)
|
|
;;; eval: (put 'stop-when-true 'racket-indent-function 1)
|
|
;;; eval: (put 'actor-system/dataspace 'racket-indent-function 1)
|
|
;;; End:
|