bug#25295: Represent eieio objects using object-print in backtraces and edebug

[Stefan Monnier <monnier@IRO.UMontreal.CA>]

> Can we allow overriding printing of primitive types too?
> I'm wanting that for e.g., printing byte code functions in nicer ways.

Maybe we should just switch to an Elisp version of printing, in that case.
We could keep the C code for the "print-readably" case only.
The main question is whether it's fast enough.


        Stefan


;;; cl-print.el --- Generic printer facilies         -*- lexical-binding: t; -*-

;; Copyright (C) 2017  Stefan Monnier

;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: 

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

;;;###autoload
(cl-defgeneric cl-print-object (object stream)
  "Dispatcher to print OBJECT on STREAM according to its type."
  (prin1 object stream))

(cl-defmethod cl-print-object ((object cons) stream)
  (let ((car (pop object)))
    (if (and (memq car '(\, quote \` \,@ \,.))
             (consp object)
             (null (cdr object)))
        (progn
          (princ (if (eq car 'quote) '\' car) stream)
          (cl-print-object (car object) stream))
      (princ "(" stream)
      (cl-print-object car stream)
      (while (consp object)
        (princ " " stream)
        (cl-print-object (pop object) stream))
      (when object
        (princ " . ") (cl-print-object object stream))
      (princ ")"))))

(cl-defmethod cl-print-object ((object vector) stream)
  (princ "[" stream)
  (dotimes (i (length object))
    (unless (zerop i) (princ " " stream))
    (cl-print-object (aref object i) stream))
  (princ "]" stream))

(cl-defmethod cl-print-object ((object compiled-function) stream)
  ;; FIXME: Give a prettier representation.
  (princ "#<compiled-function>" stream))

(cl-defmethod cl-print-object ((object cl-structure-object) stream)
  (princ "#s(")
  (let* ((class (symbol-value (aref object 0)))
         (slots (cl--struct-class-slots class)))
    (princ (cl--struct-class-name class) stream)
    (dotimes (i (length slots))
      (let ((slot (aref slots i)))
        (princ " :" stream)
        (princ (cl--slot-descriptor-name slot) stream)
        (princ " " stream)
        (cl-print-object (aref object (1+ i)) stream))))
  (princ ")"))

;;; Circularity and sharing.

;; I don't try to support the `print-continuous-numbering', because
;; I think it's ill defined anyway: if an object appears only once in each call
;; its sharing can't be properly preserved!

(defvar cl-print--number-index nil)
(defvar cl-print--number-table nil)

(cl-defmethod cl-print-object :around (object stream)
  ;; FIXME: Only put such an :around method on types where it's relevant.
  (let ((n (if cl-print--number-table (gethash object cl-print--number-table))))
    (if (not (numberp n))
        (cl-call-next-method)
      (if (> n 0)
          ;; Already printed.  Just print a reference.
          (progn (princ "#" stream) (princ n stream) (princ "#" stream))
        (puthash object (- n) cl-print--number-table)
        (princ "#" stream) (princ (- n) stream) (princ "=" stream)
        (cl-call-next-method)))))

(defun cl-print--find-sharing (object table)
  (unless
      ;; Skip objects which don't have identity!
      (or (floatp object) (numberp object))
    (let ((n (gethash object table)))
      (cond
       ((numberp n))                   ;All done.
       (n                              ;Already seen, but only once.
        (let ((n (1+ cl-print--number-index)))
          (setq cl-print--number-index n)
          (puthash object (- n) table)))
       (t
         (puthash object t table)
         (pcase object
           (`(,car . ,cdr)
            (cl-print--find-sharing car table)
            (cl-print--find-sharing cdr table))
           ((pred stringp)
            ;; We presumably won't print its text-properties.
            nil)
           ((pred arrayp)             ;FIXME: Inefficient for char-tables!
            (dotimes (i (length object))
              (cl-print--find-sharing (aref object i) table)))))))))

;;;###autoload
(defun cl-prin1 (object &optional stream)
  (if (not print-circle)
      (cl-print-object object stream)
    (let ((cl-print--number-table (make-hash-table :test 'eq))
          (cl-print--number-index 0))
      (cl-print--find-sharing object cl-print--number-table)
      (cl-print-object object stream))))

(provide 'cl-print)
;;; cl-print.el ends here