>From d0327009f0dc63ca007efa2aa8a0a9b9189b6cb9 Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Sun, 18 Dec 2016 12:12:33 -0500 Subject: [PATCH v1] Describe compiled function values in a friendlier way * lisp/emacs-lisp/nadvice.el (advice--where): New function, finds "where" a function was added. (advice-function-mapc-with-location): New function, like `advice-function-mapc', but additionally passes where to the iterating function, and returns the final non-advice function. * lisp/help-fns.el (help-byte-code): New button type, whose action call `disassemble'. (describe-function-value): New function, produces descriptive string, hiding byte code behind a `help-byte-code' button. (describe-variable): Use it to describe byte code function values. --- lisp/emacs-lisp/nadvice.el | 20 ++++++++++ lisp/help-fns.el | 94 ++++++++++++++++++++++++++++++++-------------- 2 files changed, 86 insertions(+), 28 deletions(-) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 1b30499..ed871e5 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -66,6 +66,11 @@ advice--p (defsubst advice--car (f) (aref (aref f 2) 1)) (defsubst advice--cdr (f) (aref (aref f 2) 2)) (defsubst advice--props (f) (aref (aref f 2) 3)) +(defun advice--where (f) + (require 'cl-lib) + (caar (cl-member (aref f 1) + advice--where-alist + :key (lambda (e) (nth 1 e))))) (defun advice--cd*r (f) (while (advice--p f) @@ -331,6 +336,21 @@ advice-function-mapc (funcall f (advice--car function-def) (advice--props function-def)) (setq function-def (advice--cdr function-def)))) +(defun advice-function-mapc-with-location (f function-def) + "Apply F to every advice function in FUNCTION-DEF. +F is called with three arguments: the function that was added, +the 'location' it was added at (similar to the first argument of +`add-function'), and the properties alist that was specified when +it was added. +Returns the final non-advice function found." + (while (advice--p function-def) + (funcall f + (advice--car function-def) + (advice--where function-def) + (advice--props function-def)) + (setq function-def (advice--cdr function-def))) + function-def) + (defun advice-function-member-p (advice function-def) "Return non-nil if ADVICE is already in FUNCTION-DEF. Instead of ADVICE being the actual function, it can also be the `name' diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 23dec89..605edb7 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -753,6 +753,42 @@ describe-variable-custom-version-info version package)))))) output)) +(define-button-type 'help-byte-code + 'follow-link t + 'action (lambda (button) + (disassemble (button-get button 'byte-code-function))) + 'help-echo (purecopy "mouse-2, RET: disassemble this function")) + +(defun describe-function-value (fun &optional indent-level) + (cond + ((byte-code-function-p fun) + (setq indent-level (+ (or indent-level 0) 2)) + (let* ((indent-str (concat "\n" (make-string indent-level ?\s))) + (components nil) + (final-fun (advice-function-mapc-with-location + (lambda (subfun where _props) + (push `(,where ,subfun) components)) + fun))) + (concat + (make-text-button "a compiled function" nil + :type 'help-byte-code 'byte-code-function fun) + (when components + (concat ", composed of subfunctions:" + (mapconcat (pcase-lambda (`(,where ,fun)) + (concat indent-str (symbol-name where) " " + (describe-function-value fun indent-level) + ",")) + (nreverse components) " ") + indent-str "and finally: " + (describe-function-value final-fun indent-level) "."))))) + ((symbolp fun) + (format-message "`%s'" + (make-text-button + (copy-sequence (symbol-name fun)) nil + :type 'help-function + 'help-args (list fun)))) + (t (prin1-to-string fun)))) + ;;;###autoload (defun describe-variable (variable &optional buffer frame) "Display the full documentation of VARIABLE (a symbol). @@ -829,34 +865,36 @@ describe-variable (with-current-buffer standard-output (setq val-start-pos (point)) (princ "value is") - (let ((line-beg (line-beginning-position)) - (print-rep - (let ((rep - (let ((print-quoted t)) - (prin1-to-string val)))) - (if (and (symbolp val) (not (booleanp val))) - (format-message "`%s'" rep) - rep)))) - (if (< (+ (length print-rep) (point) (- line-beg)) 68) - (insert " " print-rep) - (terpri) - (pp val) - ;; Remove trailing newline. - (delete-char -1)) - (let* ((sv (get variable 'standard-value)) - (origval (and (consp sv) - (condition-case nil - (eval (car sv)) - (error :help-eval-error)))) - from) - (when (and (consp sv) - (not (equal origval val)) - (not (equal origval :help-eval-error))) - (princ "\nOriginal value was \n") - (setq from (point)) - (pp origval) - (if (< (point) (+ from 20)) - (delete-region (1- from) from))))))) + (if (byte-code-function-p val) + (insert " " (describe-function-value val)) + (let ((line-beg (line-beginning-position)) + (print-rep + (let ((rep + (let ((print-quoted t)) + (prin1-to-string val)))) + (if (and (symbolp val) (not (booleanp val))) + (format-message "`%s'" rep) + rep)))) + (if (< (+ (length print-rep) (point) (- line-beg)) 68) + (insert " " print-rep) + (terpri) + (pp val) + ;; Remove trailing newline. + (delete-char -1)))) + (let* ((sv (get variable 'standard-value)) + (origval (and (consp sv) + (condition-case nil + (eval (car sv)) + (error :help-eval-error)))) + from) + (when (and (consp sv) + (not (equal origval val)) + (not (equal origval :help-eval-error))) + (princ "\nOriginal value was \n") + (setq from (point)) + (pp origval) + (if (< (point) (+ from 20)) + (delete-region (1- from) from)))))) (terpri) (when locus (cond -- 2.9.3