146 lines
6.0 KiB
Racket
146 lines
6.0 KiB
Racket
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
#lang syndicate/test-implementation
|
|
;; Uhoh! The current (2018-05-02) scheme for relaying between
|
|
;; dataspaces instantiates each pattern when a matching assertion
|
|
;; appears and then relays the result on via an ordinary assertion.
|
|
;; However, this is probably wrong! If one inner observer monitors
|
|
;;
|
|
;; (inbound (x _ $y))
|
|
;;
|
|
;; while another monitors
|
|
;;
|
|
;; (inbound (x $z _))
|
|
;;
|
|
;; then the second one will see a literal `(discard)` for `z`!
|
|
|
|
(assertion-struct researcher (name topic))
|
|
|
|
(define no-mention-of-discard
|
|
(lambda ()
|
|
(not (memf (lambda (line) (string-contains? line "#s(discard)"))
|
|
(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")))
|
|
|
|
(test-case
|
|
[(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 $name _))
|
|
(on-start (printf "Added researcher: ~a\n" name))
|
|
(on-stop (printf "Removed researcher: ~a\n" name)))))]
|
|
no-crashes
|
|
no-mention-of-discard
|
|
(correct-topics-and-researchers))
|
|
|
|
(test-case
|
|
;; This one is just like the one above, but doesn't have the
|
|
;; nested dataspace, so the right answers are given.
|
|
[(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 $name _)
|
|
(on-start (printf "Added researcher: ~a\n" name))
|
|
(on-stop (printf "Removed researcher: ~a\n" name))))]
|
|
no-crashes
|
|
no-mention-of-discard
|
|
(correct-topics-and-researchers))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(assertion-struct claim (detail))
|
|
|
|
(define (asserts-then-retractions)
|
|
(and (equal? (length (collected-lines)) 4)
|
|
(equal? (list->set (take (collected-lines) 2)) (set "Specific claim asserted"
|
|
"Nonspecific claim 123 asserted"))
|
|
(equal? (list->set (drop (collected-lines) 2)) (set "Specific claim retracted"
|
|
"Nonspecific claim 123 retracted"))))
|
|
|
|
(test-case
|
|
[(spawn #:name 'claimant
|
|
(assert (claim 123))
|
|
(on-start (for [(i 5)] (flush!)) (stop-current-facet)))
|
|
(spawn #:name 'monitor
|
|
(during (claim 123)
|
|
(on-start (printf "Specific claim asserted\n"))
|
|
(on-stop (printf "Specific claim retracted\n")))
|
|
(during (claim $detail)
|
|
(on-start (printf "Nonspecific claim ~v asserted\n" detail))
|
|
(on-stop (printf "Nonspecific claim ~v retracted\n" detail))))]
|
|
no-crashes
|
|
asserts-then-retractions)
|
|
|
|
(test-case
|
|
[(spawn #:name 'claimant
|
|
(assert (claim 123))
|
|
(on-start (for [(i 5)] (flush!)) (stop-current-facet)))
|
|
(dataspace #:name 'inner-dataspace
|
|
(spawn #:name 'monitor
|
|
(during (inbound (claim 123))
|
|
(on-start (printf "Specific claim asserted\n"))
|
|
(on-stop (printf "Specific claim retracted\n")))
|
|
(during (inbound (claim $detail))
|
|
(on-start (printf "Nonspecific claim ~v asserted\n" detail))
|
|
(on-stop (printf "Nonspecific claim ~v retracted\n" detail)))))]
|
|
no-crashes
|
|
asserts-then-retractions)
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(test-case
|
|
[(dataspace #:name 'inner-dataspace
|
|
(spawn #:name 'inner-monitor
|
|
(during (inbound (claim $detail))
|
|
(on-start (printf "Inner saw claim asserted\n"))
|
|
(on-stop (printf "Inner saw claim retracted\n")))))
|
|
(spawn #:name 'claimant
|
|
(assert (claim 123))
|
|
(on-start (printf "Outer claimant started\n"))
|
|
(on-stop (printf "Outer claimant stopped\n"))
|
|
(on-start (for [(i 5)] (flush!))
|
|
(printf "Stopping outer claimant\n")
|
|
(stop-current-facet)))]
|
|
no-crashes
|
|
(expected-output (list "Outer claimant started"
|
|
"Inner saw claim asserted"
|
|
"Stopping outer claimant"
|
|
"Outer claimant stopped"
|
|
"Inner saw claim retracted")))
|