* bug#25226: Describe compiled function values in a friendlier way
@ 2016-12-18 22:41 npostavs
2016-12-21 17:57 ` Eli Zaretskii
2017-06-13 3:01 ` npostavs
0 siblings, 2 replies; 3+ messages in thread
From: npostavs @ 2016-12-18 22:41 UTC (permalink / raw)
To: 25226
[-- Attachment #1: Type: text/plain, Size: 310 bytes --]
Severity: wishlist
tags: patch
There was some discussion on emacs-devel [1] about the value of
eldoc-documentation-function being unreadable. Here is a patch that
produces a more human-friendly display for compiled function values:
[1]: https://lists.gnu.org/archive/html/emacs-devel/2016-06/msg00138.html
[-- Attachment #2: patch --]
[-- Type: text/plain, Size: 7198 bytes --]
From d0327009f0dc63ca007efa2aa8a0a9b9189b6cb9 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
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
[-- Attachment #3: Type: text/plain, Size: 37 bytes --]
Here's a screenshot of the result:
[-- Attachment #4: screenshot with patch applied --]
[-- Type: image/png, Size: 52928 bytes --]
^ permalink raw reply related [flat|nested] 3+ messages in thread
end of thread, other threads:[~2017-06-13 3:01 UTC | newest]
Thread overview: 3+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2016-12-18 22:41 bug#25226: Describe compiled function values in a friendlier way npostavs
2016-12-21 17:57 ` Eli Zaretskii
2017-06-13 3:01 ` npostavs
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).