First attempt at novy syntax
This commit is contained in:
parent
35e1d24fde
commit
37bd64bf05
|
@ -3,69 +3,67 @@
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require preserves)
|
(require preserves)
|
||||||
|
|
||||||
(require "main.rkt")
|
(require (except-in "main.rkt" actor-system))
|
||||||
(require "bag.rkt")
|
(require "bag.rkt")
|
||||||
(require "schemas/gen/box-protocol.rkt")
|
(require "schemas/gen/box-protocol.rkt")
|
||||||
(require "schemas/gen/dataspace.rkt")
|
(require "schemas/gen/dataspace.rkt")
|
||||||
|
|
||||||
(define ((box ds LIMIT REPORT_EVERY) turn)
|
(require "syntax.rkt")
|
||||||
(define value (turn-field! turn 'box-value 0))
|
|
||||||
(turn-assert/dataflow! turn ds (lambda (turn) (BoxState->preserves (BoxState (value)))))
|
(define box
|
||||||
|
(action (ds LIMIT REPORT_EVERY)
|
||||||
|
(spawn (define root-facet this-facet)
|
||||||
|
(define-field value 0)
|
||||||
(define start-time (current-inexact-milliseconds))
|
(define start-time (current-inexact-milliseconds))
|
||||||
(define prev-value 0)
|
(define prev-value 0)
|
||||||
(turn-assert! turn ds
|
(at ds
|
||||||
(Observe->preserves
|
(assert (BoxState->preserves (BoxState (value))))
|
||||||
(Observe 'SetBox
|
(when (message (SetBox new-value))
|
||||||
(turn-ref turn
|
|
||||||
(entity #:message
|
|
||||||
(lambda (turn new-value-rec)
|
|
||||||
(define new-value (SetBox-value new-value-rec))
|
|
||||||
(when (zero? (remainder new-value REPORT_EVERY))
|
(when (zero? (remainder new-value REPORT_EVERY))
|
||||||
(define end-time (current-inexact-milliseconds))
|
(define end-time (current-inexact-milliseconds))
|
||||||
(define delta (/ (- end-time start-time) 1000.0))
|
(define delta (/ (- end-time start-time) 1000.0))
|
||||||
(define count (- new-value prev-value))
|
(define count (- new-value prev-value))
|
||||||
(set! prev-value new-value)
|
(set! prev-value new-value)
|
||||||
(set! start-time end-time)
|
(set! start-time end-time)
|
||||||
(log-info "Box got ~a (~a Hz)"
|
(log-info "Box got ~a (~a Hz)" new-value (/ count delta)))
|
||||||
new-value
|
|
||||||
(/ count delta)))
|
|
||||||
(when (= new-value LIMIT)
|
(when (= new-value LIMIT)
|
||||||
(turn-stop-actor! turn))
|
(stop-facet root-facet))
|
||||||
(value new-value))))))))
|
(value new-value))))))
|
||||||
|
|
||||||
(define ((client ds) turn)
|
(define client
|
||||||
(turn-assert! turn ds
|
(action (ds)
|
||||||
(Observe->preserves
|
(spawn (define root-facet this-facet)
|
||||||
|
(define count 0)
|
||||||
|
(at ds
|
||||||
|
(when (asserted (BoxState value))
|
||||||
|
(send! ds (SetBox->preserves (SetBox (+ value 1)))))
|
||||||
|
;; (during (BoxState _)
|
||||||
|
;; (on-start (set! count (+ count 1)))
|
||||||
|
;; (on-stop (set! count (- count 1))
|
||||||
|
;; (when (zero? count)
|
||||||
|
;; (log-info "Client detected box termination")
|
||||||
|
;; (stop-facet root-facet))))
|
||||||
|
(assert (Observe->preserves
|
||||||
(Observe 'BoxState
|
(Observe 'BoxState
|
||||||
(turn-ref turn
|
(ref (entity #:assert
|
||||||
(entity #:assert
|
(action (_v _h)
|
||||||
(lambda (turn current-value _handle)
|
|
||||||
;; (log-info "Client got ~a" current-value)
|
|
||||||
(turn-message! turn ds
|
|
||||||
(SetBox->preserves
|
|
||||||
(SetBox
|
|
||||||
(+ (BoxState-value current-value)
|
|
||||||
1))))))))))
|
|
||||||
(let ((count 0))
|
|
||||||
(turn-assert! turn ds
|
|
||||||
(Observe->preserves
|
|
||||||
(Observe 'BoxState
|
|
||||||
(turn-ref turn
|
|
||||||
(entity #:assert
|
|
||||||
(lambda (turn current-value _handle)
|
|
||||||
(set! count (+ count 1)))
|
(set! count (+ count 1)))
|
||||||
#:retract
|
#:retract
|
||||||
(lambda (turn _handle)
|
(action (_h)
|
||||||
(set! count (- count 1))
|
(set! count (- count 1))
|
||||||
(when (zero? count)
|
(when (zero? count)
|
||||||
(log-info "Client detected box termination")
|
(log-info "Client detected box termination")
|
||||||
(turn-stop-actor! turn))))))))))
|
(stop-facet root-facet))))))))
|
||||||
|
;; (during (BoxState _)
|
||||||
|
;; (on-stop (log-info "Client detected box termination")
|
||||||
|
;; (stop-facet root-facet)))
|
||||||
|
))))
|
||||||
|
|
||||||
(define (dataspace)
|
(define (dataspace)
|
||||||
(define handles (make-hash))
|
(define handles (make-hash))
|
||||||
(define assertions (make-bag))
|
(define assertions (make-bag))
|
||||||
(define subscriptions (make-hash))
|
(define subscriptions (make-hash))
|
||||||
(entity #:assert (lambda (turn rec handle)
|
(entity #:assert (action (rec handle)
|
||||||
(when (record? rec)
|
(when (record? rec)
|
||||||
(hash-set! handles handle rec)
|
(hash-set! handles handle rec)
|
||||||
(when (eq? (bag-change! assertions rec +1) 'absent->present)
|
(when (eq? (bag-change! assertions rec +1) 'absent->present)
|
||||||
|
@ -76,17 +74,17 @@
|
||||||
(hash-set! (hash-ref! subscriptions label make-hasheq) observer seen)
|
(hash-set! (hash-ref! subscriptions label make-hasheq) observer seen)
|
||||||
(for [(existing (in-bag assertions))]
|
(for [(existing (in-bag assertions))]
|
||||||
(when (preserve=? (record-label existing) label)
|
(when (preserve=? (record-label existing) label)
|
||||||
(hash-set! seen existing (turn-assert! turn observer existing))))])
|
(hash-set! seen existing (turn-assert! this-turn observer existing))))])
|
||||||
(for [((observer seen) (in-hash (hash-ref subscriptions (record-label rec) '#hash())))]
|
(for [((observer seen) (in-hash (hash-ref subscriptions (record-label rec) '#hash())))]
|
||||||
(unless (hash-has-key? seen rec)
|
(unless (hash-has-key? seen rec)
|
||||||
(hash-set! seen rec (turn-assert! turn observer rec)))))))
|
(hash-set! seen rec (turn-assert! this-turn observer rec)))))))
|
||||||
#:retract (lambda (turn upstream-handle)
|
#:retract (action (upstream-handle)
|
||||||
(define rec (hash-ref handles upstream-handle #f))
|
(define rec (hash-ref handles upstream-handle #f))
|
||||||
(when rec
|
(when rec
|
||||||
(hash-remove! handles upstream-handle)
|
(hash-remove! handles upstream-handle)
|
||||||
(when (eq? (bag-change! assertions rec -1) 'present->absent)
|
(when (eq? (bag-change! assertions rec -1) 'present->absent)
|
||||||
(for [(seen (in-hash-values (hash-ref subscriptions (record-label rec) '#hash())))]
|
(for [(seen (in-hash-values (hash-ref subscriptions (record-label rec) '#hash())))]
|
||||||
(turn-retract! turn (hash-ref seen rec))
|
(turn-retract! this-turn (hash-ref seen rec))
|
||||||
(hash-remove! seen rec))
|
(hash-remove! seen rec))
|
||||||
(match (parse-Observe rec)
|
(match (parse-Observe rec)
|
||||||
[(? eof-object?) (void)]
|
[(? eof-object?) (void)]
|
||||||
|
@ -95,17 +93,15 @@
|
||||||
(hash-remove! subscribers observer)
|
(hash-remove! subscribers observer)
|
||||||
(when (hash-empty? subscribers)
|
(when (hash-empty? subscribers)
|
||||||
(hash-remove! subscriptions label)))]))))
|
(hash-remove! subscriptions label)))]))))
|
||||||
#:message (lambda (turn message)
|
#:message (action (message)
|
||||||
(when (record? message)
|
(when (record? message)
|
||||||
(for [(peer (in-hash-keys (hash-ref subscriptions (record-label message) '#hash())))]
|
(for [(peer (in-hash-keys (hash-ref subscriptions (record-label message) '#hash())))]
|
||||||
(turn-message! turn peer message))))))
|
(turn-message! this-turn peer message))))))
|
||||||
|
|
||||||
(module+ main
|
(module+ main
|
||||||
(time
|
(time
|
||||||
(actor-system
|
(actor-system
|
||||||
(lambda (turn)
|
(define disarm (facet-prevent-inert-check! this-facet))
|
||||||
(actor-daemon! (facet-actor (turn-active-facet turn)) #t)
|
(define ds (ref (dataspace)))
|
||||||
(define disarm (facet-prevent-inert-check! (turn-active-facet turn)))
|
(box this-turn ds 500000 100000)
|
||||||
(define ds (turn-ref turn (dataspace)))
|
(client this-turn ds))))
|
||||||
(turn-spawn! turn (box ds 500000 100000))
|
|
||||||
(turn-spawn! turn (client ds))))))
|
|
||||||
|
|
|
@ -4,6 +4,8 @@
|
||||||
(define deps '(
|
(define deps '(
|
||||||
|
|
||||||
"base"
|
"base"
|
||||||
|
|
||||||
|
"auxiliary-macro-context"
|
||||||
"preserves"
|
"preserves"
|
||||||
"struct-defaults"
|
"struct-defaults"
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,204 @@
|
||||||
|
#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
|
||||||
|
|
||||||
|
this-target
|
||||||
|
at
|
||||||
|
assert
|
||||||
|
(rename-out [event:when when])
|
||||||
|
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")
|
||||||
|
|
||||||
|
(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-rule (actor-system 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 assertion))
|
||||||
|
|
||||||
|
(define-syntax-rule (spawn 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-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 () expr))]))
|
||||||
|
|
||||||
|
(require "schemas/gen/dataspace.rkt")
|
||||||
|
|
||||||
|
(define-event-expander event:when
|
||||||
|
(lambda (stx)
|
||||||
|
(syntax-case stx (message asserted)
|
||||||
|
[(_ (message (label fields ...)) expr ...)
|
||||||
|
#`(assert (Observe->preserves
|
||||||
|
(Observe 'label
|
||||||
|
(ref (entity #:message
|
||||||
|
(action (rec)
|
||||||
|
(match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec)
|
||||||
|
[(? eof-object?) (void)]
|
||||||
|
[(label fields ...)
|
||||||
|
expr ...])))))))]
|
||||||
|
[(_ (asserted (label fields ...)) expr ...)
|
||||||
|
#`(assert (Observe->preserves
|
||||||
|
(Observe 'label
|
||||||
|
(ref (entity #:assert
|
||||||
|
(action (rec handle)
|
||||||
|
(match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec)
|
||||||
|
[(? eof-object?) (void)]
|
||||||
|
[(label fields ...)
|
||||||
|
expr ...])))))))]))
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ test expr ...)
|
||||||
|
(when test expr ...)]))
|
||||||
|
|
||||||
|
(define-event-expander during
|
||||||
|
(lambda (stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ (label fields ...) expr ...)
|
||||||
|
#`(assert (Observe->preserves
|
||||||
|
(Observe 'label
|
||||||
|
(ref (let ((assertion-map (make-hash)))
|
||||||
|
(entity #:assert
|
||||||
|
(action (rec handle)
|
||||||
|
(match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec)
|
||||||
|
[(? eof-object?) (void)]
|
||||||
|
[(label fields ...)
|
||||||
|
(let ((facet (react
|
||||||
|
(facet-prevent-inert-check! this-facet)
|
||||||
|
expr ...)))
|
||||||
|
(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 'scheme-indent-function 1)
|
||||||
|
;;; eval: (put 'action 'racket-indent-function 1)
|
||||||
|
;;; End:
|
Loading…
Reference in New Issue