#:use-module (oop goops)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
+ #:use-module (ice-9 control)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
actor-id
actor-message-handler
+ %current-actor
+
;;; Commenting out the <address> type for now;
;;; it may be back when we have better serializers
;; <address>
actor-id-hive
actor-id-string
- simple-dispatcher build-actions make-action-dispatch
+ build-actions
+
define-simple-actor
<hive>
;;; Main actor implementation
;;; =========================
+(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)))
+ (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-class <actor> ()
;; An address object
(id #:init-keyword #:id
(hive #:init-keyword #:hive
#:accessor actor-hive)
;; How we receive and process new messages
- (message-handler #:allocation #:each-subclass))
+ (message-handler #:init-value actor-inheritable-message-handler
+ ;; @@: There's no reason not to use #:class instead of
+ ;; #:each-subclass anywhere in this file, except for
+ ;; Guile bug #25211 (#:class is broken in Guile 2.2)
+ #:allocation #:each-subclass)
+
+ ;; This is the default, "simple" way to inherit and process messages.
+ (actions #:init-value '()
+ #:allocation #:each-subclass))
(define-method (actor-message-handler (actor <actor>))
(slot-ref actor 'message-handler))
"Render the full actor id as a human-readable string"
(address->string (actor-id actor)))
+(define %current-actor
+ (make-parameter #f))
+
\f
;;; Actor utilities
;;; ===============
-(define (simple-dispatcher action-map)
- (lambda (actor message)
- (let* ((action (message-action message))
- (method (assoc-ref action-map action)))
- (if (not method)
- ;; @@: There's every possibility this should be handled in
- ;; hive-process-message instead.
- (throw 'action-not-found
- "No appropriate action handler found for actor"
- #:action action
- #:actor actor
- #:message message
- #:available-actions (map car action-map)))
- (apply method actor message (message-body message)))))
-
-(define-syntax %expand-action-item
- (syntax-rules ()
- ((_ (action-name handler))
- (cons (quote action-name) handler))))
-
-(define-syntax-rule (build-actions action-item ...)
- "Build a mapping of actions. Same syntax as make-action-dispatch
-but this doesn't build the dispatcher for you (you probably want to
-pass it to simple-dispatcher).
-
-The advantage here is that since this simply builds an alist, you can
-compose it with other action maps."
- (list (%expand-action-item action-item) ...))
-
-(define-syntax make-action-dispatch
- (syntax-rules ()
- "Expand a list of action names and actions into an alist
-
-You can use this like the following:
- (make-action-dispatch
- (cookies
- (lambda (actor message)
- (display \"I love cookies!\n\")))
- (party
- (lambda (actor message)
- (display \"Life of the party!\"))))
-
-Alternately, if you'd like to skip the lambda, you could use the slightly
-more compact following syntax:
- (make-action-dispatch
- ((cookies actor message)
- (display \"I love cookies!\n\"))
- ((party actor message)
- (display \"Life of the party!\")))"
- ((make-action-dispatch action-item ...)
- (simple-dispatcher (build-actions action-item ...)))))
-
-(define-syntax-rule (define-simple-actor class actions ...)
+(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)) ...))
+
+(define-syntax-rule (define-simple-actor class action ...)
(define-class class (<actor>)
- (message-handler
- #:init-value (make-action-dispatch actions ...)
- #:allocation #:each-subclass)))
+ (actions #:init-value (build-actions action ...)
+ #:allocation #:each-subclass)))
\f
;;; The Hive
;; to send the message, then carry on their way
(prompt #:init-thunk make-prompt-tag
#:getter hive-prompt)
- (message-handler
- #:init-value
- (make-action-dispatch
- ;; This is in the case of an ambassador failing to forward a message...
- ;; it reports it back to the hive
- (*failed-forward* hive-handle-failed-forward))))
+ (actions #:allocation #:each-subclass
+ #:init-value
+ (build-actions
+ ;; This is in the case of an ambassador failing to forward a
+ ;; message... it reports it back to the hive
+ (*failed-forward* hive-handle-failed-forward))))
(define-method (hive-handle-failed-forward (hive <hive>) message)
"Handle an ambassador failing to forward a message"
(lambda ()
(define message-handler (actor-message-handler actor))
;; @@: Should a more general error handling happen here?
- (let ((result
- (message-handler actor message)))
- (maybe-autoreply actor)
- ;; Returning result allows actors to possibly make a run-request
- ;; at the end of handling a message.
- ;; ... We do want that, right?
- result)))))
+ (parameterize ((%current-actor actor))
+ (let ((result
+ (message-handler actor message)))
+ (maybe-autoreply actor)
+ ;; Returning result allows actors to possibly make a run-request
+ ;; at the end of handling a message.
+ ;; ... We do want that, right?
+ result))))))
(define (resume-waiting-coroutine)
(cond
projects / 8sync.git / blobdiff