Simple test harness
This commit is contained in:
Tony Garnock-Jones
parent
d6c0241c57
commit
290170f450
|
|
@ -10,7 +10,8 @@
|
|||
bag-member?
|
||||
in-bag
|
||||
in-bag/count
|
||||
set->bag)
|
||||
set->bag
|
||||
bag->set)
|
||||
|
||||
(require racket/set)
|
||||
|
||||
|
|
@ -55,3 +56,6 @@
|
|||
(define (set->bag s [count 1])
|
||||
(for/hash [(e (in-set s))]
|
||||
(values e count)))
|
||||
|
||||
(define (bag->set b)
|
||||
(list->set (hash-keys b)))
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
(struct-out observe)
|
||||
|
||||
dataspace?
|
||||
dataspace-assertions ;; TODO: shouldn't be provided - needed by test.rkt
|
||||
generate-id! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
||||
|
||||
actor?
|
||||
|
|
@ -25,6 +26,8 @@
|
|||
field-handle-owner
|
||||
field-handle-value
|
||||
|
||||
current-actor-crash-logger
|
||||
|
||||
current-actor
|
||||
current-facet
|
||||
in-script? ;; TODO: shouldn't be provided - inline syntax.rkt??
|
||||
|
|
@ -169,6 +172,12 @@
|
|||
(field-handle-owner f)
|
||||
(current-actor)))
|
||||
|
||||
;; Parameterof (Actor Exn -> Void)
|
||||
(define current-actor-crash-logger
|
||||
(make-parameter
|
||||
(lambda (a e)
|
||||
(log-error "Actor ~a died with exception:\n~a" a (exn->string e)))))
|
||||
|
||||
;; Parameterof Actor
|
||||
(define current-actor (make-parameter #f))
|
||||
|
||||
|
|
@ -259,7 +268,7 @@
|
|||
(in-script? script?))
|
||||
(with-handlers ([(lambda (e) (not (exn:break? e)))
|
||||
(lambda (e)
|
||||
(log-error "Actor ~a died with exception:\n~a" a (exn->string e))
|
||||
((current-actor-crash-logger) a e)
|
||||
(abandon-queued-work! a)
|
||||
(terminate-actor! a))]) ;; TODO: tracing
|
||||
(call-with-syndicate-prompt
|
||||
|
|
|
|||
|
|
@ -581,121 +581,148 @@
|
|||
;;---------------------------------------------------------------------------
|
||||
|
||||
(module+ test
|
||||
(message-struct set-box (new-value))
|
||||
(assertion-struct box-state (value))
|
||||
(require "test.rkt")
|
||||
|
||||
(define ds
|
||||
(make-dataspace
|
||||
(lambda ()
|
||||
(schedule-script!
|
||||
(current-actor)
|
||||
|
||||
#;(lambda ()
|
||||
(test-case
|
||||
;; See .../syndicate/examples/actor/example-during-criterion-shapshotting.rkt
|
||||
|
||||
(struct foo (x y) #:prefab)
|
||||
|
||||
[(struct foo (x y) #:prefab)
|
||||
(spawn (field [x 123])
|
||||
(assert (foo (x) 999))
|
||||
(during (foo (x) $v)
|
||||
(log-info "x=~a v=~a" (x) v)
|
||||
(printf "x=~a v=~a\n" (x) v)
|
||||
(when (= (x) 123) (x 124))
|
||||
(on-stop
|
||||
(log-info "finally for x=~a v=~a" (x) v))))
|
||||
)
|
||||
(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"))
|
||||
|
||||
#;(lambda ()
|
||||
(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.
|
||||
|
||||
;; Expected output:
|
||||
;;
|
||||
;; marker appeared
|
||||
;; marker disappeared
|
||||
;;
|
||||
;; (plus the exception report for "Deliberate error")
|
||||
|
||||
(spawn #:assertions ['marker]
|
||||
[(spawn #:name 'supply
|
||||
#:assertions ['marker]
|
||||
(assert 'marker) ;; NB this is the change wrt the test case immediately below
|
||||
(error 'test-case "Deliberate error")
|
||||
(void))
|
||||
(error 'test-case "Deliberate error"))
|
||||
|
||||
(spawn (on (asserted 'marker) (printf "marker appeared\n"))
|
||||
(on (retracted 'marker) (printf "marker disappeared\n")))
|
||||
)
|
||||
(on (retracted 'marker) (printf "marker disappeared\n")))]
|
||||
(it "should crash deliberately" (actor-died? 'supply "Deliberate error"))
|
||||
(expected-output "marker appeared"
|
||||
"marker disappeared"))
|
||||
|
||||
#;(lambda ()
|
||||
(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.
|
||||
|
||||
;; Expected output:
|
||||
;;
|
||||
;; marker appeared
|
||||
;; marker disappeared
|
||||
;;
|
||||
;; (plus the exception report for "Deliberate error")
|
||||
|
||||
(spawn #:assertions ['marker]
|
||||
(error 'test-case "Deliberate error")
|
||||
(void))
|
||||
[(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")))
|
||||
)
|
||||
(on (retracted 'marker) (printf "marker disappeared\n")))]
|
||||
(it "should crash deliberately" (actor-died? 'supply "Deliberate error"))
|
||||
(expected-output "marker appeared"
|
||||
"marker disappeared"))
|
||||
|
||||
#;(lambda ()
|
||||
(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
|
||||
;;
|
||||
;; Correct output:
|
||||
;;
|
||||
;; inner gone
|
||||
;; outer gone
|
||||
;; middle gone
|
||||
;;
|
||||
;; (or some permutation of these) plus an exception report for the division by zero.
|
||||
|
||||
(assertion-struct layer (name))
|
||||
|
||||
(spawn (define root-facet (current-facet))
|
||||
[(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"))
|
||||
|
||||
(spawn (on (retracted (layer $x)) (printf "~a gone\n" x))))
|
||||
|
||||
#;(lambda ()
|
||||
(begin ;; Suite of four related tests.
|
||||
;; See .../syndicate/examples/actor/example-responsibility-transfer-2.rkt
|
||||
|
||||
(spawn #:name 'factory-1
|
||||
(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))) ;; exists just to keep the service alive if
|
||||
;; there are no other endpoints
|
||||
;; spawn executes *before* teardown of this on-asserted endpoint, and thus
|
||||
;; before the patch withdrawing (observe (list 'X 1)).
|
||||
(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)))
|
||||
(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."))
|
||||
|
||||
)
|
||||
|
||||
#;(lambda ()
|
||||
(test-case
|
||||
;; See .../syndicate/examples/actor/example-responsibility-transfer-1.rkt
|
||||
|
||||
(spawn #:name 'demand-watcher
|
||||
[(spawn #:name 'demand-watcher
|
||||
(during/spawn 'demand
|
||||
#:name (gensym 'intermediate-demand-asserter)
|
||||
(assert 'intermediate-demand)))
|
||||
|
|
@ -706,60 +733,62 @@
|
|||
(assert 'supply)))
|
||||
|
||||
(spawn* #:name 'driver
|
||||
(react (on (asserted 'supply) (log-info "Supply asserted."))
|
||||
(on (retracted 'supply) (log-info "Supply retracted.")))
|
||||
(react (on (asserted 'supply) (displayln "Supply asserted."))
|
||||
(on (retracted 'supply) (displayln "Supply retracted.")))
|
||||
(until (asserted (observe 'demand)))
|
||||
(log-info "Asserting demand.")
|
||||
(displayln "Asserting demand.")
|
||||
(assert! 'demand)
|
||||
(until (asserted 'supply))
|
||||
(log-info "Glitching demand.")
|
||||
(displayln "Glitching demand.")
|
||||
(retract! 'demand)
|
||||
(flush!)
|
||||
(assert! 'demand)
|
||||
(log-info "Demand now steady."))
|
||||
)
|
||||
|
||||
#;(lambda ()
|
||||
;; Trivial example program to demonstrate tracing
|
||||
|
||||
(assertion-struct one-plus (n m))
|
||||
(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)))
|
||||
)
|
||||
(printf "1 + 3 = ~a\n" value)))]
|
||||
no-crashes
|
||||
(expected-output "1 + 3 = 4"))
|
||||
|
||||
#;(lambda ()
|
||||
(test-case
|
||||
;; .../racket/syndicate/examples/actor/example-partial-retraction.rkt
|
||||
;;
|
||||
(struct ready (what) #:prefab)
|
||||
[(struct ready (what) #:prefab)
|
||||
(struct entry (key val) #:prefab)
|
||||
|
||||
(spawn (assert (ready 'listener))
|
||||
(on (asserted (entry $key _))
|
||||
(log-info "key ~v asserted" key)
|
||||
(printf "key ~v asserted\n" key)
|
||||
(until (retracted (entry key _))
|
||||
(on (asserted (entry key $value))
|
||||
(log-info "add binding: ~v -> ~v" key value))
|
||||
(printf "add binding: ~v -> ~v\n" key value))
|
||||
(on (retracted (entry key $value))
|
||||
(log-info "del binding: ~v -> ~v" key value)))
|
||||
(log-info "key ~v retracted" key)))
|
||||
(printf "del binding: ~v -> ~v\n" key value)))
|
||||
(printf "key ~v retracted\n" key)))
|
||||
|
||||
(spawn (assert (ready 'other-listener))
|
||||
(during (entry $key _)
|
||||
(log-info "(other-listener) key ~v asserted" key)
|
||||
(on-stop (log-info "(other-listener) key ~v retracted" key))
|
||||
(printf "(other-listener) key ~v asserted\n" key)
|
||||
(on-stop (printf "(other-listener) key ~v retracted\n" key))
|
||||
(during (entry key $value)
|
||||
(log-info "(other-listener) ~v ---> ~v" key value)
|
||||
(on-stop (log-info "(other-listener) ~v -/-> ~v" key value)))))
|
||||
(printf "(other-listener) ~v ---> ~v\n" key value)
|
||||
(on-stop (printf "(other-listener) ~v -/-> ~v\n" key value)))))
|
||||
|
||||
(define (pause)
|
||||
(log-info "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))))
|
||||
|
|
@ -784,20 +813,73 @@
|
|||
[(entry 'a _) (retract! a)]
|
||||
[_ (void)]))
|
||||
;; ^ (retract! (entry 'a ?))
|
||||
(pause))
|
||||
)
|
||||
(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"
|
||||
))
|
||||
|
||||
#;(lambda ()
|
||||
(spawn (on (message $v)
|
||||
(if (= v 10000000)
|
||||
(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)))
|
||||
)
|
||||
(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))))))
|
||||
|
||||
#;(lambda ()
|
||||
|
||||
(message-struct stage (n))
|
||||
(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))
|
||||
|
|
@ -815,33 +897,38 @@
|
|||
(until (asserted (observe (stage 0))))
|
||||
(send! (stage 0))
|
||||
(until (message (stage 1)))
|
||||
(send! (stage 2))))
|
||||
)
|
||||
(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))
|
||||
|
||||
(lambda ()
|
||||
(spawn (field [current-value 0])
|
||||
(assert (box-state (current-value)))
|
||||
(stop-when-true (= (current-value) 10)
|
||||
(log-info "box: terminating"))
|
||||
(stop-when-true (= (current-value) 3)
|
||||
(displayln "box: terminating"))
|
||||
(on (message (set-box $new-value))
|
||||
(log-info "box: taking on new-value ~v" new-value)
|
||||
(printf "box: taking on new-value ~v\n" new-value)
|
||||
(current-value new-value)))
|
||||
|
||||
(spawn (stop-when (retracted (observe (set-box _)))
|
||||
(log-info "client: box has gone"))
|
||||
(displayln "client: box has gone"))
|
||||
(on (asserted (box-state $v))
|
||||
(log-info "client: learned that box's value is now ~v" v)
|
||||
(send! (set-box (+ v 1)))))
|
||||
)
|
||||
))))
|
||||
(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"))
|
||||
|
||||
(require racket/pretty)
|
||||
;; (pretty-print ds)
|
||||
(#;time values
|
||||
(let loop ((i 0))
|
||||
;; (printf "--- i = ~v\n" i)
|
||||
(when (run-scripts! ds)
|
||||
;; (pretty-print ds)
|
||||
(loop (+ i 1)))))
|
||||
;; (pretty-print ds)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,196 @@
|
|||
#lang racket/base
|
||||
;; Test drivers for Syndicate implementation.
|
||||
|
||||
(provide collected-events
|
||||
collected-output
|
||||
collected-lines
|
||||
final-dataspace
|
||||
final-assertions
|
||||
test-run-time
|
||||
test-gc-time
|
||||
|
||||
asserted?
|
||||
emitted?
|
||||
actor-died?
|
||||
emit!
|
||||
test-case
|
||||
it
|
||||
|
||||
no-crashes
|
||||
expected-output
|
||||
|
||||
run-syndicate-test!
|
||||
log-test-result!)
|
||||
|
||||
(require racket/exn)
|
||||
(require racket/match)
|
||||
(require (only-in racket/string string-split string-join string-contains?))
|
||||
|
||||
(require "bag.rkt")
|
||||
(require "dataspace.rkt")
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
(require (for-syntax syntax/srcloc))
|
||||
|
||||
(define-logger syndicate/test)
|
||||
|
||||
(define event-accumulator (make-parameter #f))
|
||||
(define exn-accumulator (make-parameter #f))
|
||||
(define failure-detected? (make-parameter #f))
|
||||
|
||||
(define collected-events (make-parameter '()))
|
||||
(define collected-exns (make-parameter '()))
|
||||
(define collected-output (make-parameter ""))
|
||||
(define collected-lines (make-parameter '()))
|
||||
(define final-dataspace (make-parameter #f))
|
||||
(define test-run-time (make-parameter 0))
|
||||
(define test-gc-time (make-parameter 0))
|
||||
|
||||
(define (asserted? v)
|
||||
(bag-member? (dataspace-assertions (final-dataspace)) v))
|
||||
|
||||
(define (final-assertions)
|
||||
(bag->set (dataspace-assertions (final-dataspace))))
|
||||
|
||||
(define (emitted? v)
|
||||
(member v (collected-events)))
|
||||
|
||||
(define (actor-died? name [substr-or-regex ""])
|
||||
(define entry (findf (lambda (e) (equal? name (actor-name (car e)))) (collected-exns)))
|
||||
(and entry
|
||||
(let ((message (exn-message (cadr entry))))
|
||||
(match substr-or-regex
|
||||
[(? string? substr) (string-contains? message substr)]
|
||||
[(? regexp? re) (regexp-match? re message)]))))
|
||||
|
||||
(define (emit! event)
|
||||
(define b (event-accumulator))
|
||||
(set-box! b (cons event (unbox b))))
|
||||
|
||||
(define-syntax (test-case stx)
|
||||
(syntax-case stx ()
|
||||
[(_ [body ...] checks ...)
|
||||
(quasisyntax/loc stx
|
||||
(run-syndicate-test!
|
||||
#,(source-location->string stx)
|
||||
(lambda () body ...)
|
||||
(list checks ...)))]))
|
||||
|
||||
(define (not-break? e)
|
||||
(not (exn:break? e)))
|
||||
|
||||
(struct check (location description thunk) #:prefab)
|
||||
|
||||
(define (run-syndicate-test! location-str body-thunk list-of-checks)
|
||||
(parameterize ((failure-detected? #f))
|
||||
(define events-box (box '()))
|
||||
(define exns-box (box '()))
|
||||
(define (get-items b) (reverse (unbox b)))
|
||||
(define op (open-output-string))
|
||||
(with-handlers ([not-break? (lambda (e) (log-test-result! location-str #f e))])
|
||||
(log-syndicate/test-info "~a--- Running test at ~a~a"
|
||||
(color YELLOW)
|
||||
location-str
|
||||
(color NORMAL))
|
||||
(define ds (make-dataspace
|
||||
(lambda ()
|
||||
(schedule-script! (current-actor) body-thunk))))
|
||||
(define-values (_results cpu-ms _wall-ms gc-ms)
|
||||
(parameterize ((current-output-port op)
|
||||
(current-actor-crash-logger
|
||||
(lambda (a e)
|
||||
(set-box! exns-box (cons (list a e) (unbox exns-box)))))
|
||||
(event-accumulator events-box))
|
||||
(time-apply (lambda () (let loop () (when (run-scripts! ds) (loop))))
|
||||
'())))
|
||||
(define op-string (get-output-string op))
|
||||
(parameterize ((collected-events (get-items events-box))
|
||||
(collected-exns (get-items exns-box))
|
||||
(collected-output op-string)
|
||||
(collected-lines (string-split op-string "\n"))
|
||||
(final-dataspace ds)
|
||||
(test-run-time cpu-ms)
|
||||
(test-gc-time gc-ms))
|
||||
(for [(check (in-list list-of-checks))]
|
||||
(with-handlers ([not-break? (lambda (e) (log-test-result! location-str check e))])
|
||||
(match check
|
||||
[(? procedure?)
|
||||
(log-test-result! location-str check (check))]
|
||||
[(? check?)
|
||||
(log-test-result! location-str check ((check-thunk check)))])))))
|
||||
(when (failure-detected?)
|
||||
(log-syndicate/test-debug "Collected events:")
|
||||
(for [(e (get-items events-box))]
|
||||
(log-syndicate/test-debug " ~v" e))
|
||||
(log-syndicate/test-debug "Collected output:")
|
||||
(for [(l (string-split (get-output-string op) "\n"))]
|
||||
(log-syndicate/test-debug " ~a" l))
|
||||
(log-syndicate/test-debug "Crashed actors:")
|
||||
(for [(entry (get-items exns-box))]
|
||||
(match-define (list a e) entry)
|
||||
(log-syndicate/test-debug " ~a\n ~a"
|
||||
a
|
||||
(string-join (string-split (exn->string e) "\n")
|
||||
" \n"))))))
|
||||
|
||||
(define-syntax (it stx)
|
||||
(syntax-case stx ()
|
||||
[(_ description body ...)
|
||||
(quasisyntax/loc stx
|
||||
(check #,(source-location->string stx)
|
||||
description
|
||||
(lambda ()
|
||||
(and body ...))))]))
|
||||
|
||||
(define no-crashes (it "shouldn't involve any crashing actors"
|
||||
(null? (collected-exns))))
|
||||
|
||||
(define-syntax (expected-output stx)
|
||||
(syntax-case stx ()
|
||||
[(_ line ...)
|
||||
(quasisyntax/loc stx
|
||||
(it "should produce correct output"
|
||||
(equal? (collected-lines)
|
||||
(list line ...))))]))
|
||||
|
||||
(define RED ";31")
|
||||
(define BRIGHT-RED ";1;31")
|
||||
(define GREEN ";32")
|
||||
(define BRIGHT-GREEN ";1;32")
|
||||
(define YELLOW ";33")
|
||||
(define NORMAL "")
|
||||
|
||||
(define (color c) (format "\e[0~am" c))
|
||||
|
||||
(define (log-test-result! test-loc maybe-check result)
|
||||
(if (not maybe-check)
|
||||
(begin
|
||||
(failure-detected? #t)
|
||||
(log-syndicate/test-error "~a ✗ Exception running program under test:\n~a~a"
|
||||
(color BRIGHT-RED)
|
||||
(exn->string result)
|
||||
(color NORMAL)))
|
||||
(let ((description
|
||||
(match maybe-check
|
||||
[(? procedure?) (format "~a" check)]
|
||||
[(check #f description _thunk) (format "~a" description)]
|
||||
[(check check-loc description _thunk) (format "~a (~a)" description check-loc)])))
|
||||
(match result
|
||||
[(? exn?)
|
||||
(failure-detected? #t)
|
||||
(log-syndicate/test-error "~a ✗ ... ~a:\n~a~a"
|
||||
(color RED)
|
||||
description
|
||||
(exn->string result)
|
||||
(color NORMAL))]
|
||||
[#f
|
||||
(failure-detected? #t)
|
||||
(log-syndicate/test-error "~a ✗ ... ~a~a"
|
||||
(color RED)
|
||||
description
|
||||
(color NORMAL))]
|
||||
[_
|
||||
(log-syndicate/test-info "~a ✓ ... ~a~a"
|
||||
(color GREEN)
|
||||
description
|
||||
(color NORMAL))]))))
|
||||
Loading…
Reference in New Issue