diff --git a/beautiful-racket-lib/br/begin-label.rkt b/beautiful-racket-lib/br/begin-label.rkt deleted file mode 100644 index 883247b..0000000 --- a/beautiful-racket-lib/br/begin-label.rkt +++ /dev/null @@ -1,27 +0,0 @@ -#lang br -(require rackunit) -(provide (all-defined-out)) - -(define (syntax->source stx) - ;; reconstitute the source string by using srclocs - ;; magic goes here - stx) - -(define-macro (begin-label LABEL . EXPRS) - #'(begin - (define LABEL (syntax->source #'EXPRS)) - (provide LABEL) - (begin . EXPRS))) - -(begin-label - zing - (define (f x) - (+ x x)) - - (define (g x) - (* x x))) - -(display zing) - -(check-equal? (f 5) 10) -#;(check-equal? (g 5) 25) \ No newline at end of file diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index e4917bb..73ca511 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/beautiful-racket-lib/br/syntax.rkt @@ -1,6 +1,6 @@ #lang racket/base (require (for-syntax racket/base syntax/parse racket/syntax syntax/strip-context) - syntax/strip-context racket/function racket/list racket/syntax) + syntax/strip-context racket/function racket/list racket/syntax br/to-string) (provide (all-defined-out) (all-from-out syntax/strip-context)) (module+ test @@ -141,4 +141,23 @@ (define maybe-list (syntax->list stx)) (if maybe-list (map loop maybe-list) - stx)))) \ No newline at end of file + stx)))) + +(define-syntax-rule (begin-label LABEL . EXPRS) + (begin + (define LABEL (syntax->string #'EXPRS)) + (provide LABEL) + (begin . EXPRS))) + +(module+ test + (begin-label + zing + (define (f x) + [+ x x]) + + (define (g x) + (* x x))) + + (check-equal? zing "(define (f x)\n [+ x x])\n\n(define (g x)\n (* x x))") + (check-equal? (f 5) 10) + (check-equal? (g 5) 25)) \ No newline at end of file diff --git a/beautiful-racket-lib/br/to-string.rkt b/beautiful-racket-lib/br/to-string.rkt new file mode 100644 index 0000000..ec3e840 --- /dev/null +++ b/beautiful-racket-lib/br/to-string.rkt @@ -0,0 +1,92 @@ +#lang racket/base +(require racket/contract/base + syntax/stx) + +(require racket/list) + +(define (syntax->string c) + (let* ([s (open-output-string)] + [l (syntax->list c)] + [init-col (or (syntax-column (first l)) 0)] + [col init-col] + [line (or (syntax-line (first l)) 0)]) + (define (advance c init-line!) + (let ([c (syntax-column c)] + [l (syntax-line c)]) + (when (and l (l . > . line)) + (for-each (λ (_) (newline)) (range (- l line))) + (set! line l) + (init-line!)) + (when c + (display (make-string (max 0 (- c col)) #\space)) + (set! col c)))) + (parameterize ([current-output-port s] + [read-case-sensitive #t]) + (define (loop init-line!) + (lambda (c) + (cond + [(eq? 'code:blank (syntax-e c)) + (advance c init-line!)] + [(eq? '_ (syntax-e c)) (void)] + [(eq? '... (syntax-e c)) + (void)] + [(and (pair? (syntax-e c)) + (eq? (syntax-e (car (syntax-e c))) 'code:comment)) + (advance c init-line!) + (printf "; ") + (display (syntax-e (cadr (syntax->list c))))] + [(and (pair? (syntax-e c)) + (eq? (syntax-e (car (syntax-e c))) 'code:contract)) + (advance c init-line!) + (printf "; ") + (let* ([l (cdr (syntax->list c))] + [s-col (or (syntax-column (first l)) col)]) + (set! col s-col) + (for-each (loop (lambda () + (set! col s-col) + (printf "; "))) + l))] + [(and (pair? (syntax-e c)) + (eq? (syntax-e (car (syntax-e c))) 'quote)) + (advance c init-line!) + (printf "'") + (let ([i (cadr (syntax->list c))]) + (set! col (or (syntax-column i) col)) + ((loop init-line!) i))] + [(pair? (syntax-e c)) + (advance c init-line!) + (define c-paren-shape (syntax-property c 'paren-shape)) + (printf (format "~a" (or c-paren-shape #\())) + (set! col (+ col 1)) + (map (loop init-line!) (syntax->list c)) + (printf (case c-paren-shape + [(#\[) "]"] + [(#\{) "}"] + [else ")"])) + (set! col (+ col 1))] + [(vector? (syntax-e c)) + (advance c init-line!) + (printf "#(") + (set! col (+ col 2)) + (map (loop init-line!) (vector->list (syntax-e c))) + (printf ")") + (set! col (+ col 1))] + [else + (advance c init-line!) + (let ([s (format "~s" (syntax-e c))]) + (set! col (+ col (string-length s))) + (display s))]))) + (for-each (loop (lambda () (set! col init-col))) l)) + (get-output-string s))) + +(provide/contract [syntax->string (-> (and/c syntax? stx-list?) + string?)]) + +(module+ test + (require rackunit) + (check-equal? (syntax->string + #'((define (f x) + [+ x x]) + + (define (g x) + (* x x)))) "(define (f x)\n [+ x x])\n\n(define (g x)\n (* x x))"))