From: Eshel Yaron <me@eshelyaron.com>
Date: Sun, 14 Jul 2024 12:55:07 +0000 (+0200)
Subject: Improve '[un]trace-function'
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=8b75cb63a185a78205b89aa4332518a84f5bb669;p=emacs.git

Improve '[un]trace-function'
---

diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el
index 29775e77716..f1fb098f4e1 100644
--- a/lisp/emacs-lisp/trace.el
+++ b/lisp/emacs-lisp/trace.el
@@ -254,15 +254,39 @@ be printed after the arguments in the trace."
 (defun trace-is-traced (function)
   (advice-member-p trace-advice-name function))
 
+(defvar trace-function-history nil
+  "Minibuffer history for `trace-function' and `untrace-function'.")
+
 (defun trace--read-args (prompt)
   "Read a function name, prompting with string PROMPT.
 If `current-prefix-arg' is non-nil, also read a buffer and a \"context\"
 \(Lisp expression).  Return (FUNCTION BUFFER FUNCTION-CONTEXT)."
   (cons
-   (let ((default (function-called-at-point)))
-     (intern (completing-read (format-prompt prompt default)
-                              obarray 'fboundp t nil nil
-                              (if default (symbol-name default)))))
+   (let ((default (function-called-at-point))
+         (action this-command))
+     (intern
+      (minibuffer-with-setup-hook
+          (lambda ()
+            (setq minibuffer-action
+                  (cons (compose action #'intern) "trace"))
+            (setq minibuffer-alternative-action
+                  (cons (compose #'untrace-function #'intern) "untrace")))
+        (completing-read
+         (format-prompt prompt default)
+         (completion-table-with-metadata
+          obarray
+          `((affixation-function
+             . ,(lambda (cs)
+                  (let ((res (minibuffer-function-affixation cs)))
+                    (dolist (c res)
+                      (setcar
+                       (cdr c)
+                       (if (trace-is-traced (intern (car c)))
+                           (propertize "ON  " 'face 'success)
+                         (propertize "OFF " 'face 'error))))
+                    res)))))
+         #'fboundp t nil 'trace-function-history
+         (if default (symbol-name default))))))
    (when current-prefix-arg
      (list
       (read-buffer "Output to buffer" trace-buffer)
@@ -315,10 +339,17 @@ Activation is performed with `ad-update', hence remaining advice will get
 activated only if the advice of FUNCTION is currently active.  If FUNCTION
 was not traced this is a noop."
   (interactive
-   (list (intern (completing-read "Untrace function: "
-                                  obarray #'trace-is-traced t))))
+   (list (intern (let ((def (function-called-at-point)))
+                   (unless (trace-is-traced def) (setq def nil))
+                   (completing-read (format-prompt "Untrace function" def)
+                                    obarray #'trace-is-traced
+                                    t nil 'trace-function-history
+                                    (if def (symbol-name def)))))))
   (advice-remove function trace-advice-name))
 
+(put 'untrace-function 'minibuffer-action
+     (cons (compose #'untrace-function #'intern) "untrace"))
+
 (defun untrace-all ()
   "Untraces all currently traced functions."
   (interactive)