Refactor tests
This commit is contained in:
Tony Garnock-Jones
parent
afad4cd0be
commit
f40e7c15cc
|
|
@ -0,0 +1 @@
|
|||
compiled/
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#lang setup/infotab
|
||||
(define collection "imperative-syndicate")
|
||||
|
|
@ -46,7 +46,7 @@
|
|||
|
||||
(define (discard-id? stx)
|
||||
(and (identifier? stx)
|
||||
(free-transformer-identifier=? #'_ stx)))
|
||||
(free-identifier=? #'_ stx)))
|
||||
|
||||
(define (id-value stx)
|
||||
(and (identifier? stx)
|
||||
|
|
@ -54,7 +54,7 @@
|
|||
|
||||
(define (list-id? stx)
|
||||
(and (identifier? stx)
|
||||
(free-transformer-identifier=? #'list stx)))
|
||||
(free-identifier=? #'list stx)))
|
||||
|
||||
(define (analyse-pattern stx)
|
||||
(syntax-case stx ($)
|
||||
|
|
|
|||
|
|
@ -577,378 +577,3 @@
|
|||
|
||||
(define (current-adhoc-assertions)
|
||||
(actor-adhoc-assertions (current-actor)))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(module+ test
|
||||
(require "test.rkt")
|
||||
|
||||
(test-case
|
||||
;; See .../syndicate/examples/actor/example-during-criterion-shapshotting.rkt
|
||||
[(struct foo (x y) #:prefab)
|
||||
(spawn (field [x 123])
|
||||
(assert (foo (x) 999))
|
||||
(during (foo (x) $v)
|
||||
(printf "x=~a v=~a\n" (x) v)
|
||||
(when (= (x) 123) (x 124))
|
||||
(on-stop (printf "finally for x=~a v=~a\n" (x) v))))]
|
||||
no-crashes
|
||||
(expected-output "x=123 v=999"
|
||||
"x=124 v=999"
|
||||
"finally for x=124 v=999"))
|
||||
|
||||
(test-case
|
||||
;; Goal: no matter the circumstances (e.g. exception in a
|
||||
;; stop script), we will never retract an assertion more or
|
||||
;; fewer than the correct number of times.
|
||||
[(spawn #:name 'supply
|
||||
#:assertions ['marker]
|
||||
(assert 'marker) ;; NB this is the change wrt the test case immediately below
|
||||
(error 'test-case "Deliberate error"))
|
||||
|
||||
(spawn (on (asserted 'marker) (printf "marker appeared\n"))
|
||||
(on (retracted 'marker) (printf "marker disappeared\n")))]
|
||||
(it "should crash deliberately" (actor-died? 'supply "Deliberate error"))
|
||||
(expected-output "marker appeared"
|
||||
"marker disappeared"))
|
||||
|
||||
(test-case
|
||||
;; Goal: no matter the circumstances (e.g. exception in a
|
||||
;; stop script), we will never retract an assertion more or
|
||||
;; fewer than the correct number of times.
|
||||
[(spawn #:name 'supply
|
||||
#:assertions ['marker]
|
||||
(error 'test-case "Deliberate error"))
|
||||
|
||||
(spawn (on (asserted 'marker) (printf "marker appeared\n"))
|
||||
(on (retracted 'marker) (printf "marker disappeared\n")))]
|
||||
(it "should crash deliberately" (actor-died? 'supply "Deliberate error"))
|
||||
(expected-output "marker appeared"
|
||||
"marker disappeared"))
|
||||
|
||||
(test-case
|
||||
;; Goal: no matter the circumstances (e.g. exception in a
|
||||
;; stop script), we will never retract an assertion more or
|
||||
;; fewer than the correct number of times.
|
||||
;;
|
||||
;; Test cleanup after exception in stop script
|
||||
[(assertion-struct layer (name))
|
||||
(spawn #:name 'crasher
|
||||
(define root-facet (current-facet))
|
||||
(assert (layer 'outer))
|
||||
(on-start (react (assert (layer 'middle))
|
||||
(on-start (flush!) (flush!) (stop-facet root-facet))
|
||||
(on-stop (/ 1 0))
|
||||
(on-start (react (assert (layer 'inner)))))))
|
||||
(spawn (on (retracted (layer $x)) (printf "~a gone\n" x)))]
|
||||
(it "should crash with division by zero" (actor-died? 'crasher "division by zero"))
|
||||
;; a permutation of these lines is acceptable:
|
||||
(expected-output "middle gone"
|
||||
"inner gone"
|
||||
"outer gone"))
|
||||
|
||||
(begin ;; Suite of four related tests.
|
||||
;; See .../syndicate/examples/actor/example-responsibility-transfer-2.rkt
|
||||
|
||||
(test-case
|
||||
[(spawn #:name 'factory-1
|
||||
(on (asserted (list 'X 1))
|
||||
(spawn #:name 'service-1
|
||||
#:assertions [(observe (list 'X 1))] ;; (A)
|
||||
(stop-when (retracted (list 'X 1))) ;; (B)
|
||||
(on (message 'dummy)))
|
||||
(stop-current-facet)))
|
||||
(spawn (on (asserted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v asserted.\n" supplier)
|
||||
(assert! (list 'X supplier)))
|
||||
(on (retracted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v retracted.\n" supplier)))]
|
||||
no-crashes
|
||||
(expected-output "Supply 1 asserted."))
|
||||
|
||||
(test-case
|
||||
[(spawn #:name 'factory-1
|
||||
(on (asserted (list 'X 1))
|
||||
(spawn #:name 'service-1
|
||||
;; #:assertions [(observe (list 'X 1))] ;; (A)
|
||||
(stop-when (retracted (list 'X 1))) ;; (B)
|
||||
(on (message 'dummy)))
|
||||
(stop-current-facet)))
|
||||
(spawn (on (asserted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v asserted.\n" supplier)
|
||||
(assert! (list 'X supplier)))
|
||||
(on (retracted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v retracted.\n" supplier)))]
|
||||
no-crashes
|
||||
(expected-output "Supply 1 asserted."
|
||||
"Supply 1 retracted."
|
||||
"Supply 1 asserted."))
|
||||
|
||||
(test-case
|
||||
[(spawn #:name 'factory-1
|
||||
(on (asserted (list 'X 1))
|
||||
(spawn #:name 'service-1
|
||||
#:assertions [(observe (list 'X 1))] ;; (A)
|
||||
;; (stop-when (retracted (list 'X 1))) ;; (B)
|
||||
(on (message 'dummy)))
|
||||
(stop-current-facet)))
|
||||
(spawn (on (asserted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v asserted.\n" supplier)
|
||||
(assert! (list 'X supplier)))
|
||||
(on (retracted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v retracted.\n" supplier)))]
|
||||
no-crashes
|
||||
(expected-output "Supply 1 asserted."
|
||||
"Supply 1 retracted."))
|
||||
|
||||
(test-case
|
||||
[(spawn #:name 'factory-1
|
||||
(on (asserted (list 'X 1))
|
||||
(spawn #:name 'service-1
|
||||
;; #:assertions [(observe (list 'X 1))] ;; (A)
|
||||
;; (stop-when (retracted (list 'X 1))) ;; (B)
|
||||
(on (message 'dummy)))
|
||||
(stop-current-facet)))
|
||||
(spawn (on (asserted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v asserted.\n" supplier)
|
||||
(assert! (list 'X supplier)))
|
||||
(on (retracted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v retracted.\n" supplier)))]
|
||||
no-crashes
|
||||
(expected-output "Supply 1 asserted."
|
||||
"Supply 1 retracted."))
|
||||
|
||||
)
|
||||
|
||||
(test-case
|
||||
;; See .../syndicate/examples/actor/example-responsibility-transfer-1.rkt
|
||||
[(spawn #:name 'demand-watcher
|
||||
(during/spawn 'demand
|
||||
#:name (gensym 'intermediate-demand-asserter)
|
||||
(assert 'intermediate-demand)))
|
||||
|
||||
(spawn #:name 'intermediate-demand-watcher
|
||||
(during/spawn 'intermediate-demand
|
||||
#:name (gensym 'supply-asserter)
|
||||
(assert 'supply)))
|
||||
|
||||
(spawn* #:name 'driver
|
||||
(react (on (asserted 'supply) (displayln "Supply asserted."))
|
||||
(on (retracted 'supply) (displayln "Supply retracted.")))
|
||||
(until (asserted (observe 'demand)))
|
||||
(displayln "Asserting demand.")
|
||||
(assert! 'demand)
|
||||
(until (asserted 'supply))
|
||||
(displayln "Glitching demand.")
|
||||
(retract! 'demand)
|
||||
(flush!)
|
||||
(assert! 'demand)
|
||||
(displayln "Demand now steady."))]
|
||||
no-crashes
|
||||
(expected-output "Asserting demand."
|
||||
"Supply asserted."
|
||||
"Glitching demand."
|
||||
"Demand now steady."
|
||||
"Supply retracted."
|
||||
"Supply asserted."))
|
||||
|
||||
(test-case
|
||||
[(assertion-struct one-plus (n m))
|
||||
(spawn #:name 'add1-server
|
||||
(during/spawn (observe (one-plus $n _))
|
||||
#:name (list 'solving 'one-plus n)
|
||||
(assert (one-plus n (+ n 1)))))
|
||||
(spawn #:name 'client-process
|
||||
(stop-when (asserted (one-plus 3 $value))
|
||||
(printf "1 + 3 = ~a\n" value)))]
|
||||
no-crashes
|
||||
(expected-output "1 + 3 = 4"))
|
||||
|
||||
(test-case
|
||||
;; .../racket/syndicate/examples/actor/example-partial-retraction.rkt
|
||||
[(struct ready (what) #:prefab)
|
||||
(struct entry (key val) #:prefab)
|
||||
|
||||
(spawn (assert (ready 'listener))
|
||||
(on (asserted (entry $key _))
|
||||
(printf "key ~v asserted\n" key)
|
||||
(until (retracted (entry key _))
|
||||
(on (asserted (entry key $value))
|
||||
(printf "add binding: ~v -> ~v\n" key value))
|
||||
(on (retracted (entry key $value))
|
||||
(printf "del binding: ~v -> ~v\n" key value)))
|
||||
(printf "key ~v retracted\n" key)))
|
||||
|
||||
(spawn (assert (ready 'other-listener))
|
||||
(during (entry $key _)
|
||||
(printf "(other-listener) key ~v asserted\n" key)
|
||||
(on-stop (printf "(other-listener) key ~v retracted\n" key))
|
||||
(during (entry key $value)
|
||||
(printf "(other-listener) ~v ---> ~v\n" key value)
|
||||
(on-stop (printf "(other-listener) ~v -/-> ~v\n" key value)))))
|
||||
|
||||
(define (pause)
|
||||
(displayln "pause")
|
||||
(define token (gensym 'pause)) ;; FIXME:: If we use the same token every time, need epochs!
|
||||
(until (asserted (ready token))
|
||||
(assert (ready token))))
|
||||
|
||||
(spawn* (until (asserted (ready 'listener)))
|
||||
(until (asserted (ready 'other-listener)))
|
||||
(assert! (entry 'a 1))
|
||||
(assert! (entry 'a 2))
|
||||
(assert! (entry 'b 3))
|
||||
(assert! (entry 'c 33))
|
||||
(assert! (entry 'a 4))
|
||||
(assert! (entry 'a 5))
|
||||
(pause)
|
||||
(retract! (entry 'a 2))
|
||||
(retract! (entry 'c 33))
|
||||
(assert! (entry 'a 9))
|
||||
(pause)
|
||||
(local-require "bag.rkt")
|
||||
(for [(a (in-bag (current-adhoc-assertions)))]
|
||||
(local-require racket/match)
|
||||
(match a
|
||||
[(entry 'a _) (retract! a)]
|
||||
[_ (void)]))
|
||||
;; ^ (retract! (entry 'a ?))
|
||||
(pause))]
|
||||
no-crashes
|
||||
;; Within the following, some permutations are acceptable:
|
||||
#;(expected-output
|
||||
"pause"
|
||||
"pause"
|
||||
"(other-listener) key 'a asserted"
|
||||
"(other-listener) key 'c asserted"
|
||||
"(other-listener) key 'b asserted"
|
||||
"(other-listener) 'a ---> 4"
|
||||
"(other-listener) 'a ---> 1"
|
||||
"(other-listener) 'a ---> 2"
|
||||
"(other-listener) 'a ---> 5"
|
||||
"(other-listener) 'c ---> 33"
|
||||
"(other-listener) 'b ---> 3"
|
||||
"key 'a asserted"
|
||||
"key 'c asserted"
|
||||
"key 'b asserted"
|
||||
"add binding: 'a -> 4"
|
||||
"add binding: 'a -> 1"
|
||||
"add binding: 'a -> 2"
|
||||
"add binding: 'a -> 5"
|
||||
"add binding: 'c -> 33"
|
||||
"add binding: 'b -> 3"
|
||||
"pause"
|
||||
"del binding: 'a -> 2"
|
||||
"del binding: 'c -> 33"
|
||||
"add binding: 'a -> 9"
|
||||
"key 'c retracted"
|
||||
"(other-listener) 'a ---> 9"
|
||||
"(other-listener) 'a -/-> 2"
|
||||
"(other-listener) 'c -/-> 33"
|
||||
"(other-listener) key 'c retracted"
|
||||
"del binding: 'a -> 1"
|
||||
"del binding: 'a -> 9"
|
||||
"del binding: 'a -> 5"
|
||||
"del binding: 'a -> 4"
|
||||
"key 'a retracted"
|
||||
"(other-listener) 'a -/-> 1"
|
||||
"(other-listener) 'a -/-> 9"
|
||||
"(other-listener) 'a -/-> 5"
|
||||
"(other-listener) 'a -/-> 4"
|
||||
"(other-listener) key 'a retracted"
|
||||
"del binding: 'b -> 3"
|
||||
"key 'b retracted"
|
||||
"(other-listener) 'b -/-> 3"
|
||||
"(other-listener) key 'b retracted"
|
||||
))
|
||||
|
||||
(let ((N 100000))
|
||||
(test-case
|
||||
;; Rough message send speed test
|
||||
[(spawn (on (message $v)
|
||||
(if (= v N)
|
||||
(stop-current-facet)
|
||||
(send! (+ v 1))))
|
||||
(on-start (send! 0)))]
|
||||
no-crashes
|
||||
(it "should be fairly quick"
|
||||
(log-info "Rough message send speed: ~a msgs in ~a ms = ~a Hz"
|
||||
N
|
||||
(test-run-time)
|
||||
(/ N (/ (test-run-time) 1000.0))))))
|
||||
|
||||
(test-case
|
||||
;; Tests that pending actions are abandoned during a turn in which there is an exception
|
||||
[(message-struct stage (n))
|
||||
|
||||
(spawn #:name 'actor0
|
||||
(on (message (stage 0))
|
||||
(send! (stage 1)))
|
||||
|
||||
(on (message (stage 2))
|
||||
(send! (stage 3))
|
||||
(/ 1 0)
|
||||
(send! (stage 3))))
|
||||
|
||||
(spawn #:name 'main
|
||||
(on (message (stage $v))
|
||||
(printf "Got message ~v\n" v))
|
||||
(on-start
|
||||
(until (asserted (observe (stage 0))))
|
||||
(send! (stage 0))
|
||||
(until (message (stage 1)))
|
||||
(send! (stage 2))))]
|
||||
(it "should involve one crash" (actor-died? 'actor0 "division by zero"))
|
||||
(expected-output "Got message 0"
|
||||
"Got message 1"
|
||||
"Got message 2"))
|
||||
|
||||
(test-case
|
||||
;; Box-and-client
|
||||
[(message-struct set-box (new-value))
|
||||
(assertion-struct box-state (value))
|
||||
|
||||
(spawn (field [current-value 0])
|
||||
(assert (box-state (current-value)))
|
||||
(stop-when-true (= (current-value) 3)
|
||||
(displayln "box: terminating"))
|
||||
(on (message (set-box $new-value))
|
||||
(printf "box: taking on new-value ~v\n" new-value)
|
||||
(current-value new-value)))
|
||||
|
||||
(spawn (stop-when (retracted (observe (set-box _)))
|
||||
(displayln "client: box has gone"))
|
||||
(on (asserted (box-state $v))
|
||||
(printf "client: learned that box's value is now ~v\n" v)
|
||||
(send! (set-box (+ v 1)))))]
|
||||
no-crashes
|
||||
(expected-output "client: learned that box's value is now 0"
|
||||
"box: taking on new-value 1"
|
||||
"client: learned that box's value is now 1"
|
||||
"box: taking on new-value 2"
|
||||
"client: learned that box's value is now 2"
|
||||
"box: taking on new-value 3"
|
||||
"box: terminating"
|
||||
"client: box has gone"))
|
||||
|
||||
(let ((N 25000))
|
||||
(test-case
|
||||
;; Box-and-client speed test
|
||||
[(message-struct set-box (new-value))
|
||||
(assertion-struct box-state (value))
|
||||
(spawn (field [current-value 0])
|
||||
(assert (box-state (current-value)))
|
||||
(stop-when-true (= (current-value) N))
|
||||
(on (message (set-box $new-value))
|
||||
(current-value new-value)))
|
||||
(spawn (stop-when (retracted (observe (set-box _))))
|
||||
(on (asserted (box-state $v))
|
||||
(send! (set-box (+ v 1)))))]
|
||||
no-crashes
|
||||
(expected-output)
|
||||
(it "should be reasonably quick"
|
||||
(log-info "Rough box-and-client speed: ~a cycles in ~a ms = ~a Hz"
|
||||
N
|
||||
(test-run-time)
|
||||
(/ N (/ (test-run-time) 1000.0))))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -20,7 +20,13 @@
|
|||
expected-output
|
||||
|
||||
run-syndicate-test!
|
||||
log-test-result!)
|
||||
log-test-result!
|
||||
|
||||
(all-from-out racket/base)
|
||||
(all-from-out "dataspace.rkt")
|
||||
(all-from-out "syntax.rkt"))
|
||||
|
||||
(module reader syntax/module-reader imperative-syndicate/test-implementation)
|
||||
|
||||
(require racket/exn)
|
||||
(require racket/match)
|
||||
|
|
@ -28,6 +34,7 @@
|
|||
|
||||
(require "bag.rkt")
|
||||
(require "dataspace.rkt")
|
||||
(require "syntax.rkt")
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
(require (for-syntax syntax/srcloc))
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
#lang imperative-syndicate/test-implementation
|
||||
;; Tests that pending actions are abandoned during a turn in which there is an exception
|
||||
|
||||
(test-case
|
||||
[(message-struct stage (n))
|
||||
|
||||
(spawn #:name 'actor0
|
||||
(on (message (stage 0))
|
||||
(send! (stage 1)))
|
||||
|
||||
(on (message (stage 2))
|
||||
(send! (stage 3))
|
||||
(error 'test-case "Deliberate error")
|
||||
(send! (stage 3))))
|
||||
|
||||
(spawn #:name 'main
|
||||
(on (message (stage $v))
|
||||
(printf "Got message ~v\n" v))
|
||||
(on-start
|
||||
(until (asserted (observe (stage 0))))
|
||||
(send! (stage 0))
|
||||
(until (message (stage 1)))
|
||||
(send! (stage 2))))]
|
||||
(it "should involve one crash" (actor-died? 'actor0 "Deliberate error"))
|
||||
(expected-output "Got message 0"
|
||||
"Got message 1"
|
||||
"Got message 2"))
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
#lang imperative-syndicate/test-implementation
|
||||
;; Goal: no matter the circumstances (e.g. exception in a stop
|
||||
;; script), we will never retract an assertion more or fewer than the
|
||||
;; correct number of times.
|
||||
|
||||
(test-case
|
||||
[(spawn #:name 'supply
|
||||
#:assertions ['marker]
|
||||
(assert 'marker) ;; NB this is the change wrt the test case immediately below
|
||||
(error 'test-case "Deliberate error"))
|
||||
|
||||
(spawn (on (asserted 'marker) (printf "marker appeared\n"))
|
||||
(on (retracted 'marker) (printf "marker disappeared\n")))]
|
||||
(it "should crash deliberately" (actor-died? 'supply "Deliberate error"))
|
||||
(expected-output "marker appeared"
|
||||
"marker disappeared"))
|
||||
|
||||
(test-case
|
||||
[(spawn #:name 'supply
|
||||
#:assertions ['marker]
|
||||
(error 'test-case "Deliberate error"))
|
||||
|
||||
(spawn (on (asserted 'marker) (printf "marker appeared\n"))
|
||||
(on (retracted 'marker) (printf "marker disappeared\n")))]
|
||||
(it "should crash deliberately" (actor-died? 'supply "Deliberate error"))
|
||||
(expected-output "marker appeared"
|
||||
"marker disappeared"))
|
||||
|
||||
(test-case
|
||||
;; Test cleanup after exception in stop script
|
||||
[(assertion-struct layer (name))
|
||||
(spawn #:name 'crasher
|
||||
(define root-facet (current-facet))
|
||||
(assert (layer 'outer))
|
||||
(on-start (react (assert (layer 'middle))
|
||||
(on-start (flush!) (flush!) (stop-facet root-facet))
|
||||
(on-stop (error 'test-case "Deliberate error"))
|
||||
(on-start (react (assert (layer 'inner)))))))
|
||||
(spawn (on (retracted (layer $x)) (printf "~a gone\n" x)))]
|
||||
(it "should crash deliberately" (actor-died? 'crasher "Deliberate error"))
|
||||
;; a permutation of these lines is acceptable:
|
||||
(expected-output "middle gone"
|
||||
"inner gone"
|
||||
"outer gone"))
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
#lang imperative-syndicate/test-implementation
|
||||
;; See .../syndicate/examples/actor/example-during-criterion-shapshotting.rkt
|
||||
|
||||
(test-case
|
||||
[(struct foo (x y) #:prefab)
|
||||
(spawn (field [x 123])
|
||||
(assert (foo (x) 999))
|
||||
(during (foo (x) $v)
|
||||
(printf "x=~a v=~a\n" (x) v)
|
||||
(when (= (x) 123) (x 124))
|
||||
(on-stop (printf "finally for x=~a v=~a\n" (x) v))))]
|
||||
no-crashes
|
||||
(expected-output "x=123 v=999"
|
||||
"x=124 v=999"
|
||||
"finally for x=124 v=999"))
|
||||
|
|
@ -0,0 +1,100 @@
|
|||
#lang imperative-syndicate/test-implementation
|
||||
;; See .../racket/syndicate/examples/actor/example-partial-retraction.rkt
|
||||
;; TODO: deal with permissible permutations in the output
|
||||
|
||||
(test-case
|
||||
[(struct ready (what) #:prefab)
|
||||
(struct entry (key val) #:prefab)
|
||||
|
||||
(spawn (assert (ready 'listener))
|
||||
(on (asserted (entry $key _))
|
||||
(printf "key ~v asserted\n" key)
|
||||
(until (retracted (entry key _))
|
||||
(on (asserted (entry key $value))
|
||||
(printf "add binding: ~v -> ~v\n" key value))
|
||||
(on (retracted (entry key $value))
|
||||
(printf "del binding: ~v -> ~v\n" key value)))
|
||||
(printf "key ~v retracted\n" key)))
|
||||
|
||||
(spawn (assert (ready 'other-listener))
|
||||
(during (entry $key _)
|
||||
(printf "(other-listener) key ~v asserted\n" key)
|
||||
(on-stop (printf "(other-listener) key ~v retracted\n" key))
|
||||
(during (entry key $value)
|
||||
(printf "(other-listener) ~v ---> ~v\n" key value)
|
||||
(on-stop (printf "(other-listener) ~v -/-> ~v\n" key value)))))
|
||||
|
||||
(define (pause)
|
||||
(displayln "pause")
|
||||
(define token (gensym 'pause)) ;; FIXME:: If we use the same token every time, need epochs!
|
||||
(until (asserted (ready token))
|
||||
(assert (ready token))))
|
||||
|
||||
(spawn* (until (asserted (ready 'listener)))
|
||||
(until (asserted (ready 'other-listener)))
|
||||
(assert! (entry 'a 1))
|
||||
(assert! (entry 'a 2))
|
||||
(assert! (entry 'b 3))
|
||||
(assert! (entry 'c 33))
|
||||
(assert! (entry 'a 4))
|
||||
(assert! (entry 'a 5))
|
||||
(pause)
|
||||
(retract! (entry 'a 2))
|
||||
(retract! (entry 'c 33))
|
||||
(assert! (entry 'a 9))
|
||||
(pause)
|
||||
(local-require "../../bag.rkt")
|
||||
(for [(a (in-bag (current-adhoc-assertions)))]
|
||||
(local-require racket/match)
|
||||
(match a
|
||||
[(entry 'a _) (retract! a)]
|
||||
[_ (void)]))
|
||||
;; ^ (retract! (entry 'a ?))
|
||||
(pause))]
|
||||
no-crashes
|
||||
;; Within the following, some permutations are acceptable:
|
||||
#;(expected-output
|
||||
"pause"
|
||||
"pause"
|
||||
"(other-listener) key 'a asserted"
|
||||
"(other-listener) key 'c asserted"
|
||||
"(other-listener) key 'b asserted"
|
||||
"(other-listener) 'a ---> 4"
|
||||
"(other-listener) 'a ---> 1"
|
||||
"(other-listener) 'a ---> 2"
|
||||
"(other-listener) 'a ---> 5"
|
||||
"(other-listener) 'c ---> 33"
|
||||
"(other-listener) 'b ---> 3"
|
||||
"key 'a asserted"
|
||||
"key 'c asserted"
|
||||
"key 'b asserted"
|
||||
"add binding: 'a -> 4"
|
||||
"add binding: 'a -> 1"
|
||||
"add binding: 'a -> 2"
|
||||
"add binding: 'a -> 5"
|
||||
"add binding: 'c -> 33"
|
||||
"add binding: 'b -> 3"
|
||||
"pause"
|
||||
"del binding: 'a -> 2"
|
||||
"del binding: 'c -> 33"
|
||||
"add binding: 'a -> 9"
|
||||
"key 'c retracted"
|
||||
"(other-listener) 'a ---> 9"
|
||||
"(other-listener) 'a -/-> 2"
|
||||
"(other-listener) 'c -/-> 33"
|
||||
"(other-listener) key 'c retracted"
|
||||
"del binding: 'a -> 1"
|
||||
"del binding: 'a -> 9"
|
||||
"del binding: 'a -> 5"
|
||||
"del binding: 'a -> 4"
|
||||
"key 'a retracted"
|
||||
"(other-listener) 'a -/-> 1"
|
||||
"(other-listener) 'a -/-> 9"
|
||||
"(other-listener) 'a -/-> 5"
|
||||
"(other-listener) 'a -/-> 4"
|
||||
"(other-listener) key 'a retracted"
|
||||
"del binding: 'b -> 3"
|
||||
"key 'b retracted"
|
||||
"(other-listener) 'b -/-> 3"
|
||||
"(other-listener) key 'b retracted"
|
||||
))
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
#lang imperative-syndicate/test-implementation
|
||||
;; See .../syndicate/examples/actor/example-responsibility-transfer-1.rkt
|
||||
|
||||
(test-case
|
||||
[(spawn #:name 'demand-watcher
|
||||
(during/spawn 'demand
|
||||
#:name (gensym 'intermediate-demand-asserter)
|
||||
(assert 'intermediate-demand)))
|
||||
|
||||
(spawn #:name 'intermediate-demand-watcher
|
||||
(during/spawn 'intermediate-demand
|
||||
#:name (gensym 'supply-asserter)
|
||||
(assert 'supply)))
|
||||
|
||||
(spawn* #:name 'driver
|
||||
(react (on (asserted 'supply) (displayln "Supply asserted."))
|
||||
(on (retracted 'supply) (displayln "Supply retracted.")))
|
||||
(until (asserted (observe 'demand)))
|
||||
(displayln "Asserting demand.")
|
||||
(assert! 'demand)
|
||||
(until (asserted 'supply))
|
||||
(displayln "Glitching demand.")
|
||||
(retract! 'demand)
|
||||
(flush!)
|
||||
(assert! 'demand)
|
||||
(displayln "Demand now steady."))]
|
||||
no-crashes
|
||||
(expected-output "Asserting demand."
|
||||
"Supply asserted."
|
||||
"Glitching demand."
|
||||
"Demand now steady."
|
||||
"Supply retracted."
|
||||
"Supply asserted."))
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
#lang imperative-syndicate/test-implementation
|
||||
;; Suite of four related tests.
|
||||
;; See .../syndicate/examples/actor/example-responsibility-transfer-2.rkt
|
||||
|
||||
(test-case
|
||||
[(spawn #:name 'factory-1
|
||||
(on (asserted (list 'X 1))
|
||||
(spawn #:name 'service-1
|
||||
#:assertions [(observe (list 'X 1))] ;; (A)
|
||||
(stop-when (retracted (list 'X 1))) ;; (B)
|
||||
(on (message 'dummy)))
|
||||
(stop-current-facet)))
|
||||
(spawn (on (asserted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v asserted.\n" supplier)
|
||||
(assert! (list 'X supplier)))
|
||||
(on (retracted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v retracted.\n" supplier)))]
|
||||
no-crashes
|
||||
(expected-output "Supply 1 asserted."))
|
||||
|
||||
(test-case
|
||||
[(spawn #:name 'factory-1
|
||||
(on (asserted (list 'X 1))
|
||||
(spawn #:name 'service-1
|
||||
;; #:assertions [(observe (list 'X 1))] ;; (A)
|
||||
(stop-when (retracted (list 'X 1))) ;; (B)
|
||||
(on (message 'dummy)))
|
||||
(stop-current-facet)))
|
||||
(spawn (on (asserted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v asserted.\n" supplier)
|
||||
(assert! (list 'X supplier)))
|
||||
(on (retracted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v retracted.\n" supplier)))]
|
||||
no-crashes
|
||||
(expected-output "Supply 1 asserted."
|
||||
"Supply 1 retracted."
|
||||
"Supply 1 asserted."))
|
||||
|
||||
(test-case
|
||||
[(spawn #:name 'factory-1
|
||||
(on (asserted (list 'X 1))
|
||||
(spawn #:name 'service-1
|
||||
#:assertions [(observe (list 'X 1))] ;; (A)
|
||||
;; (stop-when (retracted (list 'X 1))) ;; (B)
|
||||
(on (message 'dummy)))
|
||||
(stop-current-facet)))
|
||||
(spawn (on (asserted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v asserted.\n" supplier)
|
||||
(assert! (list 'X supplier)))
|
||||
(on (retracted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v retracted.\n" supplier)))]
|
||||
no-crashes
|
||||
(expected-output "Supply 1 asserted."
|
||||
"Supply 1 retracted."))
|
||||
|
||||
(test-case
|
||||
[(spawn #:name 'factory-1
|
||||
(on (asserted (list 'X 1))
|
||||
(spawn #:name 'service-1
|
||||
;; #:assertions [(observe (list 'X 1))] ;; (A)
|
||||
;; (stop-when (retracted (list 'X 1))) ;; (B)
|
||||
(on (message 'dummy)))
|
||||
(stop-current-facet)))
|
||||
(spawn (on (asserted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v asserted.\n" supplier)
|
||||
(assert! (list 'X supplier)))
|
||||
(on (retracted (observe (list 'X $supplier)))
|
||||
(printf "Supply ~v retracted.\n" supplier)))]
|
||||
no-crashes
|
||||
(expected-output "Supply 1 asserted."
|
||||
"Supply 1 retracted."))
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
#lang imperative-syndicate/test-implementation
|
||||
|
||||
(test-case
|
||||
[(assertion-struct one-plus (n m))
|
||||
(spawn #:name 'add1-server
|
||||
(during/spawn (observe (one-plus $n _))
|
||||
#:name (list 'solving 'one-plus n)
|
||||
(assert (one-plus n (+ n 1)))))
|
||||
(spawn #:name 'client-process
|
||||
(stop-when (asserted (one-plus 3 $value))
|
||||
(printf "1 + 3 = ~a\n" value)))]
|
||||
no-crashes
|
||||
(expected-output "1 + 3 = 4"))
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
#lang imperative-syndicate/test-implementation
|
||||
;; Box-and-client
|
||||
|
||||
(test-case
|
||||
[(message-struct set-box (new-value))
|
||||
(assertion-struct box-state (value))
|
||||
|
||||
(spawn (field [current-value 0])
|
||||
(assert (box-state (current-value)))
|
||||
(stop-when-true (= (current-value) 3)
|
||||
(displayln "box: terminating"))
|
||||
(on (message (set-box $new-value))
|
||||
(printf "box: taking on new-value ~v\n" new-value)
|
||||
(current-value new-value)))
|
||||
|
||||
(spawn (stop-when (retracted (observe (set-box _)))
|
||||
(displayln "client: box has gone"))
|
||||
(on (asserted (box-state $v))
|
||||
(printf "client: learned that box's value is now ~v\n" v)
|
||||
(send! (set-box (+ v 1)))))]
|
||||
no-crashes
|
||||
(expected-output "client: learned that box's value is now 0"
|
||||
"box: taking on new-value 1"
|
||||
"client: learned that box's value is now 1"
|
||||
"box: taking on new-value 2"
|
||||
"client: learned that box's value is now 2"
|
||||
"box: taking on new-value 3"
|
||||
"box: terminating"
|
||||
"client: box has gone"))
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
#lang imperative-syndicate/test-implementation
|
||||
|
||||
(let ((N 25000))
|
||||
(test-case
|
||||
;; Box-and-client speed test
|
||||
[(message-struct set-box (new-value))
|
||||
(assertion-struct box-state (value))
|
||||
(spawn (field [current-value 0])
|
||||
(assert (box-state (current-value)))
|
||||
(stop-when-true (= (current-value) N))
|
||||
(on (message (set-box $new-value))
|
||||
(current-value new-value)))
|
||||
(spawn (stop-when (retracted (observe (set-box _))))
|
||||
(on (asserted (box-state $v))
|
||||
(send! (set-box (+ v 1)))))]
|
||||
no-crashes
|
||||
(expected-output)
|
||||
(it "should be reasonably quick"
|
||||
(log-info "Rough box-and-client speed: ~a cycles in ~a ms = ~a Hz"
|
||||
N
|
||||
(test-run-time)
|
||||
(/ N (/ (test-run-time) 1000.0))))))
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
#lang imperative-syndicate/test-implementation
|
||||
;; Rough message send speed test
|
||||
|
||||
(let ((N 100000))
|
||||
(test-case
|
||||
[(spawn (on (message $v)
|
||||
(if (= v N)
|
||||
(stop-current-facet)
|
||||
(send! (+ v 1))))
|
||||
(on-start (send! 0)))]
|
||||
no-crashes
|
||||
(it "should be fairly quick"
|
||||
(log-info "Rough message send speed: ~a msgs in ~a ms = ~a Hz"
|
||||
N
|
||||
(test-run-time)
|
||||
(/ N (/ (test-run-time) 1000.0))))))
|
||||
Loading…
Reference in New Issue