X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fsystems%2Factors.scm;h=eed3930679566bf0531ddbbd353869f132248f27;hp=84a5c2e3c178f168d39b981f90be4ff2b3b609f3;hb=e767393260e8fd96d8abd71042b6b051b95e5b13;hpb=711168a756750d8e8236c8549d8617c10ddcda58 diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm index 84a5c2e..eed3930 100644 --- a/8sync/systems/actors.scm +++ b/8sync/systems/actors.scm @@ -22,6 +22,7 @@ #: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) @@ -36,6 +37,8 @@ actor-id actor-message-handler + %current-actor + ;;; Commenting out the
type for now; ;;; it may be back when we have better serializers ;;
@@ -47,7 +50,8 @@ actor-id-hive actor-id-string - simple-dispatcher build-actions make-action-dispatch + build-actions + define-simple-actor @@ -225,6 +229,29 @@ ;;; 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 () ;; An address object (id #:init-keyword #:id @@ -234,7 +261,15 @@ (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 )) (slot-ref actor 'message-handler)) @@ -281,68 +316,26 @@ "Render the full actor id as a human-readable string" (address->string (actor-id actor))) +(define %current-actor + (make-parameter #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 () - (message-handler - #:init-value (make-action-dispatch actions ...) - #:allocation #:each-subclass))) + (actions #:init-value (build-actions action ...) + #:allocation #:each-subclass))) ;;; The Hive @@ -373,12 +366,12 @@ more compact following syntax: ;; 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 ) message) "Handle an ambassador failing to forward a message" @@ -510,13 +503,14 @@ more compact following syntax: (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