>From cd49759ff81466e31e4c96276dcdb2ff6d378d0f Mon Sep 17 00:00:00 2001 From: Arthur Miller Date: Wed, 22 Sep 2021 01:47:41 +0200 Subject: [PATCH] Display source code in 'help-mode' buffers * lisp/help-mode.el (help-mode-inline-source): New option. (help--fetch-c-src): New function. (help--fetch-lisp-src): New function. (help--insert-source): New function. (help--remove-source): New function. (help--toggle-source-view): New function. (help-source-view): New button. (help-make-xrefs): Check for 'help-mode-inline-source' and call 'help--insert-source' to perform insertion when possible. --- lisp/help-mode.el | 165 ++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 160 insertions(+), 5 deletions(-) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index 551cf7e1a3..bec7d25270 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -149,6 +149,16 @@ help-mode-hook "Hook run by `help-mode'." :type 'hook :group 'help) + +(defcustom help-mode-inline-source nil + "Display inlined source code in `help-mode' buffers. + +When enabled the source code of a symbol currently shown in the +help-buffer will be displayed inlined in the help buffer, if the +source code for the symbol is available." + :type 'boolean + :group 'help + :version "28.1") ;; Button types used by help @@ -367,6 +377,11 @@ 'help-news (view-buffer-other-window (find-file-noselect file)) (goto-char pos)) 'help-echo (purecopy "mouse-2, RET: show corresponding NEWS announcement")) + +(define-button-type 'help-source-view + :supertype 'help-xref + 'help-function #'help-toggle-source-view + 'help-echo (purecopy "mouse-2, RET: toggle source view in help-buffer")) (defvar bookmark-make-record-function) (defvar help-mode--current-data nil) @@ -503,6 +518,115 @@ describe-symbol-backends and a frame), inserts the description of that symbol in the current buffer and returns that text as well.") +(defun help--fetch-c-src (symbol type file) + "Find C source code for a Lisp SYMBOL in a FILE. + +symbol - the symbol to find. +type - the type as obtained by 'describe-*' functions. +file - the source file to search in." + (let (src beg) + (setq file (expand-file-name file source-directory)) + (when (file-readable-p file) + (with-temp-buffer + (insert-file-contents-literally file) + (delay-mode-hooks (funcall 'c-mode)) + (goto-char (point-min)) + (unless type + (require 'find-func) + ;; Either or both an alias and its target might be advised. + (setq symbol (find-function-advised-original + (indirect-function + (find-function-advised-original symbol))))) + (when (re-search-forward + (if type + (concat "DEFVAR[A-Z_]*[ \t\n]*([ \t\n]*\"" + (regexp-quote (symbol-name symbol)) + "\"") + (concat "DEFUN[ \t\n]*([ \t\n]*\"" + (regexp-quote (subr-name (advice--cd*r symbol))) + "\"")) + nil t) + (if type ;; defvar here + (progn + (goto-char (line-beginning-position)) + (skip-chars-forward "[\s\t\n\r]") + (setq beg (point)) + (re-search-forward ");$" nil t) + (narrow-to-region beg (point))) + ;;(narrow-to-defun) + (and (re-search-backward "DEFUN" nil t) + (setq beg (point)) + (re-search-forward ")[\n\s\t\r]*{") + (re-search-forward "^}[\n\s\t\r]+") + (narrow-to-region beg (point)))) + (if (fboundp 'font-lock-ensure) + (font-lock-ensure) + (with-no-warnings (font-lock-fontify-buffer))) + (setq src (buffer-string))))) + src)) + +(defun help--fetch-lisp-src (symbol type file) + "Find emacs-lisp source code for a Lisp SYMBOL in a FILE. + +symbol - the symbol to find. +type - the type as obtained by 'describe-*' functions. +file - the source file to search in." + (let (src pos) + (when file + (setq file (or file (find-lisp-object-file-name symbol type)))) + (with-temp-buffer + (insert-file-contents file) + (delay-mode-hooks (funcall 'emacs-lisp-mode)) + (require 'find-func) + ;; Either or both an alias and its target might be advised. + ;; (setq symbol (find-function-advised-original + ;; (indirect-function + ;; (find-function-advised-original symbol))))) + (setq pos (cdr (find-function-search-for-symbol symbol type file))) + (when pos + (goto-char pos) + (forward-sexp) + (narrow-to-region pos (point)) + (if (fboundp 'font-lock-ensure) + (font-lock-ensure) + (with-no-warnings (font-lock-fontify-buffer))) + (setq src (buffer-string)))) + src)) + +(defun help--insert-source () + "Fnd and insert source for the current symbol into the help-mode +buffer." + (with-silent-modifications + (with-current-buffer (help-buffer) + (save-excursion + (let* ((file (plist-get help-mode--current-data :file)) + (type (plist-get help-mode--current-data :type)) + (sym (plist-get help-mode--current-data :symbol)) + (src "Source code not available.")) + (when (eq file 'C-source) + (setq file (help-C-file-name (indirect-function sym) 'fun))) + (setq src (if (string-suffix-p ".c" file) + (help--fetch-c-src sym type file) + (help--fetch-lisp-src sym type file))) + (goto-char (point-max)) + (let ((end (point))) + (when (search-backward "View Source Code:" nil t) + (delete-region (point) end) + (help-insert-xref-button "Hide Source Code:" 'help-source-view) + (insert (concat "\n" src "\n"))))))))) + +(defun help--remove-source () + "Remove source code from the help buffer when present." + (with-current-buffer (help-buffer) + (with-silent-modifications + (save-excursion + (goto-char (point-max)) + (let ((end (point))) + (when (search-backward "Hide Source Code:" nil t) + (delete-region (point) end) + (help-insert-xref-button + "View Source Code:" 'help-source-view))))))) + ;;;###autoload (defun help-make-xrefs (&optional buffer) "Parse and hyperlink documentation cross-references in the given BUFFER. @@ -664,7 +788,25 @@ help-make-xrefs (help-insert-xref-button help-forward-label 'help-forward (current-buffer))) (when (or help-xref-stack help-xref-forward-stack) - (insert "\n"))) + (insert "\n")) + (insert "\n") + ;; get source string if needed and available + ;; describe-symbol does not produce 'current-data' plist + (unless help-mode--current-data + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "\\.\\(el\\|c\\)" nil t) + (goto-char (- (point) 2)) + (let ((props (get-text-property (point) 'help-args))) + (when props + (setq help-mode--current-data + (list :symbol (nth 0 props) + :file (nth 1 props)))))))) + (if help-mode-inline-source + (progn + (insert "View Source Code:") ;; just a little hack + (help--insert-source)) + (help-insert-xref-button "View Source Code:" 'help-source-view))) (set-buffer-modified-p old-modified))))) ;;;###autoload @@ -819,10 +961,23 @@ help-do-xref (append args (list (generate-new-buffer-name "*info*"))) args)))) -;; The doc string is meant to explain what buttons do. -(defun help-follow-mouse () - "Follow the cross-reference that you click on." - (declare (obsolete nil "28.1")) +(defun help-toggle-source-view () + "Toggle source code display in help buffer for the current symbol." + (interactive) + (when (get-buffer-window (help-buffer)) + (with-current-buffer (help-buffer) + (unless (plist-get help-mode--current-data :file) + (error "Source file for the current help item is not defined")) + (save-excursion + (goto-char (point-min)) + (if (search-forward "Hide Source Code:" nil t) + (help--remove-source) + (help--insert-source)))))) + + ;; The doc string is meant to explain what buttons do. + (defun help-follow-mouse () + "Follow the cross-reference that you click on." + (declare (obsolete nil "28.1")) (interactive) (error "No cross-reference here")) -- 2.33.0