diff --git a/syndicate/actor.rkt b/syndicate/actor.rkt index fbfe694..9a090a1 100644 --- a/syndicate/actor.rkt +++ b/syndicate/actor.rkt @@ -62,7 +62,8 @@ (module+ internals (provide make-actor - actor-terminate!)) + actor-terminate! + with-active-facet)) (require (only-in preserves preserve=?)) (require racket/match) diff --git a/syndicate/async.rkt b/syndicate/async.rkt new file mode 100644 index 0000000..34ca244 --- /dev/null +++ b/syndicate/async.rkt @@ -0,0 +1,74 @@ +#lang syndicate +;;; SPDX-License-Identifier: LGPL-3.0-or-later +;;; SPDX-FileCopyrightText: Copyright © 2022 Tony Garnock-Jones + +(provide async + async? + suspend + await) + +(require (only-in (submod "actor.rkt" internals) with-active-facet)) + +(define prompt-tag (make-continuation-prompt-tag 'syndicate)) + +(define-syntax-rule (async body ...) + (async* (lambda () body ...))) + +(define (async* thunk) + (call-with-continuation-prompt thunk prompt-tag)) + +(define (async?) + (continuation-prompt-available? prompt-tag)) + +(define (capture-chain proc) + (call-with-composable-continuation + (lambda (k) + (let ((k (lambda results + (async* (lambda () (apply k results)))))) + (abort-current-continuation prompt-tag (lambda () (proc k))))) + prompt-tag)) + +(define (suspend proc) + (unless (async?) (error 'suspend "Cannot suspend async chain outside async block")) + (define facet this-facet) + (capture-chain + (lambda (k) + (proc (lambda results + (with-active-facet facet + (lambda () + (apply k results)))))))) + +(define-syntax-rule (await k body ...) + (suspend (lambda (k) + (react + (define facet this-facet) + (let ((k (lambda results (stop-facet facet (apply k results))))) + body ...))))) + +(module+ test + (require "dataspace.rkt") + (actor-system/dataspace (ds) + (spawn + #:name 'service + (at ds + (during 'waiting + (assert 'ready) + (on-stop (stop-current-facet))))) + (at ds + (define (D x) (log-info "~v ~a" this-facet x)) + (on-start (D "outer+")) + (on-stop (D "outer-")) + (async (D "1") + (await k (D "@") (k (void))) + (D "2") + (await k + (on-start (D "A1+")) + (on-stop (D "A1-")) + (assert 'waiting) + (on (asserted 'ready) + (D "A2") + (k (void)))) + (D "3") + (await k (D "B") (k (void))) + (D "4") + (stop-current-facet)))))