;;; -*- Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Spice Lisp pretty printer.
;;; Written by Skef Wholey.
;;;

;;; This package provides the following functions:
;;;
;;; (PPRIN1 Object &Optional Output-Stream)			[EXPR]
;;; Analog of PRIN1.  Prettily prints the object to the given stream
;;; with special characters slashified.
;;;
;;; (PPRINC Object &Optional Output-Stream)			[EXPR]
;;; Analog of PRINC.  Special characters are not slashified.
;;;
;;; (PPRINT Object &Optional Output-Stream)			[EXPR]
;;; Analog of PRINT.  TERPRI + PPRIN1 + SPACE.
;;;
;;; (GRINDEF Function-Name)					[MACRO]
;;; Prettily prints the definition of the function named by Function-Name.
;;;
;;; (DEFPRINT Function-Name Definiton)				[MACRO]
;;; Defines how lists whose CAR is Function-Name will be printed.

;;; Pretty printing is done in two steps:
;;;	1] Converting the lisp object to a PP-Obj structure, and
;;;	2] Printing that structure in some pretty fashion.
;;;
;;; There are 3 levels of "prettiness" that are used in printing an object:
;;;	1] Basic grinding: formatting according to a handful of simple
;;;	   parameters.  This is done by the function Basically-Grind.
;;;	2] Simple, common ways of formating Defuns, Dos, etc.  The
;;;	   specifications for how an object is printed this way are either
;;;	   positive integers specifying the number of "special arguments" or
;;;	   negative integers specifying the number of "first line arguments".
;;;	   This is done by Specially-Grind.
;;;	3] Arbitraily hairy formatting conventions can be specified and are
;;;	   ground by Hairily-Grind.  Prog, for example, is specified this way.

;;; The PP-Obj structure holds stringified objects and their lengths. The Type
;;; slot holds SIMPLE, COMPLEX, STRING, or SPACE.  If it is SIMPLE, then Object
;;; contains an index into the PPrint-Buffer.  If it is COMPLEX, Object holds
;;; a list of PP-Objs; if it is STRING, then Object has a string representation
;;; of the object, and if it is SPACE, the PP-Obj is a marker for a possible
;;; line break.  The Callish slot holds what might be a function name from the
;;; original form.

(defstruct (pp-obj (:type vector) (:constructor slow-crufty-make-pp-obj))
  (type 'simple :read-only t)
  (length () :read-only t :type fixnum)
  (object () :read-only t)
  (callish () :read-only t))

;;; This here macro is preferable to calling the keyword-parsing function.

(defmacro make-pp-obj (&key (type ''simple) length object callish)
  `(vector ,type ,length ,object ,callish))

;;; Pre-computed pp-objs for quicker printing:

(defparameter pp-space-obj ())
(defparameter pp-open-paren-obj ())
(defparameter pp-close-paren-obj ())
(defparameter pp-sharp-open-paren-obj ())
(defparameter pp-sharp-open-angle-obj ())
(defparameter pp-close-angle-obj ())
(defparameter pp-dot-obj ())
(defparameter pp-dotdotdot-obj ())
(defparameter pp-starstar-obj ())
(defparameter pp-nil-obj ())
(defparameter pp-sharp-angle-array-rank-obj ())
(defparameter pp-sharp-obj ())
(defparameter pp-a-obj ())
(defparameter pp-dotdotdot-close-paren-obj ())

(defvar pprint-buffer-stream)

(defun pprint-init ()
  "Initializes the pretty printer."
  (setq pp-space-obj (make-pp-obj :type 'space :length 1)
	pp-open-paren-obj (make-pp-obj :type 'string :length 1 :object "(")
	pp-close-paren-obj (make-pp-obj :type 'string :length 1 :object ")")
	pp-sharp-open-paren-obj
	 (make-pp-obj :type 'string :length 2 :object "#(")
	pp-sharp-open-angle-obj
	 (make-pp-obj :type 'string :length 2 :object "#<")
	pp-close-angle-obj (make-pp-obj :type 'string :length 1 :object ">")
	pp-dot-obj (make-pp-obj :type 'string :length 1 :object ".")
	pp-dotdotdot-obj (make-pp-obj :type 'string :length 3 :object "...")
	pp-starstar-obj (make-pp-obj :type 'string :length 2 :object "**")
	pp-nil-obj (make-pp-obj :type 'string :length 3 :object "NIL")
	pp-sharp-angle-array-rank-obj
	 (make-pp-obj :type 'string :length 14 :object "#<Array, rank ")
	pp-sharp-obj (make-pp-obj :type 'string :length 1 :object "#")
	pp-a-obj (make-pp-obj :type 'string :length 1 :object "A")
	pp-dotdotdot-close-paren-obj
	 (make-pp-obj :type 'string :length 4 :object "...)")
	pprint-buffer-stream (make-string-output-stream)))

;;; PP-Line-Length is bound by the top level pprinting functions to an appropriate
;;; thing.

(defvar pp-line-length ()
  "What PPRINT thinks is the number of characters that will fit on a line.")

;;; A macro that helps putting stuff on the end of lists.

(defmacro end-cons (splice value)
  `(setq ,splice (cdr (rplacd ,splice (list ,value)))))


;;; Indentation returns the number of spaces to output after a newline as
;;; defined by the description of Indent-Style in Basically-Grind.

(defun indentation (components indent-style charpos)
  (declare (fixnum charpos))
  (cond ((numberp indent-style)
	 (+ charpos (the fixnum indent-style)))
	((eq indent-style 'normal)
	 (+ charpos (pp-obj-length (car components))))
	((eq indent-style 'past-name)
	 (+ charpos (pp-obj-length (car components))
	            (pp-obj-length (cadr components)) 1))
	(t (error "Flaming PPrint death!"))))

;;; Tab-Over prints the specified number of spaces on *Standard-Output*.

(defconstant maximum-pp-indentation 70)
(defconstant pp-indentation-string (make-string 70 :initial-element #\space))

(defun tab-over (indent-pos)
  (write-string pp-indentation-string *standard-output* 0
		(min indent-pos maximum-pp-indentation)))

;;; Converting the lisp object to a PP-Obj structure:

(defun pp-objify (object &optional (currlevel 0))
  (declare (fixnum currlevel))
  "Returns a PP-Obj structure which is used to prettily print the Object."
  (if (and *print-level* (> currlevel (the fixnum *print-level*)))
      pp-starstar-obj
      (typecase object
	(string (pp-objify-atom object))
	(vector (pp-objify-vector object currlevel))
	(array (pp-objify-array object currlevel))
	(list (pp-objify-list object currlevel))
	(t (pp-objify-atom object)))))

(defun pp-objify-atom (object)
  "Makes a PP-Obj for an atom."
  (let ((start (string-output-stream-index pprint-buffer-stream)))
    (output-object object)
    (make-pp-obj :length (- (string-output-stream-index pprint-buffer-stream)
			    start)
		 :object start)))

(defun pp-objify-vector (object currlevel)
  (declare (fixnum currlevel))
  "Makes a PP-Obj for a vector."
  (do* ((index 0 (1+ index))
	(terminus (length (the vector object)))
	(total-length 2)
	(result (list pp-sharp-open-paren-obj))
	(splice result))
       ((or (and *print-length* (>= index *print-length*)) (= index terminus))
	(cond ((/= index terminus)
	       (end-cons splice pp-dotdotdot-obj)
	       (setq total-length (+ 3 total-length))))
	(end-cons splice pp-close-paren-obj)
	(make-pp-obj :type 'complex
		     :length (1+ total-length)
		     :object result))
    (declare (fixnum index total-length terminus))
    (cond ((> index 0)
	   (end-cons splice pp-space-obj)
	   (setq total-length (1+ total-length))))
    (end-cons splice (pp-objify (aref object index) (1+ currlevel)))))

(defun pp-objify-array (object currlevel)
  "Makes a PP-Obj for an array."
  (let ((rank-obj (pp-objify (array-rank object) currlevel)))
    (if (not *print-array*)
	(make-pp-obj :type 'complex
		     :length (+ 14 (pp-obj-length rank-obj) 1)
		     :object (list pp-sharp-angle-array-rank-obj
				   rank-obj pp-close-angle-obj))
	(let ((result (list nil)))
	  (pretty-array-guts (%sp-svref object %array-data-slot)
			     (array-dimensions object)
			     currlevel 0 result)
	  (make-pp-obj :type 'complex
		       :length (+ 1 (pp-obj-length rank-obj) 1
				  (do ((total 0)
				       (stuff (cdr result) (cdr stuff)))
				      ((null stuff) total)
				    (setq
				     total (+ total
					      (pp-obj-length (car stuff))))))
		       :object (list* pp-sharp-obj rank-obj pp-a-obj
				      (cdr result)))))))

(defun pretty-array-guts (array dimensions currlevel index splice)
  (cond ((null dimensions)
	 (end-cons splice (pp-objify (%sp-svref array index)))
	 (values splice (1+ index)))
	((and (not (null *print-level*))
	      (>= currlevel *print-level*))
	 (end-cons splice pp-sharp-obj)
	 (values splice index))
	(t
	 (end-cons splice pp-open-paren-obj)
	 (do ((index index)
	      (times 0 (1+ times))
	      (limit (pop dimensions)))
	     ((or (= times limit)
		  (and (not (null *print-length*))
		       (= times *print-length*)))
	      (if (not (= times limit))
		  (end-cons splice pp-dotdotdot-close-paren-obj)
		  (end-cons splice pp-close-paren-obj))
	      (values splice index))
	   (if (not (zerop times))
	       (end-cons splice pp-space-obj))
	   (multiple-value-setq (splice index)
	     (pretty-array-guts array dimensions (1+ currlevel)
				index splice))))))

(defun pp-objify-list (object currlevel)
  (declare (fixnum currlevel))
  "Makes a PP-Obj for a list."
  (cond
   ((null object)
    pp-nil-obj)
   ((and (symbolp (car object)) (get (car object) 'simple-read-macro)
	 (listp (cdr object)) (cadr object) (null (cddr object)))
    (let ((argument (pp-objify (cadr object) currlevel))
	  (macro (get (car object) 'simple-read-macro)))
      (make-pp-obj :type 'complex
		   :length (+ (pp-obj-length argument) (pp-obj-length macro))
		   :object (cons macro (if (eq (pp-obj-type argument) 'complex)
					   (pp-obj-object argument)
					   (list argument)))
		   :callish (pp-obj-callish argument))))
   (t
    (do* ((object object (cdr object))
	  (callish (if (and (symbolp (car object))
			    (or (fboundp (car object))
				(eq (car object) 'lambda)))
		       (car object)))
	  (currlength 0 (1+ currlength))
	  (total-length 1)
	  (result (list pp-open-paren-obj))
	  (splice result))
	 ((or (and *print-length* (>= currlength (the fixnum *print-length*)))
	      (null object))
	  (cond (object
		 (end-cons splice pp-dotdotdot-obj)
		 (setq total-length (+ total-length 3))))
	  (end-cons splice pp-close-paren-obj)
	  (make-pp-obj :type 'complex
		       :length (1+ total-length)
		       :object result
		       :callish callish))
      (declare (fixnum currlength total-length))
      (cond ((> currlength 0)
	     (end-cons splice pp-space-obj)
	     (setq total-length (1+ total-length))))
      (end-cons splice (pp-objify (car object) (1+ currlevel)))
      (setq total-length (+ (pp-obj-length (car splice)) total-length))
      (cond ((not (listp (cdr object)))
	     (end-cons splice pp-space-obj)
	     (end-cons splice pp-dot-obj)
	     (end-cons splice pp-space-obj)
	     (end-cons splice (pp-objify (cdr object) (1+ currlevel)))
	     (setq total-length (+ total-length 3
				   (pp-obj-length (car splice))))
	     (setq object ())))))))

;;; Printing the PP-Obj:

;;; Break-Always = T causes newlines at every SPACE.  Many-On-a-Line = T
;;; causes as many objects as possible to be put on a line if the whole object
;;; won't fit on a line.  If Many-On-a-Line is (), then each component will
;;; be put on a separate line if the whole object won't fit on a line.
;;; An Indent-Style = NORMAL causes components on successive lines to line
;;; up with the column following the end of the first component (e.g. a left
;;; paren).  An Indent-Style = PAST-NAME causes components on successive
;;; lines to line up with the first column of the third component (e.g. the
;;; first argument to a function.)  A fixnum Indent-Style causes components
;;; to be indented that many spaces past the first column of the first
;;; component.  Charpos is the column we believe we're starting to print
;;; in.

(defun basically-grind (object break-always many-on-a-line indent-style
			       charpos)
  (declare (fixnum charpos))
  "Prints out an object constructed by PP-Objify."
  (if (or break-always
	  (and (null many-on-a-line)
	       (> (+ (pp-obj-length object) charpos) pp-line-length)))
      (break-always-grind (pp-obj-object object)
			  indent-style charpos)
      (break-sometimes-grind (pp-obj-object object)
			     indent-style charpos)))

(defun break-always-grind (object indent-style charpos)
  (declare (fixnum charpos))
  "Prints each component of the Object on its own line."
  (do ((components object (cdr components))
       (indent-pos (indentation object indent-style charpos)))
      ((null components))
    (cond ((eq (pp-obj-type (car components)) 'space)
	   (write-char #\newline)
	   (tab-over indent-pos)
	   (setq charpos indent-pos))
	  (t
	   (master-grind (car components) charpos)
	   (setq charpos (+ charpos (pp-obj-length (car components))))))))

(defun break-sometimes-grind (object indent-style charpos)
  (declare (fixnum charpos))
  "Prints as many components as possible on each line."
  (do* ((components object (cdr components))
	(early-indent-pos (indentation object 1 charpos))
	(late-indent-pos (indentation object indent-style charpos))
	(indent-pos early-indent-pos))
      ((null components))
    (declare (fixnum indent-pos))
    (cond ((eq (pp-obj-type (car components)) 'space)
	   (cond ((> (+ charpos (pp-obj-length (cadr components))) pp-line-length)
		  (write-char #\newline)
		  (tab-over indent-pos)
		  (setq charpos indent-pos))
		 (t
		  (setq indent-pos late-indent-pos)
		  (write-char #\space)
		  (setq charpos (1+ charpos)))))
	  (t
	   (master-grind (car components) charpos)
	   (setq charpos (+ charpos (pp-obj-length (car components))))))))

;;; Specially grind acts on the Specially-Grind property of the Callish slot
;;; of the given object, which must be an integer.  If this number is
;;; positive, that many SPACE PP-Objs following the function name indent
;;; ala PAST-NAME.  The following forms are indented 2 in and given
;;; separate lines.  If the number is negative, minus that many SPACE PP-Objs
;;; simply space over, and the rest are again indented 2 on separate lines.

(defun specially-grind (object charpos)
  (let ((spec (get (pp-obj-callish object) 'specially-grind)))
    (if (plusp spec)
	(special-arg-grind (pp-obj-object object) spec charpos)
	(top-line-grind (pp-obj-object object) (- spec) charpos))))

(defun special-arg-grind (object spec charpos)
  (do ((components object (cdr components))
       (body-indent)
       (indent-pos charpos))
      ((or (null components)
	   (eq (pp-obj-type (car components)) 'space))
       (when components
	 (write-char #\space)
	 (setq components (cdr components))
	 (setq indent-pos (+ indent-pos 1))
	 (dotimes (i spec)
	   (cond ((eq (pp-obj-type (car components)) 'complex)
		  (break-always-grind (pp-obj-object (car components))
				      1 indent-pos))
		 ((eq (car components) pp-nil-obj)
		  (write-string "()"))
		 (t
		  (master-grind (car components) indent-pos)))
	   (setq components (cdr components)))
	 (if components (break-always-grind components 1 body-indent))))
    (master-grind (car components) charpos)
    (setq indent-pos (+ indent-pos (pp-obj-length (car components))))
    (if (eq (car components) pp-open-paren-obj)
	(setq body-indent indent-pos))))

(defun top-line-grind (object spec charpos)
  (do ((components object (cdr components))
       (spaces-seen 0)
       (body-indent)
       (indent-pos charpos))
      ((or (null components)
	   (= spaces-seen spec))
       (when components
	 (break-always-grind components 1 (or body-indent (+ charpos 1)))))
    (cond ((eq (pp-obj-type (car components)) 'space)
	   (setq spaces-seen (1+ spaces-seen))
	   (write-char #\space)
	   (setq indent-pos (1+ indent-pos)))
	  (t
	   (master-grind (car components) charpos)
	   (setq indent-pos (+ indent-pos (pp-obj-length (car components))))
	   (if (and (null body-indent) (eq (car components) pp-open-paren-obj))
	       (setq body-indent indent-pos))))))

;;; Hairily-Grind isn't implemented:

(defun hairily-grind (&rest ignore)
  (error "I'm not yet implemented."))

;;; Master-Grind dispatches to grinders various levels of intelligence
;;; by looking at the PP-Obj handed to it.

(defun master-grind (object charpos)
  (cond ((eq (pp-obj-type object) 'simple)
	 (let ((start (pp-obj-object object)))
	   (write-string (string-output-stream-string pprint-buffer-stream)
			 *standard-output* start
			 (+ start (pp-obj-length object)))))
	((eq (pp-obj-type object) 'string)
	 (write-string (pp-obj-object object)))
	((pp-obj-callish object)
	 (cond ((get (pp-obj-callish object) 'specially-grind)
		(specially-grind object charpos))
	       ((get (pp-obj-callish object) 'hairily-grind)
		(hairily-grind object charpos))
	       (t
		(basically-grind object () t 'past-name charpos))))
	(t
	 (basically-grind object () t 'normal charpos))))

;;; The exported functions:

(defun output-pretty-object (object)
  "Prettily outputs the Object to *Standard-Output*, like Output-Object."
  (setf (string-output-stream-index pprint-buffer-stream) 0)
  (let ((pp-line-length (or (line-length) 80)))
    (master-grind
     (let ((*standard-output* pprint-buffer-stream))
       (pp-objify object))
     (or (charpos) 0))))

(defun pprin1 (object &optional (*standard-output* *standard-output*))
  "Prettily outputs the Object to the Stream slashifying special characters."
  (setup-printer-state)
  (let ((*print-escape* t))
    (output-pretty-object object)))

(defun pprinc (object &optional (*standard-output* *standard-output*))
  "Prettily outputs the Object to the Stream without slashifying."
  (setup-printer-state)
  (let ((*print-escape* ()))
    (output-pretty-object object)))

(defun pprint (object &optional (*standard-output* *standard-output*))
  "Prettily outputs the Object preceded by a newline and followed by a space."
  (write-char #\newline)
  (pprin1 object)
  (write-char #\space)
  (values))

(defun pretty-lambda-to-defun (name lambda &optional arglist)
  `(defun ,name ,(or arglist (cadr lambda))
     ,@(if (and (null (cdddr lambda)) (listp (caddr lambda))
		(eq (caaddr lambda) 'block))
	   (cddr (caddr lambda))
	   (cddr lambda))))

(defmacro grindef (function-name)
 "Prettily prints the definition of the function whose name is Function-Name."
 (if (and (symbolp function-name) (fboundp function-name))
     (let ((stuff (symbol-function function-name)))
       (if (and (listp stuff) (listp (cdr stuff)))
	   (case (car stuff)
	     (lambda `(pprint ',(pretty-lambda-to-defun function-name stuff)))
	     (macro `(pprint ',(pretty-lambda-to-defun function-name (cdr stuff)
						       '(&rest **macroarg**))))
	     (t `(pprint '(setf (symbol-function ,function-name) ',stuff))))
	   `(pprint '(setf (symbol-function ,function-name) ',stuff))))
     nil))

(defmacro defprint (function-name way)
  "Defines a Way for PPrint to print a call to the function named by
   Function-Name.  See ??? for details."
  (if (listp way)
      `(%put ',function-name ',(car way) ',(cadr way))
      `(%put ',function-name 'specially-grind ',way)))

;;; DefPrints for some common things:

(defprint block 1)
(defprint case -1)
(defprint catch 1)
(defprint catch-all 2)
(defprint cond 0)
(defprint defmacro -2)
(defprint defun -2)
(defprint do 2)
(defprint do* 2)
(defprint do-all-symbols -1)
(defprint do-external-symbols -1)
(defprint do-internal-symbols -1)
(defprint do-symbols -1)
(defprint dolist -1)
(defprint dotimes -1)
(defprint flet 1)
(defprint function (simple-read-macro #(string 2 "#'" nil)))
(defprint labels 1)
(defprint lambda 1)
(defprint let 1)
(defprint let* 1)
(defprint macrolet 1)
(defprint multiple-value-setq -1)
(defprint multiple-value-bind -2)
(defprint mvcall -1)
(defprint prog 1)					; eventually hairier
(defprint prog* 1)
(defprint prog1 0)
(defprint prog2 0)
(defprint progn 0)
(defprint progv 2)
(defprint quote (simple-read-macro #(string 1 "'" nil)))
(defprint throw 2)
(defprint typecase -1)
(defprint unless -1)
(defprint unwind-all 2)
(defprint unwind-protect 2)
(defprint when -1)