Add :template
This commit is contained in:
parent
ac01ce4dfe
commit
fe6430abfd
|
@ -5,12 +5,14 @@
|
|||
analyse-pattern
|
||||
analyse-pattern-bindings)
|
||||
define-preserves-pattern
|
||||
:pattern)
|
||||
:pattern
|
||||
:template)
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
(require (for-syntax racket/match))
|
||||
(require (for-syntax racket/list))
|
||||
(require (for-syntax racket/struct-info))
|
||||
(require (for-syntax racket/syntax))
|
||||
(require (for-syntax syntax/id-table))
|
||||
(require (for-syntax syntax/stx))
|
||||
|
||||
|
@ -27,7 +29,7 @@
|
|||
(define-syntax (define-preserves-pattern stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (ctor-stx field-stxs ...) pattern-stx bindings-stx)
|
||||
#'(begin (begin-for-syntax
|
||||
#`(begin (begin-for-syntax
|
||||
(register-preserves-pattern!
|
||||
#'ctor-stx
|
||||
(lambda (mode s)
|
||||
|
@ -36,6 +38,11 @@
|
|||
(syntax-case s ()
|
||||
[(_ field-stxs ...) pattern-stx]
|
||||
[_ (raise-syntax-error 'ctor-stx "Invalid pattern")])]
|
||||
['template
|
||||
(syntax-case s ()
|
||||
[(_ field-stxs ...)
|
||||
(syntax (#,(format-id #'ctor-stx "~a->preserves" (syntax-e #'ctor-stx))
|
||||
(ctor-stx field-stxs ...)))])]
|
||||
['bindings
|
||||
(syntax-case s ()
|
||||
[(_ field-stxs ...) bindings-stx]
|
||||
|
@ -180,15 +187,42 @@
|
|||
'()]
|
||||
|
||||
[other
|
||||
'()])))
|
||||
'()]))
|
||||
|
||||
(define (analyse-template stx)
|
||||
(syntax-case stx ($ quasiquote unquote quote)
|
||||
[(ctor args ...)
|
||||
(constructor-registered? #'ctor)
|
||||
((free-id-table-ref preserves-pattern-registry #'ctor) 'template stx)]
|
||||
|
||||
;; Extremely limited support for quasiquoting and quoting
|
||||
[(quasiquote (unquote p)) #'p]
|
||||
[(quasiquote (p ...)) (analyse-template #'(list (quasiquote p) ...))]
|
||||
[(quasiquote p) #''p]
|
||||
[(quote p) #''p]
|
||||
|
||||
[(ctor piece ...)
|
||||
(struct-info? (id-value #'ctor))
|
||||
#`(ctor #,@(map analyse-template (syntax->list #'(piece ...))))]
|
||||
|
||||
[(list-stx piece ...)
|
||||
(list-id? #'list-stx)
|
||||
#`(list-stx #,@(map analyse-template (syntax->list #'(piece ...))))]
|
||||
|
||||
[other #'other])))
|
||||
|
||||
(define-syntax (:pattern stx)
|
||||
(syntax-case stx ()
|
||||
[(_ pat-stx)
|
||||
(analyse-pattern #'pat-stx)]))
|
||||
|
||||
(provide :bindings)
|
||||
(define-syntax (:bindings stx)
|
||||
;; (provide :bindings)
|
||||
;; (define-syntax (:bindings stx)
|
||||
;; (syntax-case stx ()
|
||||
;; [(_ pat-stx)
|
||||
;; #`(quote #,(analyse-pattern-bindings #'pat-stx))]))
|
||||
|
||||
(define-syntax (:template stx)
|
||||
(syntax-case stx ()
|
||||
[(_ pat-stx)
|
||||
#`(quote #,(analyse-pattern-bindings #'pat-stx))]))
|
||||
[(_ template-stx)
|
||||
(analyse-template #'template-stx)]))
|
||||
|
|
Loading…
Reference in New Issue