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.
146 lines
5.5 KiB
Racket
146 lines
5.5 KiB
Racket
#lang racket/base
|
|
(require (for-syntax
|
|
racket/base
|
|
br/private/generate-literals)
|
|
racket/list
|
|
racket/match
|
|
racket/syntax
|
|
racket/format
|
|
syntax/stx
|
|
syntax/strip-context
|
|
syntax/parse
|
|
br/define
|
|
br/private/syntax-flatten)
|
|
(provide (all-defined-out)
|
|
syntax-flatten
|
|
stx-map
|
|
strip-context ;; under both names
|
|
(rename-out [strip-context strip-bindings]
|
|
[replace-context replace-bindings]
|
|
[stx-map syntax-map]
|
|
[syntax-flatten stx-flatten]
|
|
[prefix-id prefix-ids]
|
|
[suffix-id suffix-ids]
|
|
[infix-id infix-ids]))
|
|
|
|
(module+ test (require rackunit))
|
|
|
|
|
|
(define-macro-cases syntax-parse/easy
|
|
[(_ STX [PAT . BODY] ... [else . ELSEBODY])
|
|
(with-syntax ([(PAT ...) (map (λ (stx) (literalize-pat stx #'~literal)) (syntax->list #'(PAT ...)))])
|
|
#'(syntax-parse (syntax-case STX () [any #'any])
|
|
[PAT . BODY] ... [else . ELSEBODY]))])
|
|
|
|
|
|
(define-macro-cases pattern-case
|
|
[(_ EXPR ... [else . ELSEBODY]) #'(syntax-parse/easy EXPR ...
|
|
[else . ELSEBODY])]
|
|
[(_ STX-ARG PAT+BODY ...)
|
|
#'(pattern-case STX-ARG
|
|
PAT+BODY ...
|
|
[else (raise-syntax-error 'pattern-case
|
|
(format "unable to match pattern for ~v" (syntax->datum STX-ARG)))])])
|
|
|
|
(module+ test
|
|
(define (pc stx)
|
|
(pattern-case stx
|
|
[(a 2ND c) #'2ND]
|
|
[(LEFT RIGHT) #'LEFT]
|
|
[(g) #'hooray]))
|
|
(check-equal? (syntax->datum (pc #'(a b c))) 'b)
|
|
(check-equal? (syntax->datum (pc #'(x y))) 'x)
|
|
(check-equal? (syntax->datum (pc #'(g))) 'hooray)
|
|
(check-exn exn:fail:syntax? (λ () (pc #'(f)))))
|
|
|
|
|
|
(define-macro (pattern-case-filter STX-ARG PAT+BODY ...)
|
|
#'(let* ([arg STX-ARG]
|
|
[stxs (or (and (syntax? arg) (syntax->list arg)) arg)])
|
|
(unless (and (list? stxs) (andmap syntax? stxs))
|
|
(raise-syntax-error 'pattern-case-filter
|
|
(format "~v cannot be made into a list of syntax objects" (syntax->datum arg))))
|
|
(for*/list ([stx (in-list stxs)]
|
|
[result (in-value (pattern-case stx PAT+BODY ... [else #f]))]
|
|
#:when result)
|
|
result)))
|
|
|
|
|
|
(module+ test
|
|
(define (pcf x)
|
|
(pattern-case-filter x
|
|
[(1ST 2ND 3RD) #'2ND]
|
|
[(LEFT RIGHT) #'LEFT]))
|
|
(check-equal? (map syntax-e (pcf #'((a b c) (x y) (f)))) '(b x)))
|
|
|
|
|
|
(define-macro-cases with-pattern
|
|
[(_ () . BODY) #'(begin . BODY)]
|
|
[(_ ([PAT0 STX0] PAT+STX ...) . BODY)
|
|
#'(syntax-parse/easy STX0
|
|
[PAT0 (with-pattern (PAT+STX ...) (let () (void) . BODY))]
|
|
[else (raise-syntax-error 'with-pattern
|
|
(format "unable to match pattern ~a" 'PAT0) STX0)])])
|
|
|
|
(module+ test
|
|
(check-equal? (syntax->datum (with-pattern ([foo 'foo])
|
|
#'zzz)) 'zzz)
|
|
(check-exn exn:fail:syntax? (λ () (with-pattern ([42 'foo])
|
|
#'zzz)))
|
|
(check-exn exn:fail:syntax? (λ () (with-pattern ([bar 'foo])
|
|
#'zzz)))
|
|
(check-equal? (syntax->datum (with-pattern ([(foo BAR) '(foo 42)])
|
|
#'BAR)) 42)
|
|
(check-exn exn:fail:syntax? (λ () (with-pattern ([(foo BAR) '(zam 42)])
|
|
#'BAR))))
|
|
|
|
|
|
(define-macro (format-string FMT ID0 ID ...)
|
|
#'(datum->syntax ID0 (format FMT (syntax->datum ID0) (syntax->datum ID) ...)))
|
|
|
|
(define (->unsyntax x) (if (syntax? x) (syntax->datum x) x))
|
|
|
|
(define (stx-join stxs)
|
|
(apply string-append (map (compose1 ~a ->unsyntax) stxs)))
|
|
|
|
(define (*fix-base loc-arg ctx-arg prefixes base-or-bases suffixes)
|
|
(define list-mode? (or (list? base-or-bases) (syntax->list base-or-bases)))
|
|
(define bases (if list-mode?
|
|
(or (syntax->list base-or-bases) base-or-bases)
|
|
(list base-or-bases)))
|
|
(define result (map (λ (base) (format-id (or ctx-arg base) "~a~a~a" (stx-join prefixes) (syntax-e base) (stx-join suffixes)
|
|
#:source loc-arg)) bases))
|
|
(if list-mode? result (car result)))
|
|
|
|
|
|
(define (prefix-id #:source [loc-arg #f] #:context [ctx-arg #f] . args)
|
|
((match-lambda
|
|
[(list prefixes ... base-or-bases)
|
|
(*fix-base loc-arg ctx-arg prefixes base-or-bases empty)]) args))
|
|
|
|
(define (infix-id #:source [loc-arg #f] #:context [ctx-arg #f] . args)
|
|
((match-lambda
|
|
[(list prefix base-or-bases suffixes ...)
|
|
(*fix-base loc-arg ctx-arg (list prefix) base-or-bases suffixes)]) args))
|
|
|
|
(define (suffix-id #:source [loc-arg #f] #:context [ctx-arg #f] . args)
|
|
((match-lambda
|
|
[(list base-or-bases suffixes ...)
|
|
(*fix-base loc-arg ctx-arg empty base-or-bases suffixes)]) args))
|
|
|
|
(module+ test
|
|
(define-check (check-stx-equal? stx1 stx2)
|
|
(define stxs (list stx1 stx2))
|
|
(apply equal? (map syntax->datum stxs)))
|
|
(check-stx-equal? (prefix-id "foo" "bar" #'id) #'foobarid)
|
|
(check-stx-equal? (infix-id "foo" #'id "bar" "zam") #'fooidbarzam)
|
|
(check-stx-equal? (suffix-id #'id "foo" "bar" "zam") #'idfoobarzam)
|
|
(for-each check-stx-equal? (suffix-id #'(this that) "@") (list #'this@ #'that@)))
|
|
|
|
|
|
(define (syntax-srcloc stx)
|
|
(srcloc (syntax-source stx)
|
|
(syntax-line stx)
|
|
(syntax-column stx)
|
|
(syntax-position stx)
|
|
(syntax-span stx))) |