(provide 'write.scm)

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

(define pretty-print

  (let ((*pretty-print-length* 100)
	(*pretty-print-spacing* 2)
	(*pretty-print-float-format* "~,4F")
	(*pretty-print-left-margin* 0))
    
    (define (any? f sequence) ; this and every? ought to be built-in!
      (member #f sequence (lambda (a b) (f b))))

    (lambda* (obj (port (current-output-port)) (column 0))

      (define newlines 0)

      (define (pretty-print-1 obj port column)
	(define (spaces n) 
	  (set! newlines (+ newlines 1))
	  (format port "~%~NC" (+ n *pretty-print-left-margin*) #\space))

	(define (stacked-list lst col)
	  (do ((p lst (cdr p)))
	      ((not (pair? p)))
	    (let ((added 0))
	      (if (not (eq? p lst)) (spaces col))
	      (let* ((str (object->string (car p)))
		     (len (length str)))
		(if (and (keyword? (car p))
			 (pair? (cdr p)))
		    (begin
		      (write (car p) port)
		      (write-char #\space port)
		      (set! added (+ 1 len))
		      (set! p (cdr p))))
		(if (not (pair? p))
		    (format port " . ~S" p)
		    (if (and (pair? (car p))
			     (pair? (cdar p))
			     (null? (cddar p))
			     (> len (/ *pretty-print-length* 2)))
			(begin
			  (if (eq? (caar p) 'quote)
			      (write-char #\' port)
			      (begin
				(write-char #\( port)
				(pretty-print-1 (caar p) port col)
				(spaces (+ col 1))))
			  (pretty-print-1 (cadar p) port (+ col 1))
			  (if (not (eq? (caar p) 'quote))
			      (write-char #\) port)))
			(pretty-print-1 (car p) port (+ col added)))))
	      (set! added 0))))
	
	(define (stacked-split-list lst col)
	  (if (not (pair? lst))
	      (write lst port)
	      (do ((p lst (cdr p)))
		  ((not (pair? p)))
		(if (not (eq? p lst)) (spaces col))
		(write-char #\( port)
		(if (pair? (car p))
		    (begin
		      (write (caar p) port)
		      (write-char #\space port)
		      (if (and (pair? (cdar p))
			       (symbol? (caar p)))
			  (pretty-print-1 (cadar p) port (+ col (length (symbol->string (caar p))) 2))
			  (write (cdar p) port)))
		    (write (car p) port))
		(write-char #\) 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 #f "~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)
	       (case (car obj)
		 
		 ((lambda lambda* define* define-macro define-macro* define-bacro define-bacro* with-let
			  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 (not (and (pair? (cdr obj))
				(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 (not (and (pair? (cdr obj))
				(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*)))
			    (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 (not (pair? (cddr obj)))
			    (write-char #\) port)
			    (begin
			      (spaces (+ column 4))
			      (let ((end (caddr obj)))
				(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))))
			      (when (pair? (cdddr obj))
				(spaces (+ column *pretty-print-spacing*))
				(stacked-list (cdddr obj) (+ column *pretty-print-spacing*)))
			      (write-char #\) port))))))
		 
		 ((cond)
		  (format port "(cond ")
		  (do ((lst (cdr obj) (cdr lst)))
		      ((not (pair? lst)))
		    (if (not (eq? lst (cdr obj)))
			(spaces (+ column 6)))
		    (if (not (pair? (car lst)))
			(write (car lst) port)
			(let* ((has=> (and (pair? (cdar lst))
					   (eq? (cadar lst) '=>)))
			       (extras (and (pair? (cdar lst))
					    (pair? (cddar lst))
					    (or (not has=>)
						(pair? (cdddar lst)))))
			       (too-long (> (length (object->string (cdar lst))) 50)))
			  (write-char #\( port)
			  (let ((oldlines newlines))
			    (pretty-print-1 (caar lst) port (+ column 7))
			    (if (or extras 
				    (not (= oldlines newlines))
				    too-long)
				(spaces (+ column 7))
				(if (and (pair? (cdar lst))
					 (or (not has=>)
					     (= oldlines newlines)))
				    (write-char #\space port)))
			    (if (and (pair? (cdar lst))
				     (not extras)
				     (not too-long))
				(begin
				  (write (cadar lst) port)
				  (when has=>
				    (write-char #\space port)
				    (write (caddar lst) port)))
				(if (not (null? (cdar lst)))
				    (stacked-list (cdar lst) (+ column 7)))))
			  (write-char #\) port))))
		  (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 (not (null? (cdar lst))) ; null here is a bug in the input case statement
				    (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)
		  (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))

		 ((map for-each)
		  (let* ((objstr (object->string obj))
			 (strlen (length objstr)))
		    (if (< (+ column strlen) *pretty-print-length*)
			(display objstr port)
			(begin
			  (format port "(~A" (car obj))
			  (if (pair? (cdr obj))
			      (begin
				(write-char #\space port)
				(stacked-list (cdr obj) (+ column *pretty-print-spacing*))))
			  (write-char #\) port)))))
		 
		 ((dynamic-wind call-with-values)
		  (format port "(~A" (car obj))
		  (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)
			  (when (pair? (cddr obj)) ; might be a messed-up if
			    (spaces ifcol)
			    (pretty-print-1 (caddr obj) port ifcol)
			    (when (pair? (cdddr obj))
			      (spaces ifcol)
			      (pretty-print-1 (cadddr obj) port ifcol)))
			  (write-char #\) port)))))

		 ((when unless)
		  (let ((objstr (object->string obj)))
		    (if (< (length objstr) 40)
			(display objstr port)
			(begin
			  (format port "(~A " (car obj))
			  (pretty-print-1 (cadr obj) port (+ column (if (eq? (car obj) 'when) 6 8)))
			  (spaces (+ column *pretty-print-spacing*))
			  (when (pair? (cddr obj))
			    (stacked-list (cddr obj) (+ column *pretty-print-spacing*)))
			  (write-char #\) port)))))
		 
		 ((let let* letrec letrec*)
		  (if (not (and (pair? (cdr obj))
				(pair? (cddr obj))))
		      (write obj port)
		      (begin
			(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))
					(if (not (null? (caddr obj)))
					    (write (caddr obj) port))) ; () is already being written
				    (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)))
			  ((not (and (pair? lst)
				     (pair? (cdr lst)))))
			(if (not (eq? lst (cdr obj)))
			    (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)
			(display str port)
			(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)))))
		 
		 ((quote)
		  (if (not (pair? (cdr obj))) ; (quote) or (quote . 1)
		      (write obj port)
		      (begin
			(write-char #\' port)
			(pretty-print-1 (cadr obj) port column))))
		 
		 ((catch)
		  (format port "(~A ~S" catch (cadr obj))
		  (spaces (+ column *pretty-print-spacing*))
		  (stacked-list (cddr obj) (+ column *pretty-print-spacing*))
		  (write-char #\) port))
		 
		 (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* let let* letrec letrec*)))
				  (begin
				    (write-char #\( port)
				    (pretty-print-1 (car obj) port column)
				    (spaces (+ column 1))
				    (stacked-list (cdr obj) (+ column 1)) ; the args?
				    (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-start (+ column *pretty-print-spacing*
								    (if (or (> carstrlen 16)
									    (pair? (cadr obj)))
									0 
									carstrlen))))
					  (if (= lstlen 2)
					      (begin
						(write-char #\space port)
						(pretty-print-1 (cadr obj) port line-start))
					      (if (< lstlen 4)
						  (begin
						    (write-char #\space port)
						    (stacked-list (cdr obj) line-start))
						  (let ((obj-start line-start))
						    (do ((lst (cdr obj) (cdr lst)))
							((null? lst))
						      (let* ((str (format #f "~S" (car lst)))
							     (strlen1 (length str)))
							(if (and (> strlen1 (- *pretty-print-length* obj-start))
								 (not (eq? lst (cdr obj))))
							    (begin
							      (set! obj-start (+ line-start 1 strlen1))
							      (spaces line-start)
							      (pretty-print-1 (car lst) port line-start))
							    (begin
							      (set! obj-start (+ obj-start 1 strlen1))
							      (if (> strlen1 40)
								  (begin
								    (spaces line-start)
								    (pretty-print-1 (car lst) port line-start))
								  (begin
								    (write-char #\space port)
								    (display str port))))))))))))
				    (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 (not (boolean? old-port))
	    (values)
	    (let ((str (get-output-string port)))
	      (close-output-port port)
	      (if (eq? old-port #t)
		  (display str))
	      str))))))

(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 -- see stuff.scm for a newer version
    (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)))))
|#
