2012-02-15 15:33:53 +00:00
|
|
|
#lang racket/base
|
2012-02-15 16:39:31 +00:00
|
|
|
; Evented userland for os.rkt. Maintains persistent subscriptions.
|
2012-02-15 15:33:53 +00:00
|
|
|
|
|
|
|
(require racket/set)
|
|
|
|
(require racket/match)
|
|
|
|
(require racket/list)
|
|
|
|
(require "os.rkt")
|
|
|
|
|
|
|
|
(provide (struct-out subscribe)
|
|
|
|
subscribe/fresh
|
|
|
|
|
|
|
|
(struct-out unsubscribe)
|
|
|
|
(struct-out send-message)
|
|
|
|
(struct-out send-meta-message)
|
|
|
|
(struct-out spawn)
|
|
|
|
|
|
|
|
(struct-out on-message)
|
|
|
|
(struct-out on-meta-message)
|
|
|
|
message-handlers
|
|
|
|
meta-message-handlers
|
|
|
|
ground-message-handler
|
|
|
|
|
|
|
|
(except-out (struct-out transition) transition)
|
|
|
|
(rename-out [make-transition transition])
|
|
|
|
extend-transition
|
|
|
|
|
|
|
|
ground-vm ;; reprovided from os.rkt for convenience
|
|
|
|
os-big-bang
|
|
|
|
os-big-bang/transition)
|
|
|
|
|
|
|
|
;; A SID is an Any, a world-specific identifier for subscriptions.
|
|
|
|
|
|
|
|
;; An Action is one of
|
|
|
|
;; -- (subscribe SID EventDescription), to add a subscription
|
|
|
|
;; -- (unsubscribe SID), to remove ALL previously-added subscriptions with this SID
|
|
|
|
;; -- (send-message Message), to emit a message into the local medium
|
|
|
|
;; -- (send-meta-message MetaMessage), to emit a message into the containing medium
|
|
|
|
;; -- (spawn BootK), to start a new sibling in the raw os.rkt eventing model
|
|
|
|
(struct subscribe (sid event-description) #:transparent)
|
|
|
|
(struct unsubscribe (sid) #:transparent)
|
|
|
|
(struct send-message (body) #:transparent)
|
|
|
|
(struct send-meta-message (body) #:transparent)
|
|
|
|
(struct spawn (thunk) #:transparent)
|
|
|
|
|
|
|
|
;; An EventDescription is one of
|
|
|
|
;; -- (on-message MessagePattern (Message WorldState -> Transition)), conditionally
|
|
|
|
;; invoked when a message arrives
|
|
|
|
;; -- (on-meta-message MetaPattern (MetaMessage WorldState -> Transition)), conditionally
|
|
|
|
;; invoked when a metamessage arrives
|
|
|
|
;; If multiple EventDescriptions match a given event, one is
|
|
|
|
;; nondeterministically selected.
|
|
|
|
(struct on-message (pattern handler) #:transparent)
|
|
|
|
(struct on-meta-message (pattern handler) #:transparent)
|
|
|
|
|
|
|
|
;; A Transition is either
|
|
|
|
;; -- a (transition WorldState ListOf<Action>) or
|
|
|
|
;; -- a WorldState
|
|
|
|
(struct transition (state actions) #:transparent)
|
|
|
|
(define (make-transition state . actions) (transition state actions))
|
|
|
|
|
|
|
|
;; Transition [Action ...] -> Transition
|
|
|
|
;; Append the given actions to the transition given as the first argument.
|
|
|
|
(define (extend-transition t . more-actions)
|
|
|
|
(match t
|
|
|
|
[(transition state actions) (transition state (list actions more-actions))]
|
|
|
|
[state (transition state more-actions)]))
|
|
|
|
|
|
|
|
;; A World is a (world WorldState Map<SID,Set<EventDescription>>), a
|
|
|
|
;; representation of a suspended world and its active subscriptions.
|
|
|
|
(struct world (state subscriptions) #:transparent)
|
|
|
|
|
2012-02-15 19:15:34 +00:00
|
|
|
;; (subscribe/fresh var expr)
|
|
|
|
;; Generates a fresh SID, binds it to var, and results in a
|
|
|
|
;; subscription using that SID with the given expr's
|
|
|
|
;; event-description.
|
2012-02-15 15:33:53 +00:00
|
|
|
(define-syntax subscribe/fresh
|
|
|
|
(syntax-rules ()
|
|
|
|
((_ id-binder event-description)
|
|
|
|
(let ((id-binder (gensym 'id-binder)))
|
|
|
|
(subscribe id-binder event-description)))))
|
|
|
|
|
|
|
|
(define-syntax message-handlers*
|
|
|
|
(syntax-rules ()
|
|
|
|
((_ action-constructor old-state-pattern [pattern body ...] ...)
|
|
|
|
(action-constructor (match-lambda [pattern #t] ... [_ #f])
|
|
|
|
(lambda (message old-state)
|
|
|
|
(match-define old-state-pattern old-state)
|
|
|
|
(match message
|
|
|
|
[pattern body ...] ...))))))
|
|
|
|
|
2012-02-15 19:15:34 +00:00
|
|
|
;; (message-handlers state-pat [pat expr ...] ...)
|
|
|
|
;; When one of these message handlers is invoked, binds the
|
|
|
|
;; world-state value active at the time using state-pat, binds the
|
|
|
|
;; message using pat, and then invokes the exprs. The pat serves
|
|
|
|
;; double-duty: it both destructures the message and acts as a
|
|
|
|
;; predicate controlling receipt of the message.
|
2012-02-15 15:33:53 +00:00
|
|
|
(define-syntax message-handlers
|
|
|
|
(syntax-rules ()
|
|
|
|
((_ old-state-pattern [pattern body ...] ...)
|
|
|
|
(message-handlers* on-message old-state-pattern [pattern body ...] ...))))
|
|
|
|
|
2012-02-15 19:15:34 +00:00
|
|
|
;; As for message-handlers, but builds a meta-message handling
|
|
|
|
;; event-description instead.
|
2012-02-15 15:33:53 +00:00
|
|
|
(define-syntax meta-message-handlers
|
|
|
|
(syntax-rules ()
|
|
|
|
((_ old-state-pattern [pattern body ...] ...)
|
|
|
|
(message-handlers* on-meta-message old-state-pattern [pattern body ...] ...))))
|
|
|
|
|
2012-02-15 19:15:34 +00:00
|
|
|
;; Complex form for writing meta-message handlers at ground level,
|
|
|
|
;; which translate to event handlers. See examples in various drivers.
|
2012-02-15 15:33:53 +00:00
|
|
|
(define-syntax ground-message-handler
|
|
|
|
(syntax-rules (=>)
|
|
|
|
((_ old-state-pattern [(tag-expr evt-expr => pattern) body ...])
|
|
|
|
(on-meta-message (ground-event-pattern tag-expr evt-expr)
|
|
|
|
(lambda (meta-message old-state)
|
|
|
|
(match-define old-state-pattern old-state)
|
|
|
|
(match meta-message
|
|
|
|
[(ground-event-value _ pattern) body ...]))))))
|
|
|
|
|
2012-02-15 19:15:34 +00:00
|
|
|
;; World -> Suspension
|
|
|
|
;; Used to package up our persistent subscriptions into a transient
|
|
|
|
;; os.rkt Suspension.
|
2012-02-15 15:33:53 +00:00
|
|
|
(define (world->os-suspension w)
|
|
|
|
(suspension w
|
|
|
|
#f
|
|
|
|
(for*/list ([(sid vs) (world-subscriptions w)]
|
|
|
|
[v vs]
|
|
|
|
#:when (on-message? v))
|
|
|
|
(match-define (on-message pattern handler) v)
|
|
|
|
(message-handler pattern (wrap-handler handler)))
|
|
|
|
(for*/list ([(sid vs) (world-subscriptions w)]
|
|
|
|
[v vs]
|
|
|
|
#:when (on-meta-message? v))
|
|
|
|
(match-define (on-meta-message pattern handler) v)
|
|
|
|
(message-handler pattern (wrap-handler handler)))))
|
|
|
|
|
2012-02-15 19:15:34 +00:00
|
|
|
;; (X WorldState -> Transition) -> X -> WorldState -> Transition
|
2012-02-15 15:33:53 +00:00
|
|
|
(define (((wrap-handler handler) message) w)
|
|
|
|
(maybe-transition->os-transition w (handler message (world-state w))))
|
|
|
|
|
2012-02-15 19:15:34 +00:00
|
|
|
;; World Transition -> KernelModeTransition
|
2012-02-15 15:33:53 +00:00
|
|
|
(define (maybe-transition->os-transition w t)
|
|
|
|
(if (transition? t)
|
|
|
|
(transition->os-transition w t)
|
|
|
|
(transition->os-transition w (transition t '()))))
|
|
|
|
|
2012-02-15 19:15:34 +00:00
|
|
|
;; World (transition WorldState ListOf<Action>) -> KernelModeTransition
|
2012-02-15 15:33:53 +00:00
|
|
|
(define (transition->os-transition w t)
|
|
|
|
(match-define (transition state unflattened-actions) t)
|
|
|
|
(define actions (flatten unflattened-actions))
|
|
|
|
(kernel-mode-transition (world->os-suspension (update-world w state actions))
|
|
|
|
(for/list [(a actions) #:when (send-message? a)]
|
|
|
|
(send-message-body a))
|
|
|
|
(for/list [(a actions) #:when (send-meta-message? a)]
|
|
|
|
(send-meta-message-body a))
|
|
|
|
(for/list [(a actions) #:when (spawn? a)]
|
|
|
|
(spawn-thunk a))))
|
|
|
|
|
2012-02-15 19:15:34 +00:00
|
|
|
;; World WorldState ListOf<Action> -> World
|
|
|
|
;; Updates the World according to the given Actions, and also replaces
|
|
|
|
;; the old with the new WorldState in the result.
|
2012-02-15 15:33:53 +00:00
|
|
|
(define (update-world w new-state actions)
|
|
|
|
(world new-state
|
|
|
|
(foldl (lambda (action old-map)
|
|
|
|
(match action
|
|
|
|
[(subscribe sid desc)
|
|
|
|
(hash-update old-map sid
|
|
|
|
(lambda (s) (set-add s desc))
|
|
|
|
(lambda () (set desc)))]
|
|
|
|
[(unsubscribe sid)
|
|
|
|
(hash-remove old-map sid)]
|
|
|
|
[_ old-map]))
|
|
|
|
(world-subscriptions w)
|
|
|
|
actions)))
|
|
|
|
|
2012-02-15 19:15:34 +00:00
|
|
|
;; WorldState [Action ...] -> BootK
|
2012-02-15 15:33:53 +00:00
|
|
|
(define (os-big-bang initial-state . initial-actions)
|
|
|
|
(os-big-bang/transition (transition initial-state initial-actions)))
|
|
|
|
|
2012-02-15 19:15:34 +00:00
|
|
|
;; (transition WorldState ListOf<Action>) -> BootK
|
2012-02-15 15:33:53 +00:00
|
|
|
(define (os-big-bang/transition t)
|
|
|
|
(lambda () (transition->os-transition (world (void) (hash)) t)))
|