;;; 8sync --- Asynchronous programming for Guile
-;;; Copyright (C) 2016 Christopher Allan Webber <cwebber@dustycloud.org>
+;;; Copyright © 2016, 2017 Christopher Allan Webber <cwebber@dustycloud.org>
;;;
;;; This file is part of 8sync.
;;;
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (8sync agenda)
+ #:use-module (8sync rmeta-slot)
#:export (;; utilities... ought to go in their own module
big-random-number
big-random-number-string
(define (<-reply original-message . message-body-args)
"Reply to a message"
- (send-message '() (%current-actor) (message-from original-message) '*reply*
- original-message #f message-body-args))
+ (when (message-needs-reply? original-message)
+ (send-message '() (%current-actor) (message-from original-message) '*reply*
+ original-message #f message-body-args)))
(define (<-reply* send-options original-message . message-body-args)
"Like <-reply, but allows extra parameters via send-options"
(send-message send-options actor
(message-from original-message) '*reply*
original-message #f message-body-args))
- (apply really-send send-options))
+ (when (message-needs-reply? original-message)
+ (apply really-send send-options)))
(define (<-auto-reply actor original-message)
"Auto-reply to a message. Internal use only!"
(define (<-reply-wait original-message . message-body-args)
"Reply to a messsage, but wait until we get a response"
- (wait-maybe-handle-errors
- (send-message '() (%current-actor)
- (message-from original-message) '*reply*
- original-message #t message-body-args)))
+ (if (message-needs-reply? original-message)
+ (wait-maybe-handle-errors
+ (send-message '() (%current-actor)
+ (message-from original-message) '*reply*
+ original-message #t message-body-args))
+ #f))
(define (<-reply-wait* send-options original-message
. message-body-args)
(message-from original-message) '*reply*
original-message #t message-body-args)
send-options))
- (apply really-send send-options))
+ (when (message-needs-reply? original-message)
+ (apply really-send send-options)))
(define* (wait-maybe-handle-errors message
#:key accept-errors
(define (actor-inheritable-message-handler actor message)
(define action (message-action message))
- (define (find-message-handler return)
- (for-each (lambda (this-class)
- (define actions
- (or (and (class-slot-definition this-class 'actions)
- (class-slot-ref this-class 'actions))
- '()))
- (for-each (match-lambda
- ((action-name . method)
- (when (eq? action-name action)
- (return method))))
- actions))
- (class-precedence-list (class-of actor)))
+ (define method
+ (class-rmeta-ref (class-of actor) 'actions action
+ #:equals? eq? #:cache-set! hashq-set!
+ #:cache-ref hashq-ref))
+ (unless method
(throw 'action-not-found
"No appropriate action handler found for actor"
#:action action
#:actor actor
#:message message))
- (define method
- (call/ec find-message-handler))
(apply method actor message (message-body message)))
(define-syntax-rule (build-actions (symbol method) ...)
"Construct an alist of (symbol . method), where the method is wrapped
with wrap-apply to facilitate live hacking and allow the method definition
to come after class definition."
- (list
- (cons (quote symbol)
- (wrap-apply method)) ...))
+ (build-rmeta-slot
+ (list (cons (quote symbol)
+ (wrap-apply method)) ...)))
(define-class <actor> ()
;; An address object
#:allocation #:each-subclass
#:getter actor-message-handler)
+ ;; valid values are:
+ ;; - #t as in, send the init message, but don't wait (default)
+ ;; - 'wait, as in wait on the init message
+ ;; - #f as in don't bother to init
+ (should-init #:init-value #t
+ #:allocation #:each-subclass)
+
;; This is the default, "simple" way to inherit and process messages.
- (actions #:init-value (build-actions
+ (actions #:init-thunk (build-actions
;; Default init method is to do nothing.
(*init* (const #f))
;; Default cleanup method is to do nothing.
(action ...)
slots ...)
(define-class class inherits
- (actions #:init-value (build-actions action ...)
+ (actions #:init-thunk (build-actions action ...)
#:allocation #:each-subclass)
slots ...))
(prompt #:init-thunk make-prompt-tag
#:getter hive-prompt)
(actions #:allocation #:each-subclass
- #:init-value
+ #:init-thunk
(build-actions
;; This is in the case of an ambassador failing to forward a
;; message... it reports it back to the hive
(hash-map->list (lambda (actor-id actor) actor-id)
(hive-actor-registry hive)))
(for-each (lambda (actor-id)
- ;; @@: This could maybe just be <-, but we want actors
- ;; to be used to the expectation in all circumstances
- ;; that their init method is "waited on".
- (<-wait actor-id '*init*))
+ (let* ((actor (hash-ref (hive-actor-registry hive)
+ actor-id)))
+ (match (slot-ref actor 'should-init)
+ (#f #f)
+ ('wait
+ (<-wait actor-id '*init*))
+ (_
+ (<- actor-id '*init*)))))
actor-ids))
(define-method (hive-handle-failed-forward (hive <hive>) message)
(actor (apply make actor-class
#:hive hive
#:id actor-id
- init-args)))
+ init-args))
+ (actor-should-init (slot-ref actor 'should-init)))
(hive-register-actor! hive actor)
- ;; Wait on actor to init
- (when send-init?
- (<-wait actor-id '*init*))
+ ;; Maybe run actor init method
+ (when (and send-init? actor-should-init)
+ (let ((send-method
+ (if (eq? actor-should-init 'wait)
+ <-wait <-)))
+ (send-method actor-id '*init*)))
;; return the actor id
actor-id))