Use new projection utilities.
This commit is contained in:
parent
261c84b40d
commit
a0da39f6f7
|
@ -4,7 +4,6 @@
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "core.rkt")
|
(require "core.rkt")
|
||||||
(require (only-in "route.rkt" matcher-project matcher-key-set))
|
|
||||||
(require "drivers/timer.rkt")
|
(require "drivers/timer.rkt")
|
||||||
|
|
||||||
(provide (except-out (struct-out demand-matcher) demand-matcher)
|
(provide (except-out (struct-out demand-matcher) demand-matcher)
|
||||||
|
@ -50,10 +49,10 @@
|
||||||
;; to increased unsatisfied demand and decreased demanded supply.
|
;; to increased unsatisfied demand and decreased demanded supply.
|
||||||
(define (demand-matcher-update d s p)
|
(define (demand-matcher-update d s p)
|
||||||
(match-define (demand-matcher demand-spec supply-spec inc-h dec-h demand supply) d)
|
(match-define (demand-matcher demand-spec supply-spec inc-h dec-h demand supply) d)
|
||||||
(define added-demand (matcher-key-set (matcher-project (patch-added p) demand-spec)))
|
(define added-demand (matcher-project/set (patch-added p) demand-spec))
|
||||||
(define removed-demand (matcher-key-set (matcher-project (patch-removed p) demand-spec)))
|
(define removed-demand (matcher-project/set (patch-removed p) demand-spec))
|
||||||
(define added-supply (matcher-key-set (matcher-project (patch-added p) supply-spec)))
|
(define added-supply (matcher-project/set (patch-added p) supply-spec))
|
||||||
(define removed-supply (matcher-key-set (matcher-project (patch-removed p) supply-spec)))
|
(define removed-supply (matcher-project/set (patch-removed p) supply-spec))
|
||||||
|
|
||||||
(when (not added-demand)
|
(when (not added-demand)
|
||||||
(error 'demand-matcher "Wildcard demand of ~v:\n~a"
|
(error 'demand-matcher "Wildcard demand of ~v:\n~a"
|
||||||
|
@ -123,23 +122,24 @@
|
||||||
base-interests
|
base-interests
|
||||||
. projections)
|
. projections)
|
||||||
(define timer-id (gensym 'on-claim))
|
(define timer-id (gensym 'on-claim))
|
||||||
|
(define (on-claim-handler e current-aggregate)
|
||||||
|
(match e
|
||||||
|
[(? patch? p)
|
||||||
|
(define new-aggregate (update-interests current-aggregate p))
|
||||||
|
(define projection-results
|
||||||
|
(map (lambda (p) (matcher-project/set new-aggregate p)) projections))
|
||||||
|
(define maybe-spawn (apply check-and-maybe-spawn-fn
|
||||||
|
new-aggregate
|
||||||
|
projection-results))
|
||||||
|
(if maybe-spawn
|
||||||
|
(quit maybe-spawn)
|
||||||
|
(transition new-aggregate '()))]
|
||||||
|
[(message (timer-expired (== timer-id) _))
|
||||||
|
(quit (timeout-handler))]
|
||||||
|
[_ #f]))
|
||||||
(list
|
(list
|
||||||
(when timeout-msec (message (set-timer timer-id timeout-msec 'relative)))
|
(when timeout-msec (message (set-timer timer-id timeout-msec 'relative)))
|
||||||
(spawn (lambda (e current-aggregate)
|
(spawn on-claim-handler
|
||||||
(match e
|
|
||||||
[(? patch? p)
|
|
||||||
(define new-aggregate (update-interests current-aggregate p))
|
|
||||||
(define projection-results
|
|
||||||
(map (lambda (p) (matcher-key-set (matcher-project new-aggregate p))) projections))
|
|
||||||
(define maybe-spawn (apply check-and-maybe-spawn-fn
|
|
||||||
new-aggregate
|
|
||||||
projection-results))
|
|
||||||
(if maybe-spawn
|
|
||||||
(quit maybe-spawn)
|
|
||||||
(transition new-aggregate '()))]
|
|
||||||
[(message (timer-expired (== timer-id) _))
|
|
||||||
(quit (timeout-handler))]
|
|
||||||
[_ #f]))
|
|
||||||
(matcher-empty)
|
(matcher-empty)
|
||||||
(patch base-interests (matcher-empty))
|
(patch base-interests (matcher-empty))
|
||||||
(patch-seq* (map projection->pattern projections))
|
(patch-seq* (map projection->pattern projections))
|
||||||
|
|
|
@ -6,7 +6,6 @@
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require racket/list)
|
(require racket/list)
|
||||||
(require "core.rkt")
|
(require "core.rkt")
|
||||||
(require "route.rkt")
|
|
||||||
(require "trace/stderr.rkt")
|
(require "trace/stderr.rkt")
|
||||||
|
|
||||||
(provide (struct-out external-event)
|
(provide (struct-out external-event)
|
||||||
|
@ -48,7 +47,7 @@
|
||||||
;; Interests -> (Listof RacketEvent)
|
;; Interests -> (Listof RacketEvent)
|
||||||
;; Projects out the active event subscriptions from the given interests.
|
;; Projects out the active event subscriptions from the given interests.
|
||||||
(define (extract-active-events interests)
|
(define (extract-active-events interests)
|
||||||
(define es (matcher-key-set/single (matcher-project interests event-projection)))
|
(define es (matcher-project/set/single interests event-projection))
|
||||||
;; TODO: how should the following error be handled, ideally?
|
;; TODO: how should the following error be handled, ideally?
|
||||||
;; In principle, security restrictions should make it impossible.
|
;; In principle, security restrictions should make it impossible.
|
||||||
;; But absent those, what should be done? Should an offending
|
;; But absent those, what should be done? Should an offending
|
||||||
|
|
Loading…
Reference in New Issue