syndicate-lang
/
marketplace-2014
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Apply Ryan/Vincent's ingenious idea for avoiding literal-identifier=?.

This commit is contained in:
Tony Garnock-Jones 2013-06-12 17:25:22 -04:00
parent b477046961
commit 0e82bc83ab
4 changed files with 45 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
marketplace/sugar-endpoints-support.rkt Normal file
View File

@ -0,0 +1,21 @@
#lang racket/base
(require (for-syntax racket/base))
(require "support/dsl-untyped.rkt")
;; We define and provide these here so that they can be used by both
;; typed and untyped contexts. If we define them separately in untyped
;; and typed contexts, then TR's wrapping of provided identifiers
;; interferes with literal comparison in our macros. See also
;; definition and use of the file support/dsl-typed.rkt in git rev
;; b477046.
(define&provide-dsl-helper-syntaxes "endpoint definition context"
[match-state
match-orientation
match-conversation
match-interest-type
match-reason
on-presence
on-absence
on-message])

50
marketplace/sugar-endpoints-typed.rkt
View File

@ -2,14 +2,15 @@
(require (for-syntax syntax/parse))
(require (for-syntax racket/base))
(require "support/dsl-typed.rkt")
(require (for-syntax "support/dsl-typed.rkt"))
(require racket/match)
(require (prefix-in core: "main.rkt"))
(provide name-endpoint
(require "sugar-endpoints-support.rkt")
(provide (all-from-out "sugar-endpoints-support.rkt")
name-endpoint
let-fresh
observe-subscribers:
observe-subscribers/everything:
@ -19,16 +20,6 @@
subscriber:
build-endpoint:)
(define&provide-dsl-helper-syntaxes "endpoint definition context"
[match-state
match-orientation
match-conversation
match-interest-type
match-reason
on-presence
on-absence
on-message])
;; Must handle:
;; - orientation
;; - interest-type
@ -121,11 +112,17 @@
[(expr ...)
#`(lambda: ([state : #,State]) (core:transition state (list expr ...)))])))
(syntax-case clauses-stx ()
(syntax-case clauses-stx (match-state
match-orientation
match-conversation
match-interest-type
match-reason
on-presence
on-absence
on-message)
[() '()]
[((maybe-match-state pat-stx inner-clause ...) outer-clause ...)
(literal-identifier=? #'maybe-match-state #'match-state)
[((match-state pat-stx inner-clause ...) outer-clause ...)
(append (combine-handler-clauses State
(syntax (inner-clause ...))
#t
@ -136,8 +133,7 @@
reason-stx)
(do-tail (syntax (outer-clause ...))))]
[((maybe-match-orientation pat-stx inner-clause ...) outer-clause ...)
(literal-identifier=? #'maybe-match-orientation #'match-orientation)
[((match-orientation pat-stx inner-clause ...) outer-clause ...)
(append (combine-handler-clauses State
(syntax (inner-clause ...))
stateful?
@ -148,8 +144,7 @@
reason-stx)
(do-tail (syntax (outer-clause ...))))]
[((maybe-match-conversation pat-stx inner-clause ...) outer-clause ...)
(literal-identifier=? #'maybe-match-conversation #'match-conversation)
[((match-conversation pat-stx inner-clause ...) outer-clause ...)
(append (combine-handler-clauses State
(syntax (inner-clause ...))
stateful?
@ -160,8 +155,7 @@
reason-stx)
(do-tail (syntax (outer-clause ...))))]
[((maybe-match-interest-type pat-stx inner-clause ...) outer-clause ...)
(literal-identifier=? #'maybe-match-interest-type #'match-interest-type)
[((match-interest-type pat-stx inner-clause ...) outer-clause ...)
(append (combine-handler-clauses State
(syntax (inner-clause ...))
stateful?
@ -172,8 +166,7 @@
reason-stx)
(do-tail (syntax (outer-clause ...))))]
[((maybe-match-reason pat-stx inner-clause ...) outer-clause ...)
(literal-identifier=? #'maybe-match-reason #'match-reason)
[((match-reason pat-stx inner-clause ...) outer-clause ...)
(append (combine-handler-clauses State
(syntax (inner-clause ...))
stateful?
@ -184,16 +177,14 @@
#'pat-stx)
(do-tail (syntax (outer-clause ...))))]
[((maybe-on-presence expr ...) outer-clause ...)
(literal-identifier=? #'maybe-on-presence #'on-presence)
[((on-presence expr ...) outer-clause ...)
(cons #`[(core:presence-event (core:role #,orientation-stx
#,conversation-stx
#,interest-type-stx))
#,(stateful-lift 'on-presence (syntax (expr ...)))]
(do-tail (syntax (outer-clause ...))))]
[((maybe-on-absence expr ...) outer-clause ...)
(literal-identifier=? #'maybe-on-absence #'on-absence)
[((on-absence expr ...) outer-clause ...)
(cons #`[(core:absence-event (core:role #,orientation-stx
#,conversation-stx
#,interest-type-stx)
@ -201,8 +192,7 @@
#,(stateful-lift 'on-absence (syntax (expr ...)))]
(do-tail (syntax (outer-clause ...))))]
[((maybe-on-message [message-pat expr ...] ...) outer-clause ...)
(literal-identifier=? #'maybe-on-message #'on-message)
[((on-message [message-pat expr ...] ...) outer-clause ...)
(cons #`[(core:message-event (core:role #,orientation-stx
#,conversation-stx
#,interest-type-stx)

16
marketplace/sugar-endpoints-untyped.rkt
View File

@ -2,13 +2,15 @@
(require (for-syntax syntax/parse))
(require (for-syntax racket/base))
(require "support/dsl-untyped.rkt")
(require racket/match)
(require (prefix-in core: "main.rkt"))
(provide name-endpoint
(require "sugar-endpoints-support.rkt")
(provide (all-from-out "sugar-endpoints-support.rkt")
name-endpoint
let-fresh
observe-subscribers
observe-subscribers/everything
@ -18,16 +20,6 @@
subscriber
build-endpoint)
(define&provide-dsl-helper-syntaxes "endpoint definition context"
[match-state
match-orientation
match-conversation
match-interest-type
match-reason
on-presence
on-absence
on-message])
;; Must handle:
;; - orientation
;; - interest-type

26
marketplace/support/dsl-typed.rkt
View File

@ -1,26 +0,0 @@
#lang typed/racket/base
(require (for-syntax typed/racket/base))
(provide define&provide-dsl-helper-syntaxes)
(provide literal-identifier=?)
(define-syntax-rule (define&provide-dsl-helper-syntaxes context (identifier ...))
(begin (provide identifier ...)
(define-syntax identifier
(lambda (stx)
(raise-syntax-error #f
(format "Illegal use of ~a outside ~a"
'identifier
context)
stx)))
...))
;; Typed racket wraps literal identifiers during provide. Here we dig
;; through the renamings to see if they're the same thing. Gross!
;; Fragile?
(: literal-identifier=? : Syntax Identifier -> Boolean)
(define (literal-identifier=? actual expected)
(and (identifier? actual)
(identifier-binding actual)
(eq? (syntax-local-value actual)
(syntax-local-value expected))))