marketplace-2014/process.rkt

151 lines
5.6 KiB
Racket

#lang typed/racket/base
(require racket/match)
(require "types.rkt")
(require "roles.rkt")
(require "vm.rkt")
(require "log-typed.rkt")
(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)
(marketplace-log 'error "Process ~v(~v):~n~a~n"
debug-name pid (exn-message e))
(marketplace-log 'error "Process ~v(~v):~n~v~n"
debug-name pid e))
failure-result)])
(marketplace-log 'debug "Entering process ~v(~v)" debug-name pid)
(define result enclosed-expr)
(marketplace-log 'debug "Leaving process ~v(~v)" debug-name pid)
result))
(: 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))]))
(: 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)
(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))
([pn (notify-route-change-self pn en flow->notification)]
[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: