56 lines
2.0 KiB
Racket
56 lines
2.0 KiB
Racket
#lang racket/base
|
|
(provide ~syntax-case ~syntax-case-stat)
|
|
(require stxparse-info/parse
|
|
(for-syntax racket/base))
|
|
(define-for-syntax (~syntax-case-impl not-stat? stx)
|
|
(with-syntax ([(_ stx1) stx])
|
|
(define (id=? a b) (and (identifier? a)
|
|
(free-identifier=? a b)))
|
|
(define (ds e [ctx #'stx1])
|
|
(datum->syntax ctx e ctx ctx))
|
|
(define (ds2 sym [locprop #'stx1])
|
|
(datum->syntax #'here sym locprop locprop))
|
|
(define (sc e)
|
|
(datum->syntax #'here `{~syntax-case ,e} e e))
|
|
(define (process-sequence stx2)
|
|
(syntax-case stx2 ()
|
|
[(pat ooo . rest)
|
|
(and (id=? #'ooo (quote-syntax ...)) not-stat?)
|
|
`(,{sc #'pat} ,#'ooo . ,(process-sequence #'rest))]
|
|
[(pat . rest)
|
|
`(,{sc #'pat} . ,(process-sequence #'rest))]
|
|
[()
|
|
stx2]))
|
|
(syntax-case #'stx1 ()
|
|
[underscore (id=? #'underscore #'_)
|
|
#'underscore]
|
|
[id (identifier? #'id)
|
|
(ds `{,{ds2 '~var #'id} ,#'id})]
|
|
[(ooo stat) (and (id=? #'ooo (quote-syntax ...)) not-stat?)
|
|
{ds
|
|
`(,{ds2 '~syntax-case-stat #'ooo}
|
|
,#'stat)}]
|
|
[(pat ooo . rest) (and (id=? #'ooo (quote-syntax ...)) not-stat?)
|
|
(ds `(,{sc #'pat} ,#'ooo . ,{sc #'rest}))]
|
|
[(pat . rest) (ds `(,{sc #'pat} . ,{sc #'rest}))]
|
|
[() #'stx1]
|
|
[#(pat ...)
|
|
(ds (vector->immutable-vector
|
|
(list->vector
|
|
(process-sequence #'(pat ...)))))]
|
|
[#&pat
|
|
(ds (box-immutable (sc #'pat)))]
|
|
[p
|
|
(prefab-struct-key (syntax-e #'p))
|
|
(ds (make-prefab-struct
|
|
(prefab-struct-key (syntax-e #'p))
|
|
(process-sequence
|
|
(cdr (vector->list (struct->vector (syntax-e #'p)))))))]
|
|
[other
|
|
(ds `{,(ds2 '~datum #'other) ,#'other})])))
|
|
|
|
(define-syntax ~syntax-case
|
|
(pattern-expander (λ (stx) (~syntax-case-impl #t stx))))
|
|
(define-syntax ~syntax-case-stat
|
|
(pattern-expander (λ (stx) (~syntax-case-impl #f stx))))
|