pretty-printing funcalls with keywords

[Miles Bader <miles@cogsci.edinburgh.ac.uk>]

This is the same as the current pprint-function-call, but tries to treat
keyword arguments specially.  It makes frames displayed in the debugger a
bit prettier.

-Miles

--
Miles Bader  --  HCRC, University of Edinburgh  --  miles@cogsci.ed.ac.uk
Ich bin ein Virus. Mach' mit und kopiere mich in Deine .signature.
97% of everything is grunge

;;; Stuff to make pretty-printing function-calls with keyword args nicer

(in-package :pretty-print)

(defun function-lambda-list-template (fun)
  "Return a template corresponding to this FUNs lambda list (which is just
   something that `looks' like it, e.g., one element for each arg + the &
   keywords).  A second value returned is NIL if none could be found, T if
   the template is really a lambda-list, or :TYPES if it's actually the types
   of the lambda list args (which is often just as useful)."
  (typecase fun
    ((satisfies eval:interpreted-function-p) ; yick
     (values (cadr (function-lambda-expression fun))
	     t))
    (compiled-function
     ;; get the types of the lambda list instead...
     (let ((fun-type (kernel:%function-header-type fun)))
       (if (and (listp fun-type)
		(eq (car fun-type) 'function))
	   (values (cadr fun-type) :types)
	   (values nil nil))))
    (t
     (values nil nil))))
	   
(defun pprint-function-call (stream list &rest noise)
  (declare (ignore noise))
  (let ((template
	 (and (fboundp (car list))
	      (function-lambda-list-template (symbol-function (car list))))))
    (pprint-logical-block (stream list :prefix "(" :suffix ")")
      ;; function name
      (output-object (pprint-pop) stream)
      (pprint-exit-if-list-exhausted)

      ;; arg indentation
      (write-char #\Space stream)
      (pprint-newline :fill stream)
      (pprint-indent :current 0 stream)

      ;; args
      (let ((in-keywords-p nil))
	(loop
	  (when (not in-keywords-p)
	    ;; see if are now
	    (loop
	      (when (null template)
		(return))
	      (let ((ll-thing (pop template)))
		(unless (member ll-thing lambda-list-keywords :test #'eq)
		  (return))
		(when (eq ll-thing '&key)
		  (setf in-keywords-p t)))))
	      
	  (cond (in-keywords-p
		 ;; Print keywords arg values either on the same line with
		 ;; their keyword, or on the next line, indented 3 spaces in.
		 (let* ((keyword (pprint-pop))
			(value (pprint-pop)))
		   (pprint-logical-block (stream nil)
		     (output-object keyword stream)
		     (pprint-indent :block 3 stream)
		     (write-char #\Space stream)
		     (pprint-newline :fill stream)
		     (output-object value stream))))
		(t
		 (output-object (pprint-pop) stream)))

	  (pprint-exit-if-list-exhausted)
	  (write-char #\Space stream)
	  (pprint-newline :linear stream))))))

(defun pprint-cond (stream list &rest noise)
  (declare (ignore noise))
  (funcall (formatter
	    "~:<~^~W~^ ~@_~:I~@{~:/PP:PPRINT-LINEAR/~^ ~_~}~:>")
	   stream
	   list))