Extract raw dataspace test to separate file
This commit is contained in:
parent
2652147141
commit
f45323a097
|
@ -59,8 +59,6 @@
|
|||
(require racket/set)
|
||||
(require (only-in racket/exn exn->string))
|
||||
|
||||
(module+ test (require rackunit))
|
||||
|
||||
(require "skeleton.rkt")
|
||||
(require "pattern.rkt")
|
||||
(require "bag.rkt")
|
||||
|
@ -604,102 +602,3 @@
|
|||
(lambda () (apply raw-resume-parent results)))))
|
||||
(proc resume-parent))))
|
||||
prompt-tag))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(module+ test
|
||||
(message-struct set-box (new-value))
|
||||
(assertion-struct box-state (value))
|
||||
|
||||
(define ds
|
||||
(make-dataspace
|
||||
(lambda ()
|
||||
(schedule-script!
|
||||
(current-actor)
|
||||
(lambda ()
|
||||
(spawn!
|
||||
(current-actor)
|
||||
'box
|
||||
(lambda ()
|
||||
(define current-value (field-handle 'current-value
|
||||
(generate-id! (actor-dataspace (current-actor)))
|
||||
(current-actor)
|
||||
0))
|
||||
(add-endpoint! (current-facet)
|
||||
'stop-when-ten
|
||||
(lambda ()
|
||||
(when (= (current-value) 10)
|
||||
(stop-facet! (current-facet)
|
||||
(lambda ()
|
||||
(log-info "box: terminating"))))
|
||||
(void))
|
||||
#f)
|
||||
(add-endpoint! (current-facet)
|
||||
'assert-box-state
|
||||
(lambda () (box-state (current-value)))
|
||||
#f)
|
||||
(add-endpoint! (current-facet)
|
||||
'on-message-set-box
|
||||
(lambda () (observe (set-box (capture (discard)))))
|
||||
(skeleton-interest (list struct:set-box #f)
|
||||
'()
|
||||
'()
|
||||
'((0 0))
|
||||
(capture-facet-context
|
||||
(lambda (op new-value)
|
||||
(when (eq? '! op)
|
||||
(schedule-script!
|
||||
(current-actor)
|
||||
(lambda ()
|
||||
(log-info "box: taking on new-value ~v" new-value)
|
||||
(current-value new-value))))))
|
||||
#f)))
|
||||
(set))
|
||||
(spawn!
|
||||
(current-actor)
|
||||
'client
|
||||
(lambda ()
|
||||
(add-endpoint! (current-facet)
|
||||
'stop-when-retracted-observe-set-box
|
||||
(lambda () (observe (observe (set-box (discard)))))
|
||||
(skeleton-interest (list struct:observe (list struct:set-box #f))
|
||||
'()
|
||||
'()
|
||||
'()
|
||||
(capture-facet-context
|
||||
(lambda (op)
|
||||
(when (eq? '- op)
|
||||
(stop-facet!
|
||||
(current-facet)
|
||||
(lambda ()
|
||||
(log-info "client: box has gone"))))))
|
||||
#f))
|
||||
(add-endpoint! (current-facet)
|
||||
'on-asserted-box-state
|
||||
(lambda () (observe (box-state (capture (discard)))))
|
||||
(skeleton-interest (list struct:box-state #f)
|
||||
'()
|
||||
'()
|
||||
'((0 0))
|
||||
(capture-facet-context
|
||||
(lambda (op v)
|
||||
(when (eq? '+ op)
|
||||
(schedule-script!
|
||||
(current-actor)
|
||||
(lambda ()
|
||||
(log-info "client: learned that box's value is now ~v" v)
|
||||
(enqueue-send! (current-actor)
|
||||
(set-box (+ v 1))))))))
|
||||
#f)))
|
||||
(set)))))))
|
||||
|
||||
(require racket/pretty)
|
||||
;; (pretty-print ds)
|
||||
(#;time values
|
||||
(let loop ((i 0))
|
||||
;; (printf "--- i = ~v\n" i)
|
||||
(when (run-scripts! ds)
|
||||
;; (pretty-print ds)
|
||||
(loop (+ i 1)))))
|
||||
;; (pretty-print ds)
|
||||
)
|
||||
|
|
|
@ -0,0 +1,99 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/set)
|
||||
(require "../test-implementation.rkt")
|
||||
(require "../main.rkt")
|
||||
(require "../pattern.rkt")
|
||||
(require "../skeleton.rkt")
|
||||
|
||||
(test-case
|
||||
[(message-struct set-box (new-value))
|
||||
(assertion-struct box-state (value))
|
||||
|
||||
(spawn!
|
||||
(current-actor)
|
||||
'box
|
||||
(lambda ()
|
||||
(define current-value (field-handle 'current-value
|
||||
(generate-id! (actor-dataspace (current-actor)))
|
||||
(current-actor)
|
||||
0))
|
||||
(add-endpoint! (current-facet)
|
||||
'stop-when-ten
|
||||
(lambda ()
|
||||
(when (= (current-value) 3)
|
||||
(stop-facet! (current-facet)
|
||||
(lambda ()
|
||||
(printf "box: terminating\n"))))
|
||||
(void))
|
||||
#f)
|
||||
(add-endpoint! (current-facet)
|
||||
'assert-box-state
|
||||
(lambda () (box-state (current-value)))
|
||||
#f)
|
||||
(add-endpoint! (current-facet)
|
||||
'on-message-set-box
|
||||
(lambda () (observe (set-box (capture (discard)))))
|
||||
(skeleton-interest (list struct:set-box #f)
|
||||
'()
|
||||
'()
|
||||
'((0 0))
|
||||
(capture-facet-context
|
||||
(lambda (op new-value)
|
||||
(when (eq? '! op)
|
||||
(schedule-script!
|
||||
(current-actor)
|
||||
(lambda ()
|
||||
(printf "box: taking on new-value ~v\n" new-value)
|
||||
(current-value new-value))))))
|
||||
#f)))
|
||||
(set))
|
||||
|
||||
(spawn!
|
||||
(current-actor)
|
||||
'client
|
||||
(lambda ()
|
||||
(add-endpoint! (current-facet)
|
||||
'stop-when-retracted-observe-set-box
|
||||
(lambda () (observe (observe (set-box (discard)))))
|
||||
(skeleton-interest (list struct:observe (list struct:set-box #f))
|
||||
'()
|
||||
'()
|
||||
'()
|
||||
(capture-facet-context
|
||||
(lambda (op)
|
||||
(when (eq? '- op)
|
||||
(stop-facet!
|
||||
(current-facet)
|
||||
(lambda ()
|
||||
(printf "client: box has gone\n"))))))
|
||||
#f))
|
||||
(add-endpoint! (current-facet)
|
||||
'on-asserted-box-state
|
||||
(lambda () (observe (box-state (capture (discard)))))
|
||||
(skeleton-interest (list struct:box-state #f)
|
||||
'()
|
||||
'()
|
||||
'((0 0))
|
||||
(capture-facet-context
|
||||
(lambda (op v)
|
||||
(when (eq? '+ op)
|
||||
(schedule-script!
|
||||
(current-actor)
|
||||
(lambda ()
|
||||
(printf
|
||||
"client: learned that box's value is now ~v\n"
|
||||
v)
|
||||
(enqueue-send! (current-actor)
|
||||
(set-box (+ v 1))))))))
|
||||
#f)))
|
||||
(set))]
|
||||
no-crashes
|
||||
(expected-output "client: learned that box's value is now 0"
|
||||
"box: taking on new-value 1"
|
||||
"client: learned that box's value is now 1"
|
||||
"box: taking on new-value 2"
|
||||
"client: learned that box's value is now 2"
|
||||
"box: taking on new-value 3"
|
||||
"box: terminating"
|
||||
"client: box has gone"))
|
Loading…
Reference in New Issue