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

send-ground-message

This commit is contained in:
Tony Garnock-Jones 2014-06-11 16:02:46 -04:00
parent 3e6fd930c5
commit aa629c8bbe
1 changed files with 37 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
minimart/ground.rkt
View File

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