;;; Copyright 2019-2023 Christine Lemmer-Webber
;;; Copyright 2023 David Thompson
;;; Copyright 2024 Jessica Tallon
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(define-module (tests test-core)
  #:use-module (goblins core)
  #:use-module (goblins core-types)
  #:use-module (goblins persistence-store memory)
  #:use-module (goblins sleep-strategy always)
  #:use-module (goblins abstract-types)
  #:use-module (goblins utils ghash)
  #:use-module (goblins utils hashmap)
  #:use-module (goblins ocapn ids)
  #:use-module (tests utils)

  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-64)
  #:use-module (srfi srfi-11))

(test-begin "test-goblins-core")

;;; actormap low-level behavior tests
;;; =================================

(define-syntax-rule (snarf id ...)
  (begin
    (define id
      (@@ (goblins core) id))
    ...))

(snarf make-local-object-refr
       whactormap-set!
       whactormap-ref
       transactormap-set!
       transactormap-ref
       transactormap-merged?)

(define-syntax-rule (quietly body ...)
  (parameterize ((current-output-port (%make-void-port "w"))
                 (current-error-port (%make-void-port "w")))
    body ...))

;; set up actormap base with beeper and booper
(define actormap-base (make-whactormap))
(define (incr-am-base!)
  (increment-actormap-aurie-counter! actormap-base))
(define beeper-refr (make-local-object-refr 'beeper #f (incr-am-base!)))
(define (beeper-proc . args)
  'beep)
(whactormap-set! actormap-base beeper-refr beeper-proc)
(define booper-refr (make-local-object-refr 'booper #f (incr-am-base!)))
(define (booper-proc . args)
  'boop)
(whactormap-set! actormap-base booper-refr booper-proc)
(define blepper-refr (make-local-object-refr 'blepper #f (incr-am-base!)))
(define (blepper-proc . args)
  'blep)
(whactormap-set! actormap-base blepper-refr blepper-proc)

(define tam1
  (make-transactormap actormap-base))
(define (incr-tam1-base!)
  (increment-actormap-aurie-counter! tam1))
(define bipper-refr (make-local-object-refr 'bipper #f (incr-tam1-base!)))
(define (bipper-proc . args)
  'bippity)
(transactormap-set! tam1 bipper-refr bipper-proc)
(define (booper-proc2 . args)
  'boop2)
(transactormap-set! tam1 booper-refr booper-proc2)
(define (blepper-proc2 . args)
  'blep2)
(transactormap-set! tam1 blepper-refr blepper-proc2)
(test-eq bipper-proc
  (transactormap-ref tam1 bipper-refr))
(test-eq beeper-proc
  (transactormap-ref tam1 beeper-refr))
(test-eq booper-proc2
  (transactormap-ref tam1 booper-refr))
(test-eq blepper-proc2
  (transactormap-ref tam1 blepper-refr))
(test-eq booper-proc
  (whactormap-ref actormap-base booper-refr))
(test-assert (not (transactormap-merged? tam1)))


;;; actormap interface tests
;;; ========================

(define am (make-whactormap))
(test-assert "(make-whactormap) is a whactormap"
             (whactormap? am))
(test-assert "(make-whactormap) is also an actormap"
             (actormap? am))
(test-assert "(make-whactormap) is NOT a transactormap"
             (not (transactormap? am)))

(define (^greeter _bcom my-name)
  (lambda (your-name)
    (format #f "Hello ~a, my name is ~a!" your-name my-name)))

(define alice
  (actormap-spawn! am ^greeter "Alice"))

(test-equal "Hello Bob, my name is Alice!"
  (actormap-peek am alice "Bob"))

(define (^gregarious _bcom my-name)
  (lambda (talk-to)
    (format #f "I heard back: ~a"
            ($ talk-to my-name))))

(define greg
  (actormap-spawn! am ^gregarious "Greg"))

(test-equal "Test an actor which calls another actor"
  "I heard back: Hello Greg, my name is Alice!"
  (actormap-peek am greg alice))

;; Actor updates: update and return value separately
(define* (^cell bcom #:optional [val #f])
  (case-lambda
    [() val]
    [(new-val) (bcom (^cell bcom new-val))]))

(actormap-run!
 am
 (lambda ()
   (define cell (spawn ^cell))
   (test-equal ($ cell) #f)                  ; initial val
   (test-equal ($ cell 'foo) *unspecified*)  ; update (no return value)
   (test-equal ($ cell) 'foo)))              ; new val

;; Actor updates: update and return value at same time
(define* (^counter bcom #:optional [n 0])
  (lambda ()
    (bcom (^counter bcom (1+ n)) n)))

(actormap-run!
 am
 (lambda ()
   (define ctr (spawn ^counter))
   (test-equal 0 ($ ctr))
   (test-equal 1 ($ ctr))
   (test-equal 2 ($ ctr))
   (test-equal 3 ($ ctr))))

;; Now for some noncommittal stuff.

;; Let's noncommittally spawn our friend here...
(define-values (greety greety-tm)
  (actormap-spawn am ^greeter "Greety"))

(test-equal "Test actormap-peek works on transactormaps"
  "Hello Marge, my name is Greety!"
  (actormap-peek greety-tm greety "Marge"))
;; But we shouldn't be able to act on greety against the uncommitted
;; actormap, because nothing happened there...
(test-error (actormap-peek am greety "Marge"))
;; But now let's commit it...
(transactormap-merge! greety-tm)
;; And now we should be able to.
(test-equal "Check actor can be used (peek'ed) after committed to transactormap"
  "Hello Marge, my name is Greety!"
  (actormap-peek am greety "Marge"))

;; Test that peek and poke work right
(define a-ctr (actormap-spawn! am ^counter))
(test-equal 0 (actormap-peek am a-ctr))
(test-equal 0 (actormap-peek am a-ctr))
(test-equal 0 (actormap-poke! am a-ctr))
(test-equal 1 (actormap-poke! am a-ctr))
(test-equal 2 (actormap-peek am a-ctr))
(test-equal 2 (actormap-peek am a-ctr))
(test-equal 2 (actormap-poke! am a-ctr))
(test-equal 3 (actormap-peek am a-ctr))

(define (^spawns-during-constructor bcom)
  (define a-cell
    (spawn ^cell 'foo))
  (lambda ()
    (list 'got ($ a-cell))))
(define sdc
  (actormap-spawn! am ^spawns-during-constructor))

(test-equal "Spawn when we actormap-spawn(!) (yo dawg)"
  '(got foo)
  (actormap-peek am sdc))

;; Make sure using <-np queues a message
(test-eqv "a single message gets queued"
  1
  (let-values (((_returned tam msgs)
                (actormap-run*
                 am
                 (lambda ()
                   (<-np alice "Nobody")))))
    (length msgs)))

;; ... or three
(test-eqv "multiple messages get queued"
  3
  (let-values (((_returned tam msgs)
                (actormap-run*
                 am
                 (lambda ()
                   (<-np alice "Nobody")
                   (<-np alice "Was")
                   (<-np alice "Here")))))
    (length msgs)))


;; "on" handler for success case
(let ((on-result #f))
  (actormap-churn-run
   am
   (lambda ()
     (on (<- alice "Bob")
         (lambda (heard)
           (set! on-result `(heard-back ,heard))))))
  (test-equal "`on' handler success case"
    '(heard-back "Hello Bob, my name is Alice!")
    on-result))

(define (^explodable _bcom)
  (lambda _
    (error "oh YIKES")))

(let ((on-result #f))
  (quietly
   (actormap-churn-run
    am
    (lambda ()
      (define exploder (spawn ^explodable))
      (on (<- exploder)
          (lambda (heard)
            (set! on-result `(heard-back ,heard)))
          #:catch
          (lambda (exn)
            (set! on-result `(error ,exn)))))))
  (test-assert "`on' handler failure case"
    (match on-result
      [('error _err) #t]
      [_ #f])))

(define (^car-factory bcom company-name)
  (define (^car bcom model color)
    (lambda ()
      (format #f "*Vroom vroom!*  You drive your ~a ~a ~a!"
              color company-name model)))
  (define (make-car model color)
    (spawn ^car model color))
  make-car)

(let ((on-result #f))
  (actormap-churn-run!
   am
   (lambda ()
     (define fork-motors
       (spawn ^car-factory "Fork"))
     (define car-vow
       (<- fork-motors "Explorist" "blue"))
     (define drive-noise-vow
       (<- car-vow))
     (on drive-noise-vow
         (lambda (heard)
           (set! on-result `(heard-back ,heard))))))
  (test-equal "Pipelining works in simplest near case"
    '(heard-back "*Vroom vroom!*  You drive your blue Fork Explorist!")
    on-result))

(define (^lessgood-car-factory bcom company-name)
  (define (^car bcom model color)
    (lambda ()
      (format #f "*Vroom vroom!*  You drive your ~a ~a ~a!"
              color company-name model)))
  (define (make-car model color)
    (error "Your car exploded on the factory floor!  Oops!")
    (spawn ^car model color))
  make-car)

(let ((on-result #f))
  (quietly
   (actormap-churn-run!
    am
    (lambda ()
      (define fork-motors
        (spawn ^lessgood-car-factory "Forked"))
      (define car-vow
        (<- fork-motors "Exploder" "red"))
      (define drive-noise-vow
        (<- car-vow))
      (on drive-noise-vow
          (lambda (heard)
            (set! on-result `(heard-back ,heard)))
          #:catch
          (lambda (err)
            (set! on-result `(err ,err)))))))
  (test-assert "Errors propagate through a promise pipeline"
    (match on-result
      (('err _err) #t)
      (_ #f))))

;; And here's the other variant of promise pipelining breakage
(let ([what-i-got #f])
  (quietly
   (actormap-churn-run!
    am (lambda ()
         (define (^broken-actor _bcom)
           (lambda _
             (error "I am error")))
         (define (^returns-actor _bcom return-me)
           (lambda ()
             return-me))
         (define broken-actor
           (spawn ^broken-actor))
         (define returns-broken-actor
           (spawn ^returns-actor broken-actor))
         (define broken-actor-vow
           (<- returns-broken-actor))
         (on (<- broken-actor-vow)
             (lambda (v)
               (set! what-i-got `(yeah ,v)))
             #:catch
             (lambda (e)
               (set! what-i-got `(oh-no ,e)))))))
  (test-equal "Errors propagate through a promise pipeline, other version"
   'oh-no
   (car what-i-got)))

(test-assert "raised exceptions are actormap turn errors"
  ;; The only way this returns #t is if an actormap turn error is
  ;; handled.
  (with-exception-handler (const #t)
    (lambda ()
      (quietly (actormap-churn-run! am (lambda () (+ 1 "two"))))
      ;; If the actormap churn didn't throw an error and the test
      ;; made it here, it would fail.
      #f)
    #:unwind? #t
    #:unwind-for-type &actormap-turn-error))

(define bob (actormap-spawn! am ^cell "Hi, I'm bob!"))
(define-values (bob-vow bob-resolver)
  (actormap-run! am spawn-promise-and-resolver))

(snarf mactor:local-link?)

(actormap-poke! am bob-resolver 'fulfill bob)
(test-assert
 "Promise resolves to local-link"
 (mactor:local-link? (whactormap-ref am bob-vow)))
(test-equal "Resolved local-link acts as what it resolves to"
 "Hi, I'm bob!"
 (actormap-peek am bob-vow))
(actormap-poke! am bob-vow "Hi, I'm bobby!")
(test-equal "Resolved local-link can change original"
 "Hi, I'm bobby!"
 (actormap-peek am bob))

(define on-resolved-bob-arg #f)
(actormap-churn-run!
 am (lambda ()
      (on bob-vow
          (lambda (v)
            (set! on-resolved-bob-arg v)))))
(test-equal "Using `on' against a resolved refr returns that refr"
  bob
  on-resolved-bob-arg)

(snarf near-settled-promise-value)

(test-eq "near-settled-promise-value can extract local-refr value"
 bob
 (actormap-run
  am (lambda ()
       (near-settled-promise-value bob-vow))))

(define-values (encase-me-vow encase-me-resolver)
  (actormap-run! am spawn-promise-and-resolver))

(actormap-poke! am encase-me-resolver 'fulfill 'encase-me)
(test-eq "extracting encased value via actormap-peek"
 'encase-me
 (actormap-peek am encase-me-vow))
(test-eq "extracting encased value via $"
 'encase-me
 (actormap-run am (lambda () ($ encase-me-vow))))

(define on-resolved-encased-arg #f)
(actormap-churn-run!
 am (lambda ()
      (on encase-me-vow
          (lambda (v)
            (set! on-resolved-encased-arg v)))))
(test-equal "Using `on' against a resolved refr returns that refr"
  'encase-me
  on-resolved-encased-arg)


;; Tests for propagation of resolutions
(define (try-out-on actormap . resolve-args)
  ;; Run on against a promise, store the results
  ;; in the following cells
  (define resolved-cells
    (actormap-churn-run!
     actormap
     (lambda ()
       (define fulfilled-cell (spawn ^cell #f))
       (define broken-cell (spawn ^cell #f))
       (define finally-cell (spawn ^cell #f))
       (define-values (a-vow a-resolver)
         (spawn-promise-and-resolver))
       (on a-vow
           (lambda args
             ($ fulfilled-cell args))
           #:catch
           (lambda args
             ($ broken-cell args))
           #:finally
           (lambda ()
             ($ finally-cell #t)))
       (apply <-np a-resolver resolve-args)
       (list fulfilled-cell broken-cell finally-cell))))
  (map (lambda (cell)
         (actormap-peek actormap cell))
       resolved-cells))

(test-equal "Fulfilling a promise with on"
 '((how-fulfilling) #f #t)
 (try-out-on am 'fulfill 'how-fulfilling))

(test-equal "Breaking a promise with on"
 '(#f (i-am-broken) #t)
 (try-out-on am 'break 'i-am-broken))

(define (spawn-const val)
  (spawn (lambda _ (lambda _ val))))
(define (spawn-proc proc)
  (spawn (lambda _ proc)))

(let ([what-i-got #f])
  (actormap-churn-run!
   am (lambda ()
        (on (<- (spawn-const 'i-am-foo))
            (lambda (v)
              (set! what-i-got `(yeah ,v)))
            #:catch
            (lambda (e)
              (set! what-i-got `(oh-no ,e))))))
  (test-equal "<- returns a listen'able promise"
   '(yeah i-am-foo)
   what-i-got))

(let ([what-i-got #f])
  (quietly
   (actormap-churn-run!
    am (lambda ()
         (on (<- (spawn-proc
                  (lambda _
                    (error "I am error"))))
             (lambda (v)
               (set! what-i-got `(yeah ,v)))
             #:catch
             (lambda (e)
               (set! what-i-got `(oh-no ,e)))))))
  (test-equal "<- promise breaks as expected"
   'oh-no
   (car what-i-got)))

(let ([what-i-got #f])
  (actormap-churn-run!
   am (lambda ()
        (define foo (spawn-const 'i-am-foo))
        (on (<- (<- (spawn-proc (lambda _ foo))))
            (lambda (v)
              (set! what-i-got `(yeah ,v)))
            #:catch
            (lambda (e)
              (set! what-i-got `(oh-no ,e))))))
  (test-equal "basic promise pipelining"
   '(yeah i-am-foo)
   what-i-got))

(let ([what-i-got #f])
  (quietly
   (actormap-churn-run!
    am (lambda ()
         (define fatal-foo
           (spawn-proc
            (lambda _
              (error "I am error"))))
         (on (<- (<- (spawn-proc (lambda _ fatal-foo))))
             (lambda (v)
               (set! what-i-got `(yeah ,v)))
             #:catch
             (lambda (e)
               (set! what-i-got `(oh-no ,e)))))))
  (test-equal "basic promise contagion"
   'oh-no
   (car what-i-got)))

(test-equal "Passing #:promise? to `on` returns a promise that is resolved"
 "got: 6"
 (actormap-peek
  am
  (actormap-churn-run!
   am (lambda ()
        (define doubler (spawn (lambda (bcom)
                                 (lambda (x)
                                   (* x 2)))))
        (define the-on-promise
          (on (<- doubler 3)
              (lambda (x)
                (format #f "got: ~a" x))
              #:catch
              (lambda (e)
                "uhoh")
              #:promise? #t))
        the-on-promise))))

(let ([what-i-got #f]
      [finally-also-ran? #f])
  (actormap-churn-run!
   am
   (lambda ()
     (on 42
         (lambda (val)
           (set! what-i-got (format #f "got: ~a" val)))
         #:finally
         (lambda ()
           (set! finally-also-ran? #t)))))
  (test-equal
   "A non-promise value passed to `on` merely resolves to that value"
   "got: 42"
   what-i-got)
  (test-assert
   "#:finally also runs in case of non-promise value passed to `on`"
   finally-also-ran?))

;; verify listen-to works
(define (try-out-listen-to . resolve-args)
  (let ([resolved-val #f]
        [resolved-err #f])
    (actormap-churn-run!
     am
     (lambda ()
       (define-values (some-promise some-resolver)
         (spawn-promise-and-resolver))
       (listen-to some-promise
                  (spawn
                   (lambda (bcom)
                     (match-lambda*
                       [('fulfill val)
                        (set! resolved-val `(fulfilled ,val))]
                       [('break err)
                        (set! resolved-err `(broken ,err))]))))
       (apply $ some-resolver resolve-args)))
    (list resolved-val resolved-err)))
(test-equal "listen-to works with a fulfilled promise"
 '((fulfilled yay) #f)
 (try-out-listen-to 'fulfill 'yay))
(test-equal "listen-to works with a broken promise"
 '(#f (broken oh-no))
 (try-out-listen-to 'break 'oh-no))


(define (try-promise-to-promise . resolve-args)
  (let ([result #f]
        [finally-ran? #f])
    (actormap-churn-run!
     am
     (lambda ()
       (define-values (listen-to-promise listen-to-resolver)
         (spawn-promise-and-resolver))
       (define-values (middle-promise middle-resolver)
         (spawn-promise-and-resolver))
       (define-values (gets-the-answer-promise gets-the-answer-resolver)
         (spawn-promise-and-resolver))
       (on listen-to-promise
           (lambda (val)
             (set! result `(got-val ,val)))
           #:catch
           (lambda (err)
             (set! result `(got-err ,err)))
           #:finally
           (lambda ()
             (set! finally-ran? #t)))
       (<-np listen-to-resolver 'fulfill middle-promise)
       (<-np middle-resolver 'fulfill gets-the-answer-promise)
       (apply <-np gets-the-answer-resolver resolve-args)))
    (list result finally-ran?)))

(test-equal "Promise fulfilled to promise itself gets fulfillment"
 '((got-val yay) #t)
 (try-promise-to-promise 'fulfill 'yay))

(test-equal "Promise fulfilled to promise has broken promise contagion"
 '((got-err yikes) #t)
 (try-promise-to-promise 'break 'yikes))

;; object persistence tests
(define* (^incrementer bcom #:optional [value 0])
  (define (main-beh)
    (bcom (^incrementer bcom (+ 1 value)) (+ 1 value)))
  (define (self-portrait)
    (list value))
  (portraitize main-beh self-portrait))

(define ^persistent-greeter
  (make-redefinable-object
   (lambda* (bcom our-name #:optional [init-number-of-times #f])
     (define number-of-times
       (or init-number-of-times (spawn ^incrementer)))
     (define (main-beh your-name)
       (bcom (^persistent-greeter bcom our-name number-of-times)
             (format #f "Hello ~a, my name is ~a (called ~a)."
                     your-name our-name ($ number-of-times))))
     (define (self-portrait)
       (list our-name number-of-times))
     (portraitize main-beh self-portrait))))

(define (restored-greeter-rehydrate version our-name number-of-times)
  (spawn ^persistent-greeter
         (format #f "*restored ~a*" our-name)
         number-of-times))

(define first-actormap
  (make-actormap))

(define astrid-greeter
  (actormap-run!
   first-actormap
   (lambda ()
     (define astrid
       (spawn ^persistent-greeter "Astrid"))
     ($ astrid "Lars")
     ($ astrid "Johan")
     astrid)))

(define incrementer-env
  (make-persistence-env
   (list (list '((tests test-core) ^incrementer) ^incrementer))))

(define greeter-env
  (make-persistence-env
   (list (list '((tests test-core) ^persistent-greeter) ^persistent-greeter restored-greeter-rehydrate))
   #:extends incrementer-env))

(define-values (astrid-greeter-portrait astrid-greeter-roots)
  (actormap-take-portrait first-actormap greeter-env astrid-greeter))

(define second-actormap
  (make-actormap))

(define restored-astrid-greeter
  (actormap-restore! second-actormap greeter-env astrid-greeter-portrait astrid-greeter-roots))

(test-equal "Restored greeter reports correct number of times called"
  "Hello Ludvig, my name is *restored Astrid* (called 3)."
  (actormap-peek second-actormap restored-astrid-greeter "Ludvig"))


(set-redefinable-object-constructor!
 ^persistent-greeter
 (lambda* (bcom our-name #:optional init-number-of-times)
   (define number-of-times
     (or init-number-of-times (spawn ^incrementer)))
   (define (main-beh your-name)
     (format #f "Salutations ~a, I am called ~a, delighted to make your acquaintance! (called: ~a)"
             your-name our-name ($ number-of-times)))
   (define (self-portrait)
     (list our-name number-of-times))
   (portraitize main-beh self-portrait)))

(actormap-replace-behavior! first-actormap greeter-env)

(test-equal "Actors are updated when the behavior is replaced by new behavior"
  "Salutations Ludvig, I am called *restored Astrid*, delighted to make your acquaintance! (called: 3)"
  (actormap-peek first-actormap astrid-greeter "Ludvig"))


;; Test that when we restore what we get back is eq?
(define (^ro-cell _bcom value)
  (define (main-beh)
    value)
  (define (self-portrait)
    (list value))
  (portraitize main-beh self-portrait))
(define ro-cell-env
  (make-persistence-env
   `((((tests test-core) ^ro-cell) ,^ro-cell))
     #:extends incrementer-env))
(define incrementer
  (actormap-spawn! first-actormap ^incrementer))
(define ro-cell
  (actormap-spawn! first-actormap ^ro-cell incrementer))

(define-values (portraits root-slots)
  (actormap-take-portrait first-actormap ro-cell-env incrementer ro-cell))
(define-values (incrementer* ro-cell*)
  (actormap-restore! second-actormap ro-cell-env portraits root-slots))

(test-eq "Restored actor is eq?"
  incrementer*
  (actormap-peek second-actormap ro-cell*))

(define (^bar _bcom value)
  (define (main-beh another-value)
    (list value another-value))
  (define (self-portrait)
    (list value))
  (portraitize main-beh self-portrait))

(define* (^borked _bcom value #:optional borked?)
  (define (main-beh another-value)
    (if borked?
        (error "i am borked now, sorry")
        (list value another-value)))
  (define (self-portrait)
    ;; Become broken upon restoration.
    (list value #t))
  (portraitize main-beh self-portrait))

(define (^foo _bcom bar value)
  (define barred-value (<- bar value))
  (define (main-beh)
    barred-value)
  (define (self-portrait)
    (list bar value))
  (portraitize main-beh self-portrait))

(define env
  (make-persistence-env
   `((((tests test-core) ^bar) ,^bar)
     (((tests test-core) ^borked) ,^borked)
     (((tests test-core) ^foo) ,^foo))))

(test-equal "Check restored actors can send messages upon construction"
  '(start-bar start-foo)
  (let*-values (((am1) (make-actormap))
                ((am2) (make-actormap))
                ((bar1) (actormap-spawn! am1 ^bar 'start-bar))
                ((foo1) (actormap-spawn! am1 ^foo bar1 'start-foo))
                ((portraits roots) (actormap-take-portrait am1 env foo1))
                ((foo2) (actormap-restore! am2 env portraits roots)))
    (actormap-peek
     am2
     (actormap-churn-run!
      am2
      (lambda ()
        ($ foo2))))))

(test-equal "Restored actors can send messages upon construction that cause errors"
  'nope
  (let*-values (((am1) (make-actormap))
                ((am2) (make-actormap))
                ((bar1) (actormap-spawn! am1 ^borked 'start-bar))
                ((foo1) (actormap-spawn! am1 ^foo bar1 'start-foo))
                ((portraits roots) (actormap-take-portrait am1 env foo1))
                ;; Restoring ^borked sends a message that throws an
                ;; error and thus breaks a promise.
                ((foo2) (actormap-restore! am2 env portraits roots))
                ((result) 'idk))
    (actormap-churn-run!
     am2
     (lambda ()
       (on (<- foo2)
           (lambda (v) (set! result 'yep))
           #:catch (lambda (e) (set! result 'nope)))))
    result))

;; Test spawning another actor in the restore behavior
(define ^second
  (make-redefinable-object
   (lambda* (bcom #:optional stored-val)
     (define* (main-beh #:optional new-val)
       (if new-val
           (bcom (^second bcom new-val) 'second)
           (list 'second stored-val)))
     (define (self-portrait)
       (list stored-val))
     (portraitize main-beh self-portrait))))
(define ^first
  (make-redefinable-object
   (lambda (_bcom)
     (define (main-beh)
       'first)
     (define (self-portrait)
       (list))
     (portraitize main-beh self-portrait))))
(define first (actormap-spawn! first-actormap ^first))
(define env
  (make-persistence-env
   `((((tests test-core) ^first) ,^first)
     (((tests test-core) ^second) ,^second))))
;; Redefine it so that we spawn another object while being constructed!
(set-redefinable-object-constructor!
 ^first
 (lambda (_bcom)
   (define second (spawn ^second #f))
   (<-np second 'pineapple)
   (lambda ()
     ($ second))))

(actormap-replace-behavior! first-actormap env)
(test-equal "Redefinable objects can spawn other objects on construction"
  '(second pineapple)
  (actormap-peek first-actormap first))

;; Test all supported types can be serialized correctly
(define* (^type-serializer bcom supplied-refr
                           #:optional
                           got-number got-symbol got-list
                           got-keyword got-zilch got-tagged
                           got-string got-char got-bv got-bool
                           got-unspecified got-vector
                           got-gset got-ghash got-dotted
                           got-near-refr
                           got-promise-to-refr
                           got-promise-to-value
                           got-ocapn-peer got-ocapn-sref)
  ;; Make the promises
  (define-values (refr-vow refr-resolver)
    (spawn-promise-and-resolver))
  ($ refr-resolver 'fulfill supplied-refr)
  (define-values (encased-vow encased-resolver)
    (spawn-promise-and-resolver))
  ($ encased-resolver 'fulfill 75)

  ;; Make the other values
  (define number 7.2)
  (define symbol 'hello)
  (define my-vector #(1 2 3 zilch))
  (define my-list (list 1 2 3 zilch))
  (define bv (make-bytevector 10 10))
  (define string "tada 🪄")
  (define char #\a)
  (define keyword #:i-am-a-keyword)
  (define tagged (make-tagged 'foo supplied-refr))
  (define bool #t)
  (define gset (make-gset 1 2 3 'foo 'bar 'baz "Hello"))
  (define gh (ghash ('banana 'yellow)))
  (define dotted '(1 2 3 4 . zilch))
  (define ocapn-peer
    (make-ocapn-peer
     'fake
     "4wy6gxdweyqn5m7ntzwlxinhdia2jjanlsh37gxklwhfec7yxqr4k3qd"
     (hashmap ("name" "test 1"))))
  (define ocapn-sref
    (make-ocapn-sturdyref
     ocapn-peer
     #vu8(74 174 136 226 211 114 92 53 153 139 168 28 82 26 52 183 107 50 123 83 116 61 247 240 172 189 77 35 75 63 51 162)))

  (define (main-beh restored-refr)
    (and (eq? got-number number)
         (eq? got-symbol symbol)
         (equal? got-list my-list)
         (eq? got-keyword keyword)
         (eq? got-zilch zilch)
         (equal? got-tagged (make-tagged 'foo restored-refr))
         (string=? got-string string)
         (char=? got-char char)
         (equal? got-bv bv)
         (eq? got-bool bool)
         (unspecified? got-unspecified)
         (equal? my-vector got-vector)
         (eq? restored-refr got-near-refr)
         (equal? gset got-gset)
         (equal? gh got-ghash)
         (equal? dotted got-dotted)
         (live-refr? got-promise-to-refr)
         (eq? ($ encased-vow) ($ got-promise-to-value))
         (equal? ocapn-peer got-ocapn-peer)
         (equal? ocapn-sref got-ocapn-sref)))

  (define (self-portrait)
    (list #f
          number symbol my-list keyword zilch
          tagged string char bv bool
          *unspecified* my-vector gset gh dotted
          supplied-refr refr-vow encased-vow
          ocapn-peer ocapn-sref))
  (portraitize main-beh self-portrait))
(define env
  (make-persistence-env
   `((((tests test-core) ^type-serializer) ,^type-serializer)
     (((tests test-core) ^bar) ,^bar))))

(define bar (actormap-spawn! first-actormap ^bar 'foo))
(define types (actormap-spawn! first-actormap ^type-serializer bar))
(define-values (portraits slots)
  (actormap-take-portrait first-actormap env types bar))
(define-values (types* bar*)
  (actormap-restore! first-actormap env portraits slots))
(test-assert "All serializable types can be serialized by aurie"
  (actormap-peek first-actormap types* bar*))

(define namespaced-env
  (namespace-env
   (tests test-core)
   ^type-serializer ^bar))

(define-values (portraits slots)
  (actormap-take-portrait first-actormap namespaced-env types bar))
(define-values (types* bar*)
  (actormap-restore! first-actormap namespaced-env portraits slots))
(test-assert "Can serialize and rehydrate with env made by namespace-env"
  (actormap-peek first-actormap types* bar*))

(test-equal "Name of object is as expected when made with namespace-env"
  '((tests test-core) ^type-serializer)
  (match (hashq-ref portraits (car slots))
    [(name debug-name portrait-version portrait-data) name]))

;; Test <-hash-ref
(define am (make-actormap))
(define hm1 (hashmap ("foo" 10) ("bar" 'baz)))
(test-equal "Check <-hash-ref works when given a hashmap, not a refr"
  'baz
  (actormap-run
   am
   (lambda ()
     (<-hashmap-ref hm1 "bar"))))

(test-equal "Check <-hash-ref with already resolved vow"
  #(ok baz)
  (am-resolve-vow-and-return-result
   am
   (lambda ()
     (define-values (vow resolver)
       (spawn-promise-and-resolver))
     ($ resolver 'fulfill hm1)
     (<-hashmap-ref vow "bar"))))

(test-equal "Check <-hash-ref with promise chaining"
  #(ok baz)
  (am-resolve-vow-and-return-result
   am
   (lambda ()
     (define-values (vow1 resolver1)
       (spawn-promise-and-resolver))
     (define-values (vow2 resolver2)
       (spawn-promise-and-resolver))
     (define-values (vow3 resolver3)
       (spawn-promise-and-resolver))
     (define hashref-vow (<-hashmap-ref vow1 "bar"))
     (<-np resolver1 'fulfill vow2)
     (<-np resolver2 'fulfill vow3)
     (<-np resolver3 'fulfill hm1)
     hashref-vow)))

(test-assert "Check <-hash-ref breaks when fulfilled with non-hashmap"
  (match (am-resolve-vow-and-return-result
          am
          (lambda ()
            (define-values (vow resolver)
              (spawn-promise-and-resolver))
            ($ resolver 'fulfill 'not-a-hashmap)
            (<-hashmap-ref vow "bar")))
    [#(err _) #t]
    [#(ok _) #f]))

(define lst '(foo bar baz))
(test-equal "Check <-list-ref works when given a raw list"
  'foo
  (actormap-run
   am
   (lambda ()
     (<-list-ref lst 0))))
(test-equal "Check <-list-ref works with already resolved vow"
  #(ok foo)
  (am-resolve-vow-and-return-result
   am
   (lambda ()
     (define-values (vow resolver)
       (spawn-promise-and-resolver))
     ($ resolver 'fulfill lst)
     (<-list-ref vow 0))))

(test-equal "Check <-list-ref works with promise chaining"
  #(ok foo)
  (am-resolve-vow-and-return-result
   am
   (lambda ()
     (define-values (vow1 resolver1)
       (spawn-promise-and-resolver))
     (define-values (vow2 resolver2)
       (spawn-promise-and-resolver))
     (define-values (vow3 resolver3)
       (spawn-promise-and-resolver))
     (define listref-vow (<-list-ref vow1 0))
     (<-np resolver1 'fulfill vow2)
     (<-np resolver2 'fulfill vow3)
     (<-np resolver3 'fulfill lst)
     listref-vow)))

(test-assert "Check <-list-ref breaks when fulfilled with non-list"
  (match (am-resolve-vow-and-return-result
          am
          (lambda ()
            (define-values (vow resolver)
              (spawn-promise-and-resolver))
            ($ resolver 'fulfill 'not-a-list)
            (<-list-ref vow 0)))
    [#(err _) #t]
    [#(ok _) #f]))

(define tagged-val (make-tagged "hello" 'beepboop))
(test-equal "Check <-tagged-ref works when given a raw tagged value"
  'beepboop
  (actormap-run
   am
   (lambda ()
     (<-tagged-ref tagged-val "hello"))))
(test-equal "Check <-tagged-ref works with already resolved vow"
  #(ok beepboop)
  (am-resolve-vow-and-return-result
   am
   (lambda ()
     (define-values (vow resolver)
       (spawn-promise-and-resolver))
     ($ resolver 'fulfill tagged-val)
     (<-tagged-ref vow "hello"))))

(test-equal "Check <-tagged-ref works with promise chaining"
  #(ok beepboop)
  (am-resolve-vow-and-return-result
   am
   (lambda ()
     (define-values (vow1 resolver1)
       (spawn-promise-and-resolver))
     (define-values (vow2 resolver2)
       (spawn-promise-and-resolver))
     (define-values (vow3 resolver3)
       (spawn-promise-and-resolver))
     (define tagged-ref-vow (<-tagged-ref vow1 "hello"))
     (<-np resolver1 'fulfill vow2)
     (<-np resolver2 'fulfill vow3)
     (<-np resolver3 'fulfill tagged-val)
     tagged-ref-vow)))

(test-assert "Check <-tagged-ref breaks when fulfilled with non-tagged-value"
  (match (am-resolve-vow-and-return-result
          am
          (lambda ()
            (define-values (vow resolver)
              (spawn-promise-and-resolver))
            ($ resolver 'fulfill 'not-a-tagged-value)
            (<-tagged-ref vow "hello")))
    [#(err _) #t]
    [#(ok _) #f]))

(test-assert "Check <-tagged-ref breaks when label does not match found label"
  (match (am-resolve-vow-and-return-result
          am
          (lambda ()
            (define-values (vow resolver)
              (spawn-promise-and-resolver))
            ($ resolver 'fulfill tagged-val)
            (<-tagged-ref vow "not-the-right-label")))
    [#(err _) #t]
    [#(ok _) #f]))

(test-equal "Check refr-name returns debug name for local-refr"
  'i-am-the-local-name
  (let* ((am (make-actormap))
         (refr (actormap-run! am (lambda () (spawn-named 'i-am-the-local-name ^greeter "Bob")))))
    (refr-name refr)))

(test-equal "Check refr-name returns #f for non-local-refr values"
  #f
  (let* ((am (make-actormap))
         (vow (actormap-run! am (lambda () (spawn-promise-and-resolver)))))
    ;; vow's a promise not an actor refr...
    (refr-name vow)))

;; Sleepy Actors
;; -------------
(define (hash-table-length ht)
  (hash-fold
   (lambda (key val prev)
     (1+ prev))
   0
   ht))

;; Check we can sleep an actor
(define store (make-memory-store))
(define sleep-profile (make-sleep-profile incrementer-env store (sleep:always)))
(define am (make-actormap))
(define inc
  (call-with-sleep-profile
   sleep-profile
   (lambda ()
     (define inc (actormap-spawn! am ^incrementer 72))
     ;; Gotta make sure eva's in the store first.
     (actormap-save-to-store! am greeter-env store inc)
     inc)))

;; Now sleep her to sleep.
(actormap-bedtime! am sleep-profile (list inc))
(test-assert "Check actormap-bedtime! puts refr to sleep"
  (mactor:asleep? (actormap-ref am inc)))

;; Check we can still invoke eva
(test-equal "Check can use $ on asleep object"
  73
  (call-with-sleep-profile
   sleep-profile
   (lambda ()
     (actormap-run
      am
      (lambda () ($ inc))))))

;; We used actormap-run above, not actormap-run. Check the actor is still asleep
(test-assert "Actors do not stay awake for non-committal actormap procedures"
  (mactor:asleep? (actormap-ref am inc)))

;; Test committal prcoedures do actually wake the refr up properly.
(call-with-sleep-profile
 sleep-profile
 (lambda ()
   (actormap-poke! am inc)))

(test-assert "Actors stay awake after committal actormap procedures"
  (mactor:object? (actormap-ref am inc)))

;; Test waking up an actor with lots of nested data structures. This _should_
;; more or less work since the sleep system doesn't need to do much extra beyond
;; regular aurie, but test it anyway.
(define (^ro-cell bcom data)
  (define (self-portrait)
    (list data))
  (define (beh) data)
  (portraitize beh self-portrait))
(define env
  (make-persistence-env
   `((((tests test-core) ^cell) ,^ro-cell))))

(define store (make-memory-store))
(define sleep-profile (make-sleep-profile env store (sleep:always)))
(define am (make-actormap))
;; Spawn a bunch of actors to nest
(define-values (obj0 obj1 obj2 obj3 obj4 obj5 obj6 obj7 obj8 obj9 obj10 vow0)
  (call-with-sleep-profile
   sleep-profile
   (lambda ()
     (define obj10 (actormap-spawn-named! am 'obj10 ^ro-cell #f))
     (values (actormap-spawn-named! am 'obj0 ^ro-cell #f)
             (actormap-spawn-named! am 'obj1 ^ro-cell #f)
             (actormap-spawn-named! am 'obj2 ^ro-cell #f)
             (actormap-spawn-named! am 'obj3 ^ro-cell #f)
             (actormap-spawn-named! am 'obj4 ^ro-cell #f)
             (actormap-spawn-named! am 'obj5 ^ro-cell #f)
             (actormap-spawn-named! am 'obj6 ^ro-cell #f)
             (actormap-spawn-named! am 'obj7 ^ro-cell #f)
             (actormap-spawn-named! am 'obj8 ^ro-cell #f)
             (actormap-spawn-named! am 'obj9 ^ro-cell #f)
             obj10
             ;; vow0
             (actormap-churn-run!
              am
              (lambda ()
                (define-values (vow resolver)
                  (spawn-promise-and-resolver))
                ($ resolver 'fulfill obj10)
                vow))))))
;; Spawn the actor with the nested data
(define vec (make-vector 1))
(vector-set! vec 0 obj2)
(define nested-portrait-data-actor
  (call-with-sleep-profile
   sleep-profile
   (lambda ()
     (actormap-spawn! am ^ro-cell
                      (list
                       obj0
                       (list obj1)
                       vec
                       (cons obj3 obj4)
                       (make-tagged 'object5 obj5)
                       (make-tagged obj6 'object6)
                       (hashmap ('object-7 obj7))
                       (hashqmap (obj8 'object-8))
                       (make-gset obj9)
                       ;; vow0 contains obj10
                       vow0)))))

;; This is for the next test, but it helps to do it here.
(define-values (portraits root-slots)
  (actormap-take-portrait am env nested-portrait-data-actor))

(actormap-save-to-store! am env store nested-portrait-data-actor)
(actormap-bedtime! am sleep-profile (list nested-portrait-data-actor))
(define skeleton
  (mactor:asleep-skeleton (actormap-ref am nested-portrait-data-actor)))
(define restored-data
  (call-with-sleep-profile
   sleep-profile
   (lambda ()
     (actormap-poke! am nested-portrait-data-actor))))

;; Match the data with the data above...
(test-assert "Woken up actors have nested objects restored correctly"
  (match restored-data
    ((restored-obj0 (restored-obj1) restored-vec restored-cons restored-tagged0
                    restored-tagged1 restored-hash0 restored-hash1 restored-gset
                    restored-vow)
     (and (eq? restored-obj0 obj0)
          (eq? restored-obj1 obj1)
          (eq? (vector-ref restored-vec 0) obj2)
          (eq? (car restored-cons) obj3)
          (eq? (cdr restored-cons) obj4)
          (eq? (tagged-data restored-tagged0) obj5)
          (eq? (tagged-label restored-tagged1) obj6)
          (eq? (hashmap-ref restored-hash0 'object-7) obj7)
          (eq? (hashmap-ref restored-hash1 obj8) 'object-8)
          (equal? (gset-length restored-gset) 1)
          (eq? (car (gset->list restored-gset)) obj9)
          (eq? (match (am-resolve-vow-and-return-result am (lambda () restored-vow))
                 (#(ok refr) refr)
                 (_ #f))
               obj10)))
    (_ #f)))

;; Check the skeleton on the mactor has all 9 objects that are in the portrait.
(test-equal "Asleep actor has correct number of items in skeleton when nested"
  11
  (hash-table-length skeleton))

;; Now try restoring the nested object in an "asleep" state. It relies on a
;; sleep specific parser which should walk the portrait looking for refrs.
(define new-am (make-actormap))
(define-values (_changed-objs refrs->slots slots->refrs far-refr-resolvers roots)
  (actormap-restore-refrs-asleep! new-am portraits root-slots))

(define restored-nested-portrait-data-actor
  (match roots
    ((refr) refr)
    (#f (error "Not the root I was expected"))))

;; Check we've restored it as a asleep mactor
(define mactor (actormap-ref new-am restored-nested-portrait-data-actor))
(test-assert "actormap-restore-refrs-asleep! restored as an asleep refr"
  (mactor:asleep? mactor))

(define skeleton (mactor:asleep-skeleton mactor))
(test-equal "restored asleep actor has the amount of refrs in skeleton as expected"
  11
  (hash-table-length skeleton))

(define restored-data
  (call-with-sleep-profile
   sleep-profile
   (lambda ()
     (actormap-poke! new-am restored-nested-portrait-data-actor))))

;; Regression test for https://codeberg.org/spritely/goblins/issues/957
(define (fake-vat-connector vat-id)
  (match-lambda*
    (('aurie-vat-id) vat-id)))
(test-equal "actors correctly retain far refrs when they fall asleep after restoration"
  '(far (alice 1))
  (let* ((am1 (make-actormap #:vat-connector (fake-vat-connector 'alice)))
         (am2 (make-actormap #:vat-connector (fake-vat-connector 'bob)))
         (store (make-memory-store))
         (zzz (make-sleep-profile env store (sleep:always)))
         (alice (actormap-spawn! am1 ^ro-cell 42))
         (bob (actormap-spawn! am2 ^ro-cell alice)))
    (call-with-sleep-profile
     zzz
     (lambda ()
       ;; Save Bob.
       (actormap-save-to-store! am2 env store bob)
       ;; Create a new actormap for restoration.
       (set! am2 (make-actormap))
       ;; Restore Bob.
       (define-values (changed refrs->slots slots->refrs far-refr-resolvers roots)
         (let ((portraits (make-hash-table)))
           (hash-set! portraits 1 ((persistence-store-read-proc store) 'object-portrait 1))
           (actormap-restore-refrs-asleep! am2 portraits '(1))))
       ;; Replace the original Bob reference with the restored Bob.
       (match roots
         ((new-bob) (set! bob new-bob)))
       ;; Wake Bob up.
       (actormap-poke! am2 bob)
       ;; Put Bob back to sleep.
       (actormap-bedtime! am2 zzz (list bob))
       ;; Wake Bob up again.  The reference to Alice should be a local
       ;; promise that is linked to Alice's persistence id.
       (let ((alice* (actormap-peek am2 bob)))
         (and (local-promise-refr? alice*)
              (mactor:aurie-local-link-depiction
               (actormap-ref am2 alice*))))))))

(test-end "test-goblins-core")
