Create test harness & lang for contrasting big & little actor langs
This commit is contained in:
Sam Caldwell
parent
9498f5129e
commit
6448188e82
|
|
@ -2,3 +2,4 @@
|
|||
(define scribblings '(("scribblings/syndicate.scrbl" ())))
|
||||
(define racket-launcher-names '("syndicate-broker"))
|
||||
(define racket-launcher-libraries '("broker/server.rkt"))
|
||||
(define test-include-paths '("syndicate/tests"))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,9 @@
|
|||
#lang racket
|
||||
|
||||
(provide run
|
||||
run-with
|
||||
run-with-trace)
|
||||
|
||||
(require syndicate/monolithic)
|
||||
(require syndicate/trie)
|
||||
(require racket/set)
|
||||
|
|
@ -356,7 +360,7 @@
|
|||
(lambda (rev-vs σ e)
|
||||
(result-map (lambda (v) (cons v rev-vs))
|
||||
(eval-exp e Γ σ)))))
|
||||
(result-map (lambda (rev-vs) (cons 'list (reverse rev-vs)))
|
||||
(result-map (lambda (rev-vs) (reverse rev-vs))
|
||||
res)]
|
||||
[`(let (,x ,exp) ,body-exp)
|
||||
(result-bind (eval-exp exp Γ σ)
|
||||
|
|
@ -575,9 +579,8 @@
|
|||
(define (eval-pat pat Γ σ)
|
||||
(match pat
|
||||
[`(list ,pats ...)
|
||||
(cons 'list
|
||||
(for/list ([p (in-list pats)])
|
||||
(eval-pat p Γ σ)))]
|
||||
(for/list ([p (in-list pats)])
|
||||
(eval-pat p Γ σ))]
|
||||
[`(observe ,pat)
|
||||
(observe (eval-pat pat Γ σ))]
|
||||
[`(inbound ,pat)
|
||||
|
|
@ -649,14 +652,14 @@
|
|||
(check-equal? (occurrences `(asserted 5) (message 5) trie-empty mt-Γ mt-σ)
|
||||
(list))
|
||||
(check-equal? (occurrences `(asserted (list "price" $x))
|
||||
(scn (assertion '(list "price" 12)))
|
||||
(assertion '(list "price" 5))
|
||||
(scn (assertion '("price" 12)))
|
||||
(assertion '("price" 5))
|
||||
mt-Γ mt-σ)
|
||||
(list (list (binding 'x 12))))
|
||||
(check-equal? (list->set
|
||||
(occurrences `(asserted (list "price" $x))
|
||||
(scn (π-union (assertion '(list "price" 12)) (assertion '(list "price" 16))))
|
||||
(assertion '(list "price" 5))
|
||||
(scn (π-union (assertion '("price" 12)) (assertion '("price" 16))))
|
||||
(assertion '("price" 5))
|
||||
mt-Γ mt-σ))
|
||||
(set (list (binding 'x 12)) (list (binding 'x 16)))))
|
||||
|
||||
|
|
@ -743,6 +746,14 @@
|
|||
(boot-actor boot mt-Γ)))
|
||||
(run-ground (cons upside-down-relay boot-actions)))
|
||||
|
||||
;; Actor Program -> Syndicate
|
||||
(define (run-with regular-actor p)
|
||||
(define boot-actions
|
||||
(for/list ([boot (in-list p)])
|
||||
(boot-actor boot mt-Γ)))
|
||||
(run-ground regular-actor boot-actions))
|
||||
|
||||
|
||||
;; Actor AsyncChannel Program -> Boolean
|
||||
;; trace-actor is the first actor spawned inside the program's ground dataspace
|
||||
;; chan is a channel used by the trace-actor to signal a completed trace, by
|
||||
|
|
@ -799,92 +810,6 @@
|
|||
;; Tests
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(module+ test
|
||||
|
||||
(define test-program
|
||||
`((spawn (on-start (printf "hello,world\n")))))
|
||||
|
||||
(define test-program2
|
||||
`(
|
||||
(spawn (on (asserted 5)
|
||||
(printf "wat\n")))
|
||||
(spawn (assert 5))))
|
||||
|
||||
(test-trace (trace (assertion-added (observe 5))
|
||||
(assertion-added 5))
|
||||
test-program2)
|
||||
|
||||
|
||||
(define ping-pong
|
||||
`(
|
||||
(spawn (on (message "ping")
|
||||
(printf "ping\n")
|
||||
(send! "pong")))
|
||||
(spawn (on (message "pong")
|
||||
(printf "pong\n")
|
||||
(send! "ping"))
|
||||
(on-start (send! "ping")))))
|
||||
|
||||
(test-trace (trace (message "ping")
|
||||
(message "pong")
|
||||
(message "ping")
|
||||
(message "pong")
|
||||
(message "ping")
|
||||
(message "pong")
|
||||
(message "ping")
|
||||
(message "pong"))
|
||||
ping-pong)
|
||||
|
||||
(define bank-account
|
||||
`(
|
||||
(spawn (field [balance 0])
|
||||
(assert (list "account" (balance)))
|
||||
(on (message (list "deposit" $amount))
|
||||
(balance (+ (balance) amount))))
|
||||
|
||||
(spawn (on (asserted (list "account" $balance))
|
||||
(printf "Balance changed to ~a\n" balance))
|
||||
(stop-when (asserted (list "account" 70))
|
||||
(printf "bye\n"))
|
||||
(on-stop (printf "good.\n")))
|
||||
|
||||
(spawn (stop-when (asserted (observe (list "deposit" _)))
|
||||
(send! (list "deposit" +100))
|
||||
(send! (list "deposit" -30))))))
|
||||
|
||||
(test-trace (trace (assertion-added '(list "account" 0))
|
||||
(and (assertion-added '(list "account" 100))
|
||||
(assertion-removed '(list "account" 0)))
|
||||
(and (assertion-added '(list "account" 70))
|
||||
(assertion-removed '(list "account" 100))))
|
||||
bank-account
|
||||
#:timeout 5000)
|
||||
|
||||
(define multi-level-ex
|
||||
'(
|
||||
(spawn (on (asserted "hello")
|
||||
(printf "goodbye")))
|
||||
(dataspace (spawn (assert (outbound "hello"))))))
|
||||
|
||||
(test-trace (trace (assertion-added "hello"))
|
||||
multi-level-ex)
|
||||
|
||||
(define multi-level-message
|
||||
'(
|
||||
(spawn (on (message "hello")))
|
||||
(dataspace (spawn (on-start (send! (outbound "hello")))))))
|
||||
|
||||
(test-trace (trace (message "hello"))
|
||||
multi-level-message)
|
||||
(define multi-level-other-way
|
||||
'(
|
||||
(dataspace (spawn (on (asserted (inbound "gday"))
|
||||
(send! (outbound "good things")))))
|
||||
(spawn (assert "gday"))))
|
||||
|
||||
(test-trace (trace (message "good things"))
|
||||
multi-level-other-way))
|
||||
|
||||
(define ff
|
||||
'(
|
||||
(spawn (on (message 5)
|
||||
|
|
@ -942,41 +867,6 @@
|
|||
(on (message (list "x" $x))
|
||||
(printf "x = ~v\n" x)))))
|
||||
|
||||
(module+ test
|
||||
;; test that terminating facets can create new facets (at the parent level)
|
||||
(define stop-when-react
|
||||
'(
|
||||
(spawn (stop-when (message "stop")
|
||||
(react (on (message "poodle")
|
||||
(send! "success")
|
||||
(printf "woohoo\n")))))
|
||||
(spawn (on-start (send! "stop"))
|
||||
(on (asserted (observe "poodle"))
|
||||
(send! "poodle")))))
|
||||
(test-trace (trace (message "success"))
|
||||
stop-when-react)
|
||||
;; Reflects the current behavior, but quite possibly *not* what should happen
|
||||
(define create-new-facet-inside-on-stop
|
||||
'(
|
||||
(spawn
|
||||
(on-stop (react (assert (outbound "here"))))
|
||||
(stop-when (message "stop")))
|
||||
|
||||
(spawn (on-start (send! "stop")))))
|
||||
(test-trace (trace (assertion-added (outbound "here")))
|
||||
create-new-facet-inside-on-stop)
|
||||
;; Similarly dubious; create new facets from more nested facets
|
||||
(define facet-creation-during-stop-from-grandchild
|
||||
'(
|
||||
(spawn (on-start
|
||||
(react (on-stop
|
||||
(react (assert (outbound "inner"))))))
|
||||
(stop-when (message "stop")
|
||||
(react (assert (outbound "outer")))))
|
||||
|
||||
(spawn (on-start (send! "stop")))))
|
||||
(test-trace (trace (assertion-added (outbound "inner")))
|
||||
facet-creation-during-stop-from-grandchild))
|
||||
|
||||
(module+ test
|
||||
(define do-new-facets-run-immediately
|
||||
|
|
@ -988,31 +878,6 @@
|
|||
(check-false (run-with-trace (trace (message "I am here"))
|
||||
do-new-facets-run-immediately)))
|
||||
|
||||
(module+ test
|
||||
(define use-current-knowledge-with-new-facet
|
||||
'(
|
||||
(spawn (on (asserted "hello")
|
||||
(react (on (asserted "hello")
|
||||
(printf "do I run?\n")
|
||||
(send! "yes indeed")))))
|
||||
|
||||
(spawn (assert "hello"))))
|
||||
(test-trace (trace (message "yes indeed"))
|
||||
use-current-knowledge-with-new-facet)
|
||||
|
||||
(define maintain-knowledge-across-events
|
||||
'(
|
||||
(spawn (on (asserted "outer")
|
||||
(react (on (message "bam")
|
||||
(react (on (asserted "outer")
|
||||
(send! "icu")
|
||||
(printf "icu\n")))))))
|
||||
(spawn (assert "outer")
|
||||
(on (asserted (observe "bam"))
|
||||
(send! "bam")))))
|
||||
(test-trace (trace (message "icu"))
|
||||
maintain-knowledge-across-events))
|
||||
|
||||
(module+ test
|
||||
;; this should bring down the actor *but not* the entire program
|
||||
(define escaping-field
|
||||
|
|
@ -1024,14 +889,3 @@
|
|||
(check-false (run-with-trace (trace (message "success!"))
|
||||
escaping-field))
|
||||
(check-not-exn (lambda () (run escaping-field))))
|
||||
|
||||
(module+ test
|
||||
;; starting exceptions
|
||||
(define nested-spawn-exceptions
|
||||
'(
|
||||
(spawn (on (message "go")
|
||||
(spawn (on-start (/ 1 0)))
|
||||
(send! "lovely happiness")))
|
||||
(spawn (on-start (send! "go")))))
|
||||
(test-trace (trace (message "lovely happiness"))
|
||||
nested-spawn-exceptions))
|
||||
|
|
|
|||
|
|
@ -12,7 +12,8 @@
|
|||
(provide trace-actor
|
||||
spawn-monitor
|
||||
assertion-added
|
||||
assertion-removed)
|
||||
assertion-removed
|
||||
(for-syntax trace))
|
||||
|
||||
(module+ test
|
||||
(require rackunit))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "test.rkt")
|
||||
(require "actor-lang.rkt")
|
||||
|
||||
(provide (except-out (all-from-out "test.rkt") test-module-begin)
|
||||
(except-out (all-from-out "actor-lang.rkt") #%module-begin)
|
||||
(rename-out [test-module-begin #%module-begin]))
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
#lang racket
|
||||
|
||||
(provide test-module-begin
|
||||
(rename-out [illegal-trace trace]))
|
||||
|
||||
(module reader syntax/module-reader
|
||||
syndicate/test-lang)
|
||||
|
||||
(require racket/async-channel)
|
||||
(require racket/engine)
|
||||
|
||||
(require (prefix-in big: "actor-lang.rkt"))
|
||||
(require "monitor.rkt")
|
||||
(require "upside-down.rkt")
|
||||
(require (prefix-in little: (only-in "little-actors/core.rkt" run-with)))
|
||||
(require (for-syntax syntax/parse))
|
||||
(require rackunit)
|
||||
|
||||
(define-syntax (illegal-trace stx)
|
||||
(raise-syntax-error #f "trace: only allowed at top level of a test module" stx))
|
||||
|
||||
(begin-for-syntax
|
||||
(define (trace->actor+channel trace-stx)
|
||||
#`(let ([chan (make-async-channel)])
|
||||
(cons (trace-actor #,trace-stx
|
||||
(lambda () (async-channel-put chan #t)))
|
||||
chan))))
|
||||
|
||||
(define-syntax (test-module-begin stx)
|
||||
(define-syntax-class not-trace
|
||||
#:datum-literals (trace)
|
||||
(pattern (~and _:expr (~not _:trace))))
|
||||
(syntax-parse stx
|
||||
;; only allow one trace!
|
||||
[(_ (~or (~once t:trace)
|
||||
exps:expr)
|
||||
...)
|
||||
#'(#%module-begin
|
||||
;; do I need to worry about catching exceptions here?
|
||||
(define big-result (run-with-trace big:run-ground t (list (spawn-upside-down exps) ...)))
|
||||
(define little-result (run-with-trace little:run-with t '(exps ...)))
|
||||
(check-equal? big-result little-result)
|
||||
;; it would be nice to specify false-y traces, too
|
||||
(check-true big-result)
|
||||
(check-true little-result))]))
|
||||
|
||||
(define DEFAULT-FUEL 2000)
|
||||
|
||||
(define-syntax-rule (run-with-trace run-ground trc act-exps)
|
||||
(let ([chan (make-async-channel)])
|
||||
(test-harness run-ground
|
||||
chan
|
||||
(trace-actor trc (lambda () (async-channel-put chan #t)))
|
||||
act-exps
|
||||
DEFAULT-FUEL)))
|
||||
|
||||
(define (test-harness run-ground chan trace-act acts [timeout never-evt])
|
||||
(define syndicate-thread
|
||||
(thread (lambda ()
|
||||
(engine-run timeout
|
||||
(engine (lambda (x) (run-ground trace-act acts)))))))
|
||||
(define result
|
||||
(sync (handle-evt chan
|
||||
(lambda (val) #t))
|
||||
(handle-evt syndicate-thread
|
||||
(lambda (val)
|
||||
;; it's possible one of the final events in the
|
||||
;; dataspace resulted in an accepting trace and the
|
||||
;; thread ended at the same time, so the scheduler
|
||||
;; picked this event. Double check the channel for this
|
||||
;; case.
|
||||
(async-channel-try-get chan)))))
|
||||
(kill-thread syndicate-thread)
|
||||
result)
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
#lang syndicate/test
|
||||
|
||||
(spawn (field [balance 0])
|
||||
(assert (list "account" (balance)))
|
||||
(on (message (list "deposit" $amount))
|
||||
(balance (+ (balance) amount))))
|
||||
|
||||
(spawn (on (asserted (list "account" $balance))
|
||||
(printf "Balance changed to ~a\n" balance))
|
||||
(stop-when (asserted (list "account" 70))
|
||||
(printf "bye\n"))
|
||||
(on-stop (printf "good.\n")))
|
||||
|
||||
(spawn (stop-when (asserted (observe (list "deposit" _)))
|
||||
(send! (list "deposit" +100))
|
||||
(send! (list "deposit" -30))))
|
||||
|
||||
(trace (assertion-added '("account" 0))
|
||||
(and (assertion-added '("account" 100))
|
||||
(assertion-removed '("account" 0)))
|
||||
(and (assertion-added '("account" 70))
|
||||
(assertion-removed '("account" 100))))
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
#lang syndicate/actor
|
||||
|
||||
(dataspace
|
||||
|
||||
(spawn (on (message "hello")
|
||||
(printf "got hello\n")))
|
||||
|
||||
(spawn (assert "I am here")
|
||||
(on-start (printf "hello\n")
|
||||
(send! "hello"))))
|
||||
|
||||
#;(dataspace
|
||||
(send! 5))
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
#lang syndicate/test
|
||||
|
||||
;; Reflects the current behavior of the little implementation,
|
||||
;; but quite possibly *not* what should happen
|
||||
|
||||
(spawn
|
||||
(on-stop (react (assert (outbound "here"))))
|
||||
(stop-when (message "stop")))
|
||||
|
||||
(spawn (on-start (send! "stop")))
|
||||
|
||||
(trace (assertion-added (outbound "here")))
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
#lang syndicate/test
|
||||
|
||||
;; currently FAILS
|
||||
|
||||
;; dubious behavior by little implementation;
|
||||
;; create new facets from more nested facets
|
||||
|
||||
(spawn (on-start
|
||||
(react (on-stop
|
||||
(react (assert (outbound "inner"))))))
|
||||
(stop-when (message "stop")
|
||||
(react (assert (outbound "outer")))))
|
||||
|
||||
(spawn (on-start (send! "stop")))
|
||||
|
||||
(trace (assertion-added (outbound "inner")))
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
#lang syndicate/test
|
||||
|
||||
(spawn (on (asserted "outer")
|
||||
(react (on (message "bam")
|
||||
(react (on (asserted "outer")
|
||||
(send! "icu")
|
||||
(printf "icu\n")))))))
|
||||
|
||||
(spawn (assert "outer")
|
||||
(on (asserted (observe "bam"))
|
||||
(send! "bam")))
|
||||
|
||||
(trace (message "icu"))
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
#lang syndicate/test
|
||||
|
||||
;; currently failing, seemingly due to a bug in the big implementation; see
|
||||
;; https://github.com/tonyg/syndicate/issues/20
|
||||
|
||||
(dataspace
|
||||
(spawn (on (message "hello")
|
||||
(printf "got hello\n")))
|
||||
|
||||
(spawn (assert 12)
|
||||
(on-start (printf "hello\n")
|
||||
(send! (outbound "hello")))))
|
||||
|
||||
(trace (message "hello"))
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
#lang syndicate/test
|
||||
|
||||
(dataspace (spawn (on (asserted (inbound "gday"))
|
||||
(send! (outbound "good things")))))
|
||||
|
||||
(spawn (assert "gday"))
|
||||
|
||||
(trace (message "good things"))
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
#lang syndicate/test
|
||||
|
||||
(spawn (on (message "go")
|
||||
(spawn (on-start (/ 1 0)))
|
||||
(send! "lovely happiness")))
|
||||
|
||||
(spawn (on-start (send! "go")))
|
||||
|
||||
(trace (message "lovely happiness"))
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
#lang syndicate/test
|
||||
|
||||
(spawn (on (message "ping")
|
||||
(printf "ping\n")
|
||||
(send! "pong")))
|
||||
|
||||
(spawn (on (message "pong")
|
||||
(printf "pong\n")
|
||||
(send! "ping"))
|
||||
(on-start (send! "ping")))
|
||||
|
||||
(trace (message "ping")
|
||||
(message "pong")
|
||||
(message "ping")
|
||||
(message "pong")
|
||||
(message "ping")
|
||||
(message "pong")
|
||||
(message "ping")
|
||||
(message "pong"))
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
#lang syndicate/test
|
||||
|
||||
(spawn (on (asserted "hello")
|
||||
(printf "goodbye\n")))
|
||||
|
||||
(dataspace (spawn (assert (outbound "hello"))))
|
||||
|
||||
(trace (assertion-added "hello"))
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
#lang syndicate/test
|
||||
|
||||
(spawn (on (asserted 5)
|
||||
(printf "wat\n")))
|
||||
|
||||
(spawn (assert 5))
|
||||
|
||||
(trace (assertion-added (observe 5))
|
||||
(assertion-added 5))
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
#lang syndicate/test
|
||||
|
||||
;; test that terminating facets can create new facets (at the parent level)
|
||||
|
||||
(spawn (stop-when (message "stop")
|
||||
(react (on (message "poodle")
|
||||
(send! "success")
|
||||
(printf "woohoo\n")))))
|
||||
|
||||
(spawn (on-start (send! "stop"))
|
||||
(on (asserted (observe "poodle"))
|
||||
(send! "poodle")))
|
||||
|
||||
(trace (message "success"))
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
#lang syndicate/test
|
||||
|
||||
(spawn (on (asserted "hello")
|
||||
(react (on (asserted "hello")
|
||||
(printf "do I run?\n")
|
||||
(send! "yes indeed")))))
|
||||
|
||||
(spawn (assert "hello"))
|
||||
|
||||
(trace (message "yes indeed"))
|
||||
Loading…
Reference in New Issue