Haskellのtext.prettyprintの移植。
Hugsのソースをまるごと持ってきたもの。
Gauche:WadlersPrettierPrinterLibrary同様、lazyにしてある。
関数の対応関係はヒマがあったら後日まとめるかもしれないけど、
こっちのがより実用的でしょう。
GaucheFestの時にはゲーッって思ったけど、Wadlerのを自分で拡張するよりは
移植する方が考えなくて済む分楽チンだったし使ってても安心感がある。cut-sea:2007/07/15 22:14:15 PDT
関連
gauche.ppとしてプリティプリンタが入ってましたが、0.9.6からオフィシャルに組み込みとする予定2017/08/11 09:10:39 UTC)
;;;
;;; text.prettyprint - pretty printer 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 text.prettyprint
(use srfi-13)
(use util.match)
(use util.stream)
(use text.tree)
(export
;; Doc
;; Constructiong documents
;; Converting values into documents
char text ptext
int integer float double rational
;; Simple derived documents
semi comma colon space equals
lparen rparen lbrack rbrack lbrace rbrace
;; Wrapping documents in delimiters
parens brackets braces quotes doubleQuotes
;; Combining documents
empty
<> <+> hcat hsep
$$ $+$ vcat
sep cat
fsep fcat
nest
hang punctuate
;; Predicates on documents
empty?
;; Rendering with a particular style
;; Style(..)
Style
style
mode
lineLength
ribbonsPerLine
renderStyle
;; General rendering
fullRender
;; Mode(..)
PageMode
ZigZagMode
LeftMode
OneLineMode
;; TextDetails(..)
Chr
Str
PStr
;; pretty-print
pretty-print
)
)
(select-module text.prettyprint)
;; Rendering mode
;; PageMode,ZigZagMode,LeftMode,OneLineMode :: Mode
(define PageMode 'PageMode)
(define ZigZagMode 'ZigZagMode)
(define LeftMode 'LeftMode)
(define OneLineMode 'OneLineMode)
;; A rendering style
;; Style :: Mode -> Int -> Float -> Style
(define (Style . args)
(let-keywords* args ((mode PageMode)
(lineLength 100)
(ribbonsPerLine 1.5))
(list 'Style mode lineLength ribbonsPerLine)))
;; mode :: Style -> Mode
(define (mode s) (cadr s))
;; lineLength :: Style -> Int
(define (lineLength s) (caddr s))
;; ribbonsPerLine :: Style -> Float
(define (ribbonsPerLine s) (cadddr s))
;; The default style
;; style :: Style
(define style (Style :mode PageMode
:lineLength 100
:ribbonsPerLine 1.5))
;; The Doc calculus
;; Empty :: Doc
(define Empty 'Empty)
;; NilAbove :: Doc -> Doc
(define (NilAbove d) (stream-delay (list 'NilAbove d)))
;; TextBeside :: Int -> Doc -> Doc
(define (TextBeside td n d) (stream-delay (list 'TextBeside td n d)))
;; Nest :: Int -> Doc -> Doc
(define (Nest n d) (stream-delay (list 'Nest n d)))
;; Union :: Doc -> Doc -> Doc
(define (Union x y) (stream-delay (list 'Union x y)))
;; NoDoc :: Doc
(define NoDoc 'NoDoc)
;; Beside :: Doc -> Bool -> Doc -> Doc
(define (Beside x b y) (stream-delay (list 'Beside x b y)))
;; Above :: Doc -> Bool -> Doc -> Doc
(define (Above x b y) (stream-delay (list 'Above x b y)))
;; reduceDoc :: Doc -> Doc
(define (reduceDoc p)
(match (force p)
(('Beside p g q) (stream-delay (beside p g (reduceDoc q))))
(('Above p g q) (stream-delay (above p g (reduceDoc q))))
(else p)))
;; TextDetails
;; Chr, Str, PStr :: String -> TextDetails
(define (Chr c) (stream-delay (list 'Chr c)))
(define (Str s) (stream-delay (list 'Str s)))
(define (PStr s) (stream-delay (list 'PStr s)))
;; pace_text, nl_text :: TextDetails
(define space_text (Chr " "))
(define nl_text (Chr "\n"))
;; nilAbove_ :: Doc -> Doc
(define (nilAbove_ p) (stream-delay (NilAbove p)))
;; textBeside_ :: TextDetails -> Int -> Doc -> Doc
(define (textBeside_ s sl p) (stream-delay (TextBeside s sl p)))
;; nest_ :: Int -> Doc -> Doc
(define (nest_ k p) (stream-delay (Nest k p)))
;; union_ :: Doc -> Doc -> Doc
(define (union_ p q) (stream-delay (Union p q)))
;; empty :: Doc
(define empty 'Empty)
;; empty? :: Doc -> Bool
(define (empty? Doc) (eq? empty (force Doc)))
;; char, text, ptext :: String -> Doc
(define (char c) (stream-delay (textBeside_ (Chr c) 1 Empty)))
(define (text s) (stream-delay (textBeside_ (Str s) (string-length s) Empty)))
(define (ptext s) (stream-delay (textBeside_ (PStr s) (string-length s) Empty)))
;; semi, colon, comma, space, equals :: Doc
;; lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
(define semi (char ";"))
(define colon (char ":"))
(define comma (char ","))
(define space (char " "))
(define equals (char "="))
(define lparen (char "("))
(define rparen (char ")"))
(define lbrack (char "["))
(define rbrack (char "]"))
(define lbrace (char "{"))
(define rbrace (char "}"))
;; int, integer, float, double, rational :: Number -> Doc
(define (int n) (text (x->string n)))
(define (integer n) (text (x->string n)))
(define (float n) (text (x->string n)))
(define (double n) (text (x->string n)))
(define (rational n) (text (x->string n)))
;; quotes, doubleQuotes, parens, brackets, braces :: Doc -> Doc
(define (quotes p) (stream-delay (<> (char "'") (<> p (char "'")))))
(define (doubleQuotes p) (stream-delay (<> (char "\"") (<> p (char "\"")))))
(define (parens p) (stream-delay (<> (char "(") (<> p (char ")")))))
(define (brackets p) (stream-delay (<> (char "[") (<> p (char "]")))))
(define (braces p) (stream-delay (<> (char "{") (<> p (char "}")))))
;; hcat, hsep, vcat :: [Doc] -> Doc
(define (hcat docs)
(stream-delay (fold-right <> empty docs)))
(define (hsep docs)
(stream-delay (fold-right <+> empty docs)))
(define (vcat docs)
(stream-delay (fold-right $$ empty docs)))
;; hang :: Doc -> Int -> Doc -> Doc
(define (hang d1 n d2) (stream-delay (sep (list d1 (nest n d2)))))
;; punctuate :: Doc -> [Doc] -> [Doc]
(define (punctuate p d:ds)
(define (go d e:es)
(match (force e:es)
('() (stream-delay (list d)))
((e . es) (stream-delay (cons (<> d p) (go e es))))))
(match (force d:ds)
('() '())
((d . ds) (stream-delay (go d ds)))))
;; nest :: Int -> Doc -> Doc
(define (nest k p) (stream-delay (mkNest k (reduceDoc p))))
;; mkNest :: Int -> Doc -> Doc
(define (mkNest k p)
;; force k
(match (force p)
(('Nest k1 p) (stream-delay (mkNest (+ k k1) p)))
('NoDoc NoDoc)
('Empty Empty)
(else (if (zero? k) p
(stream-delay (nest_ k p))))))
;; mkUnion checks for an empty document
;; mkUnion :: Doc -> Doc -> Doc
(define (mkUnion p q)
(if (empty? p) Empty (stream-delay (union_ p q))))
;; Vertical composition @$$@
;; above_ :: Doc -> Bool -> Doc -> Doc
(define (above_ p g q)
(cond ((empty? q) p)
((empty? p) q)
(else (stream-delay (Above p g q)))))
;; ($$), ($+$) :: Doc -> Doc -> Doc
(define ($$ p q) (stream-delay (above_ p #f q)))
(define ($+$ p q) (stream-delay (above_ p #t q)))
;; above :: Doc -> Bool -> RDoc -> RDoc
(define (above p g q)
(match (force p)
(('Above p g1 q1) (stream-delay (above p g1 (above q1 g q))))
(('Beside _ _ _) (stream-delay (aboveNest (reduceDoc p) g 0 (reduceDoc q))))
(else (stream-delay (aboveNest p g 0 (reduceDoc q))))))
;; aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
(define (aboveNest p g k q)
;; force k
(match (force p)
('NoDoc NoDoc)
(('Union p1 p2) (stream-delay (union_ (aboveNest p1 g k q)
(aboveNest p2 g k q))))
('Empty (stream-delay (mkNest k q)))
(('Nest k1 p) (stream-delay (nest_ k1 (aboveNest p g (- k k1) q))))
(('NilAbove p) (stream-delay (nilAbove_ (aboveNest p g k q))))
(('TextBeside s sl p) (stream-delay (let* ((k1 (- k sl))
(rest (if (empty? p) (nilAboveNest g k1 q)
(aboveNest p g k1 q))))
;; force k1
(textBeside_ s sl rest))))))
;; spaces (Num a, Ord a) => a -> String
(define (spaces n)
(if (<= n 0) "" (make-string n)))
;; nilAboveNest :: Bool -> Int -> RDoc -> RDoc
(define (nilAboveNest g k q)
;; force k
(match (force q)
('Empty Empty)
(('Nest k1 q) (stream-delay (nilAboveNest g (+ k k1) q)))
(else (stream-delay (if (and (not g) (> k 0))
(textBeside_ (Str (spaces k)) k q)
(nilAbove_ (mkNest k q)))))))
;; beside_ :: Doc -> Bool -> Doc -> Doc
(define (beside_ p g q)
(cond ((empty? q) p)
((empty? p) q)
(else (stream-delay (Beside p g q)))))
;; (<>), (<+>) :: Doc -> Doc -> Doc
(define (<> p q) (stream-delay (beside_ p #f q)))
(define (<+> p q) (stream-delay (beside_ p #t q)))
;; beside :: Doc -> Bool -> RDoc -> RDoc
(define (beside p g q)
(match (force p)
('NoDoc NoDoc)
(('Union p1 p2) (stream-delay (union_ (beside p1 g q) (beside p2 g q))))
('Empty q)
(('Nest k p) (stream-delay (nest_ k (beside p g q))))
(('Beside p1 g1 q1) (stream-delay (if (eq? g1 g)
(beside p1 g1 (beside q1 g q))
(beside (reduceDoc p) g q))))
(('Above _ _ _) (stream-delay (beside (reduceDoc p) g q)))
(('NilAbove p) (stream-delay (nilAbove_ (beside p g q))))
(('TextBeside s sl p) (stream-delay (let1 rest (if (empty? p)
(nilBeside g q)
(beside p g q))
(textBeside_ s sl rest))))))
;; nilBeside :: Bool -> RDoc -> RDoc
(define (nilBeside g p)
(match (force p)
('Empty Empty)
(('Nest _ p) (stream-delay (nilBeside g p)))
(else (stream-delay (if g (textBeside_ space_text 1 p) p)))))
;; sep, cat :: [Doc] -> Doc
(define (sep docs) (stream-delay (sepX #t docs)))
(define (cat docs) (stream-delay (sepX #f docs)))
;; sepX :: Bool -> [Doc] -> Doc
(define (sepX x p:ps)
(match (force p:ps)
('() empty)
((p . ps) (stream-delay (sep1 x (reduceDoc p) 0 ps)))))
;; sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
(define (sep1 g p k ys)
;; force k
(match (force p)
('NoDoc NoDoc)
(('Union p q) (stream-delay (union_ (sep1 g p k ys)
(aboveNest q #f k (reduceDoc (vcat ys))))))
('Empty (stream-delay (mkNest k (sepX g ys))))
(('Nest n p) (stream-delay (nest_ n (sep1 g p (- k n) ys))))
(('TextBeside s sl p) (stream-delay (textBeside_ s sl (sepNB g p (- k sl) ys))))))
;; sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
(define (sepNB g p k ys)
(match (force p)
(('Nest _ p) (stream-delay (sepNB g p k ys)))
('Empty (stream-delay (let1 rest (if g (hsep ys) (hcat ys))
(mkUnion (oneLiner (nilBeside g (reduceDoc rest)))
(nilAboveNest #f k (reduceDoc (vcat ys)))))))
(else (stream-delay (sep1 g p k ys)))))
;; fsep, fcat :: [Doc] -> Doc
(define (fsep docs) (stream-delay (fill #t docs)))
(define (fcat docs) (stream-delay (fill #f docs)))
;; fill :: Bool -> [Doc] -> RDoc
(define (fill g p:ps)
(match (force p:ps)
('() empty)
((p . ps) (stream-delay (fill1 g (reduceDoc p) 0 ps)))))
;; fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
(define (fill1 g p k ys)
;; force k
(match (force p)
('NoDoc NoDoc)
(('Union p q) (stream-delay (union_ (fill1 g p k ys)
(aboveNest q #f k (fill g ys)))))
('Empty (stream-delay (mkNest k (fill g ys))))
(('Nest n p) (stream-delay (nest_ n (fill1 g p (- k n) ys))))
(('NilAbove p) (stream-delay (nilAbove_ (aboveNest p #f k (fill g ys)))))
(('TextBeside s sl p) (stream-delay (textBeside_ s sl (fillNB g p (- k sl) ys))))))
;; fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
(define (fillNB g p k ys)
;; force k
(match (force p)
(('Nest _ p) (stream-delay (fillNB g p k ys)))
('Empty (match (force ys)
('() Empty)
((y . ys) (stream-delay (let1 k1 (if g (- k 1) k)
(mkUnion (nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys))
(nilAboveNest #f k (fill g (cons y ys)))))))))
(else (stream-delay (fill1 g p k ys)))))
;; Selecting the best layout
;; best :: Mode -> Int -> Int -> RDoc -> RDoc
(define (best mode w r p)
(cond ((eq? mode OneLineMode)
(letrec ((get (lambda (p)
(match (force p)
('Empty Empty)
('NoDoc NoDoc)
(('NilAbove p) (stream-delay (nilAbove_ (get p))))
(('TextBeside s sl p) (stream-delay (textBeside_ s sl (get p))))
(('Nest k p) (stream-delay (get p)))
(('Union p q) (stream-delay (first (get p) (get q))))))))
(get p)))
(else
(letrec ((get (lambda (w p)
;; force w==0
(match (force p)
('Empty Empty)
('NoDoc NoDoc)
(('NilAbove p) (stream-delay (nilAbove_ (get w p))))
(('TextBeside s sl p) (stream-delay (textBeside_ s sl (get1 w sl p))))
(('Nest k p) (stream-delay (nest_ k (get (- w k) p))))
(('Union p q) (stream-delay (nicest w r (get w p) (get w q)))))))
(get1 (lambda (w sl p)
;; force w==0
(match (force p)
('Empty Empty)
('NoDoc NoDoc)
(('NilAbove p) (stream-delay (nilAbove_ (get (- w sl) p))))
(('TextBeside t tl p) (stream-delay (textBeside_ t tl (get1 w (+ sl tl) p))))
(('Nest k p) (stream-delay (get1 w sl p)))
(('Union p q) (stream-delay (nicest1 w r sl (get1 w sl p) (get1 w sl q))))))))
(get w p)))))
;; nicest :: Int -> Int -> Doc -> Doc -> Doc
(define (nicest w r p q) (stream-delay (nicest1 w r 0 p q)))
;; nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
(define (nicest1 w r sl p q)
(if (fits (- (minn w r) sl) p) p q))
;; fits :: Int -> Doc -> Bool
(define (fits n p)
(if (< n 0) #f
(match (force p)
('NoDoc #f)
('Empty #t)
(('NilAbove _) #t)
(('TextBeside _ sl p) (fits (- n sl) p)))))
;; minn :: (Ord a) => a -> a -> a
(define (minn x y) (if (< x y) x y))
;; first :: Doc -> Doc -> Doc
(define (first p q) (if (nonEmptySet p) p q))
;; nonEmptySet :: Doc -> Bool
(define (nonEmptySet p)
(match (force p)
('NoDoc #f)
(('Union p q) #t)
('Empty #t)
(('NilAbove p) #t)
(('TextBeside _ _ p) (nonEmptySet p))
(('Nest _ p) (nonEmptySet p))))
;; oneLiner :: Doc -> Doc
(define (oneLiner p)
(match (force p)
('NoDoc NoDoc)
('Empty Empty)
(('NilAbove p) NoDoc)
(('TextBeside s sl p) (stream-delay (textBeside_ s sl (oneLiner p))))
(('Nest k p) (stream-delay (nest_ k (oneLiner p))))
(('Union p q) (stream-delay (oneLiner p)))))
;; Display the best layout
;; renderStyle :: Style -> Doc -> String
(define (renderStyle style doc)
(fullRender (mode style)
(lineLength style)
(ribbonsPerLine style)
string_txt
""
doc))
;; render :: Doc -> String
(define (render doc) (showDoc doc ""))
;; showDoc :: Doc -> String -> String
(define (showDoc doc rest) (fullRender PageMode 100 1.5 string_txt rest doc))
;; (++) :: String -> String -> String
(define ++ string-append)
;; string_txt :: TextDetails -> String -> String
(define (string_txt p s)
(match (force p)
(('Chr c) (++ c s))
(('Str s1) (++ s1 s))
(('PStr s1) (++ s1 s))))
;; fromIntegral :: (Num b, Integral) => a -> b
(define (fromIntegral n) (x->number n))
;; quot :: (Integral a) => a -> a -> a
(define (quot n m) (floor (/ n m)))
;; fullRender :: Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc -> a
(define (fullRender mode line_length ribbons_per_line txt end doc)
(cond ((eq? mode OneLineMode) (easy_display space_text txt end (reduceDoc doc)))
((eq? mode LeftMode) (easy_display nl_text txt end (reduceDoc doc)))
(else
(letrec ((hacked_line_length (if (eq? mode ZigZagMode)
#i1/0 ;;maxBound
line_length))
(ribbon_length (round (/ (fromIntegral line_length) ribbons_per_line)))
(best_doc (best mode hacked_line_length ribbon_length (reduceDoc doc))))
(display mode line_length ribbon_length txt end best_doc)))))
;; display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
(define (display mode page_width ribbon_width txt end doc)
(let* ((gap_width (- page_width ribbon_width))
(shift (quot gap_width 2)))
(letrec ((lay (lambda (k p)
;; force k
(match (force p)
(('Nest k1 p) (lay (+ k k1) p))
('Empty end)
(('NilAbove p) (txt nl_text (lay k p)))
(('TextBeside s sl p)
(case mode
((ZigZagMode) (cond ((>= k gap_width)
(txt nl_text
(txt (Str (multi_ch shift "/"))
(txt nl_text
(lay1 (- k shift) s sl p)))))
((< k 0)
(txt nl_text
(txt (Str (multi_ch shift "\\"))
(txt nl_text
(lay1 (+ k shift) s sl p)))))
(else (lay1 k s sl p))))
(else (lay1 k s sl p)))))))
(lay1 (lambda (k s sl p)
;; force (+ k sl)
(txt (Str (indent k))
(txt s (lay2 (+ k sl) p)))))
(lay2 (lambda (k p)
;; force k
(match (force p)
(('NilAbove p) (txt nl_text (lay k p)))
(('TextBeside s sl p) (txt s (lay2 (+ k sl) p)))
(('Nest _ p) (lay2 k p))
('Empty end)))))
(lay 0 doc))))
;; cant_fail :: a
(define (cant_fail) (error "easy_display: NoDoc"))
;; easy_display :: TextDetails -> (TextDetails -> a -> a) -> a -> Doc -> a
(define (easy_display nl_text txt end doc)
(letrec ((lay (lambda (p no_doc)
(match (force p)
('NoDoc no_doc)
(('Union p q) (lay q cant_fail))
(('Nest k p) (lay p no_doc))
('Empty end)
(('NilAbove p) (txt nl_text (lay p cant_fail)))
(('TextBeside s sl p) (txt s (lay p no_doc)))))))
(lay doc cant_fail)))
;; indent :: (Ord a, Num a) => a -> String
(define indent spaces)
;; multi_ch :: (Num t) => t -> String -> String
(define (multi_ch n ch)
(if (zero? n) "" #`",ch,(multi_ch (- n 1) ch)"))
;; non-original API
(define (pretty-print doc . args)
(let-keywords* args ((style style))
(write-tree (renderStyle style doc))
(newline)
(values)))
(provide "text.prettyprint")
;; EOF
;;
;;;
;;; tree - pretty print example.
;;;
;;; 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$
;;;
;; Tree example
(use text.prettyprint)
(use util.match)
;; Tree
(define (Node s ts) (list 'Node s ts))
;; showTree :: Tree -> DOC
(define (showTree t)
(match t
(('Node s ts) (<> (text s)
(showBracket ts)))))
;; showBracket :: [Tree] -> DOC
(define (showBracket ts)
(match ts
('() empty)
(ts (brackets (showTrees ts)))))
;; showTrees :: [Tree] -> DOC
(define (showTrees ts)
(match ts
((t) (showTree t))
((t . ts) (fsep (list (<> (showTree t) (text ","))
(showTrees ts))))))
;; showTree-bis :: Tree -> DOC
(define (showTree-bis t)
(match t
(('Node s '()) (text s))
(('Node s ts) (fsep (list (<> (text s) (text "["))
(nest 2 (showTrees-bis ts)) (text "]"))))))
;; showTrees :: [Tree] -> DOC
(define (showTrees-bis ts)
(match ts
((t) (showTree-bis t))
((t . ts) (fsep (list (<> (showTree-bis t) (text ","))
(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-print (showTree tree) :style (Style :lineLength w)))
(define (testtree-bis w)
(pretty-print (showTree-bis tree) :style (Style :lineLength w)))
;; END
;;
;;;
;;; XML - pretty print library example.
;;;
;;; 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$
;;;
;; XML example
(use text.prettyprint)
(use util.match)
(use srfi-13)
;; 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)
(hcat (showXMLs x)))
;; showXMLs :: XML -> [DOC]
(define (showXMLs ns)
(match ns
((t a '()) (list (fcat (list (<> (text "<") (showTag t a)) (text "/>")))))
((t a c) (list (fcat (list (<> (text "<") (showTag t a)) (text ">")
(nest 2 (showFill showXMLs c))
(<> (text "</") (<> (text t) (text ">")))))))
((s) (map text (string-tokenize s)))))
;; showAtts :: Att -> [DOC]
(define (showAtts attr)
(match attr
((n v) (list (<> (text n)
(<> (text "=")
(doubleQuotes (text v))))))))
;; showTag :: String -> [Att] -> DOC
(define (showTag n a)
(<+> (text n) (showFill showAtts a)))
;; showFill :: (a -> [DOC]) -> [a] -> DOC
(define (showFill f xs)
(match xs
('() empty)
(xs (fsep (apply append (map f xs))))))
;; sample
(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-print (showXML xml) :style (Style :lineLength w)))
;; END
;;
;;;
;;; Sexpr - pretty print library example.
;;;
;;; 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$
;;;
;; S Expression example
(use text.prettyprint)
(use util.match)
(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 sexpr)
(match sexpr
((? list? l) (showList l))
((? vector? v) (showVector v))
((? string? s) (doubleQuotes (text s)))
(x (text (x->string x)))))
;; showList :: [Sexpr] -> DOC
(define (showList lst)
(match lst
('() (text "()"))
((x) (hcat (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) (fsep (list (showSexpr x)
(<> (showSexprs xs)
(text ")")))))))
(((? list? x) . xs) (<> (text "(")
(nest 1 (fsep (list (showSexpr x)
(<> (showSexprs xs)
(text ")")))))))
((x . xs) (<> (text "(")
(nest 1 (fsep (list (showSexpr x)
(<> (showSexprs xs)
(text ")")))))))
))
;; showVector :: Vector -> DOC
(define (showVector v)
(<> (text "#")
(nest 1 (showList (vector->list v)))))
;; showSexprs :: [Sexpr] -> DOC
(define (showSexprs xs)
(sep (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))))
(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"))))))
(define (testSexpr w)
(pretty-print (showSexpr sexpr) :style (Style :lineLength w)))
;; END
;;
Tag: PrettyPrint