suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

moved out the syntax->string function

Browse Source 
svn: r1085
This commit is contained in:
Robby Findler 2005-10-14 18:38:10 +00:00
parent 0b12dcfd54
commit 07b3789f8b
3 changed files with 83 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
collects/slideshow/code.ss
View File

@ -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 ()

8
collects/syntax/doc.txt
View File

@ -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.

72
collects/syntax/to-string.ss Normal file
View File

@ -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))))