source: project/release/3/strictly-pretty/trunk/strictly-pretty.scm @ 12060

;; 
;; _Strictly Pretty_
;; Christian Lindig
;;
;; Adapted for Chicken Scheme by Ivan Raikov.
;; Copyright 2008 Ivan Raikov and the Okinawa Institute of Science and Technology
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.
;;
;;

(require-extension syntax-case)
(require-extension matchable)
(require-extension datatype)
(require-extension srfi-1)

(define-extension strictly-pretty)

(declare (export doc? doc:cons doc:empty doc:text doc:nest doc:break
                 doc:break-with doc:group doc:concat 
                 doc:binop doc:ifthen doc:list doc:block doc:letblk
                 doc:space doc:comma doc:connect
                 doc:display doc:format sdoc? sdoc->string))


(define (spaces n)  (list->string (list-tabulate n (lambda (x) #\space))))


(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 rest))
                              (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 (PNil) (void))
(define (PText str next) 
  (display str)
  (next))
(define (PLine indent body)
  (display (spaces indent))
  (body))
  
(define (doc:display1 w k x)
  (match x 
         (()   (PNil))
         ((( i m x ) . rest)  
          (cases doc x
                 (DocNil ()      (doc:display1 w k rest))
                 (DocCons (x y)  (doc:display1 w k (cons (list i m x) (cons (list i m y) rest))))
                 (DocNest (j x)  (doc:display1 w k (cons (list (+ i j) m x) rest)))
                 (DocText (s)    (PText s (lambda () (doc:display1 w (+ k (string-length s)) rest))))
                 (DocGroup (x)   (if (doc:fits (- w k) (cons (list i (Flat) x) rest))
                                     (doc:display1 w k (cons (list i (Flat) x) rest))
                                     (doc:display1 w k (cons (list i (Break) x) rest))))
                 (DocBreak (s)   (cases mode m
                                        (Flat ()  (PText s (lambda () (doc:display1 w (+ k (string-length s)) rest))))
                                        (Break () (PText s (lambda () (PLine i (doc:display1 w i rest)))))))))
         (else (error "doc:display1: invalid doc list " x))))
         
(define (doc:display w x) (doc:display1 w 0 (list (list 0 (Flat) (DocGroup x)))))


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

|#