Apply Ryan/Vincent's ingenious idea for avoiding literal-identifier=?.
This commit is contained in:
parent
b477046961
commit
0e82bc83ab
|
@ -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])
|
|
@ -2,14 +2,15 @@
|
||||||
|
|
||||||
(require (for-syntax syntax/parse))
|
(require (for-syntax syntax/parse))
|
||||||
(require (for-syntax racket/base))
|
(require (for-syntax racket/base))
|
||||||
(require "support/dsl-typed.rkt")
|
|
||||||
(require (for-syntax "support/dsl-typed.rkt"))
|
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
|
||||||
(require (prefix-in core: "main.rkt"))
|
(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
|
let-fresh
|
||||||
observe-subscribers:
|
observe-subscribers:
|
||||||
observe-subscribers/everything:
|
observe-subscribers/everything:
|
||||||
|
@ -19,16 +20,6 @@
|
||||||
subscriber:
|
subscriber:
|
||||||
build-endpoint:)
|
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:
|
;; Must handle:
|
||||||
;; - orientation
|
;; - orientation
|
||||||
;; - interest-type
|
;; - interest-type
|
||||||
|
@ -121,11 +112,17 @@
|
||||||
[(expr ...)
|
[(expr ...)
|
||||||
#`(lambda: ([state : #,State]) (core:transition state (list 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 ...)
|
[((match-state pat-stx inner-clause ...) outer-clause ...)
|
||||||
(literal-identifier=? #'maybe-match-state #'match-state)
|
|
||||||
(append (combine-handler-clauses State
|
(append (combine-handler-clauses State
|
||||||
(syntax (inner-clause ...))
|
(syntax (inner-clause ...))
|
||||||
#t
|
#t
|
||||||
|
@ -136,8 +133,7 @@
|
||||||
reason-stx)
|
reason-stx)
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
(do-tail (syntax (outer-clause ...))))]
|
||||||
|
|
||||||
[((maybe-match-orientation pat-stx inner-clause ...) outer-clause ...)
|
[((match-orientation pat-stx inner-clause ...) outer-clause ...)
|
||||||
(literal-identifier=? #'maybe-match-orientation #'match-orientation)
|
|
||||||
(append (combine-handler-clauses State
|
(append (combine-handler-clauses State
|
||||||
(syntax (inner-clause ...))
|
(syntax (inner-clause ...))
|
||||||
stateful?
|
stateful?
|
||||||
|
@ -148,8 +144,7 @@
|
||||||
reason-stx)
|
reason-stx)
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
(do-tail (syntax (outer-clause ...))))]
|
||||||
|
|
||||||
[((maybe-match-conversation pat-stx inner-clause ...) outer-clause ...)
|
[((match-conversation pat-stx inner-clause ...) outer-clause ...)
|
||||||
(literal-identifier=? #'maybe-match-conversation #'match-conversation)
|
|
||||||
(append (combine-handler-clauses State
|
(append (combine-handler-clauses State
|
||||||
(syntax (inner-clause ...))
|
(syntax (inner-clause ...))
|
||||||
stateful?
|
stateful?
|
||||||
|
@ -160,8 +155,7 @@
|
||||||
reason-stx)
|
reason-stx)
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
(do-tail (syntax (outer-clause ...))))]
|
||||||
|
|
||||||
[((maybe-match-interest-type pat-stx inner-clause ...) outer-clause ...)
|
[((match-interest-type pat-stx inner-clause ...) outer-clause ...)
|
||||||
(literal-identifier=? #'maybe-match-interest-type #'match-interest-type)
|
|
||||||
(append (combine-handler-clauses State
|
(append (combine-handler-clauses State
|
||||||
(syntax (inner-clause ...))
|
(syntax (inner-clause ...))
|
||||||
stateful?
|
stateful?
|
||||||
|
@ -172,8 +166,7 @@
|
||||||
reason-stx)
|
reason-stx)
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
(do-tail (syntax (outer-clause ...))))]
|
||||||
|
|
||||||
[((maybe-match-reason pat-stx inner-clause ...) outer-clause ...)
|
[((match-reason pat-stx inner-clause ...) outer-clause ...)
|
||||||
(literal-identifier=? #'maybe-match-reason #'match-reason)
|
|
||||||
(append (combine-handler-clauses State
|
(append (combine-handler-clauses State
|
||||||
(syntax (inner-clause ...))
|
(syntax (inner-clause ...))
|
||||||
stateful?
|
stateful?
|
||||||
|
@ -184,16 +177,14 @@
|
||||||
#'pat-stx)
|
#'pat-stx)
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
(do-tail (syntax (outer-clause ...))))]
|
||||||
|
|
||||||
[((maybe-on-presence expr ...) outer-clause ...)
|
[((on-presence expr ...) outer-clause ...)
|
||||||
(literal-identifier=? #'maybe-on-presence #'on-presence)
|
|
||||||
(cons #`[(core:presence-event (core:role #,orientation-stx
|
(cons #`[(core:presence-event (core:role #,orientation-stx
|
||||||
#,conversation-stx
|
#,conversation-stx
|
||||||
#,interest-type-stx))
|
#,interest-type-stx))
|
||||||
#,(stateful-lift 'on-presence (syntax (expr ...)))]
|
#,(stateful-lift 'on-presence (syntax (expr ...)))]
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
(do-tail (syntax (outer-clause ...))))]
|
||||||
|
|
||||||
[((maybe-on-absence expr ...) outer-clause ...)
|
[((on-absence expr ...) outer-clause ...)
|
||||||
(literal-identifier=? #'maybe-on-absence #'on-absence)
|
|
||||||
(cons #`[(core:absence-event (core:role #,orientation-stx
|
(cons #`[(core:absence-event (core:role #,orientation-stx
|
||||||
#,conversation-stx
|
#,conversation-stx
|
||||||
#,interest-type-stx)
|
#,interest-type-stx)
|
||||||
|
@ -201,8 +192,7 @@
|
||||||
#,(stateful-lift 'on-absence (syntax (expr ...)))]
|
#,(stateful-lift 'on-absence (syntax (expr ...)))]
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
(do-tail (syntax (outer-clause ...))))]
|
||||||
|
|
||||||
[((maybe-on-message [message-pat expr ...] ...) outer-clause ...)
|
[((on-message [message-pat expr ...] ...) outer-clause ...)
|
||||||
(literal-identifier=? #'maybe-on-message #'on-message)
|
|
||||||
(cons #`[(core:message-event (core:role #,orientation-stx
|
(cons #`[(core:message-event (core:role #,orientation-stx
|
||||||
#,conversation-stx
|
#,conversation-stx
|
||||||
#,interest-type-stx)
|
#,interest-type-stx)
|
||||||
|
|
|
@ -2,13 +2,15 @@
|
||||||
|
|
||||||
(require (for-syntax syntax/parse))
|
(require (for-syntax syntax/parse))
|
||||||
(require (for-syntax racket/base))
|
(require (for-syntax racket/base))
|
||||||
(require "support/dsl-untyped.rkt")
|
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
|
||||||
(require (prefix-in core: "main.rkt"))
|
(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
|
let-fresh
|
||||||
observe-subscribers
|
observe-subscribers
|
||||||
observe-subscribers/everything
|
observe-subscribers/everything
|
||||||
|
@ -18,16 +20,6 @@
|
||||||
subscriber
|
subscriber
|
||||||
build-endpoint)
|
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:
|
;; Must handle:
|
||||||
;; - orientation
|
;; - orientation
|
||||||
;; - interest-type
|
;; - interest-type
|
||||||
|
|
|
@ -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))))
|
|
Loading…
Reference in New Issue