(provide 'write.scm)

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

(define pretty-print #f)

(let ((*pretty-print-length* 100)
      (*pretty-print-spacing* 2)
      (*pretty-print-float-format* "~,4F"))

  (define* (pretty-print-inner 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))))
  
  (set! pretty-print pretty-print-inner)
  )

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

