Subject: bug#25226: Describe compiled function values in a friendlier way

From: [email-masked]
Date: Sun, 18 Dec 2016 17:41:07 -0500

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

>From d0327009f0dc63ca007efa2aa8a0a9b9189b6cb9 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <[email-masked]>
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

Here's a screenshot of the result: