#lang syndicate/monolithic, integrated with incremental
This commit is contained in:
parent
7c11a438e4
commit
2afa0fce15
|
@ -39,6 +39,7 @@
|
|||
meta-label?
|
||||
|
||||
prepend-at-meta
|
||||
observe-at-meta
|
||||
assert
|
||||
retract
|
||||
sub
|
||||
|
|
|
@ -0,0 +1,24 @@
|
|||
#lang syndicate/monolithic
|
||||
;; Hello-worldish "bank account" example.
|
||||
|
||||
(struct account (balance) #:prefab)
|
||||
(struct deposit (amount) #:prefab)
|
||||
|
||||
(define (manager e balance)
|
||||
(match-event e
|
||||
[(message (deposit amount))
|
||||
(transition (+ balance amount)
|
||||
(scn (assertion (account (+ balance amount)))))]))
|
||||
|
||||
(define (observer e _)
|
||||
(when (scn? e) (for [(balance (project-assertions (scn-trie e) (account (?!))))]
|
||||
(printf "Balance changed to ~a\n" balance))))
|
||||
|
||||
(define (updater e _)
|
||||
(when (and (scn? e) (trie-non-empty? (scn-trie e)))
|
||||
(quit (list (message (deposit +100))
|
||||
(message (deposit -30))))))
|
||||
|
||||
(spawn manager 0 (scn/union (assertion (observe (deposit ?))) (assertion (account 0))))
|
||||
(spawn observer (void) (scn (assertion (observe (account ?)))))
|
||||
(spawn updater (void) (scn (assertion (observe (observe (deposit ?))))))
|
|
@ -0,0 +1,15 @@
|
|||
#lang racket/base
|
||||
|
||||
(module reader syntax/module-reader
|
||||
syndicate/monolithic)
|
||||
|
||||
(require (except-in "lang.rkt"
|
||||
event?
|
||||
action?
|
||||
clean-transition
|
||||
spawn))
|
||||
(require "monolithic/scn.rkt")
|
||||
(require "monolithic/core.rkt")
|
||||
(provide (all-from-out "lang.rkt")
|
||||
(all-from-out "monolithic/scn.rkt")
|
||||
(all-from-out "monolithic/core.rkt"))
|
|
@ -0,0 +1,138 @@
|
|||
#lang racket/base
|
||||
;; Monolithic Syndicate adapter.
|
||||
|
||||
(provide event?
|
||||
action?
|
||||
clean-transition
|
||||
|
||||
assertion
|
||||
subscription
|
||||
advertisement
|
||||
|
||||
assertion-set-union
|
||||
assertion-set-union*
|
||||
scn/union
|
||||
|
||||
(struct-out monolithic-wrapper)
|
||||
wrap-monolithic-state
|
||||
wrap-monolithic-behaviour
|
||||
(rename-out [spawn-monolithic spawn]))
|
||||
|
||||
(require racket/match)
|
||||
(require (only-in racket/list flatten))
|
||||
|
||||
(require "scn.rkt")
|
||||
(require "../trie.rkt")
|
||||
(require (except-in "../core.rkt"
|
||||
event?
|
||||
action?
|
||||
clean-transition))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (event? x) (or (scn? x) (message? x)))
|
||||
(define (action? x) (or (event? x) (spawn? x) (quit-dataspace? x)))
|
||||
|
||||
(define (clean-transition t)
|
||||
(match t
|
||||
[#f #f]
|
||||
[(<quit> exn actions) (quit exn (clean-actions actions))]
|
||||
[(transition state actions) (transition state (clean-actions actions))]
|
||||
[(? void?) #f]))
|
||||
|
||||
(define (clean-actions actions)
|
||||
(filter action? (flatten actions)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (assertion pattern #:meta-level [level 0])
|
||||
(pattern->trie '<assertion> (prepend-at-meta pattern level)))
|
||||
|
||||
(define (subscription pattern #:meta-level [level 0])
|
||||
(observe-at-meta pattern level))
|
||||
|
||||
(define (advertisement pattern #:meta-level [level 0])
|
||||
(assertion (advertise pattern) #:meta-level level))
|
||||
|
||||
(define (assertion-set-union . tries)
|
||||
(assertion-set-union* tries))
|
||||
|
||||
(define (assertion-set-union* tries)
|
||||
(match tries
|
||||
['() trie-empty]
|
||||
[(cons t1 rest)
|
||||
(for/fold [(t1 t1)] [(t2 (in-list rest))]
|
||||
(trie-union t1 t2 #:combiner (lambda (a b) (trie-success '<assertion-set-union*>))))]))
|
||||
|
||||
(define (scn/union . tries)
|
||||
(scn (assertion-set-union* tries)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(struct monolithic-wrapper (state assertions-in assertions-out) #:prefab)
|
||||
|
||||
(define (wrap-monolithic-state underlying-state)
|
||||
(monolithic-wrapper underlying-state trie-empty trie-empty))
|
||||
|
||||
(define (integrate-incoming incremental-e wrapped-state)
|
||||
(match incremental-e
|
||||
[(? patch? p)
|
||||
(define new-assertions-in
|
||||
(update-interests (monolithic-wrapper-assertions-in wrapped-state) p))
|
||||
(values (struct-copy monolithic-wrapper wrapped-state
|
||||
[assertions-in new-assertions-in])
|
||||
(scn new-assertions-in))]
|
||||
[(or (? message?) #f)
|
||||
(values wrapped-state incremental-e)]))
|
||||
|
||||
(define (differentiate-outgoing wrapped-state monolithic-actions)
|
||||
(let loop ((assertions-out (monolithic-wrapper-assertions-out wrapped-state))
|
||||
(actions-remaining monolithic-actions)
|
||||
(incremental-actions-rev '()))
|
||||
(match actions-remaining
|
||||
['()
|
||||
(transition (struct-copy monolithic-wrapper wrapped-state
|
||||
[assertions-out assertions-out])
|
||||
(reverse incremental-actions-rev))]
|
||||
[(cons monolithic-action rest)
|
||||
(match monolithic-action
|
||||
[(scn new-interests)
|
||||
(loop new-interests
|
||||
rest
|
||||
(cons (compute-patch assertions-out new-interests) incremental-actions-rev))]
|
||||
[other
|
||||
(loop assertions-out
|
||||
rest
|
||||
(cons other incremental-actions-rev))])])))
|
||||
|
||||
(define (wrap-monolithic-behaviour underlying-behavior)
|
||||
(lambda (incremental-e wrapped-state0)
|
||||
(define-values (wrapped-state monolithic-e) (integrate-incoming incremental-e wrapped-state0))
|
||||
(match (clean-transition
|
||||
(underlying-behavior monolithic-e (monolithic-wrapper-state wrapped-state)))
|
||||
[#f (if (eq? wrapped-state wrapped-state0)
|
||||
#f
|
||||
(transition wrapped-state '()))]
|
||||
[(<quit> exn monolithic-actions)
|
||||
(match-define (transition _ignored-final-state incremental-actions)
|
||||
(differentiate-outgoing wrapped-state monolithic-actions))
|
||||
(<quit> exn incremental-actions)]
|
||||
[(transition new-underlying-state monolithic-actions)
|
||||
(differentiate-outgoing (struct-copy monolithic-wrapper wrapped-state
|
||||
[state new-underlying-state])
|
||||
monolithic-actions)])))
|
||||
|
||||
(define-syntax spawn-monolithic
|
||||
(syntax-rules ()
|
||||
[(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp)
|
||||
(<spawn> (lambda ()
|
||||
(list (wrap-monolithic-behaviour behavior-exp)
|
||||
(differentiate-outgoing (wrap-monolithic-state initial-state-exp)
|
||||
(clean-actions initial-action-tree-exp))
|
||||
name-exp)))]
|
||||
[(_ behavior-exp initial-state-exp initial-action-tree-exp)
|
||||
(<spawn> (lambda ()
|
||||
(list (wrap-monolithic-behaviour behavior-exp)
|
||||
(differentiate-outgoing (wrap-monolithic-state initial-state-exp)
|
||||
(clean-actions initial-action-tree-exp))
|
||||
#f)))]))
|
|
@ -0,0 +1,36 @@
|
|||
#lang racket/base
|
||||
;; State Change Notifications, and assorted protocol constructors
|
||||
|
||||
(provide (struct-out scn)
|
||||
lift-scn
|
||||
drop-scn
|
||||
strip-scn
|
||||
label-scn)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require "../trie.rkt")
|
||||
(require "../patch.rkt")
|
||||
(require "../pretty.rkt")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; State Change Notifications
|
||||
(struct scn (trie) #:transparent
|
||||
#:methods gen:syndicate-pretty-printable
|
||||
[(define (syndicate-pretty-print d [p (current-output-port)])
|
||||
(pretty-print-trie (scn-trie d) p))])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (lift-scn s)
|
||||
(scn (pattern->trie '<lift-scn> (at-meta (embedded-trie (scn-trie s))))))
|
||||
|
||||
(define (drop-scn s)
|
||||
(scn (drop-interests (scn-trie s))))
|
||||
|
||||
(define (strip-scn s)
|
||||
(scn (strip-interests (scn-trie s))))
|
||||
|
||||
(define (label-scn s label)
|
||||
(scn (label-interests (scn-trie s) label)))
|
|
@ -13,6 +13,7 @@
|
|||
patch/added?
|
||||
patch/removed?
|
||||
lift-patch
|
||||
drop-interests
|
||||
drop-patch
|
||||
strip-interests
|
||||
label-interests
|
||||
|
|
Loading…
Reference in New Issue