Improved interface to gestalt-project.

minimart/core.rkt

@@ -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

minimart/demand-matcher.rkt

@@ -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)
+		  (matcher-projection->pattern projection)
-		  (compile-gestalt-projection 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-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-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

minimart/examples/chat-userland.rkt

@@ -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)
+  (define (gestalt->peers g) (gestalt-project/single g (project-pubs `(,(?!) says ,?))))
-    (matcher-key-set/single
-     (gestalt-project g 0 0 #t (compile-gestalt-projection `(,(?!) says ,?)))))
 
   (userland-thread #:gestalt (gestalt-union tcp-gestalt
 					    (sub `(,? says ,?))

minimart/examples/chat-userland2.rkt

@@ -43,9 +43,7 @@
 	(loop old-peers)]
        [(routing-update g)
 	(when (gestalt-empty? (gestalt-filter g tcp-gestalt)) (do (quit)))
-	(define new-peers
+	(define new-peers (gestalt-project/single g (project-pubs `(,(?!) says ,?))))
-	  (matcher-key-set/single
-	   (gestalt-project g 0 0 #t (compile-gestalt-projection `(,(?!) 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)]))))

minimart/examples/chat.rkt

@@ -7,8 +7,8 @@
 
 (define (spawn-session them us)
   (define user (gensym 'user))
-  (define remote-detector (compile-gestalt-projection (?!)))
+  (define remote-detector (project-pubs #:meta-level 1 (?!)))
-  (define peer-detector (compile-gestalt-projection `(,(?!) says ,?)))
+  (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
+		    (define new-peers (gestalt-project/single g peer-detector))
-		      (matcher-key-set/single (gestalt-project g 0 0 #t 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))]

minimart/gestalt.rkt

@@ -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
+;; project-subs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
-;; For use with gestalt-project.
+;; project-pubs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
-(define (compile-gestalt-projection* specs)
+;;
-  (compile-projection* specs))
+;; 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
+;; GestaltProjection -> Gestalt
-;; For use with gestalt-project.
+;; Converts a projection to an atomic unit of gestalt.
-(define (compile-gestalt-projection . specs)
+(define (projection->gestalt pr)
-  (compile-gestalt-projection* specs))
+  (simple-gestalt (not (projection-get-advertisements? pr))
+		  (projection->pattern (projection-spec pr))
+		  (projection-level pr)
+		  (projection-metalevel pr)))
 
-;; Gestalt × Natural × Natural × Boolean × CompiledProjection → Matcher
+;; Gestalt × Nat × Nat × Boolean × CompiledProjection → Matcher
-;; Retrieves the Matcher within g at the given metalevel and level,
+;; Retrieves the Matcher within g projected by the arguments.
-;; representing subscriptions or advertisements, projected by capture-spec.
+(define (gestalt-project* g metalevel level get-advertisements? capture-spec)
-(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.

minimart/ground.rkt

@@ -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))]
+  (for/list [(e (in-set es))] (event-handler e)))
-    (match-define (list e) ev)
-    (event-handler e)))
 
 ;; RacketEvent
 ;; Used only when the system is not provably inert, in order to let it