diff --git a/collects/slideshow/code.ss b/collects/slideshow/code.ss index fb1ff75f5a..ae089e147d 100644 --- a/collects/slideshow/code.ss +++ b/collects/slideshow/code.ss @@ -2,7 +2,8 @@ (module code "slideshow.ss" (require (lib "code.ss" "texpict") (lib "unitsig.ss")) - (require-for-syntax (lib "list.ss")) + (require-for-syntax (lib "to-string.ss" "syntax") + (lib "list.ss")) (define-values/invoke-unit/sig code^ code@ @@ -95,70 +96,6 @@ empty l)) - (define (to-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)) - (newline) - (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!) - (printf "(") - (set! col (+ col 1)) - (map (loop init-line!) (syntax->list 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))) - (syntax-case stx () [(_ s (showable-name runnable-name string-name) . c) #`(begin @@ -172,7 +109,7 @@ #,@(drop-to-show (syntax->list #'c))) s)) (define string-name - #,(to-string #'c)))])) + #,(syntax->string #'c)))])) (define-syntax define-exec-code (syntax-rules () diff --git a/collects/syntax/doc.txt b/collects/syntax/doc.txt index 011ff1aa43..782371aa9d 100644 --- a/collects/syntax/doc.txt +++ b/collects/syntax/doc.txt @@ -525,3 +525,11 @@ less powerful code inspector to a sub-program should generally attach the class system work properly. +====================================================================== +_to-string.ss_: rendering syntax objects with formatting +====================================================================== + +> (syntax->string stx-list) - builds a string with newlines + and indenting according to the source locations in stx-list + + the outer pair of parens are not rendered from stx-list. diff --git a/collects/syntax/to-string.ss b/collects/syntax/to-string.ss new file mode 100644 index 0000000000..25eddb9298 --- /dev/null +++ b/collects/syntax/to-string.ss @@ -0,0 +1,72 @@ +(module to-string mzscheme + (require (lib "contract.ss") + (lib "stx.ss" "syntax")) + + (provide/contract [syntax->string (-> (and/c syntax? stx-list?) + string?)]) + + (require (lib "list.ss")) + + (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)) + (newline) + (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!) + (printf "(") + (set! col (+ col 1)) + (map (loop init-line!) (syntax->list 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)))) \ No newline at end of file