Add :template
This commit is contained in:
parent
ac01ce4dfe
commit
fe6430abfd
|
@ -5,12 +5,14 @@
|
||||||
analyse-pattern
|
analyse-pattern
|
||||||
analyse-pattern-bindings)
|
analyse-pattern-bindings)
|
||||||
define-preserves-pattern
|
define-preserves-pattern
|
||||||
:pattern)
|
:pattern
|
||||||
|
:template)
|
||||||
|
|
||||||
(require (for-syntax racket/base))
|
(require (for-syntax racket/base))
|
||||||
(require (for-syntax racket/match))
|
(require (for-syntax racket/match))
|
||||||
(require (for-syntax racket/list))
|
(require (for-syntax racket/list))
|
||||||
(require (for-syntax racket/struct-info))
|
(require (for-syntax racket/struct-info))
|
||||||
|
(require (for-syntax racket/syntax))
|
||||||
(require (for-syntax syntax/id-table))
|
(require (for-syntax syntax/id-table))
|
||||||
(require (for-syntax syntax/stx))
|
(require (for-syntax syntax/stx))
|
||||||
|
|
||||||
|
@ -27,7 +29,7 @@
|
||||||
(define-syntax (define-preserves-pattern stx)
|
(define-syntax (define-preserves-pattern stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ (ctor-stx field-stxs ...) pattern-stx bindings-stx)
|
[(_ (ctor-stx field-stxs ...) pattern-stx bindings-stx)
|
||||||
#'(begin (begin-for-syntax
|
#`(begin (begin-for-syntax
|
||||||
(register-preserves-pattern!
|
(register-preserves-pattern!
|
||||||
#'ctor-stx
|
#'ctor-stx
|
||||||
(lambda (mode s)
|
(lambda (mode s)
|
||||||
|
@ -36,6 +38,11 @@
|
||||||
(syntax-case s ()
|
(syntax-case s ()
|
||||||
[(_ field-stxs ...) pattern-stx]
|
[(_ field-stxs ...) pattern-stx]
|
||||||
[_ (raise-syntax-error 'ctor-stx "Invalid pattern")])]
|
[_ (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
|
['bindings
|
||||||
(syntax-case s ()
|
(syntax-case s ()
|
||||||
[(_ field-stxs ...) bindings-stx]
|
[(_ field-stxs ...) bindings-stx]
|
||||||
|
@ -180,15 +187,42 @@
|
||||||
'()]
|
'()]
|
||||||
|
|
||||||
[other
|
[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)
|
(define-syntax (:pattern stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ pat-stx)
|
[(_ pat-stx)
|
||||||
(analyse-pattern #'pat-stx)]))
|
(analyse-pattern #'pat-stx)]))
|
||||||
|
|
||||||
(provide :bindings)
|
;; (provide :bindings)
|
||||||
(define-syntax (:bindings stx)
|
;; (define-syntax (:bindings stx)
|
||||||
|
;; (syntax-case stx ()
|
||||||
|
;; [(_ pat-stx)
|
||||||
|
;; #`(quote #,(analyse-pattern-bindings #'pat-stx))]))
|
||||||
|
|
||||||
|
(define-syntax (:template stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ pat-stx)
|
[(_ template-stx)
|
||||||
#`(quote #,(analyse-pattern-bindings #'pat-stx))]))
|
(analyse-template #'template-stx)]))
|
||||||
|
|
Loading…
Reference in New Issue