Widen ground-level inertness detection to account for non-event ground-level gestalt.

This commit is contained in:
Tony Garnock-Jones 2014-06-12 20:26:14 -04:00
parent 30c007e0be
commit 5b7b192b60
1 changed files with 14 additions and 10 deletions

View File

@ -64,29 +64,33 @@
(define (run-ground . boot-actions) (define (run-ground . boot-actions)
(parameterize ((current-ground-event-async-channel (make-async-channel))) (parameterize ((current-ground-event-async-channel (make-async-channel)))
(let await-interrupt ((inert? #f) (p (spawn-world boot-actions)) (active-events '())) (let await-interrupt ((inert? #f) (p (spawn-world boot-actions)) (active-events '()))
(define event-list (cons (current-ground-event-async-channel) (define active-gestalt (process-gestalt p))
(if inert? (define event-list (if inert?
active-events active-events
(cons idle-handler active-events)))) (cons idle-handler active-events)))
(if (null? event-list) (if (and (null? event-list) (gestalt-empty? active-gestalt))
(begin (log-info "run-ground: Terminating because inert") (begin (log-info "run-ground: Terminating because inert")
(void)) (void))
(let ((e (apply sync event-list))) (let ((e (apply sync (current-ground-event-async-channel) event-list)))
(match (deliver-event e -2 p) (match (deliver-event e -2 p)
[#f ;; inert [#f ;; inert
(await-interrupt #t p active-events)] (await-interrupt #t p active-events)]
[(transition new-state actions) [(transition new-state actions)
(let process-actions ((actions (flatten actions)) (active-events active-events)) (let process-actions ((actions (flatten actions)) (g active-gestalt))
(match actions (match actions
['() ['()
(await-interrupt #f (struct-copy process p [state new-state]) active-events)] (await-interrupt #f
(struct-copy process p
[gestalt g]
[state new-state])
(extract-active-events g))]
[(cons a actions) [(cons a actions)
(match a (match a
[(routing-update gestalt) [(routing-update gestalt)
(process-actions actions (extract-active-events gestalt))] (process-actions actions gestalt)]
[(quit) [(quit)
(log-info "run-ground: Terminating by request") (log-info "run-ground: Terminating by request")
(void)] (void)]
[_ [_
(log-warning "run-ground: ignoring useless meta-action ~v" a) (log-warning "run-ground: ignoring useless meta-action ~v" a)
(process-actions actions active-events)])]))])))))) (process-actions actions g)])]))]))))))