send-ground-message
This commit is contained in:
parent
3e6fd930c5
commit
aa629c8bbe
|
@ -1,5 +1,6 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
|
(require racket/async-channel)
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require racket/list)
|
(require racket/list)
|
||||||
|
@ -7,10 +8,18 @@
|
||||||
(require "gestalt.rkt")
|
(require "gestalt.rkt")
|
||||||
|
|
||||||
(provide (struct-out event)
|
(provide (struct-out event)
|
||||||
|
send-ground-message
|
||||||
run-ground)
|
run-ground)
|
||||||
|
|
||||||
(struct event (descriptor values) #:prefab)
|
(struct event (descriptor values) #:prefab)
|
||||||
|
|
||||||
|
(define current-ground-event-async-channel (make-parameter #f))
|
||||||
|
|
||||||
|
(define (send-ground-message body)
|
||||||
|
(match (current-ground-event-async-channel)
|
||||||
|
[(? async-channel? ch) (async-channel-put ch (send body))]
|
||||||
|
[_ (error 'send-ground-message "Called outside dynamic scope of run-ground")]))
|
||||||
|
|
||||||
(define (event-handler descriptor)
|
(define (event-handler descriptor)
|
||||||
(handle-evt descriptor (lambda vs (send (event descriptor vs)))))
|
(handle-evt descriptor (lambda vs (send (event descriptor vs)))))
|
||||||
|
|
||||||
|
@ -31,10 +40,12 @@
|
||||||
(handle-evt (system-idle-evt) (lambda _ #f)))
|
(handle-evt (system-idle-evt) (lambda _ #f)))
|
||||||
|
|
||||||
(define (run-ground . boot-actions)
|
(define (run-ground . boot-actions)
|
||||||
|
(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 (if inert?
|
(define event-list (cons (current-ground-event-async-channel)
|
||||||
|
(if inert?
|
||||||
active-events
|
active-events
|
||||||
(cons idle-handler active-events)))
|
(cons idle-handler active-events))))
|
||||||
(if (null? event-list)
|
(if (null? event-list)
|
||||||
(begin (log-info "run-ground: Terminating because inert")
|
(begin (log-info "run-ground: Terminating because inert")
|
||||||
(void))
|
(void))
|
||||||
|
@ -56,4 +67,4 @@
|
||||||
(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 active-events)])]))]))))))
|
||||||
|
|
Loading…
Reference in New Issue