beautiful-racket/beautiful-racket-lib/br/syntax.rkt

117 lines
3.8 KiB
Racket

#lang racket/base
(require (for-syntax racket/base racket/syntax)
racket/list
racket/syntax
syntax/strip-context
br/define
br/private/syntax-flatten)
(provide (all-defined-out)
syntax-flatten
(all-from-out syntax/strip-context))
(module+ test
(require rackunit))
(define-macro (syntax-match STX-ARG [(syntax PATTERN) BODY ...] ...)
#'(syntax-case STX-ARG ()
[PATTERN BODY ...] ...))
(define-macro-cases with-pattern
[(_ () . BODY) #'(begin . BODY)]
[(_ ([SID SID-STX] STX ...) . BODY)
#'(with-syntax ([SID SID-STX])
(with-pattern (STX ...) . BODY))]
[(_ ([SID] STX ...) . BODY) ; standalone id
#'(with-pattern ([SID SID] STX ...) . BODY)]) ; convert to previous case
(define (check-syntax-list-argument caller-name arg)
(cond
[(and (syntax? arg) (syntax->list arg))]
[(list? arg) arg]
[else (raise-argument-error caller-name "list of syntax, or syntaxed list" arg)]))
(define-macro (define-listy-macro MACRO-ID LIST-FUNC)
#'(define-macro (MACRO-ID STX-LIST LITERALS . MATCHERS)
#'(LIST-FUNC
(λ(stx-item)
(with-handlers ([exn:fail:syntax? (λ (exn) #f)])
(syntax-case stx-item LITERALS
. MATCHERS)))
(check-syntax-list-argument 'MACRO-ID STX-LIST))))
(define-listy-macro syntax-case-partition partition)
(define-listy-macro syntax-case-filter filter)
(define-listy-macro syntax-case-map map)
(define-macro (reformat-id FMT ID0 ID ...)
#'(format-id ID0 FMT ID0 ID ...))
(define-macro (format-string FMT ID0 ID ...)
#'(datum->syntax ID0 (format FMT (syntax->datum ID0) (syntax->datum ID) ...)))
(define-macro (->unsyntax X)
#'(if (syntax? X)
(syntax->datum X)
X))
(define-macro (prefix-id PREFIX ... BASE-OR-BASES)
#'(let* ([bobs BASE-OR-BASES]
[got-single? (and (not (list? bobs)) (not (syntax->list bobs)))]
[bases (if got-single?
(list bobs)
bobs)]
[result (syntax-case-map
bases ()
[base (format-id #'base "~a~a"
(string-append (format "~a" (->unsyntax PREFIX)) ...)
(syntax-e #'base))])])
(if got-single? (car result) result)))
(define-macro (infix-id PREFIX BASE-OR-BASES SUFFIX ...)
#'(let* ([bobs BASE-OR-BASES]
[got-single? (and (not (list? bobs)) (not (syntax->list bobs)))]
[bases (if got-single?
(list bobs)
bobs)]
[result (syntax-case-map
bases ()
[base (format-id #'base "~a~a~a"
(->unsyntax PREFIX)
(syntax-e #'base)
(string-append (format "~a" (->unsyntax SUFFIX)) ...))])])
(if got-single? (car result) result)))
(define-macro (suffix-id BASE-OR-BASES SUFFIX ...)
#'(infix-id "" BASE-OR-BASES SUFFIX ...))
(define-macro-cases syntax-property*
[(_ STX 'PROP0) ; read one
#'(syntax-property STX 'PROP0)]
[(_ STX 'PROP0 'PROP ...) ; read multiple
#'(cons (syntax-property* STX 'PROP0)
(let ([result (syntax-property* STX 'PROP ...)])
(if (pair? result)
result
(list result))))]
[(_ STX ['PROP0 VAL0 . PRESERVED0]) ; write one
#'(syntax-property STX 'PROP0 VAL0 . PRESERVED0)]
[(_ STX ['PROP0 VAL0 . PRESERVED0] ['PROP VAL . PRESERVED] ...) ; write multiple
#'(syntax-property* (syntax-property STX 'PROP0 VAL0 . PRESERVED0) ['PROP VAL . PRESERVED] ...)])
(module+ test
(define x (syntax-property* #'foo ['bar #t] ['zam 'boni]))
(check-false (syntax-property* x 'foo))
(check-true (syntax-property* x 'bar))
(check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni)))