From 2afa0fce15a7b0d1df28bbae1c2728138cd3be8d Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 12 Jul 2016 13:45:32 -0400 Subject: [PATCH] #lang syndicate/monolithic, integrated with incremental --- racket/syndicate/core.rkt | 1 + .../examples/bank-account-monolithic.rkt | 24 +++ racket/syndicate/monolithic.rkt | 15 ++ racket/syndicate/monolithic/core.rkt | 138 ++++++++++++++++++ racket/syndicate/monolithic/scn.rkt | 36 +++++ racket/syndicate/patch.rkt | 1 + 6 files changed, 215 insertions(+) create mode 100644 racket/syndicate/examples/bank-account-monolithic.rkt create mode 100644 racket/syndicate/monolithic.rkt create mode 100644 racket/syndicate/monolithic/core.rkt create mode 100644 racket/syndicate/monolithic/scn.rkt diff --git a/racket/syndicate/core.rkt b/racket/syndicate/core.rkt index ec0f7e8..bee33ca 100644 --- a/racket/syndicate/core.rkt +++ b/racket/syndicate/core.rkt @@ -39,6 +39,7 @@ meta-label? prepend-at-meta + observe-at-meta assert retract sub diff --git a/racket/syndicate/examples/bank-account-monolithic.rkt b/racket/syndicate/examples/bank-account-monolithic.rkt new file mode 100644 index 0000000..e448d8f --- /dev/null +++ b/racket/syndicate/examples/bank-account-monolithic.rkt @@ -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 ?)))))) diff --git a/racket/syndicate/monolithic.rkt b/racket/syndicate/monolithic.rkt new file mode 100644 index 0000000..1657693 --- /dev/null +++ b/racket/syndicate/monolithic.rkt @@ -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")) diff --git a/racket/syndicate/monolithic/core.rkt b/racket/syndicate/monolithic/core.rkt new file mode 100644 index 0000000..0cb94f0 --- /dev/null +++ b/racket/syndicate/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] + [( 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 ' (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 '))))])) + +(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 '()))] + [( exn monolithic-actions) + (match-define (transition _ignored-final-state incremental-actions) + (differentiate-outgoing wrapped-state monolithic-actions)) + ( 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) + ( (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) + ( (lambda () + (list (wrap-monolithic-behaviour behavior-exp) + (differentiate-outgoing (wrap-monolithic-state initial-state-exp) + (clean-actions initial-action-tree-exp)) + #f)))])) diff --git a/racket/syndicate/monolithic/scn.rkt b/racket/syndicate/monolithic/scn.rkt new file mode 100644 index 0000000..9a3fd68 --- /dev/null +++ b/racket/syndicate/monolithic/scn.rkt @@ -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 ' (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))) diff --git a/racket/syndicate/patch.rkt b/racket/syndicate/patch.rkt index 1a4fd8f..7bca800 100644 --- a/racket/syndicate/patch.rkt +++ b/racket/syndicate/patch.rkt @@ -13,6 +13,7 @@ patch/added? patch/removed? lift-patch + drop-interests drop-patch strip-interests label-interests