You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
beautiful-racket/beautiful-racket-lib/br/syntax.rkt

115 lines
4.3 KiB
Racket

#lang racket/base
(require (for-syntax racket/base syntax/parse racket/syntax syntax/strip-context)
syntax/strip-context racket/function racket/list racket/syntax)
(provide (all-defined-out) (all-from-out syntax/strip-context))
(module+ test
(require rackunit))
(define-syntax (syntax-match stx)
(syntax-case stx (syntax)
[(_ stx-arg [(syntax pattern) body ...] ...)
#'(syntax-case stx-arg ()
[pattern body ...] ...)]))
(define-syntax (inject-syntax stx)
;; todo: permit mixing of two-arg and one-arg binding forms
;; one-arg form allows you to inject an existing syntax object using its current name
(syntax-case stx (syntax)
[(_ ([(syntax sid) sid-stx] ...) body ...)
#'(with-syntax ([sid sid-stx] ...) body ...)]
;; todo: limit `sid` to be an identifier
[(_ ([sid] ...) body ...)
#'(with-syntax ([sid sid] ...) body ...)]))
(define-syntax (inject-syntax* stx)
(syntax-case stx ()
[(_ () . body) #'(begin . body)]
[(_ (stx-expr0 stx-expr ...) . body)
#'(inject-syntax (stx-expr0)
(inject-syntax* (stx-expr ...) . body))]))
(define-syntax syntax-let (make-rename-transformer #'inject-syntax))
(define-syntax add-syntax (make-rename-transformer #'inject-syntax))
(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-syntax-rule (syntax-case-partition _stx-list _literals . _matchers)
(partition (λ(stx-item)
(with-handlers ([exn:fail:syntax? (λ (exn) #f)])
(syntax-case stx-item _literals
. _matchers))) (check-syntax-list-argument 'syntax-case-partition _stx-list)))
(define-syntax-rule (syntax-case-filter _stx-list _literals . _matchers)
(filter (λ(stx-item)
(with-handlers ([exn:fail:syntax? (λ (exn) #f)])
(syntax-case stx-item _literals
. _matchers))) (check-syntax-list-argument 'syntax-case-filter _stx-list)))
(define-syntax-rule (syntax-case-map _stx-list _literals . _matchers)
(map (λ(stx-item)
(syntax-case stx-item _literals
. _matchers)) (check-syntax-list-argument 'syntax-case-map _stx-list)))
(define-syntax-rule (reformat-id fmt id0 id ...)
(format-id id0 fmt id0 id ...))
(define-syntax-rule (format-string fmt id0 id ...)
(datum->syntax id0 (format fmt (syntax->datum id0) (syntax->datum id) ...)))
(define-syntax-rule (->unsyntax x)
(if (syntax? x)
(syntax->datum x)
x))
(define-syntax-rule (prefix-id _prefix ... _base)
(format-id _base "~a~a" (string-append (format "~a" (->unsyntax _prefix)) ...) _base))
(define-syntax-rule (prefix-ids _prefix ... _bases)
(syntax-case-map _bases ()
[_base (prefix-id _prefix ... #'_base)]))
(define-syntax-rule (infix-id _prefix _base _suffix ...)
(format-id _base "~a~a~a" (->unsyntax _prefix) _base (string-append (format "~a" (->unsyntax _suffix)) ...)))
(define-syntax-rule (infix-ids _prefix _bases _suffix ...)
(syntax-case-map _bases ()
[_base (infix-id _prefix #'_base _suffix ...)]))
(define-syntax-rule (suffix-id _base _suffix ...)
(infix-id "" _base _suffix ...))
(define-syntax-rule (suffix-ids _bases _suffix ...)
(infix-ids "" _bases _suffix ...))
(define-syntax (syntax-property* stx)
(syntax-case stx (quote)
[(_ stx-object 'prop0)
#'(syntax-property stx-object 'prop0)]
[(_ stx-object 'prop0 'prop ...)
#'(cons (syntax-property stx-object 'prop0) (let ([result (syntax-property* stx-object 'prop ...)])
(if (pair? result)
result
(list result))))]
[(_ stx-object ['prop0 val0 . preserved0])
#'(syntax-property stx-object 'prop0 val0 . preserved0)]
[(_ stx-object ['prop0 val0 . preserved0] ['prop val . preserved] ...)
#'(syntax-property* (syntax-property stx-object '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)))