syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Improve the kinds of tests we can do for expected output slightly.

This commit is contained in:
Tony Garnock-Jones 2018-05-06 10:55:02 +01:00
parent daba892a07
commit be1bc6c220
15 changed files with 146 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
syndicate/test-implementation.rkt
View File

@ -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")

6
syndicate/test/core/abandon-actions-on-exn.rkt
View File

@ -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")))

2
syndicate/test/core/clean-adhoc-on-termination.rkt
View File

@ -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 ()

14
syndicate/test/core/correct-retraction-on-exn.rkt
View File

@ -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")))

18
syndicate/test/core/double-cross-layer.rkt
View File

@ -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!")))

6
syndicate/test/core/during-criterion-snapshotting.rkt
View File

@ -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")))

24
syndicate/test/core/nesting-confusion.rkt
View File

@ -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")))

91
syndicate/test/core/partial-retraction.rkt
View File

@ -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")))

12
syndicate/test/core/responsibility-transfer-1.rkt
View File

@ -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.")))

16
syndicate/test/core/responsibility-transfer-2.rkt
View File

@ -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.")))

2
syndicate/test/core/simple-addition.rkt
View File

@ -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")))

16
syndicate/test/core/simple-box-and-client.rkt
View File

@ -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")))

11
syndicate/test/core/simple-cross-layer.rkt
View File

@ -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!")))

14
syndicate/test/core/state-machine.rkt
View File

@ -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")))

16
syndicate/test/raw-dataspace.rkt
View File

@ -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")))