127 lines
4.3 KiB
Racket
127 lines
4.3 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/match
|
|
syntax/parse
|
|
(for-syntax racket/base
|
|
racket/syntax
|
|
racket/list
|
|
racket/struct
|
|
syntax/parse
|
|
racket/private/sc)
|
|
;; attribute-mapping? is provided for-syntax
|
|
(only-in syntax/parse/private/residual attribute-mapping?))
|
|
|
|
(provide auto-with-syntax)
|
|
(provide auto-syntax)
|
|
(provide auto-syntax-case)
|
|
(module+ utils
|
|
(provide (for-syntax make-auto-pvar
|
|
auto-pvar?)))
|
|
|
|
(define (leaves->datum e depth)
|
|
(if (eq? e #f) ;; for attributes with ~optional holes.
|
|
e
|
|
(if (> depth 0)
|
|
(map (λ (eᵢ) (leaves->datum eᵢ (sub1 depth))) e)
|
|
(if (syntax? e)
|
|
(syntax->datum e)
|
|
e))))
|
|
|
|
|
|
(define-syntax (to-datum stx)
|
|
(syntax-case stx ()
|
|
[(_ id)
|
|
(syntax-pattern-variable? (syntax-local-value #'id (λ () #f)))
|
|
(begin
|
|
(let* ([mapping (syntax-local-value #'id)]
|
|
[valvar (syntax-mapping-valvar mapping)]
|
|
[depth (syntax-mapping-depth mapping)])
|
|
(if (attribute-mapping? (syntax-local-value valvar (λ () #f)))
|
|
#`(leaves->datum (attribute id) #,depth)
|
|
#`(leaves->datum #,valvar #,depth))))]))
|
|
|
|
(begin-for-syntax
|
|
(define (auto-pvar-proc self stx)
|
|
(cond
|
|
[(identifier? stx)
|
|
(datum->syntax stx
|
|
`(,(quote-syntax to-datum) ,stx)
|
|
stx
|
|
stx)]
|
|
[(and (pair? (syntax-e stx))
|
|
(identifier? (car (syntax-e stx))))
|
|
(datum->syntax stx
|
|
`((,(quote-syntax to-datum) ,(car (syntax-e stx)))
|
|
.
|
|
,(cdr (syntax-e stx)))
|
|
stx
|
|
stx)]
|
|
[else (raise-syntax-error
|
|
'auto-syntax-e
|
|
"Improper use of auto-syntax-e pattern variable"
|
|
stx)]))
|
|
(define-values (struct:auto-pvar
|
|
-make-auto-pvar
|
|
auto-pvar?
|
|
auto-pvar-ref
|
|
auto-pvar-set!)
|
|
(make-struct-type 'auto-pvar
|
|
(eval #'struct:syntax-mapping
|
|
(module->namespace 'racket/private/sc))
|
|
0
|
|
0
|
|
#f
|
|
null
|
|
(current-inspector)
|
|
auto-pvar-proc))
|
|
(define (make-auto-pvar depth valvar)
|
|
(make-set!-transformer (-make-auto-pvar depth valvar))))
|
|
|
|
(define-for-syntax (syntax->tree/ids e)
|
|
(cond [(identifier? e) e]
|
|
[(syntax? e) (syntax->tree/ids (syntax-e e))]
|
|
[(pair? e) (cons (syntax->tree/ids (car e))
|
|
(syntax->tree/ids (cdr e)))]
|
|
[(vector? e) (map syntax->tree/ids (vector->list e))]
|
|
[(box? e) (syntax->tree/ids (unbox e))]
|
|
[(prefab-struct-key e) (map syntax->tree/ids (struct->list e))]
|
|
[else e]))
|
|
|
|
(define-for-syntax (syntax->ids e)
|
|
(filter identifier? (flatten (syntax->tree/ids e))))
|
|
|
|
(define-syntax auto-syntax
|
|
(syntax-parser
|
|
[(_ (id ...) body ...)
|
|
#:with (pvar-id ...) (filter (λ (id)
|
|
(syntax-pattern-variable?
|
|
(syntax-local-value id (λ () #f))))
|
|
(syntax->list #'(id ...)))
|
|
(with-disappeared-uses
|
|
(let ()
|
|
(record-disappeared-uses (syntax->list #'(pvar-id ...)))
|
|
#'(let-syntax ([pvar-id
|
|
(let ([mapping (syntax-local-value
|
|
(quote-syntax pvar-id))])
|
|
(make-auto-pvar (syntax-mapping-depth mapping)
|
|
(syntax-mapping-valvar mapping)))]
|
|
...)
|
|
body ...)))]))
|
|
|
|
(define-syntax auto-with-syntax
|
|
(syntax-parser
|
|
[(_ ([pat e] ...) body ...)
|
|
#:with (id ...) (syntax->ids #'(pat ...))
|
|
#'(with-syntax ([pat e] ...)
|
|
(auto-syntax (id ...)
|
|
body ...))]))
|
|
|
|
|
|
(define-syntax auto-syntax-case
|
|
(syntax-parser
|
|
[(_ stx-expression literals [pat guard+body ...] ...)
|
|
#:with (id ...) (syntax->ids #'(pat ...))
|
|
#'(syntax-case stx-expression literals
|
|
[pat (auto-syntax (id ...)
|
|
guard+body ...)]
|
|
...)])) |