(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* (unquasiquote x (depth 0)) ; not finished yet...
	(if (not (pair? x))
	    (if (symbol? x)
		(format #f "~NC~A" depth #\, x)
		(object->string x))
	    
	    (case (car x)
	      ((#_{list})
	       (do ((form x (cdr form))
		    (d 0 (+ d 1)))
		   ((not (and (pair? form)
			      (eq? (car form) {list})))
		    (if (eq? (car form) {apply_values})
			",@"                             ; TODO: this is broken
			(if (= d depth)
			    (format #f "(~{~A~^ ~})" (map (lambda (y) (unquasiquote y depth)) form))
			    (format #f "~NC(~{~A~^ ~})" (max 0 (- d depth)) #\` (map (lambda (y) (unquasiquote y d)) form)))))))
	      
	      ((#_{apply_values})
	       (format #f ",@~A" (unquasiquote (cadr x) (max 0 (- depth 1)))))
	      
	      ((#_{append})
	       (format #f "`(~A . ~A)" 
		       (let ((qs (unquasiquote (cadr x) depth)))
			 (substring qs 2 (- (length qs) 1)))
		       (x (- (length x) 1))))
	      
	      ((quote)
	       (if (= depth 1)
		   (object->string (cadr x))
		   (unquasiquote (cadr x) (max 0 (- depth 1)))))
	      
	      (else (format #f "~NC(~{~A~^ ~})" depth #\, (map (lambda (y) (unquasiquote y (max 0 (- depth 1)))) x))))))


      (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 ((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
			  (if (eq? (caar l1) 'quote)
			      (write-char #\' port)
			      (begin
				(write-char #\( port)
				(pretty-print-1 (caar l1) port col)
				(spaces (+ col 1))))
			  (pretty-print-1 (cadar l1) port (+ col 1))
			  (if (not (eq? (caar l1) 'quote))
			      (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 #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 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 (not (and (pair? (cdr obj)) ; (when) or (when . #t)
				(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 (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 ")
		  (do ((lst (cdr obj) (cdr lst)))
		      ((not (pair? lst)))
		    (if (not (eq? lst (cdr obj)))
			(spaces (+ column 6)))
		    (if (pair? (car lst))
			(begin
			  (write-char #\( port)
			  (let ((oldlines newlines))
			    (pretty-print-1 (caar lst) port (+ column 7))
			    (if (and (= oldlines newlines)
				     (pair? (cdar lst))
				     (or (null? (cddar lst))
					 (and (eq? (cadar lst) '=>)
					      (null? (cdddar lst))))
				     (< (length (object->string (cdar lst))) 50))
				(begin
				  (write-char #\space port)
				  (write (cadar lst) port)
				  (when (eq? (cadar lst) '=>)
				    (write-char #\space port)
				    (write (caddar lst) port)))
				(begin
				  (spaces (+ column 7))
				  (stacked-list (cdar lst) (+ column 7)))))
			  (write-char #\) port))
			(write (car lst) 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 (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 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)
			  (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 (not (and (pair? (cdr obj))
				(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)))
			  ((not (and (pair? lst)
				     (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))))
		 
		 ((catch)
		  (format port "(~A ~S" catch (cadr obj))
		  (spaces (+ column *pretty-print-spacing*))
		  (stacked-list (cddr obj) (+ column *pretty-print-spacing*))
		  (write-char #\) port))

		 ((#_{list} #_{append})
		  (display (unquasiquote obj) 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*)))
				  (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 (if (or (> carstrlen 16)
								  (pair? (cadr obj)))
							      (let ((new-col (+ column *pretty-print-spacing*)))
								(spaces (- new-col 1))
								new-col)
							      (+ column *pretty-print-spacing* 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 (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 -- 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)))))
|#
