code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/eieio-datadebug.el

   1 ;;; eieio-datadebug.el --- EIEIO extensions to the data debugger.  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 2007-2015 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6 ;; Keywords: OO, lisp
   7 ;; Package: eieio
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25 ;;
  26 ;; Extensions to data-debug for EIEIO objects.
  27 ;;
  28
  29 (require 'eieio)
  30 (require 'data-debug)
  31
  32 ;;; Code:
  33
  34 (declare-function data-debug/eieio-insert-slots "eieio-datadebug"
  35                   (obj eieio-default-superclass))
  36
  37 (defun data-debug-insert-object-slots (object prefix)
  38   "Insert all the slots of OBJECT.
  39 PREFIX specifies what to insert at the start of each line."
  40   (let ((attrprefix (concat (make-string (length prefix) ? ) "] ")))
  41     (data-debug/eieio-insert-slots object attrprefix)))
  42
  43 (defun data-debug-insert-object-slots-from-point (point)
  44   "Insert the object slots found at the object button at POINT."
  45   (let ((object (get-text-property point 'ddebug))
  46         (indent (get-text-property point 'ddebug-indent))
  47         start)
  48     (end-of-line)
  49     (setq start (point))
  50     (forward-char 1)
  51     (data-debug-insert-object-slots object
  52                                     (concat (make-string indent ? )
  53                                             "~ "))
  54     (goto-char start)))
  55
  56 (defun data-debug-insert-object-button (object prefix prebuttontext)
  57   "Insert a button representing OBJECT.
  58 PREFIX is the text that precedes the button.
  59 PREBUTTONTEXT is some text between PREFIX and the object button."
  60   (let* ((start (point))
  61          (end nil)
  62          (str (object-print object))
  63          (class (eieio-object-class object))
  64          (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots"
  65                       (eieio-object-name-string object)
  66                       class
  67                       (eieio-class-parents class)
  68                       (length (eieio-class-slots class))
  69                       ))
  70          )
  71     (insert prefix prebuttontext str)
  72     (setq end (point))
  73     (put-text-property (- end (length str)) end 'face 'font-lock-keyword-face)
  74     (put-text-property start end 'ddebug object)
  75     (put-text-property start end 'ddebug-indent(length prefix))
  76     (put-text-property start end 'ddebug-prefix prefix)
  77     (put-text-property start end 'help-echo tip)
  78     (put-text-property start end 'ddebug-function
  79                        'data-debug-insert-object-slots-from-point)
  80     (insert "\n")))
  81
  82 ;;; METHODS
  83 ;;
  84 ;; Each object should have an opportunity to show stuff about itself.
  85
  86 (cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
  87                                              prefix)
  88   "Insert the slots of OBJ into the current DDEBUG buffer."
  89   (let ((inhibit-read-only t))
  90     (data-debug-insert-thing (eieio-object-name-string obj)
  91                              prefix
  92                              "Name: ")
  93     (let* ((cv (eieio--object-class obj)))
  94       (data-debug-insert-thing (eieio--class-name cv)
  95                                prefix
  96                                "Class: ")
  97       ;; Loop over all the public slots
  98       (let ((slots (eieio--class-slots cv)))
  99         (dotimes (i (length slots))
 100           (let* ((slot (aref slots i))
 101                  (sname (cl--slot-descriptor-name slot))
 102                  (i (eieio--class-slot-initarg cv sname))
 103                  (sstr (concat (symbol-name (or i sname)) " ")))
 104             (if (slot-boundp obj sname)
 105                 (let* ((v (eieio-oref obj sname)))
 106                   (data-debug-insert-thing v prefix sstr))
 107               ;; Unbound case
 108               (data-debug-insert-custom
 109                "#unbound" prefix sstr
 110                'font-lock-keyword-face)
 111               )))))))
 112
 113 ;;; Augment the Data debug thing display list.
 114 (data-debug-add-specialized-thing (lambda (thing) (eieio-object-p thing))
 115                                   #'data-debug-insert-object-button)
 116
 117 ;;; DEBUG METHODS
 118 ;;
 119 ;; A generic function to run DDEBUG on an object and popup a new buffer.
 120 ;;
 121 (cl-defmethod data-debug-show ((obj eieio-default-superclass))
 122   "Run ddebug against any EIEIO object OBJ."
 123   (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj)))
 124   (data-debug-insert-object-slots obj "]"))
 125
 126 (provide 'eieio-datadebug)
 127
 128 ;;; eieio-datadebug.el ends here