diff --git a/helpful.el b/helpful.el index ad3fa21..7f4ee4b 100644 --- a/helpful.el +++ b/helpful.el @@ -325,6 +325,37 @@ Return SYM otherwise." (message "Forgot %s %s." kind sym) (kill-buffer (current-buffer))))) +(define-button-type 'helpful-remove-all-advice-button + 'action #'helpful--remove-all-advice + 'symbol nil + 'follow-link t + 'help-echo "Remove all advices") + +(defun helpful--remove-all-advice (button) + "Remove all advices on the symbol given by BUTTON." + (let ((sym (button-get button 'symbol))) + (ad-unadvise sym) + (advice-mapc + (lambda (advice _when) + (advice-remove sym advice)) + sym) + (helpful-update))) + +(define-button-type 'helpful-remove-advice-button + 'action #'helpful--remove-advice + 'symbol nil + 'advice nil + 'face '(error button) + 'follow-link t + 'help-echo "Remove this advice") + +(defun helpful--remove-advice (button) + "Remove an advice on the symbol as specified by BUTTON." + (advice-remove + (button-get button 'symbol) + (button-get button 'advice)) + (helpful-update)) + (define-button-type 'helpful-c-source-directory 'action #'helpful--c-source-directory 'follow-link t @@ -537,8 +568,8 @@ overrides that to include previously opened buffers." (t (--first (and (not (s-starts-with-p " " it)) (not (s-starts-with-p "*" it))) - names)) - ))) + names))))) + (get-buffer (completing-read prompt @@ -1637,6 +1668,28 @@ without the advice. Assumes function has been loaded." (advice--cd*r (advice--symbol-function sym))) +(defun helpful--advices (sym) + "Return advices of SYM. + +Each advice is returned as a list (WHERE FUNC)." + (let ((func (advice--symbol-function sym)) + result) + (while (advice--p func) + ;; Do not include the activated old style advice + (unless (s-starts-with-p + "ad-Advice" + (format "%s" (advice--car func))) + (push (list + ;; This can also be done with `advice--where', but that + ;; isn't available in Emacs 25 + (car + (--last (eq (aref func 1) (cadr it)) + advice--where-alist)) + (advice--car func)) + result)) + (setq func (advice--cdr func))) + (nreverse result))) + (defun helpful--advised-p (sym) "Does SYM have advice associated with it?" (and (symbolp sym) @@ -1651,8 +1704,8 @@ syntax highlight it." (format "'%S" (cadr name)) (format "%S" name))) (formatted-def - (format "(%s %s ...)" def formatted-name)) - ) + (format "(%s %s ...)" def formatted-name))) + (helpful--syntax-highlight formatted-def))) (defun helpful--format-reference (head longest-head ref-count position path) @@ -1870,8 +1923,8 @@ OBJ may be a symbol or a compiled function object." (setq file-name (s-chop-suffix ".gz" file-name)) (condition-case nil (help-fns--autoloaded-p sym file-name) - ; new in Emacs 29.0.50 - ; see https://github.com/Wilfred/helpful/pull/283 + ;; new in Emacs 29.0.50 + ;; see https://github.com/Wilfred/helpful/pull/283 (error (help-fns--autoloaded-p sym))))) (defun helpful--compiled-p (sym) @@ -2349,12 +2402,44 @@ state of the current symbol." " " (helpful--make-callees-button helpful--sym source))) - (when (helpful--advised-p helpful--sym) + (when (and helpful--callable-p + (helpful--advised-p helpful--sym)) (helpful--insert-section-break) (insert (helpful--heading "Advice") - (format "This %s is advised." - (if (macrop helpful--sym) "macro" "function")))) + (-if-let (advices (helpful--advices helpful--sym)) + ;; nadvice.el + (s-join "\n" + (--map + (let ((where (car it)) + (func (cadr it))) + (format "%s %s %s\n %s" + (helpful--button + "[X]" + 'helpful-remove-advice-button + 'symbol helpful--sym + 'advice func) + (helpful--propertize-sym-ref + (format "%s" where) + "" "") + (helpful--button + (if (symbolp func) + (format "%s" func) + "#") + 'helpful-describe-exactly-button + 'symbol func + 'callable-p t) + (-when-let (docstring (helpful--docstring func t)) + (car (s-lines docstring))))) + advices)) + ;; old style advice + (format "This %s is advised." + (if (macrop helpful--sym) "macro" "function"))) + "\n\n" + (helpful--button + "Remove all advices" + 'helpful-remove-all-advice-button + 'symbol helpful--sym))) (let ((can-edebug (helpful--can-edebug-p helpful--sym helpful--callable-p buf pos)) @@ -2473,10 +2558,15 @@ state of the current symbol." (defun helpful--skip-advice (docstring) "Remove mentions of advice from DOCSTRING." (let* ((lines (s-lines docstring)) + (where-types (--map (symbol-name (car it)) + advice--where-alist)) (relevant-lines - (--drop-while - (or (s-starts-with-p ":around advice:" it) - (s-starts-with-p "This function has :around advice:" it)) + (--remove + (s-matches-p + (format + (rx bol (opt "This function has ") "%s advice: ") + (regexp-opt where-types)) + it) lines))) (s-trim (s-join "\n" relevant-lines)))) diff --git a/test/helpful-unit-test.el b/test/helpful-unit-test.el index 8a95129..b24b91f 100644 --- a/test/helpful-unit-test.el +++ b/test/helpful-unit-test.el @@ -31,6 +31,10 @@ "Docstring here too." nil) +(defun test-foo-advised-new-style () + "Another docstring." + nil) + (autoload 'some-unused-function "somelib.el") (defadvice test-foo-advised (before test-advice1 activate) @@ -41,6 +45,26 @@ "Placeholder advice 2." nil) +(define-advice test-foo-advised-new-style (:around (func)) + "New style placeholder advice 1." + (funcall func)) + +(define-advice test-foo-advised-new-style (:after ()) + "New style placeholder advice 2." + nil) + +(ert-deftest helpful--advises-old-style () + "Old style advices should not be listed." + (should (not (helpful--advices 'test-foo-advised)))) + +(ert-deftest helpful--advises-new-style () + "Return new style advises." + (should + (equal + (helpful--advices 'test-foo-advised-new-style) + '((:after (closure (t) nil "New style placeholder advice 2." nil)) + (:around (closure (t) (func) "New style placeholder advice 1." (funcall func))))))) + (ert-deftest helpful--docstring () "Basic docstring fetching." (should @@ -119,9 +143,14 @@ bar"))) (should (equal (helpful--docstring #'test-foo-advised t) - (if (version< emacs-version "28") - "Docstring here too." - "Docstring here too.\n\nThis function has :around advice: `ad-Advice-test-foo-advised'.")))) + "Docstring here too."))) + +(ert-deftest helpful--docstring-advice-new-style () + "New style advice should be stripped." + (should + (equal + (helpful--docstring #'test-foo-advised-new-style t) + "Another docstring."))) (defun test-foo-no-docstring () nil)