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

Nameable demand-matchers

This commit is contained in:
Tony Garnock-Jones 2016-01-27 21:03:08 -05:00
parent bedd44aae5
commit 6b31b33230
2 changed files with 12 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
prospect-monolithic/demand-matcher.rkt
View File

@ -100,12 +100,14 @@
supply-spec supply-spec
increase-handler increase-handler
[decrease-handler unexpected-supply-decrease] [decrease-handler unexpected-supply-decrease]
#:name [name #f]
#:meta-level [meta-level 0]) #:meta-level [meta-level 0])
(define d (make-demand-matcher (compile-projection (prepend-at-meta demand-spec meta-level)) (define d (make-demand-matcher (compile-projection (prepend-at-meta demand-spec meta-level))
(compile-projection (prepend-at-meta supply-spec meta-level)) (compile-projection (prepend-at-meta supply-spec meta-level))
(lambda (acs . rs) (cons (apply increase-handler rs) acs)) (lambda (acs . rs) (cons (apply increase-handler rs) acs))
(lambda (acs . rs) (cons (apply decrease-handler rs) acs)))) (lambda (acs . rs) (cons (apply decrease-handler rs) acs))))
(spawn demand-matcher-handle-event (spawn #:name name
demand-matcher-handle-event
d d
(scn/union (subscription (projection->pattern demand-spec) #:meta-level meta-level) (scn/union (subscription (projection->pattern demand-spec) #:meta-level meta-level)
(subscription (projection->pattern supply-spec) #:meta-level meta-level) (subscription (projection->pattern supply-spec) #:meta-level meta-level)
@ -122,6 +124,7 @@
;; quits. ;; quits.
(define (on-claim #:timeout-msec [timeout-msec #f] (define (on-claim #:timeout-msec [timeout-msec #f]
#:on-timeout [timeout-handler (lambda () '())] #:on-timeout [timeout-handler (lambda () '())]
#:name [name #f]
check-and-maybe-spawn-fn check-and-maybe-spawn-fn
base-interests base-interests
. projections) . projections)
@ -142,7 +145,8 @@
[_ #f])) [_ #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 on-claim-handler (spawn #:name name
on-claim-handler
(void) (void)
(scn/union base-interests (scn/union base-interests
(assertion-set-union* (assertion-set-union*

8
prospect/demand-matcher.rkt
View File

@ -96,12 +96,14 @@
supply-spec supply-spec
increase-handler increase-handler
[decrease-handler unexpected-supply-decrease] [decrease-handler unexpected-supply-decrease]
#:name [name #f]
#:meta-level [meta-level 0]) #:meta-level [meta-level 0])
(define d (make-demand-matcher (compile-projection (prepend-at-meta demand-spec meta-level)) (define d (make-demand-matcher (compile-projection (prepend-at-meta demand-spec meta-level))
(compile-projection (prepend-at-meta supply-spec meta-level)) (compile-projection (prepend-at-meta supply-spec meta-level))
(lambda (acs . rs) (cons (apply increase-handler rs) acs)) (lambda (acs . rs) (cons (apply increase-handler rs) acs))
(lambda (acs . rs) (cons (apply decrease-handler rs) acs)))) (lambda (acs . rs) (cons (apply decrease-handler rs) acs))))
(spawn demand-matcher-handle-event (spawn #:name name
demand-matcher-handle-event
d d
(patch-seq (sub (projection->pattern demand-spec) #:meta-level meta-level) (patch-seq (sub (projection->pattern demand-spec) #:meta-level meta-level)
(sub (projection->pattern supply-spec) #:meta-level meta-level) (sub (projection->pattern supply-spec) #:meta-level meta-level)
@ -118,6 +120,7 @@
;; quits. ;; quits.
(define (on-claim #:timeout-msec [timeout-msec #f] (define (on-claim #:timeout-msec [timeout-msec #f]
#:on-timeout [timeout-handler (lambda () '())] #:on-timeout [timeout-handler (lambda () '())]
#:name [name #f]
check-and-maybe-spawn-fn check-and-maybe-spawn-fn
base-interests base-interests
. projections) . projections)
@ -139,7 +142,8 @@
[_ #f])) [_ #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 on-claim-handler (spawn #:name name
on-claim-handler
(trie-empty) (trie-empty)
(patch-seq (patch base-interests (trie-empty)) (patch-seq (patch base-interests (trie-empty))
(patch-seq* (map (lambda (p) (sub projection->pattern)) projections)) (patch-seq* (map (lambda (p) (sub projection->pattern)) projections))