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

Improved interface to gestalt-project.

This commit is contained in:
Tony Garnock-Jones 2014-06-18 16:05:46 -04:00
parent 77f876c737
commit 7df1e40433
7 changed files with 66 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
minimart/core.rkt
View File

@ -22,10 +22,9 @@
(struct-out capture)
pretty-print-matcher
matcher->pretty-string
matcher-key-set
matcher-key-set/single
projection->pattern
matcher-empty?
(rename-out [projection->pattern matcher-projection->pattern]
[compile-projection compile-matcher-projection])
sub
pub

9
minimart/demand-matcher.rkt
View File

@ -5,6 +5,7 @@
(require racket/match)
(require "core.rkt")
(require "gestalt.rkt")
(require (only-in "route.rkt" matcher-key-set))
(provide (except-out (struct-out demand-matcher) demand-matcher)
(rename-out [make-demand-matcher demand-matcher])
@ -48,8 +49,8 @@
increase-handler ;; ChangeHandler
[decrease-handler default-decrease-handler]) ;; ChangeHandler
(demand-matcher demand-is-subscription?
(projection->pattern projection)
(compile-gestalt-projection projection)
(matcher-projection->pattern projection)
(compile-matcher-projection projection)
meta-level
demand-level
supply-level
@ -65,8 +66,8 @@
;; demanded supply.
(define (demand-matcher-update d s g)
(match-define (demand-matcher demand-is-sub? _ spec ml dl sl inc-h dec-h old-demand old-supply) d)
(define new-demand (matcher-key-set (gestalt-project g ml dl (not demand-is-sub?) spec)))
(define new-supply (matcher-key-set (gestalt-project g ml sl demand-is-sub? spec)))
(define new-demand (matcher-key-set (gestalt-project* g ml dl (not demand-is-sub?) spec)))
(define new-supply (matcher-key-set (gestalt-project* g ml sl demand-is-sub? spec)))
(define demand+ (set-subtract (set-subtract new-demand old-demand) new-supply))
(define supply- (set-intersect (set-subtract old-supply new-supply) new-demand))
(define new-d (struct-copy demand-matcher d

4
minimart/examples/chat-userland.rkt
View File

@ -19,9 +19,7 @@
(sub (tcp-channel them us ?) #:meta-level 1 #:level 1)
(sub (tcp-channel them us ?) #:meta-level 1)))
(define (gestalt->peers g)
(matcher-key-set/single
(gestalt-project g 0 0 #t (compile-gestalt-projection `(,(?!) says ,?)))))
(define (gestalt->peers g) (gestalt-project/single g (project-pubs `(,(?!) says ,?))))
(userland-thread #:gestalt (gestalt-union tcp-gestalt
(sub `(,? says ,?))

4
minimart/examples/chat-userland2.rkt
View File

@ -43,9 +43,7 @@
(loop old-peers)]
[(routing-update g)
(when (gestalt-empty? (gestalt-filter g tcp-gestalt)) (do (quit)))
(define new-peers
(matcher-key-set/single
(gestalt-project g 0 0 #t (compile-gestalt-projection `(,(?!) says ,?)))))
(define new-peers (gestalt-project/single g (project-pubs `(,(?!) says ,?))))
(for/list [(who (set-subtract new-peers old-peers))] (say who "arrived."))
(for/list [(who (set-subtract old-peers new-peers))] (say who "departed."))
(loop new-peers)]))))

9
minimart/examples/chat.rkt
View File

@ -7,8 +7,8 @@
(define (spawn-session them us)
(define user (gensym 'user))
(define remote-detector (compile-gestalt-projection (?!)))
(define peer-detector (compile-gestalt-projection `(,(?!) says ,?)))
(define remote-detector (project-pubs #:meta-level 1 (?!)))
(define peer-detector (project-pubs `(,(?!) says ,?)))
(define (send-to-remote fmt . vs)
(send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))
(define (say who fmt . vs)
@ -23,11 +23,10 @@
[(message `(,who says ,what) 0 #f)
(transition old-peers (say who "says: ~a" what))]
[(routing-update g)
(define new-peers
(matcher-key-set/single (gestalt-project g 0 0 #t peer-detector)))
(define new-peers (gestalt-project/single g peer-detector))
(transition
new-peers
(list (when (matcher-empty? (gestalt-project g 1 0 #t remote-detector)) (quit))
(list (when (matcher-empty? (gestalt-project g remote-detector)) (quit))
(for/list [(who (set-subtract new-peers old-peers))]
(say who "arrived."))
(for/list [(who (set-subtract old-peers new-peers))]

63
minimart/gestalt.rkt
View File

@ -9,9 +9,16 @@
(provide (struct-out gestalt)
gestalt-match-value
compile-gestalt-projection
compile-gestalt-projection*
project-subs
project-pubs
projection?
projection->gestalt
gestalt-project*
gestalt-project
gestalt-project/keys
gestalt-project/single
drop-gestalt
lift-gestalt
simple-gestalt
@ -67,6 +74,10 @@
;; Convention: A GestaltSet is a Gestalt where the Matchers map to #t
;; instead of (NonemptySetof PID) or any other value.
;; A GestaltProjection is a single-metalevel, single-level fragment of
;; a gestalt with capture-groups. See matcher-project in route.rkt.
(struct projection (metalevel level get-advertisements? spec compiled) #:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (Listof X) Nat [-> X] -> X
@ -117,24 +128,48 @@
(define (pids-at level) (matcher-match-value (extract-matcher level) body))
(apply set-union (set) (map pids-at (gestalt-metalevel-ref g metalevel))))
;; (Listof Projection) -> CompiledProjection
;; For use with gestalt-project.
(define (compile-gestalt-projection* specs)
(compile-projection* specs))
;; project-subs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
;; project-pubs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
;;
;; Construct projectors representing subscriptions/advertisements
;; matching the given pattern, at the given meta-level and level.
;; Used with gestalt-project.
(define (project-subs p #:meta-level [ml 0] #:level [l 0])
(projection ml l #f p (compile-projection p)))
(define (project-pubs p #:meta-level [ml 0] #:level [l 0])
(projection ml l #t p (compile-projection p)))
;; Projection* -> CompiledProjection
;; For use with gestalt-project.
(define (compile-gestalt-projection . specs)
(compile-gestalt-projection* specs))
;; GestaltProjection -> Gestalt
;; Converts a projection to an atomic unit of gestalt.
(define (projection->gestalt pr)
(simple-gestalt (not (projection-get-advertisements? pr))
(projection->pattern (projection-spec pr))
(projection-level pr)
(projection-metalevel pr)))
;; Gestalt × Natural × Natural × Boolean × CompiledProjection → Matcher
;; Retrieves the Matcher within g at the given metalevel and level,
;; representing subscriptions or advertisements, projected by capture-spec.
(define (gestalt-project g metalevel level get-advertisements? capture-spec)
;; Gestalt × Nat × Nat × Boolean × CompiledProjection → Matcher
;; Retrieves the Matcher within g projected by the arguments.
(define (gestalt-project* g metalevel level get-advertisements? capture-spec)
(define extract-matcher (if get-advertisements? cdr car))
(define l (safe-list-ref (gestalt-metalevel-ref g metalevel) level (lambda () empty-level)))
(matcher-project (extract-matcher l) capture-spec))
;; Gestalt × GestaltProjection → Matcher
;; Retrieves the Matcher within g projected by pr.
(define (gestalt-project g pr)
(match-define (projection metalevel level get-advertisements? _ capture-spec) pr)
(gestalt-project* g metalevel level get-advertisements? capture-spec))
;; Gestalt × GestaltProjection → (Option (Setof (Listof Value)))
;; Projects g with pr and calls matcher-key-set on the result.
(define (gestalt-project/keys g pr)
(matcher-key-set (gestalt-project g pr)))
;; Gestalt × GestaltProjection → (Option (Setof Value))
;; Projects g with pr and calls matcher-key-set/single on the result.
(define (gestalt-project/single g pr)
(matcher-key-set/single (gestalt-project g pr)))
;; Gestalt -> Gestalt
;; Discards the 0th metalevel, renumbering others appropriately.
;; Used to map a Gestalt from a World to Gestalts of its containing World.

10
minimart/ground.rkt
View File

@ -35,23 +35,21 @@
(define (event-handler descriptor)
(handle-evt descriptor (lambda vs (send (event descriptor vs)))))
;; CompiledProjection
;; GestaltProjection
;; Used to extract event descriptors and results from subscriptions
;; from the ground VM's contained World.
(define event-projection (compile-gestalt-projection (event (?!) ?)))
(define event-projection (project-subs (event (?!) ?)))
;; Gestalt -> (Listof RacketEvent)
;; Projects out the active event subscriptions from the given gestalt.
(define (extract-active-events gestalt)
(define es (matcher-key-set (gestalt-project gestalt 0 0 #f event-projection)))
(define es (gestalt-project/single gestalt event-projection))
;; TODO: how should the following error be handled, ideally?
;; In principle, security restrictions should make it impossible.
;; But absent those, what should be done? Should an offending
;; process be identified and terminated?
(unless es (error 'extract-active-events "User program subscribed to wildcard event"))
(for/list [(ev (in-set es))]
(match-define (list e) ev)
(event-handler e)))
(for/list [(e (in-set es))] (event-handler e)))
;; RacketEvent
;; Used only when the system is not provably inert, in order to let it