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

96 lines
3.7 KiB
Racket

9 years ago
#lang racket/base
(require (for-syntax
racket/base
racket/syntax
br/private/generate-literals)
8 years ago
racket/list
8 years ago
racket/match
8 years ago
racket/syntax
8 years ago
racket/format
syntax/stx
syntax/strip-context
8 years ago
br/define
br/private/syntax-flatten)
(provide (all-defined-out)
syntax-flatten
8 years ago
stx-map
(rename-out [strip-context strip-bindings]
8 years ago
[replace-context replace-bindings]
8 years ago
[stx-map syntax-map]
[syntax-flatten stx-flatten]
[prefix-id prefix-ids]
[suffix-id suffix-ids]
[infix-id infix-ids]))
9 years ago
(module+ test
(require rackunit))
9 years ago
8 years ago
(define-macro-cases case-pattern
[(_ STX-ARG
8 years ago
[PAT . BODY] ...
[else . ELSEBODY]) (with-syntax ([(LITERAL ...) (generate-literals #'(PAT ...))])
#'(syntax-case STX-ARG (LITERAL ...)
8 years ago
[PAT . BODY] ...
[else . ELSEBODY]))]
[(_ STX-ARG
8 years ago
PAT+BODY ...) #'(case-pattern STX-ARG
PAT+BODY ...
[else (raise-syntax-error 'case-pattern
(format "unable to match pattern for ~v" (syntax->datum STX-ARG)))])])
8 years ago
(define-macro-cases with-pattern
[(_ () . BODY) #'(begin . BODY)]
[(_ ([PAT0 STX0] PAT+STX ...) . BODY)
(with-syntax ([(LITERAL ...) (generate-literals #'PAT0)])
#'(syntax-case STX0 (LITERAL ...)
[PAT0 (with-pattern (PAT+STX ...) (let () . BODY))]
[else (raise-syntax-error 'with-pattern
(format "unable to match pattern ~a" 'PAT0) STX0)]))])
8 years ago
8 years ago
(define-macro (format-string FMT ID0 ID ...)
#'(datum->syntax ID0 (format FMT (syntax->datum ID0) (syntax->datum ID) ...)))
9 years ago
8 years ago
(define (->unsyntax x) (if (syntax? x) (syntax->datum x) x))
9 years ago
(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)))
8 years ago
(define (stx-join stxs) (apply string-append (map (compose1 ~a ->unsyntax) stxs)))
(define result (map (λ (base) (format-id (or ctx-arg base) "~a~a~a" (stx-join prefixes) (syntax-e base) (stx-join suffixes)
8 years ago
#:source loc-arg)) bases))
(if list-mode? result (car result)))
8 years ago
(define (prefix-id #:source [loc-arg #f] #:context [ctx-arg #f] . args)
8 years ago
((match-lambda
[(list prefixes ... base-or-bases)
(*fix-base loc-arg ctx-arg prefixes base-or-bases empty)]) args))
8 years ago
(define (infix-id #:source [loc-arg #f] #:context [ctx-arg #f] . args)
8 years ago
((match-lambda
[(list prefix base-or-bases suffixes ...)
(*fix-base loc-arg ctx-arg (list prefix) base-or-bases suffixes)]) args))
8 years ago
(define (suffix-id #:source [loc-arg #f] #:context [ctx-arg #f] . args)
8 years ago
((match-lambda
[(list base-or-bases suffixes ...)
(*fix-base loc-arg ctx-arg empty base-or-bases suffixes)]) args))
8 years ago
(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@)))
8 years ago
8 years ago
(define (syntax-srcloc stx)
(srcloc (syntax-source stx)
(syntax-line stx)
(syntax-column stx)
(syntax-position stx)
(syntax-span stx)))