even better

dev-elider-3
Matthew Butterick 9 years ago
parent 912010a172
commit 92e7c30c28

@ -3,38 +3,30 @@
(provide (all-defined-out)) (provide (all-defined-out))
;; a little tricky because we have to mix two levels of macrology. (define-syntax-rule (br:debug-define (syntax (id pat-arg ... . rest-arg)) body-exp)
(define-syntax (br:debug-define stx) (br:define #'(id pat-arg ... . rest-arg)
(syntax-parse stx
#:literals (syntax)
[(_ (syntax (id pat-arg ... . rest-arg)) body-exp) ; (define #'(foo arg) #'(+ arg arg))
#'(define-syntax id (λ (stx)
(define result (syntax-case stx ()
[(_ pat-arg ... . rest-arg)
body-exp]))
(define arg-printing (syntax-case stx ()
[(_ pat-arg ... . rest-arg)
#`(begin #`(begin
(displayln (format "arg #'~a = ~a" #,''pat-arg pat-arg)) ...)])) (for-each displayln
(with-syntax ([syntaxed-arg-printing arg-printing] (list
[syntaxed-result result]) (format "input pattern = #'~a" '#,'(id pat-arg ... . rest-arg))
#'(begin (format "output pattern = #'~a" (cadr '#,'body-exp))
(displayln (format "input syntax = #'~a" (quote (id pat-arg ... . rest-arg)))) (format "invoked as = ~a" (syntax->datum #'(id pat-arg ... . rest-arg)))
(displayln (format "output syntax = #'~a" (syntax->datum body-exp))) (format "expanded as = ~a" '#,(syntax->datum body-exp))
syntaxed-arg-printing (format "evaluated as = ~a" #,body-exp)))
(displayln (format "expanded syntax = #'~a" 'syntaxed-result)) #,body-exp)))
syntaxed-result))))]))
(module+ test (module+ test
(require rackunit racket/port) (require rackunit racket/port)
(check-equal? (parameterize ([current-output-port (open-output-nowhere)]) (parameterize ([current-output-port (open-output-nowhere)])
(check-equal? (let ()
(br:debug-define #'(foo <x> <y> <z>) (br:debug-define #'(foo <x> <y> <z>)
#'(apply + (list <x> <y> <z>))) #'(apply + (list <x> <y> <z>)))
(foo 1 2 3)) 6)) (foo 1 2 3)) 6)
(check-equal? (let ()
(br:debug-define #'(foo <x> ...) #'(apply * (list <x> ...)))
(foo 10 11 12)) 1320)))
;; does not work with ellipses in the input pattern
#;(br:debug-define #'(foo <x> ...)
#'(apply + (list <x> ...)))
(define-syntax (br:define stx) (define-syntax (br:define stx)
(define-syntax-class syntaxed-id (define-syntax-class syntaxed-id

Loading…
Cancel
Save