;;; -*-Scheme-*-
;;;
;;; Trivial pretty-printer: hacked to allow port specification.

(provide 'ppport)

(define ppport)

(let ((max-pos 55) (pos 0) (tab-stop 8))
  
  (put 'lambda  'special #t)
  (put 'macro   'special #t)
  (put 'define  'special #t)
  (put 'define-macro     'special #t)
  (put 'define-structure 'special #t)
  (put 'fluid-let        'special #t)
  (put 'let     'special #t)
  (put 'let*    'special #t)
  (put 'letrec  'special #t)
  (put 'case    'special #t)

  (put 'call-with-current-continuation 'long #t)

  (put 'quote            'abbr "'")
  (put 'quasiquote       'abbr "`")
  (put 'unquote          'abbr ",")
  (put 'unquote-splicing 'abbr ",@")

  ;; Hack around pp of autoloadables bug,
  ;; try (pp (car (environment->list (global-environment))))
  ;; to see what I mean...

  (put 'pp 'pp-hack "#[autoload pp]")
  (put 'apropos 'pp-hack "#[autoload apropos]")
  (put 'flame 'pp-hack "#[autoload flame]")
  (put 'sort 'pp-hack "#[autoload qsort]")
  (put 'define-structure 'pp-hack "#[autoload define-structure]")
  (put 'describe 'pp-hack "#[autoload describe]")
  (put 'backtrace 'pp-hack "#[autoload qsort]")
  (put 'expt 'pp-hack "#[autoload expt]")

  ;; ``Do the right thing'' with quasiquote & quote too.

  (put 'quasiquote 'pp-hack "#[primitive quasiquote]")
  (put 'quote 'pp-hack "#[primitive quote]")

(set! ppport (lambda (x p)
  (set! pos 0)
  (cond ((eq? (type x) 'compound)
         (set! x (procedure-lambda x)))
	((eq? (type x) 'macro)
	 (set! x (macro-body x))))
  (fluid-let ((garbage-collect-notify? #f))
    (ppport-object x p))
  #v))

(define (flat-size s)
  (fluid-let ((print-length 1000) (print-depth 100))
    (string-length (format #f "~a" s))))

(define (ppport-object x p)
  (if (or (null? x) (pair? x))
      (ppport-list x p)
      (if (void? x)
	  (display "#v" p)
          (write x p))
      (set! pos (+ pos (flat-size x)))))

(define (ppport-list x p)
  (if (and (pair? x)
	   (symbol? (car x))
	   (string? (get (car x) 'abbr)))
      (if (and (get (car x) 'pp-hack) (primitive? (cdr x)))
	  (begin (display "(" p)
		 (display (car x) p)
		 (display " . " p)
		 (display (get (car x) 'pp-hack) p)
		 (display ")" p))
	(if (= 2 (length x))
	    (let ((abbr (get (car x) 'abbr)))
	      (display abbr p)
	      (set! pos (+ pos (flat-size abbr)))
	      (ppport-object (cadr x) p))))
    (if (> (flat-size x) (- max-pos pos))
	(ppport-list-vertically x p)
      (ppport-list-horizontally x p))))

(define (ppport-list-vertically x p)
  (maybe-ppport-list-vertically #t x p))

(define (ppport-list-horizontally x p)
  (maybe-ppport-list-vertically #f x p))

(define (maybe-ppport-list-vertically vertical? list p)
  (display "(" p)
  (set! pos (1+ pos))
  (if (null? list)
      (begin
	(display ")" p)
	(set! pos (1+ pos)))
      (let ((pos1 pos))
	(ppport-object (car list) p)
	(if (and vertical?
		 (or
		  (and (pair? (car list))
		       (not (null? (cdr list))))
		  (and (symbol? (car list))
		       (get (car list) 'long))))
	    (indent-newline (1- pos1) p))
	(let ((pos2 (1+ pos)) (key (car list)))
	  (if (and (symbol? key) (get key 'pp-hack))
	      ;; This will fail to print any application of the pp-hack
	      ;; procedures correctly...
	      (begin (display " . " p)
		     (set! pos (+ pos 3))
		     (ppport-object (get key 'pp-hack) p)
		     (display ")" p)
		     (set! pos (1+ pos)))
	    (let tail ((flag #f) (l (cdr list)))
		 (cond ((pair? l)
			(if flag
			    (indent-newline
			     (if (and (symbol? key) (get key 'special))
				 (1+ pos1)
			       pos2)
			     p)
			  (display " " p)
			  (set! pos (1+ pos)))
			(ppport-object (car l) p)
			(tail vertical? (cdr l)))
		       (else
			(cond ((not (null? l))
			       (display " . " p)
			       (set! pos (+ pos 3))
			       (if flag (indent-newline pos2 p))
			       (ppport-object l p)))
			(display ")" p)
			(set! pos (1+ pos))))))))))

 (define (indent-newline x p)
   (newline p)
   (set! pos x)
   (let loop ((i x))
     (cond ((>= i tab-stop)
	    (display "        " p)
	    (loop (- i tab-stop)))
	   ((> i 0)
	    (display " " p)
	    (loop (1- i)))))))

