diff --git a/minimart/actor.rkt b/minimart/actor.rkt new file mode 100644 index 0000000..7b22edf --- /dev/null +++ b/minimart/actor.rkt @@ -0,0 +1,459 @@ +#lang racket/base + +(provide actor + observe-subscribers + observe-advertisers + advertise + subscribe + for/advertise + for/subscribe + define-transition + begin-transition) + +;; (require (for-syntax racket/pretty)) +;; (require (for-syntax racket/trace)) + +(require racket/set) +(require racket/match) + +(require (for-syntax racket/match)) +(require (for-syntax racket/list)) +(require (for-syntax racket/base)) +(require (for-syntax syntax/stx)) + +(require (for-syntax racket/stxparam)) +(require racket/stxparam) + +;; (require (for-syntax syntax/parse)) + +(require "core.rkt") +(require "gestalt.rkt") + +(define-syntax (actor stx) + (syntax-case stx () + [(_ forms ...) + (analyze-actor #f '() '() '() '() '() '() #'(forms ...))])) + +(define-syntax (observe-subscribers stx) (raise-syntax-error #f "Use of observe-subscribers outside actor form" stx)) +(define-syntax (observe-advertisers stx) (raise-syntax-error #f "Use of observe-advertisers outside actor form" stx)) +(define-syntax (advertise stx) (raise-syntax-error #f "Use of advertise outside actor form" stx)) +(define-syntax (subscribe stx) (raise-syntax-error #f "Use of subscribe outside actor form" stx)) +(define-syntax (for/advertise stx) (raise-syntax-error #f "Use of for/advertise outside actor form" stx)) +(define-syntax (for/subscribe stx) (raise-syntax-error #f "Use of for/subscribe outside actor form" stx)) + +(define-syntax-parameter update-state-struct #f) +(define-syntax-parameter match-state #f) +(define-syntax-parameter compute-gestalt #f) + +(define-syntax-rule (define-transition head tail ...) + (define head (begin-transition tail ...))) + +(define-syntax (begin-transition stx) + (syntax-case stx () + [(_ forms ...) + (let () + (define result (accumulate-actions (gensym 'begin-transition) '() '() #'(forms ...))) + ;; (pretty-print `(result ,(syntax->datum result))) + result)])) + +(begin-for-syntax + (struct observer (condition level meta-level presence-name set-name set-exp added-name removed-name) #:transparent) + (struct participator (condition meta-level) #:transparent) + + (define (defbinding name-stx init-name-stx init-exp) + (list #`(define #,init-name-stx #,init-exp) + #`(define-syntax-parameter #,name-stx (syntax-id-rules () [_ #,init-name-stx])))) + + (define (analyze-actor actor-name + states + gestalt-observers + gestalt-computers + message-handlers + action-ids + body-forms + forms-stx) + + (define-syntax-rule (analyze-body* body-stx struct-type o [keyword accessor fieldname] ...) + (syntax-case body-stx () + [(keyword v rest (... ...)) + (if (accessor o) + (raise-syntax-error #f (format "duplicate ~a clause" 'keyword) body-stx) + (analyze-observer-body #'(rest (... ...)) (struct-copy struct-type o [fieldname #'v])))] + ... + [other (values o #'other)])) + + (define (analyze-observer-body body-stx o) + (analyze-body* body-stx observer o + [#:when observer-condition condition] + [#:level observer-level level] + [#:meta-level observer-meta-level meta-level] + [#:presence observer-presence-name presence-name] + [#:name observer-set-name set-name] + [#:set observer-set-exp set-exp] + [#:added observer-added-name added-name] + [#:removed observer-removed-name removed-name])) + + (define (analyze-participator-body body-stx p) + (analyze-body* body-stx participator p + [#:when participator-condition condition] + [#:meta-level participator-meta-level meta-level])) + + (define (analyze-pattern pat-stx) + (syntax-case pat-stx ($ quasiquote unquote quote) + ;; Extremely limited support for quasiquoting and quoting + [(quasiquote (unquote p)) (analyze-pattern #'p)] + [(quasiquote (p ...)) (analyze-pattern #'(list (quasiquote p) ...))] + [(quasiquote p) (values #''p #''p #''p '())] + [(quote p) (values #''p #''p #''p '())] + + [($ v) + (values #'(?!) + #'? + #'v + (list #'v))] + [($ v p) + (let () + (define-values (pr g m bs) (analyze-pattern #'p)) + (when (not (null? bs)) (raise-syntax-error #f "nested bindings not supported" pat-stx)) + (values #`(?! #,pr) + g + #`(and v #,m) + (list #'v)))] + [(ctor p ...) + (let () + (define parts (if (identifier? #'ctor) #'(p ...) #'(ctor p ...))) + (define-values (pr g m bs) + (for/fold [(pr '()) (g '()) (m '()) (bs '())] [(p (syntax->list parts))] + (define-values (pr1 g1 m1 bs1) (analyze-pattern p)) + (values (cons pr1 pr) + (cons g1 g) + (cons m1 m) + (append bs1 bs)))) + (if (identifier? #'ctor) + (values (cons #'ctor (reverse pr)) + (cons #'ctor (reverse g)) + (cons #'ctor (reverse m)) + bs) + (values (reverse pr) + (reverse g) + (reverse m) + bs)))] + [non-pair + (if (and (identifier? #'non-pair) + (free-identifier=? #'non-pair #'?)) + (values #'? + #'? + #'_ + '()) + (values #'non-pair + #'non-pair + #'(== non-pair) + '()))])) + ;; (trace analyze-pattern) + + (define (analyze-observation pat-stx body-stx pub? forms-stx) + (define-values (o remaining-stx) (analyze-observer-body body-stx (observer #f #f #f #f #f #f #f #f))) + (match-define (observer condition level meta-level presence-name set-name set-exp added-name removed-name) o) + (when (and (not set-name) (or set-exp added-name removed-name)) + (define stx (or set-exp added-name removed-name)) + (raise-syntax-error #f "#:name is required when using #:set, #:added and/or #:removed" stx)) + (match-define (list presence-init set-init projector-name gestalt-name set-temp) + (generate-temporaries (list presence-name set-name pat-stx pat-stx set-name))) + (define-values (projector-stx gestalt-stx matcher-stx binders) (analyze-pattern pat-stx)) + (analyze-actor actor-name + (append (if presence-name (list (list presence-name presence-init)) '()) + (if set-name (list (list set-name set-init)) '()) + states) + (append (if presence-name + (list (lambda (g-stx) + #`(#:update [#,presence-name + (not (gestalt-empty? (gestalt-filter #,g-stx #,gestalt-name)))]))) + '()) + (if (or set-name added-name removed-name) + (list (lambda (g-stx) + #`((define #,set-temp + #,(if set-exp + #`(for/set [(e (in-set + (gestalt-project/keys #,g-stx #,projector-name)))] + (match-define (list #,@binders) e) + #,set-exp) + #`(gestalt-project/keys #,g-stx #,projector-name))) + #,@(if added-name + #`((define #,added-name (set-subtract #,set-temp #,set-name))) + #'()) + #,@(if removed-name + #`((define #,removed-name (set-subtract #,set-name #,set-temp))) + #'()) + #,@(if set-name + #`(#:update [#,set-name #,set-temp]) + #'())))) + '()) + (list (lambda (g-stx) remaining-stx)) + gestalt-observers) + (append (if condition + (list #`(if #,condition #,gestalt-name (gestalt-empty))) + (list gestalt-name)) + gestalt-computers) + message-handlers + action-ids + (cons #`(begin + #,@(if presence-name (defbinding presence-name presence-init #'#f) #'()) + #,@(if set-name (defbinding set-name set-init #'(set)) #'()) + (define #,projector-name (#,(if pub? #'project-subs #'project-pubs) #,projector-stx + #:level #,(or level 0) #:meta-level #,(or meta-level 0))) + (define #,gestalt-name (projection->gestalt #,projector-name))) + body-forms) + forms-stx)) + + (define (analyze-participation pat-stx body-stx pub? forms-stx) + (define-values (p remaining-stx) (analyze-participator-body body-stx (participator #f #f))) + (match-define (participator condition meta-level) p) + (match-define (list gestalt-name) (generate-temporaries (list pat-stx))) + (define-values (projector-stx gestalt-stx matcher-stx binders) (analyze-pattern pat-stx)) + (analyze-actor actor-name + states + gestalt-observers + (append (if condition + (list #`(if #,condition #,gestalt-name (gestalt-empty))) + (list gestalt-name)) + gestalt-computers) + (append (list (lambda (e-stx) + #`[(message #,matcher-stx (== #,(or meta-level 0)) #,pub?) + (begin-transition #,@remaining-stx)])) + message-handlers) + action-ids + (cons #`(define #,gestalt-name (#,(if pub? #'pub #'sub) #,gestalt-stx + #:meta-level #,(or meta-level 0))) + body-forms) + forms-stx)) + + (define (analyze-group-participation loopspecs-stx pat-stx body-stx pub? forms-stx) + (define-values (p remaining-stx) (analyze-participator-body body-stx (participator #f #f))) + (match-define (participator condition meta-level) p) + (match-define (list projector-name gestalt-name) (generate-temporaries (list pat-stx pat-stx))) + (define-values (projector-stx gestalt-stx matcher-stx binders) (analyze-pattern pat-stx)) + (unless (stx-null? remaining-stx) + (raise-syntax-error #f "for/advertise and for/subscribe cannot currently install message handlers")) + (analyze-actor actor-name + states + gestalt-observers + (append (list #`(gestalt-union* (for/list #,loopspecs-stx + #,@(if condition + #`(#:when #,condition) + #'()) + (#,(if pub? #'pub #'sub) #,gestalt-stx + #:meta-level #,meta-level)))) + gestalt-computers) + message-handlers + action-ids + body-forms + forms-stx)) + + (define (accumulate-action action-stx forms-stx) + (define temp (car (generate-temporaries (list action-stx)))) + (analyze-actor actor-name + states + gestalt-observers + gestalt-computers + message-handlers + (cons temp action-ids) + (cons #`(define #,temp #,action-stx) body-forms) + forms-stx)) + + (syntax-case forms-stx (observe-subscribers + observe-advertisers + advertise + subscribe + for/advertise + for/subscribe) + [() + (let ((actor-name (or actor-name #'anonymous-actor))) + (define state-struct-name + (datum->syntax actor-name (string->symbol (format "~a-state" (syntax->datum actor-name))))) + (match-define (list e-stx state-stx g-stx compute-gestalt-stx) + (generate-temporaries (list #'event #'state #'gestalt #'compute-gestalt))) + (define statevars (map car states)) + (define stateinits (map cadr states)) + (define result + #`(let () + (struct #,state-struct-name (#,@statevars) #:prefab) + #,@(reverse body-forms) + (syntax-parameterize + ((update-state-struct (syntax-rules () [(_ v [n e] (... ...)) + (struct-copy #,state-struct-name v [n e] (... ...))])) + (match-state (syntax-rules () [(_ id body (... ...)) + (match-lambda + [(and id (struct #,state-struct-name (#,@stateinits))) + (syntax-parameterize (#,@(for/list ([sv statevars] [si stateinits]) + #`(#,sv (syntax-id-rules () [_ #,si])))) + body (... ...))])])) + (compute-gestalt (syntax-rules () [(_ state) (#,compute-gestalt-stx state)]))) + (let ((#,compute-gestalt-stx (match-state #,state-stx + (gestalt-union #,@gestalt-computers))) + (#,state-stx (#,state-struct-name #,@statevars))) + (spawn #:boot (begin-transition #,@(reverse action-ids)) + (procedure-rename + (lambda (#,e-stx #,state-stx) + ((match-state #,state-stx + ((match #,e-stx + [(routing-update #,g-stx) + (begin-transition + #,@(append-map (lambda (p) (syntax->list (p g-stx))) gestalt-observers))] + #,@(map (lambda (p) (p e-stx)) message-handlers) + [_ (lambda (state) #f)]) + #,state-stx)) + #,state-stx)) + '#,actor-name) + #,state-stx + (#,compute-gestalt-stx #,state-stx)))))) + ;; (pretty-print `(result ,(syntax->datum result))) + result)] + + [(#:name name rest ...) ;; TODO: named processes + (let () + (when actor-name (raise-syntax-error #f "duplicate actor #:name" forms-stx)) + (unless (identifier? #'name) (raise-syntax-error #f "actor #:name must be an identifier" #'name)) + (analyze-actor #'name states gestalt-observers gestalt-computers message-handlers action-ids body-forms #'(rest ...)))] + + [(#:arguments [arg ...] rest ...) ;; TODO arguments + (analyze-actor actor-name states gestalt-observers gestalt-computers message-handlers action-ids body-forms #'(rest ...))] + + [(#:state [statevar stateexp] rest ...) + (let () + (match-define (list stateinit) (generate-temporaries (list #'statevar))) + (analyze-actor actor-name + (cons (list #'statevar stateinit) states) + gestalt-observers + gestalt-computers + message-handlers + action-ids + (append (defbinding #'statevar stateinit #'stateexp) body-forms) + #'(rest ...)))] + + [((observe-subscribers pat body ...) rest ...) + (analyze-observation #'pat #'(body ...) #t #'(rest ...))] + + [((observe-advertisers pat body ...) rest ...) + (analyze-observation #'pat #'(body ...) #f #'(rest ...))] + + [((advertise pat body ...) rest ...) + (analyze-participation #'pat #'(body ...) #t #'(rest ...))] + + [((subscribe pat body ...) rest ...) + (analyze-participation #'pat #'(body ...) #f #'(rest ...))] + + [((for/advertise [loopspec ...] pat body ...) rest ...) + (analyze-group-participation #'(loopspec ...) #'pat #'(body ...) #t #'(rest ...))] + + [((for/subscribe [loopspec ...] pat body ...) rest ...) + (analyze-group-participation #'(loopspec ...) #'pat #'(body ...) #f #'(rest ...))] + + [(expr rest ...) + (syntax-case (expand-in-context (gensym 'actor-initialization) #'expr) () + [(head inner-rest ...) + (if (or (free-identifier=? #'head #'begin) + (free-identifier=? #'head #'begin-transition)) + (analyze-actor actor-name + states + gestalt-observers + gestalt-computers + message-handlers + action-ids + body-forms + #'(inner-rest ... rest ...)) + (if (ormap (lambda (i) (free-identifier=? #'head i)) + (syntax->list #'(define-values define-syntaxes begin-for-syntax + module module* + #%module-begin + #%require #%provide))) + (analyze-actor actor-name + states + gestalt-observers + gestalt-computers + message-handlers + action-ids + (cons #'expr body-forms) + #'(rest ...)) + (accumulate-action #'expr #'(rest ...))))] + [non-pair-syntax (accumulate-action #'expr #'(rest ...))])])) + + (define (expand-in-context context-id stx) + (local-expand stx + (list context-id) + (syntax->list #'(quote quote-syntax lambda case-lambda let-values letrec-values + begin begin0 set! with-continuation-mark if #%app #%expression + define-values define-syntaxes begin-for-syntax #%require #%provide + #%variable-reference)))) + + (define (accumulate-actions context-id action-ids final-forms forms) + (syntax-case forms () + [() + #`(match-state state + #,@(reverse final-forms) + (transition state (list #,@(reverse action-ids))))] + + [(#:run-transition exp rest ...) + #`(match-state _state + #,@(reverse final-forms) + (sequence-transitions (transition state (list #,@(reverse action-ids))) + exp + (begin-transition rest ...)))] + + [(#:update [statevar stateval] rest ...) + #`(match-state state + #,@(reverse final-forms) + (sequence-transitions (transition (update-state-struct state [statevar stateval]) + (list #,@(reverse action-ids))) + (begin-transition rest ...)))] + + [(#:update-routes rest ...) + #`(match-state state + #,@(reverse final-forms) + (sequence-transitions (transition state (list #,@(reverse action-ids) + (routing-update (compute-gestalt state)))) + (begin-transition rest ...)))] + + [(expr rest ...) + (syntax-case (expand-in-context context-id #'expr) () + [(head inner-rest ...) + (if (or (free-identifier=? #'head #'begin) + (free-identifier=? #'head #'begin-transition)) + (accumulate-actions context-id + action-ids + final-forms + (append (syntax->list #'(inner-rest ...)) #'(rest ...))) + (if (ormap (lambda (i) (free-identifier=? #'head i)) + (syntax->list #'(define-values define-syntaxes begin-for-syntax + module module* + #%module-begin + #%require #%provide))) + (accumulate-actions context-id + action-ids + (cons #'expr final-forms) + #'(rest ...)) + (accumulate-action #'expr + context-id + action-ids + final-forms + #'(rest ...))))] + [non-pair-syntax + (accumulate-action #'expr + context-id + action-ids + final-forms + #'(rest ...))])])) + + (define (accumulate-action action-stx context-id action-ids final-forms remaining-forms) + (define temp (car (generate-temporaries (list action-stx)))) + (accumulate-actions context-id + (cons temp action-ids) + (cons #`(define #,temp #,action-stx) final-forms) + remaining-forms))) + +;;; Local Variables: +;;; eval: (put 'begin-transition 'scheme-indent-function 0) +;;; eval: (put 'observe-subscribers 'scheme-indent-function 1) +;;; eval: (put 'observe-advertisers 'scheme-indent-function 1) +;;; eval: (put 'subscribe 'scheme-indent-function 1) +;;; eval: (put 'advertise 'scheme-indent-function 1) +;;; End: diff --git a/minimart/examples/chat-actor.rkt b/minimart/examples/chat-actor.rkt new file mode 100644 index 0000000..c354746 --- /dev/null +++ b/minimart/examples/chat-actor.rkt @@ -0,0 +1,45 @@ +#lang minimart + +(require racket/set) +(require (only-in racket/string string-trim)) +(require "../drivers/tcp.rkt") +(require "../demand-matcher.rkt") + +(define (spawn-session them us) + (actor #:name user-session + + (define user (gensym 'user)) + + (define (send-to-remote fmt . vs) + (send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))) + (define (say who fmt . vs) + (unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs)))) + + (send-to-remote "Welcome, ~a.\n" user) + + (observe-advertisers `(,($ who) says ,?) + #:name present-user-names + #:set who + #:added arrived + #:removed departed + (for/list [(who arrived)] (say who "arrived.")) + (for/list [(who departed)] (say who "departed."))) + + (observe-advertisers (tcp-channel them us ?) + #:meta-level 1 + #:presence remote-present? + (when (not remote-present?) (quit))) + + (advertise `(,user says ,?)) + (subscribe `(,($ who) says ,($ what)) + (say who "says: ~a" what)) + + (advertise (tcp-channel us them ?) #:meta-level 1) + (subscribe (tcp-channel them us ($ bs)) #:meta-level 1 + (send `(,user says ,(string-trim (bytes->string/utf-8 bs))))))) + +(spawn-tcp-driver) +(spawn-world + (spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 5999)) ?) + #:meta-level 1 + spawn-session)) diff --git a/minimart/examples/chat-client-actor.rkt b/minimart/examples/chat-client-actor.rkt new file mode 100644 index 0000000..132004e --- /dev/null +++ b/minimart/examples/chat-client-actor.rkt @@ -0,0 +1,29 @@ +#lang minimart + +(require (only-in racket/port read-bytes-line-evt)) +(require "../drivers/tcp.rkt") + +(define local-handle (tcp-handle 'chat)) +(define remote-handle (tcp-address "localhost" 5999)) + +(spawn-tcp-driver) + +(actor #:name chat-client + #:state [seen-remote? #f] + + (define read-evt (read-bytes-line-evt (current-input-port) 'any)) + (subscribe (event read-evt (list ($ line))) + #:meta-level 1 + (if (eof-object? line) + (quit) + (send (tcp-channel local-handle remote-handle line)))) + + (advertise (tcp-channel local-handle remote-handle ?)) + (subscribe (tcp-channel remote-handle local-handle ($ bs)) + (write-bytes bs) + (flush-output)) + + (observe-advertisers (tcp-channel remote-handle local-handle ?) + #:presence remote-present? + (when (and (not remote-present?) seen-remote?) (quit)) + #:update [seen-remote? (or seen-remote? remote-present?)])) diff --git a/minimart/main.rkt b/minimart/main.rkt index cdf15d7..fcb7cb2 100644 --- a/minimart/main.rkt +++ b/minimart/main.rkt @@ -3,8 +3,10 @@ (require "core.rkt") (require "gestalt.rkt") (require "ground.rkt") +(require "actor.rkt") (provide (all-from-out "core.rkt") (all-from-out "gestalt.rkt") - (all-from-out "ground.rkt")) + (all-from-out "ground.rkt") + (all-from-out "actor.rkt"))