initial support for on start and on stop
This commit is contained in:
parent
3ad0457bd5
commit
3e1d4d108f
|
@ -34,8 +34,12 @@
|
||||||
;; a D is one of
|
;; a D is one of
|
||||||
;; - (Know τ), reaction to assertion
|
;; - (Know τ), reaction to assertion
|
||||||
;; - (¬Know τ), reaction to retraction
|
;; - (¬Know τ), reaction to retraction
|
||||||
|
;; - StartEvt, reaction to facet startup
|
||||||
|
;; - StopEvt, reaction to facet shutdown
|
||||||
(struct Know (ty) #:transparent)
|
(struct Know (ty) #:transparent)
|
||||||
(struct ¬Know (ty) #:transparent)
|
(struct ¬Know (ty) #:transparent)
|
||||||
|
(define StartEvt 'Start)
|
||||||
|
(define StopEvt 'Stop)
|
||||||
|
|
||||||
;; a τ is one of
|
;; a τ is one of
|
||||||
;; - (U (Listof τ))
|
;; - (U (Listof τ))
|
||||||
|
@ -255,6 +259,7 @@
|
||||||
;; Compiling Roles to state machines
|
;; Compiling Roles to state machines
|
||||||
|
|
||||||
;; a State is a (state StateName (Hashof D (Setof StateName)))
|
;; a State is a (state StateName (Hashof D (Setof StateName)))
|
||||||
|
;; where each D in the hash satisfies external-evt?
|
||||||
;; a StateName is a (Setof FacetName)
|
;; a StateName is a (Setof FacetName)
|
||||||
;; let's assume that all FacetNames are unique
|
;; let's assume that all FacetNames are unique
|
||||||
;; ok, this is also ignoring Spawn actions for now, would show up in the transitions hash
|
;; ok, this is also ignoring Spawn actions for now, would show up in the transitions hash
|
||||||
|
@ -291,11 +296,13 @@
|
||||||
(hash-union agg txns
|
(hash-union agg txns
|
||||||
#:combine combine-effect-sets)))
|
#:combine combine-effect-sets)))
|
||||||
(define transitions
|
(define transitions
|
||||||
(for/hash ([(D effs) (in-hash agg-txn)])
|
(for/hash ([(D effs) (in-hash agg-txn)]
|
||||||
|
#:when (external-evt? D))
|
||||||
;; TODO - may want to remove self loops here
|
;; TODO - may want to remove self loops here
|
||||||
(define destinations
|
(define destinations
|
||||||
(for/set ([eff* (in-set effs)])
|
(for*/set ([eff* (in-set effs)]
|
||||||
(apply-effects eff* current ft)))
|
[dst (in-set (apply-effects eff* current ft roles#))])
|
||||||
|
dst))
|
||||||
(values D destinations)))
|
(values D destinations)))
|
||||||
(define new-work
|
(define new-work
|
||||||
(for*/list ([st-set (in-hash-values transitions)]
|
(for*/list ([st-set (in-hash-values transitions)]
|
||||||
|
@ -308,6 +315,11 @@
|
||||||
['()
|
['()
|
||||||
(role-graph (set (Role-nm role)) states)])))
|
(role-graph (set (Role-nm role)) states)])))
|
||||||
|
|
||||||
|
;; D -> Bool
|
||||||
|
;; test if D corresponds to an external event (assertion, message)
|
||||||
|
(define (external-evt? D)
|
||||||
|
(or (Know? D) (¬Know? D)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(test-case
|
(test-case
|
||||||
"compile seller"
|
"compile seller"
|
||||||
|
@ -541,6 +553,19 @@
|
||||||
(and parent
|
(and parent
|
||||||
(ancestor? parent ansc ft))]))
|
(ancestor? parent ansc ft))]))
|
||||||
|
|
||||||
|
;; FacetName FacetName FacetTree -> (U #f Nat)
|
||||||
|
;; determine if the first argument is a child*, or equal to, the second; if so,
|
||||||
|
;; return their distance from one another in the tree
|
||||||
|
(define (ancestor?/dist desc ansc ft)
|
||||||
|
(cond
|
||||||
|
[(equal? desc ansc)
|
||||||
|
0]
|
||||||
|
[else
|
||||||
|
(define parent (hash-ref (facet-tree-up ft) desc))
|
||||||
|
(define ans? (and parent (ancestor?/dist parent ansc ft)))
|
||||||
|
(and ans?
|
||||||
|
(add1 ans?))]))
|
||||||
|
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(test-case
|
(test-case
|
||||||
|
@ -549,7 +574,14 @@
|
||||||
(check-true (ancestor? 'leader 'leader ft))
|
(check-true (ancestor? 'leader 'leader ft))
|
||||||
(check-true (ancestor? 'poll 'leader ft))
|
(check-true (ancestor? 'poll 'leader ft))
|
||||||
(check-false (ancestor? 'leader 'poll ft))
|
(check-false (ancestor? 'leader 'poll ft))
|
||||||
(check-false (ancestor? 'announce 'leader ft))))
|
(check-false (ancestor? 'announce 'leader ft)))
|
||||||
|
(test-case
|
||||||
|
"ancestor?/dist in leader-spec facet tree"
|
||||||
|
(define ft (make-facet-tree leader-spec))
|
||||||
|
(check-equal? (ancestor?/dist 'leader 'leader ft) 0)
|
||||||
|
(check-equal? (ancestor?/dist 'poll 'leader ft) 1)
|
||||||
|
(check-false (ancestor?/dist 'leader 'poll ft))
|
||||||
|
(check-false (ancestor?/dist 'announce 'leader ft))))
|
||||||
|
|
||||||
;; a RoleEffect is one of
|
;; a RoleEffect is one of
|
||||||
;; - (start RoleName)
|
;; - (start RoleName)
|
||||||
|
@ -559,21 +591,66 @@
|
||||||
(struct stop (nm) #:transparent)
|
(struct stop (nm) #:transparent)
|
||||||
|
|
||||||
;; a TransitionDesc is a (Hashof D (Setof (Listof RoleEffect)), describing the
|
;; a TransitionDesc is a (Hashof D (Setof (Listof RoleEffect)), describing the
|
||||||
;; possible ways an event (+/- of an assertion) can alter the facet tree
|
;; possible ways an event (+/- of an assertion) can alter the facet tree.
|
||||||
|
;; It always includes the keys StartEvt and StopEvt.
|
||||||
|
(define txn-desc0 (hash StartEvt (set) StopEvt (set)))
|
||||||
|
|
||||||
;; (Listof RoleEffect) StateName FacetTree -> StateName determine the state
|
;; (Listof RoleEffect) StateName
|
||||||
;; resulting from some effects, given the currently active facets and a
|
;; FacetTree
|
||||||
;; description of possible facet locations.
|
;; (Hashof FacetName TransitionDesc)
|
||||||
(define (apply-effects effs st ft)
|
;; -> (Setof StateName)
|
||||||
(for/fold ([st st])
|
;; determine the state resulting from some effects, given the currently active
|
||||||
([eff (in-list effs)])
|
;; facets and a description of possible facet locations and behavior.
|
||||||
(match eff
|
(define (apply-effects effs st ft txn#)
|
||||||
[(start nm)
|
#;(printf "apply-effects: ~a\n" effs)
|
||||||
(set-add st nm)]
|
(let loop ([st st]
|
||||||
[(stop nm)
|
[effs effs])
|
||||||
(for/set ([f-name (in-set st)]
|
(match effs
|
||||||
#:unless (ancestor? f-name nm ft))
|
['()
|
||||||
f-name)])))
|
(set st)]
|
||||||
|
[(cons eff rest)
|
||||||
|
(match eff
|
||||||
|
[(start nm)
|
||||||
|
(define st+ (set-add st nm))
|
||||||
|
(define start-effs (hash-ref (hash-ref txn# nm) StartEvt))
|
||||||
|
(cond
|
||||||
|
[(set-empty? start-effs)
|
||||||
|
(loop st+ rest)]
|
||||||
|
[else
|
||||||
|
(for/set ([eff* (in-set start-effs)])
|
||||||
|
(loop st+ (append rest eff*)))])]
|
||||||
|
[(stop nm)
|
||||||
|
;; better include nm
|
||||||
|
(define children (find-children ft nm st))
|
||||||
|
(define st-
|
||||||
|
(for/fold ([st st])
|
||||||
|
([c (in-list children)])
|
||||||
|
(set-remove st c)))
|
||||||
|
(for/fold ([sts (set st-)])
|
||||||
|
([f-name (in-list children)])
|
||||||
|
(define stop-effs (hash-ref (hash-ref txn# f-name) StopEvt))
|
||||||
|
(cond
|
||||||
|
[(set-empty? stop-effs)
|
||||||
|
(for*/set ([st (in-set sts)]
|
||||||
|
[result (in-set (loop st rest))])
|
||||||
|
result)]
|
||||||
|
[else
|
||||||
|
(for*/set ([st (in-set sts)]
|
||||||
|
[effs* (in-set stop-effs)]
|
||||||
|
[result (in-set (loop st (append rest effs*)))])
|
||||||
|
result)]))])])))
|
||||||
|
|
||||||
|
;; FacetTree FacetName (Setof FacetName) -> (List FacetName)
|
||||||
|
;; return the facets in names that are children of the given facet nm, ordered
|
||||||
|
;; by their distance (farthest children first etc.)
|
||||||
|
(define (find-children ft nm names)
|
||||||
|
(define relations
|
||||||
|
(for*/list ([n (in-set names)]
|
||||||
|
[ans? (in-value (ancestor?/dist n nm ft))]
|
||||||
|
#:when ans?)
|
||||||
|
(list n ans?)))
|
||||||
|
(define farthest-to-nearest (sort relations > #:key second))
|
||||||
|
(map first farthest-to-nearest))
|
||||||
|
|
||||||
;; Role -> (Hashof FacetName TransitionDesc)
|
;; Role -> (Hashof FacetName TransitionDesc)
|
||||||
;; Extract a description of all roles mentioned in a Role
|
;; Extract a description of all roles mentioned in a Role
|
||||||
|
@ -609,11 +686,21 @@
|
||||||
(define (describe-role role)
|
(define (describe-role role)
|
||||||
(match role
|
(match role
|
||||||
[(Role nm eps)
|
[(Role nm eps)
|
||||||
(for/fold ([txns (hash)])
|
(for/fold ([txns txn-desc0])
|
||||||
([ep (in-list eps)]
|
([ep (in-list eps)]
|
||||||
#:when (Reacts? ep))
|
#:when (Reacts? ep))
|
||||||
(match-define (Reacts evt body) ep)
|
(match-define (Reacts evt body) ep)
|
||||||
(define effects (Body->effects body))
|
(define effects (Body->effects body))
|
||||||
|
(when (equal? StopEvt evt)
|
||||||
|
;; facets that start inside a stop handler will get shutdown.
|
||||||
|
(define effects+
|
||||||
|
(for/set ([effs* (in-set effects)])
|
||||||
|
(define extra-stops
|
||||||
|
(for/list ([eff (in-list effs*)]
|
||||||
|
#:when (start? eff))
|
||||||
|
(stop (start-nm eff))))
|
||||||
|
(append effs* extra-stops)))
|
||||||
|
(set! effects effects+))
|
||||||
(cond
|
(cond
|
||||||
[(or (set-empty? effects)
|
[(or (set-empty? effects)
|
||||||
(equal? effects (set '())))
|
(equal? effects (set '())))
|
||||||
|
@ -642,14 +729,14 @@
|
||||||
(define desc (describe-roles manager))
|
(define desc (describe-roles manager))
|
||||||
(check-true (hash-has-key? desc 'account-manager))
|
(check-true (hash-has-key? desc 'account-manager))
|
||||||
(check-equal? (hash-ref desc 'account-manager)
|
(check-equal? (hash-ref desc 'account-manager)
|
||||||
(hash)))
|
txn-desc0))
|
||||||
(test-case
|
(test-case
|
||||||
"describe nested role"
|
"describe nested role"
|
||||||
(define desc (describe-roles seller))
|
(define desc (describe-roles seller))
|
||||||
(check-true (hash-has-key? desc 'seller))
|
(check-true (hash-has-key? desc 'seller))
|
||||||
(check-true (hash-has-key? desc 'fulfill))
|
(check-true (hash-has-key? desc 'fulfill))
|
||||||
(check-equal? (hash-ref desc 'fulfill)
|
(check-equal? (hash-ref desc 'fulfill)
|
||||||
(hash))
|
txn-desc0)
|
||||||
(define seller-txns (hash-ref desc 'seller))
|
(define seller-txns (hash-ref desc 'seller))
|
||||||
(define quote-request
|
(define quote-request
|
||||||
(Observe (book-quote String ⋆)))
|
(Observe (book-quote String ⋆)))
|
||||||
|
@ -677,7 +764,7 @@
|
||||||
(define desc (describe-roles leader-spec))
|
(define desc (describe-roles leader-spec))
|
||||||
(check-true (hash-has-key? desc 'announce))
|
(check-true (hash-has-key? desc 'announce))
|
||||||
(check-equal? (hash-ref desc 'announce)
|
(check-equal? (hash-ref desc 'announce)
|
||||||
(hash)))
|
txn-desc0))
|
||||||
(test-case
|
(test-case
|
||||||
"leader-spec transitions from {leader,poll} to {leader}"
|
"leader-spec transitions from {leader,poll} to {leader}"
|
||||||
(define desc (describe-roles leader-spec))
|
(define desc (describe-roles leader-spec))
|
||||||
|
@ -1063,7 +1150,11 @@
|
||||||
[(Know τ)
|
[(Know τ)
|
||||||
(string-append "+" (τ->string τ))]
|
(string-append "+" (τ->string τ))]
|
||||||
[(¬Know τ)
|
[(¬Know τ)
|
||||||
(string-append "-" (τ->string τ))]))
|
(string-append "-" (τ->string τ))]
|
||||||
|
[(== StartEvt)
|
||||||
|
"Start"]
|
||||||
|
[(== StopEvt)
|
||||||
|
"Stop"]))
|
||||||
|
|
||||||
;; - (U (Listof τ))
|
;; - (U (Listof τ))
|
||||||
;; - (Struct StructName (Listof τ ...))
|
;; - (Struct StructName (Listof τ ...))
|
||||||
|
@ -1178,7 +1269,11 @@
|
||||||
[(list 'Know t)
|
[(list 'Know t)
|
||||||
(Know (parse-τ t))]
|
(Know (parse-τ t))]
|
||||||
[(list '¬Know t)
|
[(list '¬Know t)
|
||||||
(¬Know (parse-τ t))]))
|
(¬Know (parse-τ t))]
|
||||||
|
['OnStart
|
||||||
|
StartEvt]
|
||||||
|
['OnStop
|
||||||
|
StopEvt]))
|
||||||
|
|
||||||
;; Sexp -> τ
|
;; Sexp -> τ
|
||||||
(define (parse-τ ty)
|
(define (parse-τ ty)
|
||||||
|
|
Loading…
Reference in New Issue