task manager role
This commit is contained in:
parent
33ef42818d
commit
555c41a153
|
@ -155,6 +155,13 @@
|
||||||
;; describing the initial state and the behavior in each state.
|
;; describing the initial state and the behavior in each state.
|
||||||
(struct role-graph (st0 states) #:transparent)
|
(struct role-graph (st0 states) #:transparent)
|
||||||
|
|
||||||
|
;; RoleGraph -> Nat
|
||||||
|
(define (role-graph-size rg)
|
||||||
|
(for/sum ([st (in-hash-values (role-graph-states rg))])
|
||||||
|
(define edge-count (for/sum ([txns (in-hash-values (state-transitions st))])
|
||||||
|
(set-count txns)))
|
||||||
|
(add1 edge-count)))
|
||||||
|
|
||||||
;; Role -> RoleGraph
|
;; Role -> RoleGraph
|
||||||
;; in each state, the transitions will include the reactions of the parent
|
;; in each state, the transitions will include the reactions of the parent
|
||||||
;; facet(s)
|
;; facet(s)
|
||||||
|
@ -257,8 +264,11 @@
|
||||||
(set)]))
|
(set)]))
|
||||||
(define states
|
(define states
|
||||||
(for/hash ([(sn txns) (in-hash st#)]
|
(for/hash ([(sn txns) (in-hash st#)]
|
||||||
|
;; get rid of the empty state unless it is the start,
|
||||||
|
;; or some other state transitions to it
|
||||||
#:unless (and (set-empty? sn)
|
#:unless (and (set-empty? sn)
|
||||||
(not (equal? sn new-st0))))
|
(not (equal? sn new-st0))
|
||||||
|
(not (target-of-transition? sn st#))))
|
||||||
(values sn (state sn txns))))
|
(values sn (state sn txns))))
|
||||||
(role-graph new-st0 states)]
|
(role-graph new-st0 states)]
|
||||||
[(cons (work-item from path/r to by with effs) more-work)
|
[(cons (work-item from path/r to by with effs) more-work)
|
||||||
|
@ -365,14 +375,13 @@
|
||||||
(check-equal? i m))
|
(check-equal? i m))
|
||||||
(test-case
|
(test-case
|
||||||
"removing internal events on more involved role"
|
"removing internal events on more involved role"
|
||||||
;; though it doesn't use any internal events
|
;; because it doesn't use any internal events, it should be unaffected
|
||||||
(define tmr (parse-T task-manager-ty))
|
(define tmr (parse-T task-runner-ty))
|
||||||
(define tm (compile tmr))
|
(define tm (compile tmr))
|
||||||
(define tmi (compile/internal-events tm tmr))
|
(define tmi (compile/internal-events tm tmr))
|
||||||
(check-true (role-graph? tmi))
|
(check-true (role-graph? tmi))
|
||||||
(check-true (simulates?/rg tmi tmr tm tmr))
|
;; I'm not exactly sure how the two should be related via simulation :S
|
||||||
(check-true (simulates?/rg tm tmr tmi tmr))
|
(check-true (simulates?/rg tmi tmr tm tmr)))
|
||||||
(check-equal? tmi tm))
|
|
||||||
(test-case
|
(test-case
|
||||||
"detect a simple internal event cycle"
|
"detect a simple internal event cycle"
|
||||||
(define cyclic
|
(define cyclic
|
||||||
|
@ -540,6 +549,14 @@
|
||||||
(StartOf? D)
|
(StartOf? D)
|
||||||
(StopOf? D)))
|
(StopOf? D)))
|
||||||
|
|
||||||
|
;; StateName (Hashof StateName (Hashof D+ (Setof Transition))) -> Bool
|
||||||
|
;; do any of the transitions go to `sn`?
|
||||||
|
(define (target-of-transition? sn st#)
|
||||||
|
(for*/or ([txn# (in-hash-values st#)]
|
||||||
|
[txns (in-hash-values txn#)]
|
||||||
|
[txn (in-set txns)])
|
||||||
|
(equal? sn (transition-dest txn))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(test-case
|
(test-case
|
||||||
"compile seller"
|
"compile seller"
|
||||||
|
@ -1670,7 +1687,7 @@
|
||||||
(define tpr (parse-T task-performer-spec))
|
(define tpr (parse-T task-performer-spec))
|
||||||
(define tmr (parse-T task-manager-ty))
|
(define tmr (parse-T task-manager-ty))
|
||||||
(define ans (simulating-subgraphs tmr tpr))
|
(define ans (simulating-subgraphs tmr tpr))
|
||||||
(check-equal? (length ans) 2)
|
(check-equal? (length ans) 68)
|
||||||
(define tprg (compile tpr))
|
(define tprg (compile tpr))
|
||||||
(check-true (simulates?/rg (first ans) tmr tprg tpr))
|
(check-true (simulates?/rg (first ans) tmr tprg tpr))
|
||||||
(check-true (simulates?/rg (second ans) tmr tprg tpr))))
|
(check-true (simulates?/rg (second ans) tmr tprg tpr))))
|
||||||
|
@ -2412,9 +2429,74 @@
|
||||||
(check-false (empty? ans))))
|
(check-false (empty? ans))))
|
||||||
|
|
||||||
(define task-manager-ty
|
(define task-manager-ty
|
||||||
'())
|
`(Role
|
||||||
|
(tm)
|
||||||
|
(Reacts
|
||||||
|
(Asserted (JobManagerAlive))
|
||||||
|
(Role
|
||||||
|
(during-inner2)
|
||||||
|
(Shares (TaskManager Symbol Int))
|
||||||
|
(Reacts
|
||||||
|
(Asserted
|
||||||
|
(Observe
|
||||||
|
(TaskPerformance
|
||||||
|
Symbol
|
||||||
|
(Bind
|
||||||
|
(Task
|
||||||
|
(Tuple Int Symbol)
|
||||||
|
(U
|
||||||
|
(MapWork String)
|
||||||
|
(ReduceWork (Hash String Int) (Hash String Int)))))
|
||||||
|
Discard)))
|
||||||
|
(Role
|
||||||
|
(during-inner3)
|
||||||
|
(Shares
|
||||||
|
(TaskPerformance
|
||||||
|
Symbol
|
||||||
|
(Task
|
||||||
|
(Tuple Int Symbol)
|
||||||
|
(U
|
||||||
|
(MapWork String)
|
||||||
|
(ReduceWork (Hash String Int) (Hash String Int))))
|
||||||
|
(U (Finished (Hash String Int)) Symbol)))
|
||||||
|
(Reacts
|
||||||
|
(Asserted
|
||||||
|
(TaskPerformance
|
||||||
|
Symbol
|
||||||
|
(Task
|
||||||
|
(Tuple Int Symbol)
|
||||||
|
(U
|
||||||
|
(MapWork String)
|
||||||
|
(ReduceWork (Hash String Int) (Hash String Int))))
|
||||||
|
(Bind (U (Finished (Hash String Int)) Symbol)))))
|
||||||
|
(Reacts OnStop)
|
||||||
|
(Reacts
|
||||||
|
(Retracted
|
||||||
|
(Observe
|
||||||
|
(TaskPerformance
|
||||||
|
Symbol
|
||||||
|
(Task
|
||||||
|
(Tuple Int Symbol)
|
||||||
|
(U
|
||||||
|
(MapWork String)
|
||||||
|
(ReduceWork (Hash String Int) (Hash String Int))))
|
||||||
|
Discard)))
|
||||||
|
(Stop during-inner3))))
|
||||||
|
(Reacts OnDataflow)
|
||||||
|
(Reacts
|
||||||
|
OnStart
|
||||||
|
(Role
|
||||||
|
(monitor-task-runner)
|
||||||
|
(Reacts
|
||||||
|
(Retracted (TaskRunner Symbol))
|
||||||
|
(Spawn ,task-runner-ty))
|
||||||
|
(Reacts (Asserted (TaskRunner Symbol)))
|
||||||
|
(Reacts
|
||||||
|
OnStart
|
||||||
|
(Spawn ,task-runner-ty))))
|
||||||
|
(Reacts (Retracted (JobManagerAlive)) (Stop during-inner2))))))
|
||||||
|
|
||||||
#;(module+ test
|
(module+ test
|
||||||
(test-case "parse and compile task-manager-ty"
|
(test-case "parse and compile task-manager-ty"
|
||||||
(check-true (Role? (parse-T task-manager-ty)))
|
(check-true (Role? (parse-T task-manager-ty)))
|
||||||
(check-true (role-graph? (compile (parse-T task-manager-ty)))))
|
(check-true (role-graph? (compile (parse-T task-manager-ty)))))
|
||||||
|
|
Loading…
Reference in New Issue