cut-sea, び 等で話題になってますが、 他にもリクエストを受けたことがあるので。
Shiro: Gauche標準としてサポートするからには、ユーザ定義データ型の 出力もpretty printされて欲しいと思っています。仕様としてはCommon Lispという 先例があるので、ベターな仕様が思い付かなければそれに倣えば良いのですが、 ちょっとまとまった時間を取って取り組まなくちゃならないので後回しに なってます。
そこまで考慮した実装をしてくれる方がいたら大歓迎。ただ、再帰的なwrite の流れの中でコンテキストを受渡してゆく、という処理はpretty printだけでなく write/ss等、他にも出てくるので、それらをすっきりと扱えるような仕組みから 考えるとなると、write.cのアーキテクチャの改良を含めた実装とならざるを 得ないでしょう。
出力をpretty printするようにした。結局pretty printer書いちゃった。
手を加えずにload可能 -> http://ftp.cs.indiana.edu/pub/scheme-repository/code/string/pp.scm
(use slib) (require 'pretty-print) (pretty-print s)
WadlerのHaskellによる解説をSchemeにて実装。
Haskellのtext.prettyprintの移植。
ちゃんとした物は難しい。でも長ーい S 式を気軽に見やすく表示したい。そんなニーズは誰もがもつし、 プログラミングの課題としても面白いかも。十分に短ければソースを書き換えるという究極の カスタマイズも可能。というわけで、元ネタとしても役に立つかも。
(define pp-indent-level 2)
(define (pianissimo v)
(define (ff v n)
(let ((sp (make-string n #?space)))
(define (wri x) (display sp) (write x) (newline))
(define (dsp x) (display sp) (display x) (newline))
(for-each (lambda (x)
(if (pair? x)
(begin
(dsp "(")
(ff x (+ n pp-indent-level))
(dsp ")"))
(wri x)))
v)))
(newline)
(display "(")(newline)
(ff v pp-indent-level)
(display ")")(newline)
)
せっかくなのでわたしのもこちらに持ってきました。けっこう整形の好みがでますね(笑)。
(define (pretty-print-sexp s)
(define (do-indent level)
(dotimes (_ level) (write-char #?space)))
(define (pp-parenl)
(write-char #?())
(define (pp-parenr)
(write-char #?)))
(define (pp-atom e prefix)
(when prefix (write-char #?space))
(write e))
(define (pp-list s level prefix)
(and prefix (do-indent level))
(pp-parenl)
(let loop ((s s)
(prefix #f))
(if (null? s)
(pp-parenr)
(let1 e (car s)
(if (list? e)
(begin (and prefix (newline))
(pp-list e (+ level 1) prefix))
(pp-atom e prefix))
(loop (cdr s) #t)))))
(if (list? s)
(pp-list s 0 #f)
(write s))
(newline))
(define (tree->format-string tree)
(define indent 1)
(define (insert-space n)
(display (make-string n #?space)))
(define (format-one-list t n)
(display "(")
(let loop ((l t))
(cond ((null? l) (display ")"))
((list? (car l))
(format-one-list (car l) (+ n indent))
(unless (null? (cdr l)) (newline) (insert-space n))
(loop (cdr l)))
(else
(write (car l))
(cond ((null? (cdr l)))
((list? (cadr l)) (newline) (insert-space n))
(else (display " ")))
(loop (cdr l))))))
(with-output-to-string
(cut format-one-list tree indent)))
Kispでpretty printerを書いていらっしゃいます: pretty-print.scm。
Lindig の pretty printer の移植。
(define-module pp
(use srfi-1)
(use util.list)
(use util.match)
(use text.tree)
(export pretty-print
x->pp
))
(select-module pp)
;; <doc> =
;; | () (nil)
;; | "..." (text)
;; | #\newline (line)
;; | (<integer> <doc> ...) (nest)
;; | (group <doc> ...) (group)
;; | (<doc> ...) (cons)
(define (pp-fits? width xs)
(and (not (negative? width))
(match xs
(() #t)
(((i m ()) ys ...)
(pp-fits? width ys))
(((i m ('group doc ...)) ys ...)
(pp-fits? width (cons (list i 'flat doc) ys)))
(((i m ([? integer? j] x ...)) ys ...)
(pp-fits? width
(cons (list (+ i j) m x) ys)))
(((i m [? string? s]) ys ...)
(pp-fits? (- width (string-length s)) ys))
(((i 'flat #\newline) ys ...)
(pp-fits? (- width 1) ys))
(((i 'break #\newline) ys ...)
#t)
(((i m (y1 . ys)) zs ...)
(pp-fits? width
(cons* (list i m y1) (list i m ys) zs))))))
(define (pp-make-tree width k xs)
(match xs
(() "")
(((i m ()) ys ...)
(pp-make-tree width k ys))
(((i m ('group doc ...)) ys ...)
(let1 mode (if (pp-fits? (- width k) (cons (list i 'flat doc) ys))
'flat
'break)
(pp-make-tree width k (cons (list i mode doc) ys))))
(((i m ([? integer? j] x ...)) ys ...)
(pp-make-tree width k (cons (list (+ i j) m x) ys)))
(((i m [? string? s]) ys ...)
(cons s (pp-make-tree width (+ k (string-length s)) ys)))
(((i 'flat #\newline) ys ...)
(cons #\space (pp-make-tree width (+ k 1) ys)))
(((i 'break #\newline) ys ...)
(cons* #\newline (make-string i #\space) (pp-make-tree width i ys)))
(((i m (y1 . ys)) zs ...)
(pp-make-tree width k (cons* (list i m y1) (list i m ys) zs)))))
(define-method x->pp (obj)
(write-to-string obj))
(define-method x->pp ((xs <list>))
(match xs
(() "()")
(('quote obj)
(list "'" (x->pp obj)))
(('quasiquote obj)
(list "`" (x->pp obj)))
(('unquote obj)
(list "," (x->pp obj)))
(('unquote-splicing obj)
(list ",@" (x->pp obj)))
(('define (name&args ..1) body ..1)
`(group "(define " (group (8 ,@(x->pp name&args)))
(2 #\newline (group ,@(map x->pp body)))
")"))
(_
(let loop ((xs (cdr xs))
(rs (list (x->pp (car xs)))))
(cond ((null? xs)
`(group "(" (1 ,@(reverse rs)) ")"))
((pair? xs)
(loop (cdr xs) (cons* (x->pp (car xs)) #\newline rs)))
(else
(loop '() (cons* (x->pp xs) #\newline "." #\newline rs))))))))
(define-method x->pp ((v <vector>))
`(group "#(" (2 ,@(intersperse #\newline (map x->pp (vector->list v)))) ")"))
(define-method pretty-print (obj (port <port>) (width <integer>))
(%pp obj port width))
(define-method pretty-print (obj (port <port>))
(%pp obj port #f))
(define-method pretty-print (obj (width <integer>))
(%pp obj #f width))
(define-method pretty-print (obj)
(%pp obj #f #f))
(define (%pp obj port width)
(let1 p (or port (current-output-port))
(write-tree (pp-make-tree (or width 78) 0 `((0 flat ,(x->pp obj))))
p)
(newline p)))
(provide "pp")
Tag: PrettyPrint