diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt index 263c2b3..62725f1 100644 --- a/syndicate/pattern.rkt +++ b/syndicate/pattern.rkt @@ -136,6 +136,8 @@ [(quasiquote p) #`(Pattern-DLit (DLit 'p))] [(quote p) #`(Pattern-DLit (DLit 'p))] + [(unquote p) #'p] + [(ctor piece ...) (struct-info? (id-value #'ctor)) (let-values (((label arity) (struct-label-and-arity #'ctor (length (syntax->list #'(piece ...)))))) @@ -165,6 +167,9 @@ (dollar-id? #'id) #`(Pattern-DBind (DBind '#,(undollar #'id) (Pattern-DDiscard (DDiscard))))] + [($ (unquote bp) p) + #`(Pattern-DBind (DBind bp #,(analyse-pattern #'p)))] + [($ id p) #`(Pattern-DBind (DBind 'id #,(analyse-pattern #'p)))] @@ -247,10 +252,20 @@ [other #'other]))) -(define-syntax (:pattern stx) - (syntax-case stx () - [(_ pat-stx) - (analyse-pattern #'pat-stx)])) +(define-pattern-expander :pattern + (lambda (stx) + (syntax-case stx () + [(_ pat-stx) + ;; This effectively quasiquotes the pattern; a naked unquote in + ;; the pattern returns to the "outer" context. This is useful + ;; for observing observers: + ;; + ;; (Observe (:pattern (some-pattern ...)) _) + (analyse-pattern #'pat-stx)])) + (lambda (stx) + (syntax-case stx () + [(_ pat-stx) + (analyse-pattern #'pat-stx)]))) ;; (provide :bindings) ;; (define-syntax (:bindings stx)