;; 
;; _Strictly Pretty_
;; Christian Lindig
;;
;; Adapted for Chicken Scheme by Ivan Raikov.
;; Copyright 2008-2009 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/>.
;;
;;

(module strictly-pretty

 (export doc? doc:cons doc:empty 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)
		   
 (import scheme chicken data-structures extras )

 (require-extension srfi-1 datatype matchable )

(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:empty? x)     (and (doc? x) (cases doc x (DocNil () #t) (else #f))))

(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)
    (if (doc:empty? 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)))

|#
)