Re: [Chicken-users] pretty-printer for CPS code needed

[Ivan Raikov]

Hi Felix,

   Have you read the paper _Strictly Pretty_ by Christian Lindig?  A
while ago, I used the algorithm it describes to solve a similar
problem. Well, it took some effort to get my pretty printer to work as
I wanted it, but I did manage to get it break the lines in a readable
manner. The paper is here:

http://www.st.cs.uni-sb.de/~lindig/papers/pretty/strictly-pretty.pdf

   I also ported the Standard ML code in the paper to Scheme, with the
intention of packaging it as an egg, but never got around to it. So
here is my (very untested) Scheme implementation, maybe you will find
it helpful. Since it is a direct port from SML, it relies on the
datatype egg and pattern matching, but it shouldn't be too much work
to rewrite the code to not use datatypes.


;; 
;;          _Strictly Pretty_
;;        Christian Lindig
;;

(require-extension datatype)


(define-datatype doc doc?
  (DocNil)
  (DocCons   (car doc?) (cdr doc?))
  (DocText   (text string?))
  (DocNest   (level integer?) (body doc?))
  (DocBreak  (sep string?))
  (DocGroup  (group doc?)))

(define-datatype sdoc sdoc?
  (SNil)
  (SText (text string?) (next sdoc?))
  (SLine (indent integer?) (body sdoc?)))

(define-datatype mode mode?
  (Flat)
  (Break))


(define-record-printer (mode x out)
  (cases mode x
         (Flat () (fprintf out "#(mode Flat)"))
         (Break () (fprintf out "#(mode Break)"))))

(define-record-printer (sdoc x out)
  (cases sdoc x
         (SNil ()     (fprintf out "#(SNil)"))
         (SText (t n) (fprintf out "#(SText ~S ~A)" t n))
         (SLine (i d) (fprintf out "#(SLine (~A, ~A))" i d))))

(define-record-printer (doc x out)
  (cases doc x
         (DocNil ()     (fprintf out "#(DocNil)"))
         (DocCons (x y) (fprintf out "#(DocCons ~A ~A)" x y))
         (DocText (s)   (fprintf out "#(DocText ~A)" s))
         (DocNest (i d) (fprintf out "#(DocNest (~A, ~A))" i d))
         (DocBreak (s)  (fprintf out  "#(DocBreak ~S)" s))
         (DocGroup (g)  (fprintf out  "#(DocGroup ~A)" g))))



(define (doc:cons x y)  (DocCons x y))
(define (doc:empty)     (DocNil))
(define (doc:text s)    (DocText s))
(define (doc:nest i x)  (DocNest i x))
(define (doc:break)     (DocBreak " "))
(define (doc:break-with s)  (DocBreak s)) 
(define (doc:group x)   (DocGroup x))

(define (doc:connect x y)
  (cases doc x
         (DocNil ()   y)
         (else   (cases doc y 
                        (DocNil () x)
                        (else (doc:cons x (doc:cons (doc:break) y)))))))

(define (doc:connect-with s x y)
  (cases doc x
         (DocNil ()   y)
         (else   (cases doc y 
                        (DocNil () x)
                        (else (doc:cons x (doc:cons (doc:break-with s) y)))))))

(define (doc:concat lst)
  (match lst
         (()     (doc:empty))
         (( x )  (doc:group x))
         (( x . rest)  (cases doc x 
                              (DocNil ()  (doc:concat r))
                              (else       (doc:cons x (doc:concat rest)))))
         (else (error "doc:concat: invalid  doc list"))))

(define (doc:fits w x)
  (if (< w 0) #f
      (match x
             (()  #t)
             ((( i m x ) . rest)  (cases doc x
                                       (DocNil   ()     (doc:fits w rest))
                                       (DocCons  (x y)  (doc:fits w (cons (list 
i m x) (cons (list i m y) rest))))
                                       (DocNest  (j x)  (doc:fits w (cons (list 
(+ i j) m x) rest)))
                                       (DocText  (s)    (doc:fits (- w 
(string-length s)) rest))
                                       (DocGroup (x)    (doc:fits w (cons (list 
i (Flat) x) rest)))
                                       (DocBreak (s)    (cases mode m 
                                                               (Flat ()  
(doc:fits (- w (string-length s)) rest))
                                                               (Break () #t)))))
             (else (error "doc:fits: invalid doc list")))))

(define (format1 w k x)
  (match x 
         (()   (SNil))
         ((( i m x ) . rest)  (cases doc x
                                     (DocNil ()      (format1 w k rest))
                                     (DocCons (x y)  (format1 w k (cons (list i 
m x) (cons (list i m y) rest))))
                                     (DocNest (j x)  (format1 w k (cons (list 
(+ i j) m x) rest)))
                                     (DocText (s)    (SText s (format1 w (+ k 
(string-length s)) rest)))
                                     (DocGroup (x)   (if (doc:fits (- w k) 
(cons (list i (Flat) x) rest))
                                                         (format1 w k (cons 
(list i (Flat) x) rest))
                                                         (format1 w k (cons 
(list i (Break) x) rest))))
                                     (DocBreak (s)   (cases mode m
                                                            (Flat ()  (SText s 
(format1 w (+ k (string-length s)) rest)))
                                                            (Break () (SText s 
(SLine i (format1 w i rest))))))))
         (else (error "doc:format1: invalid doc list"))))
         
(define (doc:format w x) (format1 w 0 (list (list 0 (Flat) (DocGroup x)))))

(define (sdoc->string x)
  (let loop ((port (open-output-string)) (x x))
    (cases sdoc x
           (SNil ()      (get-output-string port))
           (SText (s d)  (begin 
                           (display s port) 
                           (loop port d)))
           (SLine (i d)  (let ((prefix (make-string i #\space)))
                           (display "\n" port)
                           (display prefix port)
                           (loop port d))))))

(define (doc:binop indent)
  (lambda (left oper right)
    (doc:group (doc:nest indent (doc:connect (doc:group (doc:connect left 
oper)) right)))))

(define (doc:list indent elem->doc sep)
  (define (ll ax lst)
    (match lst
           (()  (reverse ax))
           ((x) (reverse (cons (doc:group (doc:nest indent (elem->doc x))) ax)))
           ((x . rest)  (ll (cons (sep) (cons (doc:group (doc:nest indent 
(elem->doc x))) ax)) rest))))
        
  (lambda (lst)
    (doc:group (doc:concat (ll (list) lst)))))

(define (doc:ifthen indent i t e)
  (lambda (c e1 e2)
    (doc:group 
     (doc:nest indent 
               (doc:connect (doc:connect i c)
                            (doc:connect (doc:group (doc:nest indent 
(doc:connect t e1)))
                                         (doc:group (doc:nest indent 
(doc:connect e e2)))))))))
    
(define (doc:block indent open close)
  (lambda (b)
    (doc:group (doc:cons open (doc:cons (doc:nest indent b) close)))))

(define (doc:letblk indent l i e)
  (lambda (e1 e2)
    (doc:group (doc:connect (doc:nest indent (doc:connect l (doc:group e1)))
                            (doc:connect (doc:nest indent (doc:connect i 
(doc:group e2))) e)))))
        

(define (doc:space)  (doc:text " "))
                     
(define (doc:comma)  (doc:break-with ", "))
                     
; Examples:

(define cond1 ((doc:binop 2) (doc:text "a") (doc:text "==") (doc:text "b")))
(define e1    ((doc:binop 2) (doc:text "a") (doc:text "<<") (doc:text "2")))
(define e2    ((doc:binop 2) (doc:text "c") (doc:text "+") (doc:text "d")))

(define doc1 ((doc:ifthen 2 (doc:text "if") (doc:text "then") (doc:text "else"))
              cond1 e1 e2))

(define doc2 ((doc:block 2 (doc:text "(") (doc:text ")")) doc1))

(define doc3 ((doc:list 2 (lambda (x) x) doc:break) (list e1 e2)))
(define doc4 ((doc:letblk 2 (doc:text "program") (doc:text "in") (doc:text 
"end"))
              doc3 doc1))

(print (sdoc->string (doc:format 32 doc4)))

(print (sdoc->string (doc:format 10 doc4)))




"felix winkelmann" <address@hidden> writes:

> Hello!
>
> As I'm currently writing on a document that describes chicken's
> compilation process, I need something to pretty print CPS
> converted code properly. Chicken's pretty-printer creates
> rather wide output, so it's not particularly well readable.
>
> Any ideas or even code? Code that has little dependencies
> would be best, as it could go directly into the compiler to
> format the output generated by the "-debug" option.
>
>
> cheers,
> felix
>