;;;; -*- mode:emacs-lisp; coding:utf-8; lexical-binding:t -*-
(require 'cl)
;; (let ((types (make-hash-table :test (function equal)))
;; (objects (make-hash-table))
;; (queue '()))
;; (do-symbols (symbol)
;; (push symbol queue))
;; (loop
;; while queue
;; for object = (pop queue)
;; do (unless (gethash object objects)
;; (setf (gethash object objects) t)
;; (incf (gethash (type-of object) types 0))
;; (typecase object
;; (symbol
;; (when (boundp object) (push (symbol-value object) queue))
;; (when (fboundp object) (push (symbol-function object) queue))
;; (setf queue (nconc (copy-list (symbol-plist object)) queue)))
;; (cons
;; (push (car object) queue)
;; (push (cdr object) queue))
;; (vector
;; (loop for i below (length object)
;; do (push (aref object i) queue))))))
;; (values
;; types
;; (hash-table-count objects)))
;; (#s(hash-table size 65 test equal rehash-size 1.5 rehash-threshold 0.8 data
;; (
;; cons 674435
;; string 95654
;; integer 94087
;; symbol 73342
;; compiled-function 16826
;; vector 12107
;; subr 1125
;; float 461
;; marker 174
;; char-table 158
;; overlay 18
;; buffer 72
;; hash-table 25
;; process 5
;; frame 2
;; window-configuration 2
;; window 2
;; obarray 1
;; ))
;; 968495)
;; --> ((window window-configuration hash-table frame marker buffer overlay process char-table float vector subr compiled-function string cons integer symbol)
;; 964895)
(defvar inspect:*inspectors* (make-hash-table))
(defmacro inspect:define-inspector (type (object) &body body)
`(setf (gethash ',type *inspectors*)
(lambda (,object) (block ,type ,@body))))
(defun inspect:function-parameter-list (function)
"Return the parameter list of the emacs FUNCTION."
(let* ((def (if (symbolp function)
(symbol-function function)
function))
(help (help-function-arglist def))
(doc (documentation function))
(split (help-split-fundoc doc function)))
(or help
(when (first split) (cdar (read-from-string (first split))))
split
:unknown)))
(defun inspect:function-argument-counts (function)
"Return a cons continaing the minimum and maximum number of arguments
the FUNCTION can take."
(let* ((args (split-lambda-list-on-keywords
(maptree (lambda (item)
(if (memq item '(&optional &rest))
(intern (string-upcase item))
item))
(function-parameter-list (function enlarge-window)))
:ordinary))
(min (length (cdr (assoc '&MANDATORY args)))))
(if (assoc '&REST args)
(cons min '&rest)
(cons min (+ min (length (cdr (assoc '&OPTIONAL args))))))))
(defun inspect:hash-table-slots (hash-table)
(let ((slots '()))
(maphash (lambda (k v) (push (cons k v) slots)) hash-table)
(nreverse slots)))
(defun inspect:vector-slots (vector)
(let ((slots '()))
(loop for i below (length vector) do (push (cons i (aref vector i)) slots))
(nreverse slots)))
(defun inspect:obarray-symbols (obarray)
(let ((symbols '()))
(do-symbols (symbol obarray)
(push symbol symbols))
(mapcar (let ((i -1))
(lambda (symbol) (cons (incf i) symbol)))
(sort symbols (function string<)))))
(defun inspect:buffer-slots (buffer)
;; properties are in string
;; markers? processes? what else?
(list (list :string (with-current-buffer buffer (buffer-string)))))
(defparameter inspect:*type-attribute-alist*
'((cons
car cdr)
(string
;; text-properties-at
length
string-bytes)
(integer
identity)
(float
identity)
(symbol
symbol-name
(boundp symbol-value)
(fboundp symbol-function)
symbol-plist
function-overload-p)
(compiled-function
function-argument-counts
function-parameter-list)
(vector
length
(:contents inspect:vector-slots))
(subr
subr-name
subr-arity)
(marker
marker-buffer
marker-position
marker-insertion-type)
(char-table
;; char-table-extra-slot
;; char-table-range
char-table-parent
char-table-subtype)
(overlay
overlay-buffer
overlay-start
overlay-end
overlay-properties)
(buffer
buffer-name
buffer-file-name
buffer-size
buffer-base-buffer
buffer-chars-modified-tick
buffer-live-p
buffer-local-variables
buffer-modified-p
buffer-modified-tick
(:contents inspect:buffer-slots))
(hash-table
hash-table-test
hash-table-weakness
hash-table-count
hash-table-size
hash-table-rehash-size
hash-table-rehash-threshold
(:contents inspect:hash-table-slots))
(process
process-id
process-name
process-type
process-plist
process-buffer
process-coding-system
process-command
process-contact
process-datagram-address
process-filter
process-filter-multibyte-p
;; process-get
process-inherit-coding-system-flag
process-live-p
process-mark
process-query-on-exit-flag
process-running-child-p
process-sentinel
process-status
process-exit-status
process-tty-name)
(frame
frame-name
frame-title
frame-left frame-top frame-width frame-height
frame-pixel-left frame-pixel-top frame-pixel-width frame-pixel-height
frame-left-fringe
frame-right-fringe
frame-auto-lower
frame-auto-raise
frame-foreground-color
frame-background-color
frame-background-mode
frame-border-color
frame-border-width
frame-buffer-list
frame-buffer-predicate
frame-cursor-color
frame-cursor-type
frame-display
frame-display-type
frame-font
frame-icon-name
frame-icon-type
frame-internal-border-width
frame-line-spacing
frame-menu-bar-lines
frame-minibuffer
frame-modeline
frame-mouse-color
frame-parent-id
frame-window-id
frame-outer-window-id
frame-screen-gamma
frame-horizontal-scroll-bars
frame-vertical-scroll-bars
frame-scroll-bar-background
frame-scroll-bar-foreground
frame-scroll-bar-width
frame-current-scroll-bars
frame-tool-bar-lines
frame-unsplittable
frame-visibility
frame-wait-for-wm
frame-char-height frame-char-width frame-face-alist
frame-first-window frame-focus frame-live-p frame-parameters
frame-pointer-visible-p
frame-root-window frame-selected-window frame-terminal
frame-terminal-default-bg-mode frame-visible-p
window-system
window-list
window-tree
buffer-list)
(window-configuration
window-configuration-frame)
(window
window-atom-root window-body-size window-body-height
window-body-width window-buffer window-buffer-height
window-next-buffers window-prev-buffers window-child
window-child-count window-top-child window-left-child
window-last-child window-combination-limit window-combinations
window-combined-p window-current-scroll-bars window-dedicated-p
window-deletable-p window-display-table window-dot window-edges
window-end window-fixed-size-p window-frame window-fringes
window-full-height-p window-full-width-p window-height
window-hscroll window-inside-absolute-pixel-edges
window-inside-edges window-inside-pixel-edges window-left
window-right window-left-column window-top-line window-line-height
window-live-p window-margins window-max-delta window-min-delta
window-min-size window-minibuffer-p window-next-sibling
window-prev-sibling window-normal-size window-parameters
window-parent window-pixel-edges window-point
window-safely-shrinkable-p window-scroll-bars window-size-fixed-p
window-split-min-size window-splittable-p window-start
window-state-get window-text-height window-total-height
window-total-size window-total-width window-use-time
window-valid-p window-vscroll window-width
frame-root-window-p)
(obarray
(:contents inspect:obarray-symbols)))
"
An a-list mapping types to a list of attributes.
Each attribute is either:
- a symbol naming a predicate or reader function.
- a list of symbols naming predicate or reader functions; the rest of
the list is applied only when the preceding elements return true.
- a list containing the keyword :contents and a symbol naming a
function that takes an object of the given type, returning an a-list
of (key . value) for each slot in the object.
")
(defun inspect:max-slot-name-width (slots)
(loop
for slot in slots
maximize (cond
((symbolp slot) (length (symbol-name slot)))
((stringp slot) (length slot))
((atom slot) 0)
((eq :contents (first slot)) 0)
(t (reduce (function max) slot
:key (lambda (fun) (length (symbol-name fun))))))))
(defun inspect:insert-description (object)
(let* ((type (type-of object))
(slots (cdr (assoc type inspect:*type-attribute-alist*)))
(width (inspect:max-slot-name-width slots))
(fmtstr (format "%%-%ds : %%S\n" width))
(print-length 10)
(print-level 4))
(insert (format "\nObject of type %s\n\n" type))
(loop
for slot in slots
do (cond
((symbolp slot)
(insert (format fmtstr slot (funcall slot object))))
((atom slot)
0)
((eq :contents (first slot))
(insert "Contents:\n")
(let* ((slots (funcall (second slot) object))
(width (inspect:max-slot-name-width
(mapcar (lambda (slot) (format "%S" (car slot)))
slots)))
(fmtstr (format "[%%%dS] : %%S\n" width)))
(loop
for (key . value) in slots
do (insert (format fmtstr key value)))))
(t
(loop
for predicate in slot
for value = (funcall slot object)
do (insert (format fmtstr slot value))
while value))))))
;; (inspect:insert-description '(a . 2))
;; (inspect:insert-description '[(a . 2) 3 4.5 "Hello"])
;; (inspect:insert-description (selected-frame))