role macro

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))