Gauche:WadlersPrettierPrinterLibrary

Gauche:WadlersPrettierPrinterLibrary

参考文献) Philip Wadler, A prettier printer, March 1998( prettier.pdf)

関連


ppr.scm

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
;;

Example

サンプルの動作確認をするには、まず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

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(xml.scm)

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
;;

S Expression(sxpr.scm)

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.scm中にあるサンプルsexprを途中でevalしています。
まだ、シンボル固有のインデントルールを入れるところまで実装してない。 ちなみにこいつで<+/>を使うとlazyじゃないpprだと劇的に重くなることが発覚した。 <+/>を使った瞬間にパターンが爆発するためと思われるが、 nobsunにはやーっぱりlazyじゃなきゃダメなんだよ!って笑われた。

やれば出来る子なんだよ。Schemeは!って言い切ってやったけど、 Festの最後にこれでハマってHaskellに心が行きそうになったのは内緒。(w

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


Last modified : 2013/05/06 10:00:45 UTC