Gauche:PrettyPrint

Gauche:PrettyPrint

cut-sea, 等で話題になってますが、 他にもリクエストを受けたことがあるので。

Gauche標準のpretty printerが未だに無い(言い)訳

Shiro: Gauche標準としてサポートするからには、ユーザ定義データ型の 出力もpretty printされて欲しいと思っています。仕様としてはCommon Lispという 先例があるので、ベターな仕様が思い付かなければそれに倣えば良いのですが、 ちょっとまとまった時間を取って取り組まなくちゃならないので後回しに なってます。

そこまで考慮した実装をしてくれる方がいたら大歓迎。ただ、再帰的なwrite の流れの中でコンテキストを受渡してゆく、という処理はpretty printだけでなく write/ss等、他にも出てくるので、それらをすっきりと扱えるような仕組みから 考えるとなると、write.cのアーキテクチャの改良を含めた実装とならざるを 得ないでしょう。

Gaucheで使えるpretty printerの情報

Feeley's pp.scm

手を加えずにload可能 -> http://ftp.cs.indiana.edu/pub/scheme-repository/code/string/pp.scm

SLIB の pretty-print

(use slib)

(require 'pretty-print)

(pretty-print s)

Gauche:WadlersPrettierPrinterLibrary

WadlerのHaskellによる解説をSchemeにて実装。

Gauche:text.prettyprint

Haskellのtext.prettyprintの移植。

自作なんちゃって pp を貼付ける。

ちゃんとした物は難しい。でも長ーい S 式を気軽に見やすく表示したい。そんなニーズは誰もがもつし、 プログラミングの課題としても面白いかも。十分に短ければソースを書き換えるという究極の カスタマイズも可能。というわけで、元ネタとしても役に立つかも。

skimu

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

いわた(hiraさん改良)版

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

hira

Kispでpretty printerを書いていらっしゃいます: pretty-print.scm

leque

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


Last modified : 2013/04/27 21:54:40 UTC