From 0b6aaaa6f1d327abf8a3830c81ed417fabc4721f Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 2 Jun 2013 16:30:23 -0400 Subject: [PATCH] Experimental extra sugar --- .../examples/chat-paper-extrasugar.rkt | 47 ++++ marketplace/extrasugar.rkt | 218 ++++++++++++++++++ 2 files changed, 265 insertions(+) create mode 100644 marketplace/examples/chat-paper-extrasugar.rkt create mode 100644 marketplace/extrasugar.rkt diff --git a/marketplace/examples/chat-paper-extrasugar.rkt b/marketplace/examples/chat-paper-extrasugar.rkt new file mode 100644 index 0000000..70e43c9 --- /dev/null +++ b/marketplace/examples/chat-paper-extrasugar.rkt @@ -0,0 +1,47 @@ +#lang marketplace +(require "../extrasugar.rkt") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(nested-vm + (at-meta-level + (observe-publishers (tcp-channel ? (tcp-listener 5999) ?) + (match-conversation (tcp-channel them us _) + (on-presence (spawn #:child (chat-session them us))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (chat-session them us) + (define user (gensym 'user)) + (transition stateless + (listen-to-user user them us) + (speak-to-user user them us))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (listen-to-user user them us) + (list + (publish-on-topic `(,user says ,?)) + (at-meta-level + (subscribe-to-topic (tcp-channel them us ?) + (on-absence (quit)) + (on-message + [(tcp-channel _ _ (? bytes? text)) + (send-message `(,user says ,text))]))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (speak-to-user user them us) + (define (say fmt . args) + (at-meta-level + (send-message + (tcp-channel us them (apply format fmt args))))) + (define (announce who did-what) + (unless (equal? who user) + (say "~s ~s.~n" who did-what))) + (list + (say "You are ~s.~n" user) + (at-meta-level + (publish-on-topic (tcp-channel us them ?))) + (subscribe-to-topic `(,? says ,?) + (match-conversation `(,who says ,_) + (on-presence (announce who 'arrived)) + (on-absence (announce who 'departed)) + (on-message [`(,who says ,what) + (say "~a: ~a" who what)]))))) diff --git a/marketplace/extrasugar.rkt b/marketplace/extrasugar.rkt new file mode 100644 index 0000000..f54df90 --- /dev/null +++ b/marketplace/extrasugar.rkt @@ -0,0 +1,218 @@ +#lang racket/base + +(require (for-syntax syntax/parse)) +(require (for-syntax racket/base)) + +(require racket/stxparam) +(require racket/splicing) + +(require racket/match) + +(require (prefix-in core: "main.rkt")) +(require (except-in "main.rkt" + at-meta-level + spawn + yield + transition + delete-endpoint + send-message + quit)) +(require "sugar-untyped.rkt") + +(provide (except-out (all-from-out "sugar-untyped.rkt") endpoint) + (all-from-out "main.rkt") + name-endpoint + let-fresh + observe-subscribers + observe-publishers + publish-on-topic + subscribe-to-topic + build-endpoint) + +(define-syntax-rule (define&provide-endpoint-helper-syntaxes identifier ...) + (begin (provide identifier ...) + (define-syntax identifier + (lambda (stx) + (raise-syntax-error #f + (format "Illegal use of ~a outside endpoint definition context" + 'identifier) + stx))) + ...)) + +(define&provide-endpoint-helper-syntaxes + match-state + match-orientation + match-conversation + match-interest-type + match-reason + on-presence + on-absence + on-message) + +;; Must handle: +;; - orientation +;; - interest-type +;; - let-name +;; - naming of endpoints +;; - state matching +;; - conversation (and generally role) matching +;; - presence event handling +;; - absence event handling (including reason matching) +;; - message event handling (including message matching) + +(define (name-endpoint n e) + (match e + [(core:add-endpoint _ role handler) + (core:add-endpoint n role handler)])) + +(define-syntax-rule (let-fresh (id ...) exp ...) + (let ((id (gensym 'id)) ...) exp ...)) + +(define-syntax-rule (observe-subscribers topic clause ...) + (build-endpoint (gensym 'anonymous-endpoint) + (core:role 'publisher topic 'observer) + clause ...)) + +(define-syntax-rule (observe-publishers topic clause ...) + (build-endpoint (gensym 'anonymous-endpoint) + (core:role 'subscriber topic 'observer) + clause ...)) + +(define-syntax-rule (publish-on-topic topic clause ...) + (build-endpoint (gensym 'anonymous-endpoint) + (core:role 'publisher topic 'participant) + clause ...)) + +(define-syntax-rule (subscribe-to-topic topic clause ...) + (build-endpoint (gensym 'anonymous-endpoint) + (core:role 'subscriber topic 'participant) + clause ...)) + +(define-syntax build-endpoint + (lambda (stx) + (define (combine-handler-clauses clauses-stx + stateful? + state-stx + orientation-stx + conversation-stx + interest-type-stx + reason-stx) + + (define (do-tail new-clauses-stx) + (combine-handler-clauses new-clauses-stx + stateful? + state-stx + orientation-stx + conversation-stx + interest-type-stx + reason-stx)) + + (define (stateful-lift expr-stx) + (if stateful? + #`(match-lambda [#,state-stx #,expr-stx]) + #`(lambda (state) (core:transition state #,expr-stx)))) + + (syntax-case clauses-stx (match-state + match-orientation + match-conversation + match-interest-type + match-reason + on-presence + on-absence + on-message) + [() '()] + + [((match-state pat-stx inner-clause ...) outer-clause ...) + (append (combine-handler-clauses (syntax (inner-clause ...)) + #t + #'pat-stx + orientation-stx + conversation-stx + interest-type-stx + reason-stx) + (do-tail (syntax (outer-clause ...))))] + + [((match-orientation pat-stx inner-clause ...) outer-clause ...) + (append (combine-handler-clauses (syntax (inner-clause ...)) + stateful? + state-stx + #'pat-stx + conversation-stx + interest-type-stx + reason-stx) + (do-tail (syntax (outer-clause ...))))] + + [((match-conversation pat-stx inner-clause ...) outer-clause ...) + (append (combine-handler-clauses (syntax (inner-clause ...)) + stateful? + state-stx + orientation-stx + #'pat-stx + interest-type-stx + reason-stx) + (do-tail (syntax (outer-clause ...))))] + + [((match-interest-type pat-stx inner-clause ...) outer-clause ...) + (append (combine-handler-clauses (syntax (inner-clause ...)) + stateful? + state-stx + orientation-stx + conversation-stx + #'pat-stx + reason-stx) + (do-tail (syntax (outer-clause ...))))] + + [((match-reason pat-stx inner-clause ...) outer-clause ...) + (append (combine-handler-clauses (syntax (inner-clause ...)) + stateful? + state-stx + orientation-stx + conversation-stx + interest-type-stx + #'pat-stx) + (do-tail (syntax (outer-clause ...))))] + + [((on-presence expr ...) outer-clause ...) + (cons #`[(core:presence-event (core:role #,orientation-stx + #,conversation-stx + #,interest-type-stx)) + #,(stateful-lift (syntax (begin expr ...)))] + (do-tail (syntax (outer-clause ...))))] + + [((on-absence expr ...) outer-clause ...) + (cons #`[(core:absence-event (core:role #,orientation-stx + #,conversation-stx + #,interest-type-stx) + #,reason-stx) + #,(stateful-lift (syntax (begin expr ...)))] + (do-tail (syntax (outer-clause ...))))] + + [((on-message [message-pat expr ...] ...) outer-clause ...) + (cons #`[(core:message-event (core:role #,orientation-stx + #,conversation-stx + #,interest-type-stx) + message) + (match message + #,@(map (lambda (message-clause) + (syntax-case message-clause () + ([message-pat expr ...] + #`[message-pat #,(stateful-lift (syntax (begin expr ...)))]))) + (syntax->list (syntax ([message-pat expr ...] ...)))) + [_ (lambda (state) (core:transition state '()))])] + (do-tail (syntax (outer-clause ...))))])) + + (syntax-case stx () + [(dummy pre-eid-exp role-exp handler-clause ...) + #`(core:add-endpoint pre-eid-exp + role-exp + (match-lambda + #,@(reverse + (combine-handler-clauses + (syntax (handler-clause ...)) + #f + (syntax old-state) + (syntax _) + (syntax _) + (syntax _) + (syntax _))) + [_ (lambda (state) (core:transition state '()))]))])))