; SPDX-License-Identifier: LGPL-3.0-or-later
; Copyright (C) 2010-2021 Tony Garnock-Jones <tonygarnockjones@gmail.com>

#lang syndicate/test-implementation
;;
;; In principle, we might like that actors within a turn should
;; respond to assertions currently in the database *as modified by
;; previous pending actions of the actor*. However, this doesn't
;; currently work. Not only does the syndicate
;; implementation not do this, the old syndicate implementation
;; doesn't do it either, and there's also a theoretical problem: Say
;; we had been asserting `'x`, and within a single turn, we retract it
;; and establish a facet responding to it. Should the new facet react
;; to `'x`? The answer can only be "maybe", because our own assertion
;; of `'x` may not be the only one in the dataspace. Therefore,
;; perhaps it's best just to keep the current situation, or its ideal
;; reflection perhaps, which is: within-turn actions should execute in
;; context of the dataspace state as it was at the beginning of the
;; turn. I'm not 100% sure whether the current implementation actually
;; provides this guarantee, but it must be quite close since it seems
;; to hold for the examples I've tried.
;;
;; This line of thinking is in reaction to an infelicity I noticed
;; while working on the client/server/federation code. The following
;; code, on connection drop, runs through the `boot-connection` loop
;; *twice* instead of just once, because the retraction of
;; `server-connected` hasn't had time to actually be reflected in the
;; dataspace by the time the reaction to `server-connected` is
;; (re)established. The `server-connected` record is withdrawn on the
;; next turn, leading to a second `boot-connection`, and the system
;; stabilises here because `server-connected` is no longer present.
;;
;;   (let boot-connection ()
;;     (define root-facet (current-facet))
;;     (log-info "boot-connection ~v ~a" (current-facet) (facet-live? (current-facet)))
;;
;;     (reassert-on (tcp-connection id (tcp-address host port))
;;                  (retracted (tcp-accepted id))
;;                  (asserted (tcp-rejected id _)))
;;
;;     (during (tcp-accepted id)
;;       (on-start (log-info "+tcp-accepted ~v ~a" (current-facet) id))
;;       (on-stop (log-info "-tcp-accepted ~v ~a" (current-facet) id))
;;       (assert (server-connected address))
;;       (define accumulate! (packet-accumulator (lambda (p) (send! (server-packet address p)))))
;;       (on (message (tcp-in id $bs)) (accumulate! bs)))
;;
;;     (during (server-connected address)
;;       (on-start (log-info "+server-connected ~v ~a" (current-facet) address))
;;       (on-stop (log-info "-server-connected ~v ~a" (current-facet) address))
;;       ;; (on-start (send! (tcp-out id (encode (Connect scope)))))
;;       (generic-client-session-facet address (lambda (x) (send! (tcp-out id (encode x)))))
;;       (on-stop (log-info "---- ~v" (current-facet))
;;                (stop-facet root-facet
;;                            (log-info "!!!! ~v" (current-facet))
;;                            (react (boot-connection))))))
;;
;; The following test case is simplified but analogous to the problem
;; I noticed. Note particularly the `(flush!)` call, which is needed
;; to force the retraction of `'y` through to the dataspace and back
;; to the actor, so that the next `retry` doesn't improperly react to
;; a soon-to-be-retracted assertion of `'y`.

(test-case
    [
     (spawn* (until (asserted (observe 'x)))
             (send! 'x))

     ;; (spawn (on (asserted $anything) (printf "+ ~a\n" anything))
     ;;        (on (retracted $anything) (printf "- ~a\n" anything))
     ;;        (on (message $anything) (printf "! ~a\n" anything)))

     (spawn (let retry ((n 0))
              (cond [(>= n 10) (printf "Exceeded count\n")]
                    [else
                     (define f (current-facet))
                     ;; (during 'x (assert 'y))
                     (on (message 'x)
                         (react (assert 'y)
                                (on (asserted (observe 'go))
                                    (send! 'go))))
                     (during ($ val 'y)
                       (on-start (printf "+++++ ~a\n" val))
                       (on-stop (printf "----- ~a\n" val))
                       (on (message 'go)
                           (printf "going\n")
                           (stop-current-facet))
                       (on-stop
                        (printf "stopping\n")
                        (stop-facet f
                                    (printf "calling retry\n")
                                    (flush!) ;; !!!! Crucial!
                                    (react (retry (+ n 1))))))])))
     ]
  no-crashes
  (expected-output (list "+++++ y"
                         "going"
                         "----- y"
                         ;;
                         ;; (If we comment out the `(flush!)` above,
                         ;;  the following additional events appear
                         ;;  here, reflecting the unwanted reaction to
                         ;;  the doomed `'y` assertion:)
                         ;;
                         ;; "stopping"
                         ;; "calling retry"
                         ;; "+++++ y"
                         ;; "----- y"
                         ;;
                         "stopping"
                         "calling retry")))