Comments in ground.rkt
This commit is contained in:
parent
4370cb72a4
commit
a86da29f68
|
@ -1,4 +1,5 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
;; Breaking the infinite tower of nested Worlds, connecting to the "real" world at the fracture line.
|
||||||
|
|
||||||
(require racket/async-channel)
|
(require racket/async-channel)
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
|
@ -11,20 +12,36 @@
|
||||||
send-ground-message
|
send-ground-message
|
||||||
run-ground)
|
run-ground)
|
||||||
|
|
||||||
|
;; A GroundEvent is a pair of a Racket (evt?) event and its yielded
|
||||||
|
;; results.
|
||||||
|
;; - (event RacketEvent (Listof Any))
|
||||||
(struct event (descriptor values) #:prefab)
|
(struct event (descriptor values) #:prefab)
|
||||||
|
|
||||||
|
;; (Parameterof (Option AsyncChannel))
|
||||||
|
;; Communication channel from auxiliary (usually driver) threads to
|
||||||
|
;; the currently-active ground VM.
|
||||||
(define current-ground-event-async-channel (make-parameter #f))
|
(define current-ground-event-async-channel (make-parameter #f))
|
||||||
|
|
||||||
|
;; Any -> Void
|
||||||
|
;; Sends a (non-feedback) message at the ground-VM metalevel.
|
||||||
(define (send-ground-message body)
|
(define (send-ground-message body)
|
||||||
(match (current-ground-event-async-channel)
|
(match (current-ground-event-async-channel)
|
||||||
[(? async-channel? ch) (async-channel-put ch (send body))]
|
[(? async-channel? ch) (async-channel-put ch (send body))]
|
||||||
[_ (error 'send-ground-message "Called outside dynamic scope of run-ground")]))
|
[_ (error 'send-ground-message "Called outside dynamic scope of run-ground")]))
|
||||||
|
|
||||||
|
;; RacketEvent -> RacketEvent
|
||||||
|
;; Wraps a CML-style Racket event with a handler that sends the event
|
||||||
|
;; results via the ground VM.
|
||||||
(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)))))
|
||||||
|
|
||||||
|
;; CompiledProjection
|
||||||
|
;; Used to extract event descriptors and results from subscriptions
|
||||||
|
;; from the ground VM's contained World.
|
||||||
(define event-projection (compile-gestalt-projection (event (?!) ?)))
|
(define event-projection (compile-gestalt-projection (event (?!) ?)))
|
||||||
|
|
||||||
|
;; Gestalt -> (Listof RacketEvent)
|
||||||
|
;; Projects out the active event subscriptions from the given gestalt.
|
||||||
(define (extract-active-events gestalt)
|
(define (extract-active-events gestalt)
|
||||||
(define es (matcher-key-set (gestalt-project gestalt 0 0 #f event-projection)))
|
(define es (matcher-key-set (gestalt-project gestalt 0 0 #f event-projection)))
|
||||||
;; TODO: how should the following error be handled, ideally?
|
;; TODO: how should the following error be handled, ideally?
|
||||||
|
@ -36,9 +53,14 @@
|
||||||
(match-define (list e) ev)
|
(match-define (list e) ev)
|
||||||
(event-handler e)))
|
(event-handler e)))
|
||||||
|
|
||||||
|
;; RacketEvent
|
||||||
|
;; Used only when the system is not provably inert, in order to let it
|
||||||
|
;; take further internal reductions.
|
||||||
(define idle-handler
|
(define idle-handler
|
||||||
(handle-evt (system-idle-evt) (lambda _ #f)))
|
(handle-evt (system-idle-evt) (lambda _ #f)))
|
||||||
|
|
||||||
|
;; Action* -> Void
|
||||||
|
;; Runs a ground VM, booting the outermost World with the given Actions.
|
||||||
(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 '()))
|
||||||
|
|
Loading…
Reference in New Issue