参考文献) Philip Wadler, A prettier printer, March 1998( prettier.pdf)
関連
WadlerのHaskellによる解説をSchemeにて実装。
これがHaskellの勉強になったのは皮肉というかなんというか。。。
まずHaskellで実装してみて確認。
次に本題のSchemeでの実装なんだけど、
そのまま移植したら、lazyじゃなかったので激重でとても使いものにならなかった。
宿題になったlazy化をしたので実用に耐えそうな感じです。cut-sea:2007/07/09 08:42:27 PDT
;;;
;;; ppr - pretty print library.
;;;
;;; Copyright (c) 2007 Katsutoshi Itoh <cut-sea@master.email.ne.jp>
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;;
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;;
;;; 3. Neither the name of the authors nor the names of its contributors
;;; may be used to endorse or promote products derived from this
;;; software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;
;;; $Id$
;;;
(define-module ppr
(use srfi-13)
(use util.match)
(use util.stream)
(use text.tree)
(export
++
beside
nest
text
line
above
nil
group
flatten
layout
copy
best
better
fits
pretty
beside-by-space
above-by-newline
folddoc
spread
stack
bracket
beside/above-by-space/newline
words
fillwords
fill
;; aliases
<> <+> </> <+/>
)
)
(select-module ppr)
(define ++ string-append)
;; DOC
(define NIL 'NIL)
;; (<>),(:<>) :: DOC -> DOC -> DOC
(define (beside x y) (stream-delay (list 'BESIDE x y)))
(define (nest i d) (stream-delay (list 'NEST i d)))
(define (text s) (stream-delay (list 'TEXT s)))
(define LINE 'LINE)
(define line LINE)
;; (:<|>) :: DOC -> DOC -> DOC
(define (above x y) (stream-delay (list 'ABOVE x y)))
;; Doc
(define Nil 'Nil)
;; Text :: String -> Doc -> Doc
(define (Text s d) (stream-delay (list 'Text s d)))
;; Line :: Int -> Doc -> Doc
(define (Line i d) (stream-delay (list 'Line i d)))
;; nil :: DOC
(define nil NIL)
;; group :: DOC -> DOC
(define (group x) (stream-delay (above (flatten x) x)))
;; flatten ;; DOC -> DOC
(define (flatten xs)
(match (force xs)
('NIL 'NIL)
(('BESIDE x y) (beside (flatten x) (flatten y)))
(('NEST i x) (nest i (flatten x)))
(('TEXT s) (text s))
('LINE (text " "))
(('ABOVE x y) (flatten x))))
;; layout :: Doc -> String
(define (layout xs)
(match (force xs)
('Nil "")
(('Text s x) (++ s (layout x)))
(('Line i x) (++ "\n" (copy i #\sp) (layout x)))))
(define copy make-string)
;; best :: Int -> Int -> DOC -> DOC
(define (best w k x) (be w k (stream-delay (list (cons 0 x)))))
;; be :: Int -> Int -> [(Int, DOC)] -> Doc
(define (be w k xs)
(define (force-pattern s)
(cons (cons (stream-caar s)
(force (stream-cdar s)))
(stream-cdr s)))
(match (force xs)
('() Nil)
(((i . 'NIL) . z) (be w k z))
(((i . 'LINE) . z) (Line i (be w i z)))
(else
(match (force-pattern xs)
(((i . ('BESIDE x y)) . z) (be w k `((,i . ,x) (,i . ,y) ,@z)))
(((i . ('NEST j x)) . z) (be w k `((,(+ i j) . ,x) ,@z)))
(((i . ('TEXT s)) . z) (Text s (stream-delay (be w (+ k (string-length s)) z))))
(((i . ('ABOVE x y)) . z) (better w k
(stream-delay (be w k `((,i . ,x) ,@z)))
(stream-delay (be w k `((,i . ,y) ,@z)))))))))
;; better :: Int -> Int -> Doc -> Doc -> Doc
(define (better w k x y) (if (fits (- w k) x) x y))
;; fits :: Int -> Doc -> Bool
(define (fits w xs)
(if (< w 0) #f
(match (force xs)
('Nil #t)
(('Text s x) (fits (- w (string-length s)) x))
(('Line i x) #t))))
;; pretty :: Int -> DOC -> String
(define (pretty w x)
(write-tree (layout (best w 0 x)))
(newline)
(values))
;; Utility function
;; (<+>) :: DOC -> DOC -> DOC
(define (beside-by-space x y) (stream-delay (beside x (beside (text " ") y))))
;; (</>) :: DOC -> DOC -> DOC
(define (above-by-newline x y) (stream-delay (beside x (beside LINE y))))
;; folddoc :: (DOC -> DOC -> DOC) -> [DOC] -> DOC
(define (folddoc f xs)
(match (force xs)
('() 'NIL)
((x) x)
((x . xs) (f x (folddoc f xs)))))
;; spread :: [DOC] -> DOC
(define (spread xs) (folddoc beside-by-space xs))
;; stack :: [DOC] -> DOC
(define (stack xs) (folddoc above-by-newline xs))
;; bracket :: String -> DOC -> String -> DOC
(define (bracket l x r)
(stream-delay
(group (beside (text l)
(beside (nest 2 (beside line x))
(beside line (text r)))))))
;; (<+/>) :: DOC -> DOC -> DOC
(define (beside/above-by-space/newline x y)
(stream-delay (beside x (beside (above (text " ") line) y))))
;; words :: String -> [String]
(define words string-tokenize)
;; fillwords :: String -> DOC
(define (fillwords ws)
(stream-delay
(folddoc beside/above-by-space/newline
(map text (words ws)))))
;; fill :: [DOC] -> DOC
(define (fill xs)
(match (force xs)
('() nil)
((x) x)
((x y . zs) (above (beside-by-space (flatten x)
(fill (cons (flatten y) zs)))
(above-by-newline x (fill (cons y zs)))))))
;; aliases
(define <> beside)
(define <+> beside-by-space)
(define </> above-by-newline)
(define <+/> beside/above-by-space/newline)
(provide "ppr")
;; END
;;
サンプルの動作確認をするには、まずppr.scmをuse可能な様にしてください。
その後でtree.scm,xml.scm,sexpr.scmをloadもしくは、
全ての式を評価して下さい。
あとは、(testtree 40)とか(testtree-bis 30)とか
(testXML 40)とか(testSexpr 40)とかすればプリティプリントされます。
数値はcolumn指定です。
それに応じて詰めあわされますが、そこはそれ、コードによりますので、
sexpr.scmとか私が書いたのはあんまprettyじゃないってことで。cut-sea:2007/07/09 08:56:05 PDT
tree.scmは論文中で紹介されている。 これが最初に動作した時は結構うれしかった。cut-sea:2007/07/09 08:48:33 PDT
;; Tree example
(use ppr)
(use util.match)
;; Tree
(define (Node s ts) (list 'Node s ts))
;; showTree :: Tree -> DOC
(define (showTree t)
(match t
(('Node s ts) (group (<> (text s)
(nest (string-length s)
(showBracket ts)))))))
;; showBracket :: [Tree] -> DOC
(define (showBracket ts)
(match ts
('() nil)
(ts (<> (text "[")
(<> (nest 1 (showTrees ts)) (text "]"))))))
;; showTrees :: [Tree] -> DOC
(define (showTrees ts)
(match ts
((t) (showTree t))
((t . ts) (<> (showTree t)
(<> (text ",")
(<> line
(showTrees ts)))))))
;; showTree-bis :: Tree -> DOC
(define (showTree-bis t)
(match t
(('Node s ts) (<> (text s) (showBracket-bis ts)))))
;; showBracket-bis :: [Tree] -> DOC
(define (showBracket-bis ts)
(match ts
('() nil)
(ts (bracket "[" (showTrees-bis ts) "]"))))
;; showTrees-bis :: [Tree] -> DOC
(define (showTrees-bis ts)
(match ts
((t) (showTree-bis t))
((t . ts) (<> (showTree-bis t)
(<> (text ",")
(<> line
(showTrees-bis ts)))))))
(define tree
(Node "aaa"
(list (Node "bbbbb"
(list (Node "ccc" [])
(Node "dd" [])))
(Node "eee" [])
(Node "ffff"
(list (Node "gg" [])
(Node "hhh" [])
(Node "ii" []))))))
;; execute
(define (testtree w)
(pretty w (showTree tree)))
(define (testtree-bis w)
(pretty w (showTree-bis tree)))
;; END Exapmles
;;
xml.scmも論文のサンプルだけど、sxml形式じゃないのが残念。 まぁたいした問題じゃない。cut-sea:2007/07/09 08:48:33 PDT
;; XML example
(use ppr)
(use util.match)
;; XML
(define (Elt tag atts xmls) (list tag atts xmls))
(define (Txt s) (list s))
(define (Att n v) (list n v))
;; showXML :: XML -> DOC
(define (showXML x)
(folddoc <> (showXMLs x)))
;; showXMLs :: XML -> [DOC]
(define (showXMLs ns)
(match ns
((t a '()) (list (<> (text "<")
(<> (showTag t a) (text "/>")))))
((t a c) (list
(<> (text "<")
(<> (showTag t a)
(<> (text ">")
(<> (showFill showXMLs c)
(<> (text "</")
(<> (text t)
(text ">")))))))))
((s) (map text (words s)))))
;; showAtts :: Att -> [DOC]
(define (showAtts attr)
(match attr
((n v) (list (<> (text n)
(<> (text "=")
(text (quoted v))))))))
;; quoted :: String -> String
(define (quoted s) #`"\",s\"")
;; showTag :: String -> [Att] -> DOC
(define (showTag n a) (beside (text n) (showFill showAtts a)))
;; showFill :: (a -> [DOC]) -> [a] -> DOC
(define (showFill f xs)
(match xs
('() nil)
(xs (bracket "" (fill (apply append (map f xs))) ""))))
(define xml
(Elt "p"
(list
(Att "color" "red")
(Att "font" "Times")
(Att "size" "10"))
(list
(Txt "Here is some")
(Elt "em" [] (list (Txt "emphasized")))
(Txt "text")
(Txt "Here is a")
(Elt "a"
(list (Att "href" "http://www.eg.com/"))
(list (Txt "link")))
(Txt "elsewhere."))))
;; execute
(define (testXML w)
(pretty w (showXML xml)))
;; END Exapmles
;;
sexpr.scmは自分で実装してみたものだけど、まるで良くないなぁ。 インデントも個別設定してないし、色々バグってそうだしー。 まだ使い方を勉強中なんで勘弁してちょ。cut-sea:2007/07/09 08:48:33 PDT
;; S Expression example
(use ppr)
(use util.match)
;; Sexpr
(define (nest-of sexpr)
(define (obj-length obj)
(cond ((string? obj) (+ 2 (string-length obj)))
(else (string-length (x->string obj)))))
(case sexpr
((quote quasiquote unquote) 1)
((unquote-splicing) 2)
((debug-print) 3)
(else (+ 2 (obj-length sexpr)))))
(define (macro-symbol? m)
(memq m
'(quote unquote quasiquote unquote-splicing debug-print)))
;; showSexpr :: Sexpr -> DOC
(define (showSexpr sexp)
(define (quoted s) #`"\",s\"")
(match sexp
((? list? l) (showList l))
((? vector? v) (showVector v))
((? string? s) (text (quoted s)))
(x (text (x->string x)))))
;; showList :: [Sexpr] -> DOC
(define (showList lst)
(match lst
('() (text "()"))
((x) (folddoc <> (list (text "(") (showSexpr x) (text ")"))))
(((? macro-symbol? m) x) (nest (nest-of m) (<> (showMacrotext m)
(showSexpr x))))
(((? symbol? x) . xs) (<> (text "(")
(nest (nest-of x) (<+/> (showSexpr x)
(<> (showSexprs xs)
(text ")"))))))
(((? list? x) . xs) (<> (text "(")
(nest 1 (<+/> (showSexpr x)
(<> (showSexprs xs)
(text ")"))))))
((x . xs) (<> (text "(")
(nest 1 (<+/> (showSexpr x)
(<> (showSexprs xs)
(text ")"))))))
))
;; showVector :: Vector -> DOC
(define (showVector v)
(<> (text "#")
(nest 1 (showList (vector->list v)))))
;; showSexprs :: [Sexpr] -> DOC
(define (showSexprs xs)
(fill (map showSexpr xs)))
(define (showMacrotext m)
(case m
((quote) (text "'"))
((quasiquote) (text "`"))
((unquote) (text ","))
((unquote-splicing) (text ",@"))
((debug-print) (text "#?="))
(else (error "illegal macro symbol found." m))))
;; sample data
(define sexpr
'(define (fact n)
(if (= n 0)
1
(* n (fact (- n 1))))))
(define sexpr
'(define (fact/cps n cont)
(if (= n 0)
(cont 1)
(fact/cps (- #?=n 1)
(lambda (a)
(cont (* n #?=a)))))))
(define sexpr
'(define-macro (while test . body)
`(do ()
((not ,test))
,@body)))
(define sexpr
'(define (make-counter n)
(define (plus n) (+ n 1))
(let ((c n))
(define (inc!)
(set! c (+ c 1)))
(define (dec!)
(set! c (- c 1)))
(lambda (msg)
(cond ((msg 'inc) (inc!))
((msg 'dec) (dec!))
(error "No Such command"))))))
;; execute
(define (testSexpr w)
(pretty w (showSexpr sexpr)))
;; END
;;
sexpr.scm中にあるサンプルsexprを途中でevalしています。
まだ、シンボル固有のインデントルールを入れるところまで実装してない。
ちなみにこいつで<+/>を使うとlazyじゃないpprだと劇的に重くなることが発覚した。
<+/>を使った瞬間にパターンが爆発するためと思われるが、
nobsunにはやーっぱりlazyじゃなきゃダメなんだよ!って笑われた。
やれば出来る子なんだよ。Schemeは！って言い切ってやったけど、 Festの最後にこれでハマってHaskellに心が行きそうになったのは内緒。(ｗ
gosh> sexpr
gosh> (testSexpr 40)
(define (fact n)
(if (= n 0) 1
(* n (fact (- n 1)))))
gosh> sexpr
gosh> (testSexpr 40)
(define (fact/cps n cont)
(if (= n 0) (cont 1)
(fact/cps (- #?=n 1)
(lambda (a)
(cont (* n
#?=a))))))
gosh> sexpr
gosh> (testSexpr 40)
(define-macro (while test . body)
`(do () ((not ,test))
,@body))
gosh> sexpr
gosh> (testSexpr 80)
(define (make-counter n) (define (plus n) (+ n 1))
(let ((c n)) (define (inc!) (set! c (+ c 1)))
(define (dec!) (set! c (- c 1)))
(lambda (msg)
(cond ((msg 'inc) (inc!)) ((msg 'dec) (dec!))
(error "No Such command")))))
gosh>
Tags: PrettyPrint, util.stream