#lang syndicate/monolithic, integrated with incremental
This commit is contained in:
parent
7c11a438e4
commit
2afa0fce15
|
@ -39,6 +39,7 @@
|
||||||
meta-label?
|
meta-label?
|
||||||
|
|
||||||
prepend-at-meta
|
prepend-at-meta
|
||||||
|
observe-at-meta
|
||||||
assert
|
assert
|
||||||
retract
|
retract
|
||||||
sub
|
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/added?
|
||||||
patch/removed?
|
patch/removed?
|
||||||
lift-patch
|
lift-patch
|
||||||
|
drop-interests
|
||||||
drop-patch
|
drop-patch
|
||||||
strip-interests
|
strip-interests
|
||||||
label-interests
|
label-interests
|
||||||
|
|
Loading…
Reference in New Issue