From be1bc6c2207c87d1e15d370ef0d9d5370a6875a4 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 6 May 2018 10:55:02 +0100 Subject: [PATCH] Improve the kinds of tests we can do for expected output slightly. --- syndicate/test-implementation.rkt | 32 ++++--- .../test/core/abandon-actions-on-exn.rkt | 6 +- .../test/core/clean-adhoc-on-termination.rkt | 2 +- .../test/core/correct-retraction-on-exn.rkt | 14 +-- syndicate/test/core/double-cross-layer.rkt | 18 ++-- .../core/during-criterion-snapshotting.rkt | 6 +- syndicate/test/core/nesting-confusion.rkt | 24 ++--- syndicate/test/core/partial-retraction.rkt | 91 +++++++++---------- .../test/core/responsibility-transfer-1.rkt | 12 +-- .../test/core/responsibility-transfer-2.rkt | 16 ++-- syndicate/test/core/simple-addition.rkt | 2 +- syndicate/test/core/simple-box-and-client.rkt | 16 ++-- syndicate/test/core/simple-cross-layer.rkt | 11 ++- syndicate/test/core/state-machine.rkt | 14 +-- syndicate/test/raw-dataspace.rkt | 16 ++-- 15 files changed, 146 insertions(+), 134 deletions(-) diff --git a/syndicate/test-implementation.rkt b/syndicate/test-implementation.rkt index 8a32e31..c7dba85 100644 --- a/syndicate/test-implementation.rkt +++ b/syndicate/test-implementation.rkt @@ -18,7 +18,7 @@ no-crashes expected-output - expected-output-set + expected-output? run-syndicate-test! log-test-result! @@ -151,19 +151,29 @@ (define-syntax (expected-output stx) (syntax-case stx () - [(_ line ...) + [(_ list-or-set-of-strings-expr ...) (quasisyntax/loc stx (it "should produce correct output" - (equal? (collected-lines) - (list line ...))))])) + (expected-output? (collected-lines) + (list list-or-set-of-strings-expr ...))))])) -(define-syntax (expected-output-set stx) - (syntax-case stx () - [(_ line ...) - (quasisyntax/loc stx - (it "should produce correct set of output lines" - (equal? (list->set (collected-lines)) - (set line ...))))])) +(define (take-at-most xs n) + (cond [(zero? n) '()] + [(null? xs) '()] + [else (cons (car xs) (take-at-most (cdr xs) (- n 1)))])) + +(define (expected-output? lines checks) + (match checks + ['() + (null? lines)] + [(cons (? list? expected-lines) rest) + (define actual-lines (take-at-most lines (length expected-lines))) + (and (equal? actual-lines expected-lines) + (expected-output? (drop lines (length expected-lines)) rest))] + [(cons (? set? expected-lines) rest) + (define actual-lines (list->set (take-at-most lines (set-count expected-lines)))) + (and (equal? actual-lines expected-lines) + (expected-output? (drop lines (set-count expected-lines)) rest))])) (define RED ";31") (define BRIGHT-RED ";1;31") diff --git a/syndicate/test/core/abandon-actions-on-exn.rkt b/syndicate/test/core/abandon-actions-on-exn.rkt index 3450f2b..8f898ea 100644 --- a/syndicate/test/core/abandon-actions-on-exn.rkt +++ b/syndicate/test/core/abandon-actions-on-exn.rkt @@ -22,6 +22,6 @@ (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")) + (expected-output (list "Got message 0" + "Got message 1" + "Got message 2"))) diff --git a/syndicate/test/core/clean-adhoc-on-termination.rkt b/syndicate/test/core/clean-adhoc-on-termination.rkt index 04ed53a..b942b6a 100644 --- a/syndicate/test/core/clean-adhoc-on-termination.rkt +++ b/syndicate/test/core/clean-adhoc-on-termination.rkt @@ -19,7 +19,7 @@ (send! (trigger)))) (define (only-seen-monitor-output?) - (expected-output "Seen: '#s(observe #s(capture #s(discard)))")) + (expected-output (list "Seen: '#s(observe #s(capture #s(discard)))"))) (define (only-seen-monitor-assertions?) (lambda () diff --git a/syndicate/test/core/correct-retraction-on-exn.rkt b/syndicate/test/core/correct-retraction-on-exn.rkt index 43ef368..6d26669 100644 --- a/syndicate/test/core/correct-retraction-on-exn.rkt +++ b/syndicate/test/core/correct-retraction-on-exn.rkt @@ -12,8 +12,8 @@ (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")) + (expected-output (list "marker appeared" + "marker disappeared"))) (test-case [(spawn #:name 'supply @@ -23,8 +23,8 @@ (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")) + (expected-output (list "marker appeared" + "marker disappeared"))) (test-case ;; Test cleanup after exception in stop script @@ -39,6 +39,6 @@ (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-set "middle gone" - "inner gone" - "outer gone")) + (expected-output (set "middle gone" + "inner gone" + "outer gone"))) diff --git a/syndicate/test/core/double-cross-layer.rkt b/syndicate/test/core/double-cross-layer.rkt index ce76614..08b16ab 100644 --- a/syndicate/test/core/double-cross-layer.rkt +++ b/syndicate/test/core/double-cross-layer.rkt @@ -17,12 +17,12 @@ (spawn #:name "H" (on (asserted (inbound (inbound (greeting $t)))) (printf "Inner dataspace: ~a\n" t)))))] no-crashes - (expected-output-set "Outer dataspace: Hi from outer space!" - "Middle dataspace: Hi from outer space!" - "Inner dataspace: Hi from outer space!" - "Outer dataspace: Hi from middle!" - "Middle dataspace: Hi from middle!" - "Inner dataspace: Hi from middle!" - "Outer dataspace: Inner!" - "Middle dataspace: Inner!" - "Inner dataspace: Inner!")) + (expected-output (set "Outer dataspace: Hi from outer space!" + "Middle dataspace: Hi from outer space!" + "Inner dataspace: Hi from outer space!" + "Outer dataspace: Hi from middle!" + "Middle dataspace: Hi from middle!" + "Inner dataspace: Hi from middle!" + "Outer dataspace: Inner!" + "Middle dataspace: Inner!" + "Inner dataspace: Inner!"))) diff --git a/syndicate/test/core/during-criterion-snapshotting.rkt b/syndicate/test/core/during-criterion-snapshotting.rkt index 12a1af2..deb0992 100644 --- a/syndicate/test/core/during-criterion-snapshotting.rkt +++ b/syndicate/test/core/during-criterion-snapshotting.rkt @@ -12,6 +12,6 @@ (on-stop (printf "finally for x0=~a x=~a v=~a\n" x0 (x) v))))] no-crashes - (expected-output "x=123 v=999" - "x=124 v=999" - "finally for x0=123 x=124 v=999")) + (expected-output (list "x=123 v=999" + "x=124 v=999" + "finally for x0=123 x=124 v=999"))) diff --git a/syndicate/test/core/nesting-confusion.rkt b/syndicate/test/core/nesting-confusion.rkt index 4393499..ffc8db1 100644 --- a/syndicate/test/core/nesting-confusion.rkt +++ b/syndicate/test/core/nesting-confusion.rkt @@ -20,13 +20,13 @@ (collected-lines))))) (define-syntax-rule (correct-topics-and-researchers) - (expected-output-set "Added researcher: Alice" - "Added researcher: Eve" - "Added researcher: Tony" - "Added topic: Bicycling" - "Added topic: Computering" - "Added topic: Cryptography" - "Added topic: Evil")) + (expected-output (set "Added researcher: Alice" + "Added researcher: Eve" + "Added researcher: Tony" + "Added topic: Bicycling" + "Added topic: Computering" + "Added topic: Cryptography" + "Added topic: Evil"))) (test-case [(spawn #:name 'tony @@ -135,8 +135,8 @@ (printf "Stopping outer claimant\n") (stop-current-facet)))] no-crashes - (expected-output "Outer claimant started" - "Inner saw claim asserted" - "Stopping outer claimant" - "Outer claimant stopped" - "Inner saw claim retracted")) + (expected-output (list "Outer claimant started" + "Inner saw claim asserted" + "Stopping outer claimant" + "Outer claimant stopped" + "Inner saw claim retracted"))) diff --git a/syndicate/test/core/partial-retraction.rkt b/syndicate/test/core/partial-retraction.rkt index 5bbafec..3a9098a 100644 --- a/syndicate/test/core/partial-retraction.rkt +++ b/syndicate/test/core/partial-retraction.rkt @@ -51,49 +51,48 @@ ;; ^ (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" - )) + ;; To properly test this, we need something closer to real + ;; regular-expressions-with-interleave over output lines: + #;(expected-output (list "pause" + "pause") + (set "(other-listener) key 'a asserted" + "(other-listener) key 'c asserted" + "(other-listener) key 'b asserted") + (set "(other-listener) 'a ---> 4" + "(other-listener) 'a ---> 1" + "(other-listener) 'a ---> 2" + "(other-listener) 'a ---> 5" + "(other-listener) 'c ---> 33" + "(other-listener) 'b ---> 3") + (set "key 'a asserted" + "key 'c asserted" + "key 'b asserted") + (set "add binding: 'a -> 4" + "add binding: 'a -> 1" + "add binding: 'a -> 2" + "add binding: 'a -> 5" + "add binding: 'c -> 33" + "add binding: 'b -> 3") + (list "pause") + (set "del binding: 'a -> 2" + "del binding: 'c -> 33" + "add binding: 'a -> 9") + (set "key 'c retracted") + (set "(other-listener) 'a ---> 9" + "(other-listener) 'a -/-> 2" + "(other-listener) 'c -/-> 33" + "(other-listener) key 'c retracted") + (set "del binding: 'a -> 1" + "del binding: 'a -> 9" + "del binding: 'a -> 5" + "del binding: 'a -> 4") + (set "key 'a retracted") + (set "(other-listener) 'a -/-> 1" + "(other-listener) 'a -/-> 9" + "(other-listener) 'a -/-> 5" + "(other-listener) 'a -/-> 4") + (set "(other-listener) key 'a retracted") + (set "del binding: 'b -> 3") + (set "key 'b retracted") + (set "(other-listener) 'b -/-> 3") + (set "(other-listener) key 'b retracted"))) diff --git a/syndicate/test/core/responsibility-transfer-1.rkt b/syndicate/test/core/responsibility-transfer-1.rkt index c1b3b6d..1c5a083 100644 --- a/syndicate/test/core/responsibility-transfer-1.rkt +++ b/syndicate/test/core/responsibility-transfer-1.rkt @@ -25,9 +25,9 @@ (assert! 'demand) (displayln "Demand now steady."))] no-crashes - (expected-output "Asserting demand." - "Supply asserted." - "Glitching demand." - "Demand now steady." - "Supply retracted." - "Supply asserted.")) + (expected-output (list "Asserting demand." + "Supply asserted." + "Glitching demand." + "Demand now steady." + "Supply retracted." + "Supply asserted."))) diff --git a/syndicate/test/core/responsibility-transfer-2.rkt b/syndicate/test/core/responsibility-transfer-2.rkt index 5f0b86f..755acde 100644 --- a/syndicate/test/core/responsibility-transfer-2.rkt +++ b/syndicate/test/core/responsibility-transfer-2.rkt @@ -16,7 +16,7 @@ (on (retracted (observe (list 'X $supplier))) (printf "Supply ~v retracted.\n" supplier)))] no-crashes - (expected-output "Supply 1 asserted.")) + (expected-output (list "Supply 1 asserted."))) (test-case [(spawn #:name 'factory-1 @@ -32,9 +32,9 @@ (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.")) + (expected-output (list "Supply 1 asserted." + "Supply 1 retracted." + "Supply 1 asserted."))) (test-case [(spawn #:name 'factory-1 @@ -50,8 +50,8 @@ (on (retracted (observe (list 'X $supplier))) (printf "Supply ~v retracted.\n" supplier)))] no-crashes - (expected-output "Supply 1 asserted." - "Supply 1 retracted.")) + (expected-output (list "Supply 1 asserted." + "Supply 1 retracted."))) (test-case [(spawn #:name 'factory-1 @@ -67,5 +67,5 @@ (on (retracted (observe (list 'X $supplier))) (printf "Supply ~v retracted.\n" supplier)))] no-crashes - (expected-output "Supply 1 asserted." - "Supply 1 retracted.")) + (expected-output (list "Supply 1 asserted." + "Supply 1 retracted."))) diff --git a/syndicate/test/core/simple-addition.rkt b/syndicate/test/core/simple-addition.rkt index f894074..62d4294 100644 --- a/syndicate/test/core/simple-addition.rkt +++ b/syndicate/test/core/simple-addition.rkt @@ -10,4 +10,4 @@ (stop-when (asserted (one-plus 3 $value)) (printf "1 + 3 = ~a\n" value)))] no-crashes - (expected-output "1 + 3 = 4")) + (expected-output (list "1 + 3 = 4"))) diff --git a/syndicate/test/core/simple-box-and-client.rkt b/syndicate/test/core/simple-box-and-client.rkt index 106cf0a..6538de2 100644 --- a/syndicate/test/core/simple-box-and-client.rkt +++ b/syndicate/test/core/simple-box-and-client.rkt @@ -19,11 +19,11 @@ (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")) + (expected-output (list "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"))) diff --git a/syndicate/test/core/simple-cross-layer.rkt b/syndicate/test/core/simple-cross-layer.rkt index 12a4236..e93528a 100644 --- a/syndicate/test/core/simple-cross-layer.rkt +++ b/syndicate/test/core/simple-cross-layer.rkt @@ -12,7 +12,10 @@ (spawn #:name "E" (on (asserted (inbound (greeting $t))) (printf "Inner dataspace: ~a\n" t))))] no-crashes - (expected-output-set "Outer dataspace: Hi from outer space!" - "Inner dataspace: Hi from outer space!" - "Outer dataspace: Hi from inner!" - "Inner dataspace: Hi from inner!")) + ;; There are constraints not expressed here; to properly test this, + ;; we need something closer to real + ;; regular-expressions-with-interleave over output lines. + (expected-output (set "Outer dataspace: Hi from outer space!" + "Inner dataspace: Hi from outer space!" + "Outer dataspace: Hi from inner!" + "Inner dataspace: Hi from inner!"))) diff --git a/syndicate/test/core/state-machine.rkt b/syndicate/test/core/state-machine.rkt index 1c2cc6c..79cbc71 100644 --- a/syndicate/test/core/state-machine.rkt +++ b/syndicate/test/core/state-machine.rkt @@ -18,10 +18,10 @@ (send! (toggle)) (send! (toggle)))] no-crashes - (expected-output "+even" - "-even" - "+odd" - "-odd" - "+even" - "-even" - "+odd")) + (expected-output (list "+even" + "-even" + "+odd" + "-odd" + "+even" + "-even" + "+odd"))) diff --git a/syndicate/test/raw-dataspace.rkt b/syndicate/test/raw-dataspace.rkt index 9975e08..907f9f5 100644 --- a/syndicate/test/raw-dataspace.rkt +++ b/syndicate/test/raw-dataspace.rkt @@ -99,11 +99,11 @@ #f))))) (set))] 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")) + (expected-output (list "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")))