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