syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Eliminate a few useless parameters

This commit is contained in:
Tony Garnock-Jones 2018-04-06 11:58:49 +01:00
parent 2e67feee6d
commit 4c4afc6b6e
1 changed files with 54 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
syndicate/dataspace.rkt
View File

@ -75,15 +75,9 @@
;; Parameterof Dataspace ;; Parameterof Dataspace
(define current-dataspace (make-parameter #f)) (define current-dataspace (make-parameter #f))
;; Parameterof FID
(define current-actor (make-parameter #f))
;; Parameterof FID ;; Parameterof FID
(define current-facet-id (make-parameter #f)) (define current-facet-id (make-parameter #f))
;; Parameterof Facet
(define current-facet (make-parameter #f))
;; Parameterof Boolean ;; Parameterof Boolean
(define in-script? (make-parameter #t)) (define in-script? (make-parameter #t))
@ -149,26 +143,22 @@
(define (add-actor! ds boot-proc) (define (add-actor! ds boot-proc)
(define actor-fid (generate-fid! ds '())) (define actor-fid (generate-fid! ds '()))
(set-add! (dataspace-actors ds) actor-fid) (set-add! (dataspace-actors ds) actor-fid)
(add-facet! ds actor-fid actor-fid boot-proc)) (add-facet! ds actor-fid boot-proc))
(define (lookup-facet ds fid) (define (lookup-facet ds fid)
(hash-ref (dataspace-facets ds) fid #f)) (hash-ref (dataspace-facets ds) fid #f))
(define-syntax-rule (with-current-facet [ds actor-fid fid f script?] body ...) (define-syntax-rule (with-current-facet [ds fid script?] body ...)
(parameterize ((current-dataspace ds) (parameterize ((current-dataspace ds)
(current-actor actor-fid)
(current-facet-id fid) (current-facet-id fid)
(current-facet f)
(in-script? script?)) (in-script? script?))
body ...)) body ...))
(define (capture-facet-context proc) (define (capture-facet-context proc)
(let ((ds (current-dataspace)) (let ((ds (current-dataspace))
(actor-fid (current-actor)) (fid (current-facet-id)))
(fid (current-facet-id))
(f (current-facet)))
(lambda args (lambda args
(with-current-facet [ds actor-fid fid f #t] (with-current-facet [ds fid #t]
(apply proc args))))) (apply proc args)))))
(define (pop-next-script! ds) (define (pop-next-script! ds)
@ -191,17 +181,18 @@
(match-define (list fid eid) subject-id) (match-define (list fid eid) subject-id)
(define f (lookup-facet ds fid)) (define f (lookup-facet ds fid))
(when f (when f
(define ep (hash-ref (facet-endpoints f) eid)) (with-current-facet [ds fid #f]
(define old-assertion (endpoint-assertion ep)) (define ep (hash-ref (facet-endpoints f) eid))
(define new-assertion ((endpoint-assertion-fn ep))) (define old-assertion (endpoint-assertion ep))
(when (not (equal? old-assertion new-assertion)) (define new-assertion ((endpoint-assertion-fn ep)))
(set-endpoint-assertion! ep new-assertion) (when (not (equal? old-assertion new-assertion))
(dataspace-retract! ds old-assertion) (set-endpoint-assertion! ep new-assertion)
(dataspace-assert! ds new-assertion) (dataspace-retract! ds old-assertion)
(define h (endpoint-handler ep)) (dataspace-assert! ds new-assertion)
(when h (define h (endpoint-handler ep))
(dataspace-unsubscribe! ds h) (when h
(dataspace-subscribe! ds h)))))) (dataspace-unsubscribe! ds h)
(dataspace-subscribe! ds h)))))))
(run-all-pending-scripts! ds)))) (run-all-pending-scripts! ds))))
(define (perform-pending-actions! ds) (define (perform-pending-actions! ds)
@ -230,7 +221,7 @@
;; being held elsewhere! ;; being held elsewhere!
(or ran-a-script performed-an-action)) (or ran-a-script performed-an-action))
(define (add-facet! ds actor-fid fid boot-proc) (define (add-facet! ds fid boot-proc)
(define parent-fid (fid-parent fid)) (define parent-fid (fid-parent fid))
(define f (facet fid (define f (facet fid
(make-hash) (make-hash)
@ -240,13 +231,13 @@
(when (pair? parent-fid) (when (pair? parent-fid)
(define pf (lookup-facet ds parent-fid)) (define pf (lookup-facet ds parent-fid))
(when pf (set-facet-children! pf (set-add (facet-children pf) fid)))) (when pf (set-facet-children! pf (set-add (facet-children pf) fid))))
(with-current-facet [ds actor-fid fid f #f] (with-current-facet [ds fid #f]
(boot-proc)) (boot-proc))
(schedule-script! ds (lambda () (schedule-script! ds (lambda ()
(when (and (facet-live? ds fid) (when (and (facet-live? ds fid)
(or (and (pair? parent-fid) (not (facet-live? ds parent-fid))) (or (and (pair? parent-fid) (not (facet-live? ds parent-fid)))
(facet-live-but-inert? ds fid))) (facet-live-but-inert? ds fid)))
(terminate-facet! ds actor-fid fid))))) (terminate-facet! ds fid)))))
(define (facet-live? ds fid) (define (facet-live? ds fid)
(hash-has-key? (dataspace-facets ds) fid)) (hash-has-key? (dataspace-facets ds) fid))
@ -259,9 +250,9 @@
(define (schedule-script! #:priority [priority *normal-priority*] ds thunk) (define (schedule-script! #:priority [priority *normal-priority*] ds thunk)
(define v (dataspace-pending-scripts ds)) (define v (dataspace-pending-scripts ds))
(vector-set! v priority (enqueue (vector-ref v priority) thunk))) (vector-set! v priority (enqueue (vector-ref v priority) (capture-facet-context thunk))))
(define (terminate-facet! ds actor-fid fid) (define (terminate-facet! ds fid)
(define f (lookup-facet ds fid)) (define f (lookup-facet ds fid))
(when f (when f
(define parent-fid (fid-parent fid)) (define parent-fid (fid-parent fid))
@ -273,7 +264,7 @@
(hash-remove! (dataspace-facets ds) fid) (hash-remove! (dataspace-facets ds) fid)
(for [(child-fid (in-set (facet-children f)))] (for [(child-fid (in-set (facet-children f)))]
(terminate-facet! ds actor-fid child-fid)) (terminate-facet! ds child-fid))
;; Run stop-scripts after terminating children. This means that ;; Run stop-scripts after terminating children. This means that
;; children's stop-scripts run before ours. ;; children's stop-scripts run before ours.
@ -295,21 +286,28 @@
(lambda () (lambda ()
(when (and (pair? parent-fid) (facet-live-but-inert? ds parent-fid)) (when (and (pair? parent-fid) (facet-live-but-inert? ds parent-fid))
(log-info "terminating ~v because it's dead and child ~v terminated" parent-fid fid) (log-info "terminating ~v because it's dead and child ~v terminated" parent-fid fid)
(terminate-facet! ds actor-fid parent-fid)))))) (terminate-facet! ds parent-fid))))))
(define (stop-facet! ds fid stop-script)
(with-current-facet [ds (fid-parent fid) #t] ;; run in parent context wrt terminating facet
(schedule-script! ds (lambda ()
(terminate-facet! ds fid)
(schedule-script! ds stop-script)))))
(define (add-endpoint! ds where assertion-fn handler) (define (add-endpoint! ds where assertion-fn handler)
(when (in-script?) (when (in-script?)
(error 'add-endpoint! (error 'add-endpoint!
"~a: Cannot add endpoint in script; are you missing a (react ...)?" "~a: Cannot add endpoint in script; are you missing a (react ...)?"
where)) where))
(define fid (current-facet-id))
(define eid (generate-id! ds)) (define eid (generate-id! ds))
(define assertion (define assertion
(parameterize ((current-dataflow-subject-id (list (current-facet-id) eid))) (parameterize ((current-dataflow-subject-id (list fid eid)))
(assertion-fn))) (assertion-fn)))
(define ep (endpoint eid assertion assertion-fn handler)) (define ep (endpoint eid assertion assertion-fn handler))
(dataspace-assert! ds assertion) (dataspace-assert! ds assertion)
(when handler (dataspace-subscribe! ds handler)) (when handler (dataspace-subscribe! ds handler))
(hash-set! (facet-endpoints (current-facet)) eid ep)) (hash-set! (facet-endpoints (lookup-facet ds fid)) eid ep))
(define (ensure-patch-action! ds) (define (ensure-patch-action! ds)
(define old-q (dataspace-pending-actions ds)) (define old-q (dataspace-pending-actions ds))
@ -355,31 +353,21 @@
0)) 0))
(add-endpoint! (current-dataspace) (add-endpoint! (current-dataspace)
'stop-when-ten 'stop-when-ten
(capture-facet-context (lambda ()
(lambda () (when (= (current-value) 10)
(when (= (current-value) 10) (stop-facet! (current-dataspace)
(schedule-script! (current-dataspace) (current-facet-id)
(capture-facet-context (lambda ()
(lambda () (printf "box: terminating\n"))))
(schedule-script! (void))
(current-dataspace)
(capture-facet-context
(lambda ()
(printf "box: terminating\n"))))
(terminate-facet! (current-dataspace)
(current-actor)
(current-facet-id))))))
(void)))
#f) #f)
(add-endpoint! (current-dataspace) (add-endpoint! (current-dataspace)
'assert-box-state 'assert-box-state
(capture-facet-context (lambda () (box-state (current-value)))
(lambda () (box-state (current-value))))
#f) #f)
(add-endpoint! (current-dataspace) (add-endpoint! (current-dataspace)
'on-message-set-box 'on-message-set-box
(capture-facet-context (lambda () (observe (set-box (capture (discard)))))
(lambda () (observe (set-box (capture (discard))))))
(skeleton-interest (list struct:set-box #f) (skeleton-interest (list struct:set-box #f)
'() '()
'() '()
@ -389,16 +377,14 @@
(when (eq? '! op) (when (eq? '! op)
(schedule-script! (schedule-script!
(current-dataspace) (current-dataspace)
(capture-facet-context (lambda ()
(lambda () (printf "new-value ~a ~v\n" op new-value)
(printf "new-value ~a ~v\n" op new-value) (current-value new-value))))))))))
(current-value new-value)))))))))))
(add-actor! ds (add-actor! ds
(lambda () (lambda ()
(add-endpoint! (current-dataspace) (add-endpoint! (current-dataspace)
'stop-when-retracted-observe-set-box 'stop-when-retracted-observe-set-box
(capture-facet-context (lambda () (observe (observe (set-box (discard)))))
(lambda () (observe (observe (set-box (discard))))))
(skeleton-interest (list struct:observe (list struct:set-box #f)) (skeleton-interest (list struct:observe (list struct:set-box #f))
'() '()
'() '()
@ -406,22 +392,14 @@
(capture-facet-context (capture-facet-context
(lambda (op) (lambda (op)
(when (eq? '- op) (when (eq? '- op)
(schedule-script! (stop-facet!
(current-dataspace) (current-dataspace)
(capture-facet-context (current-facet-id)
(lambda () (lambda ()
(schedule-script! (printf "client: box has gone\n"))))))))
(current-dataspace)
(capture-facet-context
(lambda ()
(printf "client: box has gone\n"))))
(terminate-facet! (current-dataspace)
(current-actor)
(current-facet-id))))))))))
(add-endpoint! (current-dataspace) (add-endpoint! (current-dataspace)
'on-asserted-box-state 'on-asserted-box-state
(capture-facet-context (lambda () (observe (box-state (capture (discard)))))
(lambda () (observe (box-state (capture (discard))))))
(skeleton-interest (list struct:box-state #f) (skeleton-interest (list struct:box-state #f)
'() '()
'() '()
@ -431,11 +409,10 @@
(when (eq? '+ op) (when (eq? '+ op)
(schedule-script! (schedule-script!
(current-dataspace) (current-dataspace)
(capture-facet-context (lambda ()
(lambda () (printf "v ~a ~v\n" op v)
(printf "v ~a ~v\n" op v) (dataspace-send! (current-dataspace)
(dataspace-send! (current-dataspace) (set-box (+ v 1))))))))))))
(set-box (+ v 1)))))))))))))
(require racket/pretty) (require racket/pretty)
(pretty-print ds) (pretty-print ds)