From a16e8d851ffe67e1307dc6803bd46704032f9ed4 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Fri, 11 Apr 2025 12:37:45 +0200 Subject: [PATCH] Make scope.el symbol types a first class citizen. --- lisp/emacs-lisp/find-func.el | 6 +- lisp/emacs-lisp/scope.el | 359 +++++++++++++++++++++++++++++++++-- lisp/loadhist.el | 5 + lisp/progmodes/elisp-mode.el | 185 +++++------------- 4 files changed, 405 insertions(+), 150 deletions(-) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 54e6cb30b87..13c58482697 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -79,6 +79,9 @@ Please send improvements and fixes to the maintainer." (defvar find-error-regexp (concat "^\\s-*(define-error" find-function-space-re "%s\\(\\s-\\|$\\)")) +(defvar find-symbol-type-regexp + (concat "^\\s-*(scope-define-symbol-type" find-function-space-re "%s\\(\\s-\\|$\\)")) + (defvar find-widget-regexp (concat "^\\s-*(define-widget" find-function-space-re "%s\\(\\s-\\|$\\)")) @@ -140,7 +143,8 @@ should insert the feature name." (defalias . find-alias-regexp) (ert-deftest . find-ert-deftest-regexp) (define-widget . find-widget-regexp) - (define-error . find-error-regexp)) + (define-error . find-error-regexp) + (define-symbol-type . find-symbol-type-regexp)) "Alist mapping definition types into regexp variables. Each regexp variable's value should actually be a format string to be used to substitute the desired symbol name into the regexp. diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el index 1b083f3c835..a2e45a3e47a 100644 --- a/lisp/emacs-lisp/scope.el +++ b/lisp/emacs-lisp/scope.el @@ -26,6 +26,301 @@ ;;; Code: +(defun scope--define-symbol-type (name parents props) + (put name 'scope-parent-types parents) + (put name 'scope-type-properties props) + (add-to-list 'current-load-list `(define-symbol-type . ,name))) + +;;;###autoload +(defmacro scope-define-symbol-type (name parents &rest props) + (declare (indent defun)) + `(scope--define-symbol-type ',name ',parents ,(when props `(list ,@props)))) + +;;;###autoload +(defun scope-get-symbol-type-property (type prop) + (named-let loop ((current type) + (parents (get type 'scope-parent-types)) + (more nil) + (done nil)) + (or (plist-get (get current 'scope-type-properties) prop) + (when-let ((next (car parents))) + (loop (car parents) (get next 'scope-parent-types) (append (cdr parents) more) done)) + (when-let ((next (car more))) + (loop next (let (res) + (dolist (per (get next 'scope-parent-types)) + (unless (memq per done) + (push per res))) + (nreverse res)) + (cdr more) done))))) + +;;;###autoload +(defun scope-symbol-type-p (sym) + (or (get sym 'scope-parent-types) (get sym 'scope-type-properties))) + +(defvar scope-read-symbol-type-history nil) + +(defun scope-read-symbol-type (prompt &optional default) + (completing-read + (format-prompt prompt default) + obarray #'scope-symbol-type-p 'confirm + nil 'scope-read-symbol-type-history default)) + +(defvar help-mode--current-data) + +;;;###autoload +(defun scope-describe-symbol-type (type) + (interactive (list (scope-read-symbol-type + "Describe symbol type" + (when-let ((def (symbol-at-point)) + ((scope-symbol-type-p def))) + def)))) + (when (stringp type) (setq type (intern type))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'scope-describe-symbol-type type) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (insert "Symbol type " + (substitute-quotes (concat "`" (symbol-name type) "'")) + ":\n\n" + (substitute-quotes + (or (scope-get-symbol-type-property type :doc) + "Undocumented."))) + (when-let ((parents (get type 'scope-parent-types))) + (insert "\n\nParent types: " + (mapconcat (lambda (parent) + (let ((name (symbol-name parent))) + (substitute-quotes + (concat + "`" + (buttonize + name #'scope-describe-symbol-type name + "mouse-2, RET: describe this symbol type") + "'")))) + parents ", "))) + (setq help-mode--current-data + (list :symbol type :type 'define-symbol-type + :file (find-lisp-object-file-name type 'define-symbol-type))))))) + +(put 'scope-describe-symbol-type 'minibuffer-action "describe") + +(scope-define-symbol-type symbol-type () + :doc "Symbol type names." + :face 'elisp-symbol-type + :help (constantly "Symbol type") + :completion (constantly #'scope-symbol-type-p) + :namespace 'symbol-type) + +(scope-define-symbol-type symbol-type-definition (symbol-type) + :doc "Symbol type name definitions." + :face 'elisp-symbol-type-definition + :help (constantly "Symbol type definition") + :imenu "Symbol Type" + :namespace 'symbol-type) + +(scope-define-symbol-type variable () + :doc "Variable names." + :face 'elisp-free-variable + :help (lambda (beg end def) + (cond ((equal beg def) "Local variable definition") + (def "Local variable") + (t (elisp--help-echo beg end 'variable-documentation "Special variable")))) + :completion (lambda () + (let ((local-vars (elisp-local-variables))) + (lambda (sym) (or (elisp--shorthand-aware-boundp sym) + (memq sym local-vars))))) + :namespace 'variable) + +(scope-define-symbol-type face () + :doc "Face names." + :face 'elisp-face + :help (lambda (beg end _def) + (elisp--help-echo beg end 'face-documentation "Face")) + :completion (constantly #'facep) + :namespace 'face) + +(scope-define-symbol-type callable () + :doc "Abstract symbol type of function-like symbols." + :completion (constantly #'elisp--shorthand-aware-fboundp) + :namespace 'function) + +(scope-define-symbol-type function (callable) + :doc "Function names." + :face 'elisp-function-call + :help (lambda (beg end def) + (cond ((equal beg def) "Local function definition") + (def "Local function call") + (t (if-let ((sym (intern-soft (buffer-substring-no-properties beg end)))) + (apply-partially #'elisp--function-help-echo sym) + "Function call"))))) + +(scope-define-symbol-type non-local-exit (function) + :doc "Functions that do not return." + :face 'elisp-non-local-exit + :help (lambda (beg end _def) + (if-let ((sym (intern-soft (buffer-substring-no-properties beg end)))) + (apply-partially #'elisp--function-help-echo sym) + "Non-local exit"))) + +(scope-define-symbol-type macro (callable) + :doc "Macro names." + :face 'elisp-macro-call + :help (lambda (beg end _def) + (if-let ((sym (intern-soft (buffer-substring-no-properties beg end)))) + (apply-partially #'elisp--function-help-echo sym) + "Macro call"))) + +(scope-define-symbol-type special-form (callable) + :doc "Special form names." + :face 'elisp-special-form + :help (lambda (beg end _def) + (if-let ((sym (intern-soft (buffer-substring-no-properties beg end)))) + (apply-partially #'elisp--function-help-echo sym) + "Special form"))) + +(scope-define-symbol-type throw-tag () + :doc "Symbols used as `throw'/`catch' tags." + :face 'elisp-throw-tag + :help (constantly "`throw'/`catch' tag")) + +(scope-define-symbol-type warning-type () + :doc "Byte-compilation warning types." + :face 'font-lock-type-face + :help (constantly "Warning type") + :completion (constantly (lambda (sym) (memq sym byte-compile-warning-types)))) + +(scope-define-symbol-type feature () + :doc "Feature names." + :face 'elisp-feature + :help (constantly "Feature") + :completion (constantly #'featurep) + :namespace 'feature) + +(scope-define-symbol-type declaration () + :doc "Function attribute declaration types." + :face 'font-lock-variable-use-face + :help (constantly "Declaration") + :completion (constantly + (lambda (sym) (or (alist-get sym macro-declarations-alist) + (alist-get sym defun-declarations-alist))))) + +(scope-define-symbol-type rx-construct () + :doc "`rx' constructs." + :face 'elisp-rx + :help (constantly "`rx' construct")) + +(scope-define-symbol-type theme () + :doc "Custom theme names." + :face 'elisp-theme + :help (constantly "Theme") + :completion (constantly #'custom-theme-p)) + +(scope-define-symbol-type thing () + :doc "`thing-at-point' \"thing\" identifiers." + :face 'font-lock-type-face + :help (constantly "Thing (text object)") + :completion + (constantly + (lambda (sym) + (or + (assq sym (bound-and-true-p thing-at-point-provider-alist)) + (assq sym (bound-and-true-p bounds-of-thing-at-point-provider-alist)) + (get sym 'thing-at-point) + (get sym 'bounds-of-thing-at-point) + (get sym 'beginning-op) + (get sym 'end-op))))) + +(scope-define-symbol-type slot () + :doc "EIEIO slots." + :face 'font-lock-builtin-face + :help (constantly "Slot")) + +(scope-define-symbol-type widget-type () + :doc "Widget types." + :face 'font-lock-type-face + :help (constantly "Widget type") + :completion (constantly (lambda (sym) (get sym 'widget-type))) + :namespace 'widget-type) + +(scope-define-symbol-type type () + :doc "ELisp object type names." + :face 'font-lock-type-face + :help (constantly "Type") + :completion (constantly (lambda (sym) (get sym 'cl--class)))) + +(scope-define-symbol-type group () + :doc "Customization groups." + :face 'font-lock-type-face + :help (constantly "Customization group") + :completion (constantly (lambda (sym) (get sym 'group-documentation)))) + +(scope-define-symbol-type nnoo-backend () + :doc "`nnoo' backend names." + :face 'font-lock-type-face + :help (constantly "`nnoo' backend")) + +(scope-define-symbol-type condition () + :doc "`condition-case' conditions." + :face 'elisp-condition + :help (lambda (beg end _def) + (lambda (&rest _) + (let ((msg (get (intern (buffer-substring beg end)) 'error-message))) + (apply #'concat + "`condition-case' condition" + (when (and msg (not (string-empty-p msg))) + `(": " ,msg)))))) + :completion (constantly (lambda (sym) (get sym 'error-conditions))) + :namespace 'condition) + +(scope-define-symbol-type ampersand () + :doc "Argument list markers, such as `&optional' and `&rest'." + :face 'font-lock-type-face + :help (constantly "Arguments separator")) + +(scope-define-symbol-type constant () + :doc "Self-evaluating symbols." + :face 'font-lock-builtin-face + :help (constantly "Constant")) + +(scope-define-symbol-type defun () + :doc "Function definitions." + :face 'font-lock-function-name-face + :help (constantly "Function definition") + :imenu "Function" + :namespace 'function) + +(scope-define-symbol-type defvar () + :doc "Variable definitions." + :face 'font-lock-variable-name-face + :help (constantly "Special variable definition") + :imenu "Variable" + :namespace 'variable) + +(scope-define-symbol-type defface () + :doc "Face definitions." + :face 'font-lock-variable-name-face + :help (constantly "Face definition") + :imenu "Face" + :namespace 'face) + +(scope-define-symbol-type major-mode () + :doc "Major mode names." + :face 'elisp-major-mode-name + :help (lambda (beg end _def) + (if-let ((sym (intern (buffer-substring-no-properties beg end)))) + (lambda (&rest _) + (if-let ((doc (documentation sym))) + (format "Major mode `%S'.\n\n%s" sym doc) + "Major mode")) + "Major mode")) + :completion (constantly (lambda (sym) (get sym 'major-mode-name))) + :namespace 'function) + +(scope-define-symbol-type block () + :doc "`cl-block' block names." + :help (lambda (beg _end def) + (if (equal beg def) "Block definition" "Block"))) + (defvar scope-counter nil) (defvar scope-local-functions nil) @@ -301,7 +596,7 @@ Optional argument LOCAL is a local context to extend." (let ((bare (bare-symbol arg)) (beg (scope-sym-pos arg))) (cond - ((or (functionp bare) scope-assume-func-p) + ((or (functionp bare) (memq bare scope-local-functions) scope-assume-func-p) (when beg (scope-report 'function beg (length (symbol-name bare))))) ((or (assq bare scope-flet-alist) (consp arg)) @@ -1130,16 +1425,28 @@ a (possibly empty) list of safe macros.") (defun ,analyzer ,args ,@body) (put ',fsym 'scope-analyzer #',analyzer)))) -(defmacro scope-define-function-analyzer (fsym args &rest body) +(defmacro scope--define-function-analyzer (fsym args type &rest body) (declare (indent defun)) (let* ((helper (intern (concat "scope--analyze-" (symbol-name fsym) "-1")))) `(progn (defun ,helper ,args ,@body) (scope-define-analyzer ,fsym (l f &rest args) - (scope-report-s f 'function) + (scope-report-s f ',type) (apply #',helper args) (scope-n l args))))) +(defmacro scope-define-function-analyzer (fsym args &rest body) + (declare (indent defun)) + `(scope--define-function-analyzer ,fsym ,args function ,@body) + ;; (let* ((helper (intern (concat "scope--analyze-" (symbol-name fsym) "-1")))) + ;; `(progn + ;; (defun ,helper ,args ,@body) + ;; (scope-define-analyzer ,fsym (l f &rest args) + ;; (scope-report-s f 'function) + ;; (apply #',helper args) + ;; (scope-n l args)))) + ) + (defmacro scope-define-macro-analyzer (fsym args &rest body) (declare (indent defun)) (let* ((helper (intern (concat "scope--analyze-" (symbol-name fsym) "-1")))) @@ -1235,16 +1542,26 @@ a (possibly empty) list of safe macros.") (scope-define-function-analyzer pulse-momentary-highlight-region (_start _end &optional face) (when-let ((q (scope--unqoute face))) (scope-face q))) -(scope-define-function-analyzer throw (tag _value) +(scope--define-function-analyzer throw (tag _value) non-local-exit (when-let ((q (scope--unqoute tag))) (scope-report-s q 'throw-tag))) +(scope--define-function-analyzer signal (error-symbol &optional _data) non-local-exit + (when-let ((q (scope--unqoute error-symbol))) (scope-report-s q 'condition))) + +(scope--define-function-analyzer kill-emacs (&rest _) non-local-exit) +(scope--define-function-analyzer abort-recursive-edit (&rest _) non-local-exit) +(scope--define-function-analyzer top-level (&rest _) non-local-exit) +(scope--define-function-analyzer exit-recursive-edit (&rest _) non-local-exit) +(scope--define-function-analyzer tty-frame-restack (&rest _) non-local-exit) +(scope--define-function-analyzer error (&rest _) non-local-exit) +(scope--define-function-analyzer user-error (&rest _) non-local-exit) +(scope--define-function-analyzer minibuffer-quit-recursive-edit (&rest _) non-local-exit) +(scope--define-function-analyzer exit-minibuffer (&rest _) non-local-exit) + (scope-define-function-analyzer run-hooks (&rest hooks) (dolist (hook hooks) (when-let ((q (scope--unqoute hook))) (scope-report-s q 'variable)))) -(scope-define-function-analyzer signal (error-symbol &optional _data) - (when-let ((q (scope--unqoute error-symbol))) (scope-report-s q 'condition))) - (scope-define-function-analyzer fboundp (symbol) (when-let ((q (scope--unqoute symbol))) (scope-report-s q 'function))) @@ -1335,6 +1652,12 @@ a (possibly empty) list of safe macros.") (scope-define-function-analyzer derived-mode-p (modes &rest _obsolete) (when-let ((q (scope--unqoute modes))) (scope-report-s q 'major-mode))) +(scope-define-function-analyzer scope-report (type &rest _) + (when-let ((q (scope--unqoute type))) (scope-report-s q 'symbol-type))) + +(scope-define-function-analyzer scope-report-s (_sym type) + (when-let ((q (scope--unqoute type))) (scope-report-s q 'symbol-type))) + (scope-define-macro-analyzer define-globalized-minor-mode (l global mode turn-on &rest body) (scope-report-s mode 'function) (scope-report-s turn-on 'function) @@ -1466,6 +1789,20 @@ a (possibly empty) list of safe macros.") (put 'defmacro 'scope-analyzer #'scope--analyze-defun) (put 'ert-deftest 'scope-analyzer #'scope--analyze-defun) +(scope-define-macro-analyzer scope-define-symbol-type (l &optional name parents &rest props) + (scope-report-s name 'symbol-type-definition) + (dolist (parent parents) (scope-report-s parent 'symbol-type)) + (while-let ((kw (car-safe props)) + (bkw (scope-sym-bare kw)) + ((keywordp bkw))) + (scope-report-s kw 'constant) + (case bkw + (:face + (if-let ((q (scope--unqoute (cadr props)))) (scope-face-1 q) + (scope-1 l (cadr props)))) + (otherwise (scope-1 l (cadr props)))) + (setq props (cddr props)))) + (scope-define-macro-analyzer cl-letf (l bindings &rest body) (let ((l0 l)) (dolist (binding bindings) @@ -1618,11 +1955,9 @@ starting with a top-level form, by inspecting HEAD at each level: - If within the code under analysis HEAD is a `cl-flet'-bound local function name, analyze the form as a function call. -- Otherwise, HEAD is unknown. If the HEAD of the top-level form that - this function reads from STREAM is unknown, then this function ignores - it and returns nil. If an unknown HEAD occurs in a nested form, then - by default it is similarly ignored, but if `scope-assume-func-p' is - non-nil, then this function assumes that such HEADs are functions." +- If HEAD is unknown, then it is ignored, unless `scope-assume-func-p' + is non-nil, in which case this function assumes that unknown HEADs are + functions." (let ((scope-counter 0) (scope-callback callback) (read-symbol-shorthands nil)) diff --git a/lisp/loadhist.el b/lisp/loadhist.el index d063fb6cc43..ff531403c6c 100644 --- a/lisp/loadhist.el +++ b/lisp/loadhist.el @@ -239,6 +239,11 @@ unloading." (put name 'error-conditions nil) (put name 'error-message nil))) +(cl-defmethod loadhist-unload-element ((x (head define-symbol-type))) + (let ((name (cdr x))) + (put name 'scope-parent-types nil) + (put name 'scope-type-properties nil))) + ;;;###autoload (defun unload-feature (feature &optional force) "Unload the library that provided FEATURE. diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 1b0f0f10263..a9451fbda19 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -348,10 +348,22 @@ happens in interactive invocations." "Face for highlighting face names in Emacs Lisp code." :group 'lisp) +(defface elisp-symbol-type '((t :foreground "#00008b" :inherit font-lock-function-call-face)) + "Face for highlighting symbol type names in Emacs Lisp code." + :group 'lisp) + +(defface elisp-symbol-type-definition '((t :foreground "#00008b" :inherit font-lock-function-name-face)) + "Face for highlighting symbol type names in Emacs Lisp code." + :group 'lisp) + (defface elisp-function-call '((t :inherit font-lock-function-call-face)) "Face for highlighting function calls in Emacs Lisp code." :group 'lisp) +(defface elisp-non-local-exit '((t :inherit elisp-function-call :underline "red")) + "Face for highlighting function calls in Emacs Lisp code." + :group 'lisp) + (defface elisp-macro-call '((t :inherit font-lock-keyword-face)) "Face for highlighting macro calls in Emacs Lisp code." :group 'lisp) @@ -437,82 +449,13 @@ happens in interactive invocations." (defun elisp--annotate-symbol-with-help-echo (type beg end def) (put-text-property beg end 'help-echo - (case type - (variable (cond ((equal beg def) "Local variable definition") - (def "Local variable") - (t (elisp--help-echo beg end 'variable-documentation "Special variable")))) - (block (if (equal beg def) "Block definition" "Block")) - (face (elisp--help-echo beg end 'face-documentation "Face")) - (function (cond ((equal beg def) "Local function definition") - (def "Local function call") - (t (if-let ((sym (intern-soft (buffer-substring-no-properties beg end)))) - (apply-partially #'elisp--function-help-echo sym) - "Function call")))) - (macro (if-let ((sym (intern-soft (buffer-substring-no-properties beg end)))) - (apply-partially #'elisp--function-help-echo sym) - "Macro call")) - (special-form (if-let ((sym (intern-soft (buffer-substring-no-properties beg end)))) - (apply-partially #'elisp--function-help-echo sym) - "Special form")) - (throw-tag "`throw'/`catch' tag") - (warning-type "Warning type") - (feature "Feature") - (declaration "Declaration") - (rx-construct "`rx' construct") - (theme "Theme") - (thing "Thing (text object)") - (slot "Slot") - (widget-type "Widget type") - (type "Type") - (group "Customization group") - (condition (lambda (&rest _) - (let ((msg (get (intern (buffer-substring beg end)) 'error-message))) - (apply #'concat - "`condition-case' condition" - (when (and msg (not (string-empty-p msg))) - `(": " ,msg)))))) - (ampersand "Arguments separator") - (constant "Constant") - (defun "Function definition") - (defvar "Special variable definition") - (defface "Face definition") - (nnoo-backend "`nnoo' backend") - (major-mode (if-let ((sym (intern (buffer-substring-no-properties beg end)))) - (lambda (&rest _) - (if-let ((doc (documentation sym))) - (format "Major mode `%S'.\n\n%s" sym doc) - "Major mode")) - "Major mode"))))) + (when-let ((fun (scope-get-symbol-type-property type :help))) + (funcall fun beg end def)))) (defun elisp-fontify-symbol (type sym len id &optional def) (elisp--annotate-symbol-with-help-echo type sym (+ sym len) def) (let ((face (cond - ((null id) - (case type - (variable 'elisp-free-variable) - (face 'elisp-face) - (function 'elisp-function-call) - (macro 'elisp-macro-call) - (special-form 'elisp-special-form) - (throw-tag 'elisp-throw-tag) - (warning-type 'font-lock-type-face) - (feature 'elisp-feature) - (declaration 'font-lock-variable-use-face) - (rx-construct 'elisp-rx) - (theme 'elisp-theme) - (thing 'font-lock-type-face) - (slot 'font-lock-builtin-face) - (widget-type 'font-lock-type-face) - (type 'font-lock-type-face) - (group 'font-lock-type-face) - (nnoo-backend 'font-lock-type-face) - (condition 'elisp-condition) - (ampersand 'font-lock-type-face) - (constant 'font-lock-builtin-face) - (defun 'font-lock-function-name-face) - (defvar 'font-lock-variable-name-face) - (defface 'font-lock-variable-name-face) - (major-mode 'elisp-major-mode-name))) + ((null id) (scope-get-symbol-type-property type :face)) ((equal sym def) 'elisp-binding-variable) (t 'elisp-bound-variable)))) (add-face-text-property sym (+ sym len) face t) @@ -855,46 +798,11 @@ in `completion-at-point-functions' (which see)." (with-syntax-table emacs-lisp-mode-syntax-table (when-let ((pos (point)) (scope-assume-func-p t) - (predicate (case (save-excursion - (goto-char pos) - (beginning-of-defun) - (catch 'sym-type - (scope (lambda (type beg len &rest _) - (when (<= beg pos (+ beg len)) - (throw 'sym-type type)))) - nil)) - ((variable constant) (let ((local-vars (elisp-local-variables))) - (lambda (sym) (or (elisp--shorthand-aware-boundp sym) - (memq sym local-vars))))) - ((function macro special-form top-level) #'elisp--shorthand-aware-fboundp) - ((major-mode) (lambda (sym) (get sym 'major-mode-name))) - ((type) (lambda (sym) (get sym 'cl--class))) - ((widget-type) (lambda (sym) (get sym 'widget-type))) - ((warning-type) - (lambda (sym) (memq sym byte-compile-warning-types))) - ((declaration) - (lambda (sym) (or (alist-get sym macro-declarations-alist) - (alist-get sym defun-declarations-alist)))) - ((group) (lambda (sym) (get sym 'group-documentation))) - ((condition) (lambda (sym) (get sym 'error-conditions))) - ((face) #'facep) - ((feature) #'featurep) - ((theme) #'custom-theme-p) - ((thing) (lambda (sym) - (or - (assq sym (bound-and-true-p thing-at-point-provider-alist)) - (assq sym (bound-and-true-p bounds-of-thing-at-point-provider-alist)) - (get sym 'thing-at-point) - (get sym 'bounds-of-thing-at-point) - (get sym 'beginning-op) - (get sym 'end-op)))) - ((nil) (lambda (sym) - (let ((sym (intern-soft (symbol-name sym)))) - (or (boundp sym) - (fboundp sym) - (featurep sym) - (facep sym) - (symbol-plist sym))))))) + (predicate + (if-let ((fun (scope-get-symbol-type-property + (elisp-symbol-type-at-pos pos) :completion))) + (funcall fun) + #'elisp-completion-at-point-default-predicate)) (beg-end (bounds-of-thing-at-point 'symbol)) (beg (car beg-end)) (end (cdr beg-end))) @@ -902,6 +810,20 @@ in `completion-at-point-functions' (which see)." :predicate predicate :exclusive 'no :sort-function #'elisp--sort-completions)))) +(defun elisp-symbol-type-at-pos (&optional pos) + (let ((pos (or pos (point)))) + (save-excursion + (goto-char pos) + (beginning-of-defun) + (catch 'sym-type + (scope (lambda (type beg len &rest _) + (when (<= beg pos (+ beg len)) + (throw 'sym-type type)))) + nil)))) + +(defun elisp-completion-at-point-default-predicate (sym) + (or (boundp sym) (fboundp sym) (featurep sym) (facep sym) (symbol-plist sym))) + (defalias 'elisp-capf (completion-at-point-function-with-frecency-sorting #'elisp-completion-at-point)) @@ -1124,19 +1046,8 @@ confidence." (t 'maybe-variable)))))))) (defun elisp--xref-infer-namespace-1 (pos) - (save-excursion - (beginning-of-defun-raw) - (case (catch 'sym-type - (scope (lambda (type beg len &rest _) - (when (<= beg pos (+ beg len)) - (throw 'sym-type type)))) - nil) - ((defface face) 'face) - ((feature) 'feature) - ((widget-type) 'widget-type) - ((condition) 'condition) - ((defvar variable constant) 'variable) - ((defun function macro special-form top-level major-mode) 'function)))) + (scope-get-symbol-type-property + (elisp-symbol-type-at-pos pos) :namespace)) (cl-defmethod xref-backend-identifier-at-point ((_backend (eql 'elisp))) (let ((bounds (bounds-of-thing-at-point 'symbol))) @@ -1203,7 +1114,8 @@ confidence." (widget-type '(widget-type)) (condition '(condition)) (variable '(defvar variable constant)) - (function '(defun function macro special-form top-level major-mode))))) + (symbol-type '(symbol-type symbol-type-definition)) + (function '(defun function macro special-form major-mode))))) (require 'project) (dolist-with-progress-reporter (file @@ -1262,6 +1174,7 @@ confidence." ('face '(defface)) ('feature '(feature)) ('condition '(define-error)) + ('symbol-type '(define-symbol-type)) ('widget-type '(define-widget))))) (cl-loop for d in definitions when (memq @@ -1314,6 +1227,10 @@ confidence." (when-let ((file (find-lisp-object-file-name symbol 'define-error))) (push (elisp--xref-make-xref 'define-error symbol file) xrefs))) + (when (scope-symbol-type-p symbol) + (when-let ((file (find-lisp-object-file-name symbol 'define-symbol-type))) + (push (elisp--xref-make-xref 'define-symbol-type symbol file) xrefs))) + (when (fboundp symbol) (let ((file (find-lisp-object-file-name symbol (symbol-function symbol))) generic doc) @@ -2650,7 +2567,8 @@ of TARGET." (beginning-of-defun-raw) (scope (lambda (type sbeg len _id &optional def) (and (<= sbeg beg) - (memq type '(function macro special-form top-level)) + ;; FIXME: use namespace info. + (memq type '(function macro special-form)) (push (nth 1 (syntax-ppss sbeg)) targets)) (let ((send (+ sbeg len))) (and (<= beg sbeg send end) def (< def beg) @@ -2725,16 +2643,9 @@ of TARGET." (condition-case nil (while t (scope (lambda (type beg len &rest _) - (case type - ((defun) - (push (cons (buffer-substring-no-properties beg (+ beg len)) beg) - (alist-get "Function" index nil nil #'string=))) - ((defvar) - (push (cons (buffer-substring-no-properties beg (+ beg len)) beg) - (alist-get "Var" index nil nil #'string=))) - ((defface) - (push (cons (buffer-substring-no-properties beg (+ beg len)) beg) - (alist-get "Face" index nil nil #'string=))))))) + (when-let ((group (scope-get-symbol-type-property type :imenu))) + (push (cons (buffer-substring-no-properties beg (+ beg len)) beg) + (alist-get group index nil nil #'string=)))))) (end-of-file (dolist (group index) (setcdr group (nreverse (cdr group)))) index)))) -- 2.39.5