diff --git a/os2.rkt b/os2.rkt index 7a606a9..4f098e4 100644 --- a/os2.rkt +++ b/os2.rkt @@ -21,6 +21,7 @@ (rename-out [make-transition transition]) extend-transition + role (except-out (struct-out add-role) add-role) (rename-out [make-add-role add-role]) (except-out (struct-out delete-role) delete-role) @@ -103,6 +104,54 @@ ;;--------------------------------------------------------------------------- +(require (for-syntax syntax/parse)) +(require (for-syntax racket/base)) +(define-syntax role + (lambda (stx) + (syntax-parse stx + [(_ topic-expr + #:state state-pattern + (~or (~optional (~seq #:on-presence presence) #:name "#:on-presence handler") + (~optional (~seq #:on-absence absence) #:name "#:on-absence handler") + (~optional (~seq #:on-ready ready) #:name "#:on-ready handler") + (~optional (~seq #:id eid) #:name "#:id") + (~optional (~seq #:topic topic) #:name "#:topic") + (~optional (~seq #:reason reason) #:name "#:reason")) + ... + [message-pattern clause-body ...] + ...) + (with-syntax ([eid (if (attribute eid) #'eid #'dummy-eid)] + [topic (if (attribute topic) #'topic #'dummy-topic)] + [reason (if (attribute reason) #'reason #'dummy-reason)]) + (with-syntax ([presence-handler (if (not (attribute presence)) + #'#f + #'(lambda (eid topic) + (lambda (state) + (match state + [state-pattern presence]))))] + [absence-handler (if (not (attribute absence)) + #'#f + #'(lambda (eid topic reason) + (lambda (state) + (match state + [state-pattern absence]))))] + [ready-handler (if (not (attribute ready)) + #'#f + #'(lambda (eid) + (lambda (state) + (match state + [state-pattern ready]))))] + [message-handler #'(lambda (eid topic message-body) + (lambda (state) + (match state + [state-pattern + (match message-body + [message-pattern clause-body ...] + ...)])))]) + #'(add-role topic-expr + (handlers presence-handler absence-handler message-handler) + ready-handler)))]))) + (define (make-transition state . actions) (transition state actions)) (define (make-add-role topic handlers [k #f]) (add-role topic handlers k)) (define (make-delete-role eid [reason #f]) (delete-role eid reason))