80 lines
3.3 KiB
Racket
80 lines
3.3 KiB
Racket
#lang imperative-syndicate/test-implementation
|
|
;; 2018-11-20 Prior to the commit that introduced this test case (and
|
|
;; fixed the bug it exposed), matching a constant/literal `(discard)`
|
|
;; in an `inbound` pattern would match a visibility-restricted term,
|
|
;; so long as the captures were in the right places. After the fix,
|
|
;; `instantiate-term->value` replaces `(discard)` in the term with an
|
|
;; opaque value that cannot match any other value, meaning that only
|
|
;; patterns which completely ignore `discard`ed positions will match.
|
|
;;
|
|
;; Previously, the test-case marked (B) below yielded the correct
|
|
;; output, but (A) yielded the following incorrect output:
|
|
;;
|
|
;; Added discarded topic: Computering
|
|
;; Added discarded topic: Bicycling
|
|
;; Added discarded topic: Evil
|
|
;; Added discarded topic: Cryptography
|
|
;; Added topic: Computering
|
|
;; Added topic: Bicycling
|
|
;; Added topic: Evil
|
|
;; Added topic: Cryptography
|
|
;;
|
|
;; Now both yield the same output.
|
|
|
|
(require (only-in imperative-syndicate/pattern discard capture))
|
|
|
|
(assertion-struct researcher (name topic))
|
|
|
|
(define-syntax-rule (correct-topics)
|
|
(expected-output (set "Added topic: Bicycling"
|
|
"Added topic: Computering"
|
|
"Added topic: Cryptography"
|
|
"Added topic: Evil")))
|
|
|
|
(test-case ;; (A)
|
|
[(spawn #:name 'tony
|
|
(assert (researcher "Tony" "Computering"))
|
|
(assert (researcher "Tony" "Bicycling")))
|
|
(spawn #:name 'alice
|
|
(assert (researcher "Alice" "Cryptography"))
|
|
(assert (researcher "Alice" "Bicycling")))
|
|
(spawn #:name 'eve
|
|
(assert (researcher "Eve" "Cryptography"))
|
|
(assert (researcher "Eve" "Computering"))
|
|
(assert (researcher "Eve" "Evil")))
|
|
|
|
(dataspace #:name 'inner-dataspace
|
|
(spawn #:name 'all-topics
|
|
(during (inbound (researcher _ $topic))
|
|
(on-start (printf "Added topic: ~a\n" topic))
|
|
(on-stop (printf "Removed topic: ~a\n" topic))))
|
|
(spawn #:name 'all-researchers
|
|
(during (inbound (researcher (discard) $topic))
|
|
(on-start (printf "Added discarded topic: ~a\n" topic))
|
|
(on-stop (printf "Removed discarded topic: ~a\n" topic)))))]
|
|
no-crashes
|
|
(correct-topics))
|
|
|
|
(test-case ;; (B)
|
|
[(spawn #:name 'tony
|
|
(assert (researcher "Tony" "Computering"))
|
|
(assert (researcher "Tony" "Bicycling")))
|
|
(spawn #:name 'alice
|
|
(assert (researcher "Alice" "Cryptography"))
|
|
(assert (researcher "Alice" "Bicycling")))
|
|
(spawn #:name 'eve
|
|
(assert (researcher "Eve" "Cryptography"))
|
|
(assert (researcher "Eve" "Computering"))
|
|
(assert (researcher "Eve" "Evil")))
|
|
|
|
(spawn #:name 'all-topics
|
|
(during (researcher _ $topic)
|
|
(on-start (printf "Added topic: ~a\n" topic))
|
|
(on-stop (printf "Removed topic: ~a\n" topic))))
|
|
(spawn #:name 'all-researchers
|
|
(during (researcher (discard) $topic)
|
|
(on-start (printf "Added discarded topic: ~a\n" topic))
|
|
(on-stop (printf "Removed discarded topic: ~a\n" topic))))]
|
|
no-crashes
|
|
(correct-topics))
|