Add :template

This commit is contained in:
Tony Garnock-Jones 2021-06-02 12:50:21 +02:00
parent ac01ce4dfe
commit fe6430abfd
1 changed files with 41 additions and 7 deletions

View File

@ -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)]))