(provide 'write.scm)

;;; -------------------------------- pretty-print --------------------------------

(define pretty-print

  (let ((*pretty-print-length* 100)
	(*pretty-print-spacing* 2)
	(*pretty-print-float-format* "~,4F"))
    
    (lambda* (obj (port (current-output-port)) (column 0))
      
      (define (pretty-print-1 obj port column)
	(define (spaces n) 
	  (write-char #\newline port)
	  (do ((i 0 (+ i 1))) ((= i n)) (write-char #\space port)))
	
	(define (stacked-list lst col)
	  (do ((l1 lst (cdr l1)))
	      ((not (pair? l1)))
	    (let ((added 0))
	      (if (not (eq? l1 lst)) (spaces col))
	      (let* ((str (object->string (car l1)))
		     (len (length str)))
		(if (and (keyword? (car l1))
			 (pair? (cdr l1)))
		    (begin
		      (write (car l1) port)
		      (write-char #\space port)
		      (set! added (+ 1 len))
		      (set! l1 (cdr l1))))
		(if (pair? l1)
		    (if (and (pair? (car l1))
			     (pair? (cdar l1))
			     (null? (cddar l1))
			     (> len (/ *pretty-print-length* 2)))
			(begin
			  (write-char #\( port)
			  (pretty-print-1 (caar l1) port col)
			  (spaces (+ col 1))
			  (pretty-print-1 (cadar l1) port (+ col 1))
			  (write-char #\) port))
			(pretty-print-1 (car l1) port (+ col added)))
		    (format port " . ~S" l1)))
	      (set! added 0))))
	
	(define (stacked-split-list lst col)
	  (if (pair? lst)
	      (do ((l1 lst (cdr l1)))
		  ((not (pair? l1)))
		(if (not (eq? l1 lst)) (spaces col))
		(write-char #\( port)
		(if (pair? (car l1))
		    (begin
		      (write (caar l1) port)
		      (write-char #\space port)
		      (if (and (pair? (cdar l1))
			       (symbol? (caar l1)))
			  (pretty-print-1 (cadar l1) port (+ col (length (symbol->string (caar l1))) 2))
			  (write (cdar l1) port)))
		    (write (car l1) port))
		(write-char #\) port))
	      (write lst port)))
	
	(define (messy-number z)
	  (if (real? z)
	      (if (or (nan? z)
		      (infinite? z))
		  (object->string z)
		  (if (= z pi)
		      "pi"
		      (format #f *pretty-print-float-format* z)))
	      (format "~A~A~Ai" 
		      (messy-number (real-part z))
		      (if (negative? (imag-part z)) "-" "+")
		      (messy-number (abs (imag-part z))))))
	
	(define (any-keyword? lst)
	  (and (pair? lst)
	       (or (keyword? (car lst))
		   (any-keyword? (cdr lst)))))
	
	(cond ((number? obj)
	       (if (rational? obj)
		   (write obj port)
		   (display (messy-number obj) port)))
	      
	      ((pair? obj)
	       (let ((cobj (if (symbol? (car obj)) (string->symbol (symbol->string (car obj))) (car obj)))) ; this clears out some optimization confusion
		 (case cobj
		   
		   ((lambda lambda* define* define-macro define-macro* define-bacro define-bacro* with-let when unless
			    call-with-input-string call-with-input-file call-with-output-file
			    with-input-from-file with-input-from-string with-output-to-file)
		    (if (or (not (pair? (cdr obj))) ; (when) or (when . #t)
			    (not (pair? (cddr obj))))
			(write obj port)
			(begin
			  (format port "(~A ~A" (car obj) (cadr obj))
			  (spaces (+ column *pretty-print-spacing*))
			  (stacked-list (cddr obj) (+ column *pretty-print-spacing*))
			  (write-char #\) port))))
		   
		   ((defmacro defmacro*)
		    (if (or (not (pair? (cdr obj)))
			    (not (pair? (cddr obj))))
			(write obj port)
			(begin
			  (format port "(~A ~A ~A" (car obj) (cadr obj) (caddr obj))
			  (spaces (+ column *pretty-print-spacing*))
			  (stacked-list (cdddr obj) (+ column *pretty-print-spacing*))
			  (write-char #\) port))))
		   
		   ((define)
		    (if (not (pair? (cdr obj)))
			(write obj port)
			(begin
			  (format port "(~A ~A " (car obj) (cadr obj))
			  (if (pair? (cadr obj))
			      (begin
				(spaces (+ column *pretty-print-spacing*))
				(stacked-list (cddr obj) (+ column *pretty-print-spacing*)))
			      (begin
				(if (pair? (cddr obj))
				    (let ((str (object->string (caddr obj))))
				      (if (> (length str) 60)
					  (begin
					    (spaces (+ column *pretty-print-spacing*))
					    (pretty-print-1 (caddr obj) port (+ column *pretty-print-spacing*)))
					  (write (caddr obj) port)))
				    (write (cddr obj) port))))
			  (write-char #\) port))))
		   
		   ((do)
		    (if (not (pair? (cdr obj)))
			(write obj port)
			(begin
			  (format port "(do (")
			  (if (pair? (cadr obj))
			      (stacked-list (cadr obj) (+ column 5)))
			  (write-char #\) port)
			  (if (pair? (cddr obj))
			      (let ((end (caddr obj)))
				(spaces (+ column 4))
				(if (< (length (object->string end)) (- *pretty-print-length* column))
				    (write end port)
				    (begin
				      (write-char #\( port)
				      (pretty-print-1 (car end) port (+ column 4))
				      (spaces (+ column 5))
				      (stacked-list (cdr end) (+ column 5))
				      (write-char #\) port)))
				(spaces (+ column *pretty-print-spacing*))
				(stacked-list (cdddr obj) (+ column *pretty-print-spacing*))
				(write-char #\) port))
			      (write-char #\) port)))))
		   
		   ((cond)
		    (format port "(cond ")
		    (stacked-list (cdr obj) (+ column 6))
		    (write-char #\) port))
		   
		   ((or and)
		    (if (> (length (object->string obj)) 40)
			(begin
			  (format port "(~A " (car obj))
			  (stacked-list (cdr obj) (+ column *pretty-print-spacing* (length (symbol->string (car obj)))))
			  (write-char #\) port))
			(write obj port)))
		   
		   ((case)
		    (if (not (pair? (cdr obj)))
			(write obj port)
			(begin
			  (format port "(case ~A" (cadr obj)) ; send out the selector
			  (do ((lst (cddr obj) (cdr lst)))
			      ((not (pair? lst)))
			    (spaces (+ column *pretty-print-spacing*))
			    (if (not (pair? (car lst)))
				(write (car lst) port)
				(begin
				  (write-char #\( port)
				  (if (not (pair? (caar lst)))
				      (write (caar lst) port)
				      (let ((len (length (caar lst))))
					(if (< len 6)
					    (write (caar lst) port)
					    (let ((p (caar lst)))
					      (write-char #\( port)
					      (do ((i 0 (+ i 6)))
						  ((>= i len))
						(do ((j 0 (+ j 1)))
						    ((or (= j 6)
							 (null? p))
						     (if (pair? p) (spaces (+ column 4))))
						  (write (car p) port)
						  (set! p (cdr p))
						  (if (pair? p) (write-char #\space port))))
					      (write-char #\) port)))))
				  (if (and (pair? (cdar lst))
					   (null? (cddar lst))
					   (< (length (object->string (cadar lst))) 60))
				      (begin
					(write-char #\space port)
					(write (cadar lst) port))
				      (begin
					(spaces (+ column 3))
					(stacked-list (cdar lst) (+ column 3))))
				  (write-char #\) port))))
			  (write-char #\) port))))
		   
		   ((begin call-with-exit call/cc call-with-current-continuation with-baffle with-output-to-string call-with-output-string
			   map for-each)
		    (format port "(~A" (car obj))
		    (if (pair? (cdr obj))
			(begin
			  (spaces (+ column *pretty-print-spacing*))
			  (stacked-list (cdr obj) (+ column *pretty-print-spacing*))))
		    (write-char #\) port))
		   
		   ((dynamic-wind)
		    (format port "(dynamic-wind")
		    (spaces (+ column *pretty-print-spacing*))
		    (stacked-list (cdr obj) (+ column *pretty-print-spacing*))
		    (write-char #\) port))
		   
		   ((if)
		    (let ((objstr (object->string obj))
			  (ifcol (+ column 4)))
		      (if (< (length objstr) 40)
			  (display objstr port)
			  (begin
			    (format port "(if ")
			    (pretty-print-1 (cadr obj) port ifcol)
			    (spaces (+ column 4))
			    (pretty-print-1 (caddr obj) port ifcol)
			    (if (pair? (cdddr obj))
				(begin
				  (spaces (+ column 4))
				  (pretty-print-1 (cadddr obj) port ifcol)))
			    (write-char #\) port)))))
		   
		   ((let let* letrec letrec*)
		    (if (or (not (pair? (cdr obj)))
			    (not (pair? (cddr obj))))
			(write obj port)
			(let ((head-len (length (symbol->string (car obj)))))
			  (if (symbol? (cadr obj))
			      (begin
				(format port "(~A ~A (" (car obj) (cadr obj))
				(if (pair? (cddr obj))
				    (if (pair? (caddr obj)) ; (let x () ...)
					(stacked-split-list (caddr obj) (+ column head-len (length (symbol->string (cadr obj))) 4))
					(write (caddr obj) port))
				    (if (not (null? (cddr obj)))
					(format port " . ~S" (cddr obj)))))
			      (begin
				(format port "(~A (" (car obj))
				(if (pair? (cadr obj))
				    (stacked-split-list (cadr obj) (+ column head-len 3)))))
			  (write-char #\) port)
			  (spaces (+ column *pretty-print-spacing*))
			  (if (pair? ((if (symbol? (cadr obj)) cdddr cddr) obj))
			      (stacked-list ((if (symbol? (cadr obj)) cdddr cddr) obj) (+ column *pretty-print-spacing*)))
			  (write-char #\) port))))
		   
		   ((inlet)
		    (format port "(inlet")
		    (if (pair? (cdr obj))
			(do ((lst (cdr obj) (cddr lst)))
			    ((or (not (pair? lst))
				 (not (pair? (cdr lst)))))
			  (spaces (+ column *pretty-print-spacing*))
			  (if (pair? (cdr lst))
			      (begin
				(write (car lst) port)
				(write-char #\space port)
				(pretty-print-1 (cadr lst) port (+ column *pretty-print-spacing* (length (object->string (car lst))))))
			      (write lst port))))
		    (write-char #\) port))
		   
		   ((set!)
		    (let ((str (object->string obj)))
		      (if (> (length str) 60)
			  (let ((settee (object->string (cadr obj))))
			    (format port "(set! ~A" settee)
			    (if (> (length settee) 20)
				(begin
				  (spaces (+ column 6))
				  (pretty-print-1 (caddr obj) port (+ column 6)))
				(begin
				  (write-char #\space port)
				  (pretty-print-1 (caddr obj) port (+ column 7 (length settee)))))
			    (write-char #\) port))
			  (display str port))))
		   
		   ((quote)
		    (if (not (pair? (cdr obj))) ; (quote) or (quote . 1)
			(write obj port)
			(begin
			  (write-char #\' port)
			  (pretty-print-1 (cadr obj) port column))))
		   
		   (else
		    (let* ((objstr (object->string obj))
			   (strlen (length objstr)))
		      (if (< (+ column strlen) *pretty-print-length*)
			  (display objstr port)
			  (let ((lstlen (length obj)))
			    (if (or (infinite? lstlen)
				    (< lstlen 2))
				(display objstr port)
				(if (and (pair? (car obj))
					 (memq (caar obj) '(lambda lambda*)))
				    (begin
				      (write-char #\( port)
				      (pretty-print-1 (car obj) port column)
				      (spaces (+ column 1))
				      (display (cadr obj) port)
				      (write-char #\) port))
				    (let* ((carstr (object->string (car obj)))
					   (carstrlen (length carstr)))
				      (if (eq? (car obj) 'quote)
					  (write-char #\' port)
					  (format port "(~A" carstr))
				      (if (any-keyword? (cdr obj))
					  (begin
					    (spaces (+ column *pretty-print-spacing*))
					    (stacked-list (cdr obj) (+ column *pretty-print-spacing*)))
					  (let ((line-len (ceiling (/ (- strlen carstrlen) 40)))
						(line-start (+ column *pretty-print-spacing* carstrlen)))
					    (if (= lstlen 2)
						(begin
						  (write-char #\space port)
						  (pretty-print-1 (cadr obj) port line-start))
						(if (< lstlen 5)
						    (begin
						      (write-char #\space port)
						      (stacked-list (cdr obj) line-start))
						    (let ((lst (cdr obj)))
						      (do ((i 1 (+ i line-len)))
							  ((>= i lstlen))
							(do ((k 0 (+ k 1)))
							    ((or (null? lst)
								 (= k line-len)))
							  (let ((str (format #f "~S" (car lst))))
							    (if (> (length str) (- *pretty-print-length* line-start))
								(begin
								  (if (not (zero? k)) (spaces line-start))
								  (pretty-print-1 (car lst) port line-start))
								(begin
								  (if (or (not (zero? k)) (= i 1)) (write-char #\space port))
								  (display str port))))
							  (set! lst (cdr lst)))
							(if (pair? lst)
							    (spaces line-start))))))))
				      (if (not (eq? (car obj) 'quote))
					  (write-char #\) port))))))))))))
	      (else
	       (write obj port))))
      
      (let ((old-port port))
	(if (boolean? old-port)
	    (set! port (open-output-string)))
	(pretty-print-1 obj port column)
	(flush-output-port port)
	(if (boolean? old-port)
	    (let ((str (get-output-string port)))
	      (close-output-port port)
	      (if (eq? old-port #t)
		  (display str))
	      str)
	      (values))))))

(define (pp obj)
  (call-with-output-string
    (lambda (p)
      (pretty-print obj p))))

#|
(define (pretty-print-all)
  (let ((st (symbol-table)))
    (for-each
     (lambda (sym)
       (if (defined? sym)
	   (let ((val (symbol->value sym)))
	     (let ((source (and (procedure? val)
				(procedure-source val))))
	       (if (pair? source)
		   (format *stderr* "~<sym~> ~<val~>:~%~<(pp source)~>~%~%"))))))
     st)))
|#

(define-macro (fully-macroexpand form)
  (define (expand form)
    ;; walk form looking for macros, expand any that are found
    (if (pair? form)
	(if (and (symbol? (car form))
		 (macro? (symbol->value (car form))))
	    (expand ((eval (procedure-source (symbol->value (car form)))) form))
	    (cons (expand (car form))
		  (expand (cdr form))))
	form))
  `(pretty-print ',(expand form)))

#|
(define* (pp-sequence seq)
  (let ((iter (make-iterator seq))
	(strs ())
	(plen (*s7* 'print-length)))
    (do ((i 0 (+ i 1))
	 (entry (iterate iter) (iterate iter)))
	((or (= i plen)
	     (eof-object? entry))
	 (if (not (eof-object? entry))
	     (apply string-append (append (reverse! strs) (list "...")))
	     (apply string-append (reverse! strs))))
      (set! strs (cons (format #f "~S " entry) strs)))))
|#
