2013-03-29 03:00:29 +00:00
|
|
|
#lang typed/racket/base
|
|
|
|
|
|
|
|
(require racket/match)
|
|
|
|
(require "types.rkt")
|
|
|
|
(require "roles.rkt")
|
|
|
|
(require "vm.rkt")
|
2013-04-11 19:19:31 +00:00
|
|
|
(require "log-typed.rkt")
|
2013-03-29 03:00:29 +00:00
|
|
|
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
|
|
|
|
|
|
|
|
(provide send-to-user
|
|
|
|
send-to-user*
|
|
|
|
action-tree->quasiqueue
|
|
|
|
quit-interruptk
|
|
|
|
run-ready
|
|
|
|
notify-route-change-vm)
|
|
|
|
|
|
|
|
(define-syntax-rule (send-to-user p (e) failure-result enclosed-expr)
|
|
|
|
(send-to-user* (process-debug-name p) (process-pid p) (e) failure-result enclosed-expr))
|
|
|
|
|
|
|
|
(define-syntax-rule (send-to-user* debug-name pid (e) failure-result enclosed-expr)
|
|
|
|
(with-handlers ([exn:fail? (lambda: ([e : Reason])
|
|
|
|
(if (exn? e)
|
2013-04-11 22:18:30 +00:00
|
|
|
(matrix-log 'error "Process ~v(~v):~n~a~n"
|
|
|
|
debug-name pid (exn-message e))
|
|
|
|
(matrix-log 'error "Process ~v(~v):~n~v~n"
|
|
|
|
debug-name pid e))
|
2013-03-29 03:00:29 +00:00
|
|
|
failure-result)])
|
2013-04-11 19:19:31 +00:00
|
|
|
(matrix-log 'debug "Entering process ~v(~v)" debug-name pid)
|
|
|
|
(define result enclosed-expr)
|
|
|
|
(matrix-log 'debug "Leaving process ~v(~v)" debug-name pid)
|
|
|
|
result))
|
2013-03-29 03:00:29 +00:00
|
|
|
|
|
|
|
(: action-tree->quasiqueue : (All (State) (ActionTree State) -> (QuasiQueue (Action State))))
|
|
|
|
(define (action-tree->quasiqueue t)
|
|
|
|
(let loop ((#{revacc : (QuasiQueue (Action State))} '()) (t t))
|
|
|
|
;; 1. Tried match with (define-predicate action? Action).
|
|
|
|
;; Failed because of parametric function contracts.
|
|
|
|
;; 2. Tried flipping the order or clauses in the match to
|
|
|
|
;; avoid the use of (action?), trying to pull out the
|
|
|
|
;; false/nil/void leaving only, by exclusion, the
|
|
|
|
;; Action. Failed, complaining that it didn't know the
|
|
|
|
;; type in the third, default, branch.
|
|
|
|
;; 3. Just like 2, but with cond. This worked!
|
|
|
|
(cond
|
|
|
|
[(pair? t) (loop (loop revacc (car t)) (cdr t))]
|
|
|
|
[(or (null? t) (eq? t #f) (void? t)) revacc]
|
|
|
|
[else (cons t revacc)])))
|
|
|
|
|
|
|
|
;; Split out to provide a syntactic location to define State in
|
|
|
|
(: quit-interruptk : Reason -> (All (State) State -> (Transition State)))
|
|
|
|
(define ((quit-interruptk e) old-process-state)
|
|
|
|
(transition old-process-state (quit #f e)))
|
|
|
|
|
|
|
|
(: run-ready : (All (State) (process State) (InterruptK State) -> (process State)))
|
|
|
|
(define (run-ready p interruptk)
|
|
|
|
(define old-state (process-state p))
|
|
|
|
(match-define (transition new-state actions)
|
|
|
|
(send-to-user p (e) (transition old-state (ann (quit #f e) (Action State)))
|
|
|
|
(interruptk old-state)))
|
|
|
|
(struct-copy process p
|
|
|
|
[state new-state]
|
|
|
|
[pending-actions (quasiqueue-append (process-pending-actions p)
|
|
|
|
(action-tree->quasiqueue actions))]))
|
|
|
|
|
2013-04-11 19:20:02 +00:00
|
|
|
(: notify-route-change-self : (All (SNew)
|
|
|
|
(process SNew)
|
|
|
|
(endpoint SNew)
|
|
|
|
(Role -> EndpointEvent)
|
|
|
|
->
|
|
|
|
(process SNew)))
|
|
|
|
(define (notify-route-change-self pn en flow->notification)
|
|
|
|
(define endpointso (process-endpoints pn))
|
|
|
|
(for/fold ([pn pn]) ([eido (in-hash-keys endpointso)])
|
|
|
|
(define eo (hash-ref endpointso eido))
|
|
|
|
(cond
|
|
|
|
[(role-intersection (endpoint-role eo) (endpoint-role en))
|
|
|
|
=> (lambda (intersecting-topic)
|
|
|
|
(define flow-toward-o (refine-role (endpoint-role en) intersecting-topic))
|
|
|
|
(define flow-toward-n (refine-role (endpoint-role eo) intersecting-topic))
|
|
|
|
(invoke-handler-if-visible (invoke-handler-if-visible pn
|
|
|
|
eo
|
|
|
|
flow-toward-o
|
|
|
|
flow->notification)
|
|
|
|
en
|
|
|
|
flow-toward-n
|
|
|
|
flow->notification))]
|
|
|
|
[else pn])))
|
|
|
|
|
|
|
|
(: notify-route-change-process : (All (SOld SNew)
|
2013-03-29 03:00:29 +00:00
|
|
|
(process SOld)
|
|
|
|
(process SNew)
|
|
|
|
(endpoint SNew)
|
|
|
|
(Role -> EndpointEvent)
|
|
|
|
-> (values (process SOld)
|
|
|
|
(process SNew))))
|
|
|
|
(define (notify-route-change-process po pn en flow->notification)
|
|
|
|
(define endpointso (process-endpoints po))
|
|
|
|
(for/fold ([po po]
|
|
|
|
[pn pn])
|
|
|
|
([eido (in-hash-keys endpointso)])
|
|
|
|
(define eo (hash-ref endpointso eido))
|
|
|
|
(cond
|
|
|
|
[(role-intersection (endpoint-role eo) (endpoint-role en))
|
|
|
|
=> (lambda (intersecting-topic)
|
|
|
|
(define flow-toward-o (refine-role (endpoint-role en) intersecting-topic))
|
|
|
|
(define flow-toward-n (refine-role (endpoint-role eo) intersecting-topic))
|
|
|
|
(values (invoke-handler-if-visible po eo flow-toward-o flow->notification)
|
|
|
|
(invoke-handler-if-visible pn en flow-toward-n flow->notification)))]
|
|
|
|
[else
|
|
|
|
(values po pn)])))
|
|
|
|
|
|
|
|
(: invoke-handler-if-visible : (All (State)
|
|
|
|
(process State)
|
|
|
|
(endpoint State)
|
|
|
|
Role
|
|
|
|
(Role -> EndpointEvent)
|
|
|
|
->
|
|
|
|
(process State)))
|
|
|
|
(define (invoke-handler-if-visible p ep flow flow->notification)
|
|
|
|
(if (flow-visible? (endpoint-role ep) flow)
|
|
|
|
(run-ready p (send-to-user p (e) (quit-interruptk e)
|
|
|
|
((endpoint-handler ep) (flow->notification flow))))
|
|
|
|
p))
|
|
|
|
|
|
|
|
(: notify-route-change-vm : (All (SNew)
|
|
|
|
(process SNew)
|
|
|
|
(endpoint SNew)
|
|
|
|
(Role -> EndpointEvent)
|
|
|
|
vm
|
|
|
|
-> (values (process SNew)
|
|
|
|
vm)))
|
|
|
|
(define (notify-route-change-vm pn en flow->notification state)
|
|
|
|
(define old-processes (vm-processes state))
|
|
|
|
(define-values (final-pn new-processes)
|
|
|
|
(for/fold: : (values (process SNew)
|
|
|
|
(HashTable PID Process))
|
2013-04-11 19:20:02 +00:00
|
|
|
([pn (notify-route-change-self pn en flow->notification)]
|
2013-03-29 03:00:29 +00:00
|
|
|
[new-processes (ann #hash() (HashTable PID Process))])
|
|
|
|
([pid (in-hash-keys old-processes)])
|
|
|
|
(define wp (hash-ref old-processes pid))
|
|
|
|
(apply values
|
|
|
|
(unwrap-process SOld (List (process SNew) (HashTable PID Process)) (po wp)
|
|
|
|
(let-values (((po pn) (notify-route-change-process po pn en flow->notification)))
|
|
|
|
(list pn (hash-set new-processes pid (mkProcess po))))))))
|
|
|
|
(values final-pn
|
|
|
|
(struct-copy vm state [processes new-processes])))
|
|
|
|
|
|
|
|
;;; Local Variables:
|
|
|
|
;;; eval: (put 'send-to-user 'scheme-indent-function 3)
|
|
|
|
;;; End:
|