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 no-crashes
expected-output expected-output
expected-output-set expected-output?
run-syndicate-test! run-syndicate-test!
log-test-result! log-test-result!
@ -151,19 +151,29 @@
(define-syntax (expected-output stx) (define-syntax (expected-output stx)
(syntax-case stx () (syntax-case stx ()
[(_ line ...) [(_ list-or-set-of-strings-expr ...)
(quasisyntax/loc stx (quasisyntax/loc stx
(it "should produce correct output" (it "should produce correct output"
(equal? (collected-lines) (expected-output? (collected-lines)
(list line ...))))])) (list list-or-set-of-strings-expr ...))))]))
(define-syntax (expected-output-set stx) (define (take-at-most xs n)
(syntax-case stx () (cond [(zero? n) '()]
[(_ line ...) [(null? xs) '()]
(quasisyntax/loc stx [else (cons (car xs) (take-at-most (cdr xs) (- n 1)))]))
(it "should produce correct set of output lines"
(equal? (list->set (collected-lines)) (define (expected-output? lines checks)
(set line ...))))])) (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 RED ";31")
(define BRIGHT-RED ";1;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))) (until (message (stage 1)))
(send! (stage 2))))] (send! (stage 2))))]
(it "should involve one crash" (actor-died? 'actor0 "Deliberate error")) (it "should involve one crash" (actor-died? 'actor0 "Deliberate error"))
(expected-output "Got message 0" (expected-output (list "Got message 0"
"Got message 1" "Got message 1"
"Got message 2")) "Got message 2")))

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

@ -19,7 +19,7 @@
(send! (trigger)))) (send! (trigger))))
(define (only-seen-monitor-output?) (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?) (define (only-seen-monitor-assertions?)
(lambda () (lambda ()

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

@ -12,8 +12,8 @@
(spawn (on (asserted 'marker) (printf "marker appeared\n")) (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")) (it "should crash deliberately" (actor-died? 'supply "Deliberate error"))
(expected-output "marker appeared" (expected-output (list "marker appeared"
"marker disappeared")) "marker disappeared")))
(test-case (test-case
[(spawn #:name 'supply [(spawn #:name 'supply
@ -23,8 +23,8 @@
(spawn (on (asserted 'marker) (printf "marker appeared\n")) (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")) (it "should crash deliberately" (actor-died? 'supply "Deliberate error"))
(expected-output "marker appeared" (expected-output (list "marker appeared"
"marker disappeared")) "marker disappeared")))
(test-case (test-case
;; Test cleanup after exception in stop script ;; Test cleanup after exception in stop script
@ -39,6 +39,6 @@
(spawn (on (retracted (layer $x)) (printf "~a gone\n" x)))] (spawn (on (retracted (layer $x)) (printf "~a gone\n" x)))]
(it "should crash deliberately" (actor-died? 'crasher "Deliberate error")) (it "should crash deliberately" (actor-died? 'crasher "Deliberate error"))
;; a permutation of these lines is acceptable: ;; a permutation of these lines is acceptable:
(expected-output-set "middle gone" (expected-output (set "middle gone"
"inner gone" "inner gone"
"outer 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)))) (spawn #:name "H" (on (asserted (inbound (inbound (greeting $t))))
(printf "Inner dataspace: ~a\n" t)))))] (printf "Inner dataspace: ~a\n" t)))))]
no-crashes no-crashes
(expected-output-set "Outer dataspace: Hi from outer space!" (expected-output (set "Outer dataspace: Hi from outer space!"
"Middle dataspace: Hi from outer space!" "Middle dataspace: Hi from outer space!"
"Inner dataspace: Hi from outer space!" "Inner dataspace: Hi from outer space!"
"Outer dataspace: Hi from middle!" "Outer dataspace: Hi from middle!"
"Middle dataspace: Hi from middle!" "Middle dataspace: Hi from middle!"
"Inner dataspace: Hi from middle!" "Inner dataspace: Hi from middle!"
"Outer dataspace: Inner!" "Outer dataspace: Inner!"
"Middle dataspace: Inner!" "Middle dataspace: Inner!"
"Inner dataspace: Inner!")) "Inner dataspace: Inner!")))

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

@ -12,6 +12,6 @@
(on-stop (on-stop
(printf "finally for x0=~a x=~a v=~a\n" x0 (x) v))))] (printf "finally for x0=~a x=~a v=~a\n" x0 (x) v))))]
no-crashes no-crashes
(expected-output "x=123 v=999" (expected-output (list "x=123 v=999"
"x=124 v=999" "x=124 v=999"
"finally for x0=123 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))))) (collected-lines)))))
(define-syntax-rule (correct-topics-and-researchers) (define-syntax-rule (correct-topics-and-researchers)
(expected-output-set "Added researcher: Alice" (expected-output (set "Added researcher: Alice"
"Added researcher: Eve" "Added researcher: Eve"
"Added researcher: Tony" "Added researcher: Tony"
"Added topic: Bicycling" "Added topic: Bicycling"
"Added topic: Computering" "Added topic: Computering"
"Added topic: Cryptography" "Added topic: Cryptography"
"Added topic: Evil")) "Added topic: Evil")))
(test-case (test-case
[(spawn #:name 'tony [(spawn #:name 'tony
@ -135,8 +135,8 @@
(printf "Stopping outer claimant\n") (printf "Stopping outer claimant\n")
(stop-current-facet)))] (stop-current-facet)))]
no-crashes no-crashes
(expected-output "Outer claimant started" (expected-output (list "Outer claimant started"
"Inner saw claim asserted" "Inner saw claim asserted"
"Stopping outer claimant" "Stopping outer claimant"
"Outer claimant stopped" "Outer claimant stopped"
"Inner saw claim retracted")) "Inner saw claim retracted")))

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

@ -51,49 +51,48 @@
;; ^ (retract! (entry 'a ?)) ;; ^ (retract! (entry 'a ?))
(pause))] (pause))]
no-crashes no-crashes
;; Within the following, some permutations are acceptable: ;; To properly test this, we need something closer to real
#;(expected-output ;; regular-expressions-with-interleave over output lines:
"pause" #;(expected-output (list "pause"
"pause" "pause")
"(other-listener) key 'a asserted" (set "(other-listener) key 'a asserted"
"(other-listener) key 'c asserted" "(other-listener) key 'c asserted"
"(other-listener) key 'b asserted" "(other-listener) key 'b asserted")
"(other-listener) 'a ---> 4" (set "(other-listener) 'a ---> 4"
"(other-listener) 'a ---> 1" "(other-listener) 'a ---> 1"
"(other-listener) 'a ---> 2" "(other-listener) 'a ---> 2"
"(other-listener) 'a ---> 5" "(other-listener) 'a ---> 5"
"(other-listener) 'c ---> 33" "(other-listener) 'c ---> 33"
"(other-listener) 'b ---> 3" "(other-listener) 'b ---> 3")
"key 'a asserted" (set "key 'a asserted"
"key 'c asserted" "key 'c asserted"
"key 'b asserted" "key 'b asserted")
"add binding: 'a -> 4" (set "add binding: 'a -> 4"
"add binding: 'a -> 1" "add binding: 'a -> 1"
"add binding: 'a -> 2" "add binding: 'a -> 2"
"add binding: 'a -> 5" "add binding: 'a -> 5"
"add binding: 'c -> 33" "add binding: 'c -> 33"
"add binding: 'b -> 3" "add binding: 'b -> 3")
"pause" (list "pause")
"del binding: 'a -> 2" (set "del binding: 'a -> 2"
"del binding: 'c -> 33" "del binding: 'c -> 33"
"add binding: 'a -> 9" "add binding: 'a -> 9")
"key 'c retracted" (set "key 'c retracted")
"(other-listener) 'a ---> 9" (set "(other-listener) 'a ---> 9"
"(other-listener) 'a -/-> 2" "(other-listener) 'a -/-> 2"
"(other-listener) 'c -/-> 33" "(other-listener) 'c -/-> 33"
"(other-listener) key 'c retracted" "(other-listener) key 'c retracted")
"del binding: 'a -> 1" (set "del binding: 'a -> 1"
"del binding: 'a -> 9" "del binding: 'a -> 9"
"del binding: 'a -> 5" "del binding: 'a -> 5"
"del binding: 'a -> 4" "del binding: 'a -> 4")
"key 'a retracted" (set "key 'a retracted")
"(other-listener) 'a -/-> 1" (set "(other-listener) 'a -/-> 1"
"(other-listener) 'a -/-> 9" "(other-listener) 'a -/-> 9"
"(other-listener) 'a -/-> 5" "(other-listener) 'a -/-> 5"
"(other-listener) 'a -/-> 4" "(other-listener) 'a -/-> 4")
"(other-listener) key 'a retracted" (set "(other-listener) key 'a retracted")
"del binding: 'b -> 3" (set "del binding: 'b -> 3")
"key 'b retracted" (set "key 'b retracted")
"(other-listener) 'b -/-> 3" (set "(other-listener) 'b -/-> 3")
"(other-listener) key 'b retracted" (set "(other-listener) key 'b retracted")))
))

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

@ -25,9 +25,9 @@
(assert! 'demand) (assert! 'demand)
(displayln "Demand now steady."))] (displayln "Demand now steady."))]
no-crashes no-crashes
(expected-output "Asserting demand." (expected-output (list "Asserting demand."
"Supply asserted." "Supply asserted."
"Glitching demand." "Glitching demand."
"Demand now steady." "Demand now steady."
"Supply retracted." "Supply retracted."
"Supply asserted.")) "Supply asserted.")))

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

@ -16,7 +16,7 @@
(on (retracted (observe (list 'X $supplier))) (on (retracted (observe (list 'X $supplier)))
(printf "Supply ~v retracted.\n" supplier)))] (printf "Supply ~v retracted.\n" supplier)))]
no-crashes no-crashes
(expected-output "Supply 1 asserted.")) (expected-output (list "Supply 1 asserted.")))
(test-case (test-case
[(spawn #:name 'factory-1 [(spawn #:name 'factory-1
@ -32,9 +32,9 @@
(on (retracted (observe (list 'X $supplier))) (on (retracted (observe (list 'X $supplier)))
(printf "Supply ~v retracted.\n" supplier)))] (printf "Supply ~v retracted.\n" supplier)))]
no-crashes no-crashes
(expected-output "Supply 1 asserted." (expected-output (list "Supply 1 asserted."
"Supply 1 retracted." "Supply 1 retracted."
"Supply 1 asserted.")) "Supply 1 asserted.")))
(test-case (test-case
[(spawn #:name 'factory-1 [(spawn #:name 'factory-1
@ -50,8 +50,8 @@
(on (retracted (observe (list 'X $supplier))) (on (retracted (observe (list 'X $supplier)))
(printf "Supply ~v retracted.\n" supplier)))] (printf "Supply ~v retracted.\n" supplier)))]
no-crashes no-crashes
(expected-output "Supply 1 asserted." (expected-output (list "Supply 1 asserted."
"Supply 1 retracted.")) "Supply 1 retracted.")))
(test-case (test-case
[(spawn #:name 'factory-1 [(spawn #:name 'factory-1
@ -67,5 +67,5 @@
(on (retracted (observe (list 'X $supplier))) (on (retracted (observe (list 'X $supplier)))
(printf "Supply ~v retracted.\n" supplier)))] (printf "Supply ~v retracted.\n" supplier)))]
no-crashes no-crashes
(expected-output "Supply 1 asserted." (expected-output (list "Supply 1 asserted."
"Supply 1 retracted.")) "Supply 1 retracted.")))

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

@ -10,4 +10,4 @@
(stop-when (asserted (one-plus 3 $value)) (stop-when (asserted (one-plus 3 $value))
(printf "1 + 3 = ~a\n" value)))] (printf "1 + 3 = ~a\n" value)))]
no-crashes 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) (printf "client: learned that box's value is now ~v\n" v)
(send! (set-box (+ v 1)))))] (send! (set-box (+ v 1)))))]
no-crashes no-crashes
(expected-output "client: learned that box's value is now 0" (expected-output (list "client: learned that box's value is now 0"
"box: taking on new-value 1" "box: taking on new-value 1"
"client: learned that box's value is now 1" "client: learned that box's value is now 1"
"box: taking on new-value 2" "box: taking on new-value 2"
"client: learned that box's value is now 2" "client: learned that box's value is now 2"
"box: taking on new-value 3" "box: taking on new-value 3"
"box: terminating" "box: terminating"
"client: box has gone")) "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))) (spawn #:name "E" (on (asserted (inbound (greeting $t)))
(printf "Inner dataspace: ~a\n" t))))] (printf "Inner dataspace: ~a\n" t))))]
no-crashes no-crashes
(expected-output-set "Outer dataspace: Hi from outer space!" ;; There are constraints not expressed here; to properly test this,
"Inner dataspace: Hi from outer space!" ;; we need something closer to real
"Outer dataspace: Hi from inner!" ;; regular-expressions-with-interleave over output lines.
"Inner dataspace: Hi from inner!")) (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))
(send! (toggle)))] (send! (toggle)))]
no-crashes no-crashes
(expected-output "+even" (expected-output (list "+even"
"-even" "-even"
"+odd" "+odd"
"-odd" "-odd"
"+even" "+even"
"-even" "-even"
"+odd")) "+odd")))

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

@ -99,11 +99,11 @@
#f))))) #f)))))
(set))] (set))]
no-crashes no-crashes
(expected-output "client: learned that box's value is now 0" (expected-output (list "client: learned that box's value is now 0"
"box: taking on new-value 1" "box: taking on new-value 1"
"client: learned that box's value is now 1" "client: learned that box's value is now 1"
"box: taking on new-value 2" "box: taking on new-value 2"
"client: learned that box's value is now 2" "client: learned that box's value is now 2"
"box: taking on new-value 3" "box: taking on new-value 3"
"box: terminating" "box: terminating"
"client: box has gone")) "client: box has gone")))