racket-matrix-2012/os-big-bang.rkt

#lang racket/base
; Evented userland for os.rkt. Maintains persistent subscriptions.

(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)

;; (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.
(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 ...] ...))))))

;; (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.
(define-syntax message-handlers
  (syntax-rules ()
    ((_ old-state-pattern [pattern body ...] ...)
     (message-handlers* on-message old-state-pattern [pattern body ...] ...))))

;; As for message-handlers, but builds a meta-message handling
;; event-description instead.
(define-syntax meta-message-handlers
  (syntax-rules ()
    ((_ old-state-pattern [pattern body ...] ...)
     (message-handlers* on-meta-message old-state-pattern [pattern body ...] ...))))

;; Complex form for writing meta-message handlers at ground level,
;; which translate to event handlers. See examples in various drivers.
(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 ...]))))))

;; World -> Suspension
;; Used to package up our persistent subscriptions into a transient
;; os.rkt Suspension.
(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)))))

;; (X WorldState -> Transition) -> X -> WorldState -> Transition
(define (((wrap-handler handler) message) w)
  (maybe-transition->os-transition w (handler message (world-state w))))

;; World Transition -> KernelModeTransition
(define (maybe-transition->os-transition w t)
  (if (transition? t)
      (transition->os-transition w t)
      (transition->os-transition w (transition t '()))))

;; World (transition WorldState ListOf<Action>) -> KernelModeTransition
(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))))

;; 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.
(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)))

;; WorldState [Action ...] -> BootK
(define (os-big-bang initial-state . initial-actions)
  (os-big-bang/transition (transition initial-state initial-actions)))

;; (transition WorldState ListOf<Action>) -> BootK
(define (os-big-bang/transition t)
  (lambda () (transition->os-transition (world (void) (hash)) t)))