From 6af0856059a4e4bf2cb28b338dd9b070ca8f44ac Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Sat, 18 Jan 2025 11:19:03 +0100 Subject: [PATCH] Various 'emacs-lisp-mode' enhancements --- lisp/emacs-lisp/scope.el | 230 ++++++++++++++++++++++++++++------- lisp/progmodes/elisp-mode.el | 155 +++++++++++++++++++++-- 2 files changed, 331 insertions(+), 54 deletions(-) diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el index 3ea378784ec..26f1154860a 100644 --- a/lisp/emacs-lisp/scope.el +++ b/lisp/emacs-lisp/scope.el @@ -88,44 +88,57 @@ Optional argument LOCAL is a local context to extend." (scope-local-new bare beg local) (cdr bindings) body)) (scope-n local body))) +(defun scope-interactive (local spec modes) + (scope-1 local spec) + (dolist (mode modes) + (and (symbol-with-pos-p mode) + (when-let* ((beg (symbol-with-pos-pos mode)) + (bare (bare-symbol mode)) + (len (length (symbol-name bare)))) + (funcall scope-callback 'major-mode beg len nil))))) + (defun scope-lambda (local args body) - (let ((int-spec nil) - (doc-form nil)) - (cond - ((and (consp (car body)) - (or (symbol-with-pos-p (caar body)) - (symbolp (caar body))) - (eq (bare-symbol (caar body)) :documentation)) - (setq doc-form (cadar body)) - (setq body (cdr body))) - ((stringp (car body)) (setq body (cdr body)))) - (when (and (consp (car body)) - (or (symbol-with-pos-p (caar body)) - (symbolp (caar body))) - (eq (bare-symbol (caar body)) 'declare)) - (setq body (cdr body))) - (when (and (consp (car body)) - (or (symbol-with-pos-p (caar body)) - (symbolp (caar body))) - (eq (bare-symbol (caar body)) 'interactive)) - (setq int-spec (cadar body)) - (setq body (cdr body))) + "Analyze (lambda ARGS BODY) function definition in LOCAL context." + ;; Handle docstring. + (cond + ((and (consp (car body)) + (or (symbol-with-pos-p (caar body)) + (symbolp (caar body))) + (eq (bare-symbol (caar body)) :documentation)) + (scope-1 local (cadar body)) + (setq body (cdr body))) + ((stringp (car body)) (setq body (cdr body)))) + ;; Handle `declare'. + (when (and (consp (car body)) + (or (symbol-with-pos-p (caar body)) + (symbolp (caar body))) + (eq (bare-symbol (caar body)) 'declare)) + (setq body (cdr body))) + ;; Handle `interactive'. + (when (and (consp (car body)) + (or (symbol-with-pos-p (caar body)) + (symbolp (caar body))) + (eq (bare-symbol (caar body)) 'interactive)) + (scope-interactive local (cadar body) (cddar body)) + (setq body (cdr body))) + ;; Handle ARGS. + (dolist (arg args) + (and (symbol-with-pos-p arg) + (let* ((beg (symbol-with-pos-pos arg)) + (bare (bare-symbol arg)) + (len (length (symbol-name bare)))) + (when beg + (if (memq (bare-symbol arg) '(&optional &rest _)) + (funcall scope-callback 'ampersand beg len nil) + (funcall scope-callback 'variable beg len beg)))))) + ;; Handle BODY. + (let ((l local)) (dolist (arg args) - (and (symbol-with-pos-p arg) - (not (memq (bare-symbol arg) '(&optional &rest _))) - (let* ((beg (symbol-with-pos-pos arg)) - (bare (bare-symbol arg)) - (len (length (symbol-name bare)))) - (when beg (funcall scope-callback 'variable beg len beg))))) - (scope-1 local doc-form) - (scope-1 local int-spec) - (let ((l local)) - (dolist (arg args) - (when-let ((bare (bare-symbol arg)) - (beg (scope-sym-pos arg))) - (unless (memq bare '(&optional &rest)) - (setq l (scope-local-new bare beg l))))) - (scope-n l body)))) + (when-let ((bare (bare-symbol arg)) + (beg (scope-sym-pos arg))) + (unless (memq bare '(&optional &rest)) + (setq l (scope-local-new bare beg l))))) + (scope-n l body))) (defun scope-defun (local name args body) (when-let ((beg (scope-sym-pos name)) @@ -158,7 +171,16 @@ Optional argument LOCAL is a local context to extend." (when beg (funcall scope-callback 'variable beg (length (symbol-name bare)) beg)) (scope-1 local bodyform) - (dolist (handler handlers) (scope-n l (cdr handler))))) + (dolist (handler handlers) + (dolist (cond-name (ensure-list (car-safe handler))) + (when-let* ((cbeg (scope-sym-pos cond-name)) + (cbare (scope-sym-bare cond-name)) + (clen (length (symbol-name cbare)))) + (cond + ((booleanp cbare)) + ((keywordp cbare) (funcall scope-callback 'constant cbeg clen nil)) + (t (funcall scope-callback 'condition cbeg clen nil))))) + (scope-n l (cdr handler))))) (defvar scope-flet-alist nil) @@ -494,6 +516,47 @@ Optional argument LOCAL is a local context to extend." (funcall scope-callback 'function beg (length (symbol-name bare)) nil)) (scope-n local rest)) +(defun scope-catch (local tag body) + (when-let* (((memq (car-safe tag) '(quote \`))) + (sym (cadr tag)) + (beg (scope-sym-pos sym)) + (bare (scope-sym-bare sym))) + (funcall scope-callback 'throw-tag beg (length (symbol-name bare)) nil)) + (scope-n local body)) + +(defun scope-face (_local face-form) + (when-let (((memq (scope-sym-bare (car-safe face-form)) '(quote \`))) + (face (cadr face-form))) + (if (or (scope-sym-bare face) + (keywordp (scope-sym-bare (car-safe face)))) + (scope-face-1 face) + (mapc #'scope-face-1 face)))) + +(defun scope-face-1 (face) + (cond + ((symbol-with-pos-p face) + (when-let ((beg (scope-sym-pos face)) (bare (scope-sym-bare face))) + (funcall scope-callback 'face beg (length (symbol-name bare)) nil))) + ((keywordp (scope-sym-bare (car-safe face))) + (let ((l face)) + (while l + (let ((kw (car l)) + (vl (cadr l))) + (setq l (cddr l)) + (when-let ((bare (scope-sym-bare kw)) + ((keywordp bare))) + (when-let ((beg (scope-sym-pos kw)) + (len (length (symbol-name bare)))) + (funcall scope-callback 'constant beg len nil)) + (when (eq bare :inherit) + (when-let ((beg (scope-sym-pos vl)) (fbare (scope-sym-bare vl))) + (funcall scope-callback 'face beg (length (symbol-name fbare)) nil)))))))))) + +(defun scope-deftype (local name args body) + (when-let* ((beg (scope-sym-pos name)) (bare (scope-sym-bare name))) + (funcall scope-callback 'type beg (length (symbol-name bare)) nil)) + (scope-lambda local args body)) + (defvar scope-safe-macros t "Specify which macros are safe to expand. @@ -556,7 +619,87 @@ a (possibly empty) list of safe macros.") (alias (cadr alias-form)) (beg (scope-sym-pos alias)) (bare (scope-sym-bare alias))) - (funcall scope-callback 'defface beg (length (symbol-name bare)) nil)))) + (funcall scope-callback 'defface beg (length (symbol-name bare)) nil)) + (when-let* ((spec-form (cadr forms)) + ((eq (scope-sym-bare (car-safe spec-form)) 'quote)) + (specs (cadr spec-form)) + ((consp specs))) + (dolist (spec specs) + (scope-face local (list 'quote (cdr spec)))))) + (throw + (when-let* ((tag-form (car forms)) + ((memq (scope-sym-bare (car-safe tag-form)) '(quote \`))) + (tag (cadr tag-form)) + (beg (scope-sym-pos tag)) + (bare (scope-sym-bare tag))) + (funcall scope-callback 'throw-tag beg (length (symbol-name bare)) nil))) + (( boundp set symbol-value + special-variable-p local-variable-p + local-variable-if-set-p + make-variable-buffer-local + default-value set-default make-local-variable + buffer-local-value add-to-list add-hook) + (when-let* ((var-form (car forms)) + ((memq (scope-sym-bare (car-safe var-form)) '(quote \`))) + (var (cadr var-form)) + (beg (scope-sym-pos var)) + (bare (scope-sym-bare var))) + (funcall scope-callback 'variable beg (length (symbol-name bare)) nil))) + ((featurep provide require) + (when-let* ((feat-form (car forms)) + ((memq (scope-sym-bare (car-safe feat-form)) '(quote \`))) + (feat (cadr feat-form)) + (beg (scope-sym-pos feat)) + (bare (scope-sym-bare feat))) + (funcall scope-callback 'feature beg (length (symbol-name bare)) nil))) + ((fboundp) + (when-let* ((fun-form (car forms)) + ((memq (scope-sym-bare (car-safe fun-form)) '(quote \`))) + (fun (cadr fun-form)) + (beg (scope-sym-pos fun)) + (bare (scope-sym-bare fun))) + (funcall scope-callback 'function beg (length (symbol-name bare)) nil))) + (overlay-put + (when-let* ((prop (cadr forms)) + ((memq (scope-sym-bare (car-safe prop)) '(quote \`))) + ((eq (scope-sym-bare (cadr prop)) 'face))) + (scope-face local (caddr forms)))) + ((remove-overlays put-text-property) + (when-let* ((prop (caddr forms)) + ((memq (scope-sym-bare (car-safe prop)) '(quote \`))) + ((eq (scope-sym-bare (cadr prop)) 'face))) + (scope-face local (cadddr forms)))) + (propertize + (when-let* ((props (cdr forms)) + (symbols-with-pos-enabled t) + (val-form (plist-get props ''face #'equal))) + (scope-face local val-form))) + ((eieio-defclass-internal) + (when-let* ((name-form (car forms)) + ((memq (scope-sym-bare (car-safe name-form)) '(quote \`))) + (name (cadr name-form)) + (beg (scope-sym-pos name)) + (bare (scope-sym-bare name))) + (funcall scope-callback 'type beg (length (symbol-name bare)) nil)) + (when-let* ((sups-form (cadr forms)) + ((memq (scope-sym-bare (car-safe sups-form)) '(quote \`))) + (sups (cadr sups-form))) + (dolist (sup (cadr sups-form)) + (when-let* ((beg (scope-sym-pos sup)) (bare (scope-sym-bare sup))) + (funcall scope-callback 'type beg (length (symbol-name bare)) nil))))) + ((cl-struct-define) + (when-let* ((name-form (car forms)) + ((memq (scope-sym-bare (car-safe name-form)) '(quote \`))) + (name (cadr name-form)) + (beg (scope-sym-pos name)) + (bare (scope-sym-bare name))) + (funcall scope-callback 'type beg (length (symbol-name bare)) nil)) + (when-let* ((prnt-form (caddr forms)) + ((memq (scope-sym-bare (car-safe prnt-form)) '(quote \`))) + (prnt (cadr prnt-form)) + (beg (scope-sym-pos prnt)) + (bare (scope-sym-bare prnt))) + (funcall scope-callback 'type beg (length (symbol-name bare)) nil)))) (when (symbol-with-pos-p f) (funcall scope-callback 'function (symbol-with-pos-pos f) (length (symbol-name bare)) @@ -580,9 +723,11 @@ a (possibly empty) list of safe macros.") (scope-condition-case local (car forms) (cadr forms) (cddr forms))) ((eq bare 'function) (scope-sharpquote local (car forms))) + ((eq bare 'catch) + (scope-catch local (car forms) (cdr forms))) ((memq bare '( if and or while save-excursion save-restriction save-current-buffer - catch unwind-protect + unwind-protect progn prog1)) (scope-n local forms)))) ((macrop bare) @@ -629,6 +774,8 @@ a (possibly empty) list of safe macros.") ((memq bare '(gv-define-simple-setter)) (scope-gv-define-simple-setter local (car forms) (cadr forms) (cddr forms))) + ((memq bare '(cl-deftype)) + (scope-deftype local (car forms) (cadr forms) (cddr forms))) ((scope-safe-macro-p bare) (scope-1 local (let ((symbols-with-pos-enabled t)) ;; Ignore errors from trying to expand @@ -660,9 +807,8 @@ a (possibly empty) list of safe macros.") "Read and analyze code from STREAM, reporting findings via CALLBACK. Call CALLBACK for each analyzed symbol SYM with arguments TYPE, POS, LEN -and BINDER, where TYPE a symbol that specifies the semantics of SYM, one -of `variable', `function', `block' `defun' and `defvar'; POS is the -position of SYM in STREAM; LEN is SYM's length; and BINDER is the +and BINDER, where TYPE a symbol that specifies the semantics of SYM; POS +is the position of SYM in STREAM; LEN is SYM's length; and BINDER is the position in which SYM is bound. If SYM is itself a binding occurrence, then POS and BINDER are equal. If SYM is not lexically bound, then BINDER is nil. This function ignores `read-symbol-shorthands', so SYM diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 3544e9bb7fc..abbdb58ea78 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -51,7 +51,6 @@ It has `lisp-mode-abbrev-table' as its parent." :doc "Keymap for Emacs Lisp mode. All commands in `lisp-mode-shared-map' are inherited by this map." :parent lisp-mode-shared-map - "M-TAB" #'completion-at-point "C-M-x" #'eval-defun "C-c C-e" #'elisp-eval-region-or-buffer "C-c C-f" #'elisp-byte-compile-file @@ -331,6 +330,34 @@ happens in interactive invocations." "Face for highlighting free variables in Emacs Lisp code." :group 'lisp) +(defface elisp-condition '((t :foreground "red")) + "Face for highlighting `condition-case' conditions in Emacs Lisp code." + :group 'lisp) + +(defface elisp-major-mode-name '((t :foreground "#006400")) + "Face for highlighting major mode names in Emacs Lisp code." + :group 'lisp) + +(defface elisp-face '((t :inherit font-lock-type-face)) + "Face for highlighting face names 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) + +(defface elisp-special-form '((t :inherit elisp-macro-call)) + "Face for highlighting special forms in Emacs Lisp code." + :group 'lisp) + +(defface elisp-throw-tag '((t :inherit font-lock-constant-face)) + "Face for highlighting `catch'/`throw' tags in Emacs Lisp code." + :group 'lisp) + +(defface elisp-feature '((t :inherit font-lock-constant-face)) + "Face for highlighting feature names in Emacs Lisp code." + :group 'lisp) + (defface elisp-binding-variable '((t :slant italic :inherit font-lock-variable-name-face)) "Face for highlighting binding occurrences of variables in Emacs Lisp code." @@ -382,13 +409,50 @@ happens in interactive invocations." :type 'boolean :group 'lisp) +(defun elisp--annotate-symbol-with-help-echo (type beg end bind) + (put-text-property + beg end 'help-echo + (cl-case type + (variable (cond ((equal beg bind) "Local variable definition") + (bind "Local variable") + (t "Special variable"))) + (block (if (equal beg bind) "Block definition" "Block")) + (face "Face") + (function (cond ((equal beg bind) "Local function definition") + (bind "Local function call") + (t "Function call"))) + (macro "Macro call") + (special-form "Special form") + (throw-tag "`throw'/`catch' tag") + (feature "Feature") + (type "Type") + (condition "`condition-case' condition") + (ampersand "Arguments separator") + (constant "Constant") + (defun "Function definition") + (defvar "Special variable definition") + (defface "Face definition") + (major-mode "Major mode")))) + (defun elisp-fontify-symbol (type sym len bind) + (elisp--annotate-symbol-with-help-echo type sym (+ sym len) bind) (if (null bind) (when-let ((face (cl-case type - (variable 'elisp-free-variable) - (function 'font-lock-function-call-face) - (defun 'font-lock-function-name-face) - (defvar 'font-lock-variable-name-face)))) + (variable 'elisp-free-variable) + (face 'elisp-face) + (function 'font-lock-function-call-face) + (macro 'elisp-macro-call) + (special-form 'elisp-special-form) + (throw-tag 'elisp-throw-tag) + (feature 'elisp-feature) + (type '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)))) (add-face-text-property sym (+ sym len) face t)) (add-face-text-property sym (+ sym len) (if (equal sym bind) @@ -405,9 +469,7 @@ happens in interactive invocations." "Fontify symbols between BEG and END according to their semantics." (save-excursion (goto-char beg) - (while (< (point) end) - (ignore-errors - (scope #'elisp-fontify-symbol (current-buffer)))))) + (while (< (point) end) (ignore-errors (scope #'elisp-fontify-symbol))))) (defun elisp-fontify-region (beg end &optional loudly) "Fontify ELisp code between BEG and END. @@ -428,6 +490,57 @@ This is the `font-lock-fontify-region-function' for `emacs-lisp-mode'." (scan-error nil))) (font-lock-default-fontify-region beg end loudly))) +(defconst elisp-font-lock-keywords + `(;; Regexp negated char group. + ("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend) + ;; Words inside \\[], \\<>, \\{} or \\`' tend to be for + ;; `substitute-command-keys'. + (,(rx "\\\\" (or (seq "[" + (group-n 1 (seq lisp-mode-symbol (not "\\"))) "]") + (seq "`" (group-n 1 + ;; allow multiple words, e.g. "C-x a" + lisp-mode-symbol (* " " lisp-mode-symbol)) + "'"))) + (1 font-lock-constant-face prepend)) + (,(rx "\\\\" (or (seq "<" + (group-n 1 (seq lisp-mode-symbol (not "\\"))) ">") + (seq "{" + (group-n 1 (seq lisp-mode-symbol (not "\\"))) "}"))) + (1 font-lock-variable-name-face prepend)) + ;; Ineffective backslashes (typically in need of doubling). + ("\\(\\\\\\)\\([^\"\\]\\)" + (1 (elisp--font-lock-backslash) prepend)) + ;; Words inside ‘’, '' and `' tend to be symbol names. + (,(concat "[`‘']\\(" (rx lisp-mode-symbol) "\\)['’]") + (1 font-lock-constant-face prepend)) + ;; \\= tends to be an escape in doc strings. + (,(rx "\\\\=") + (0 font-lock-builtin-face prepend)) + ;; ELisp regexp grouping constructs + (,(lambda (bound) + (catch 'found + ;; The following loop is needed to continue searching after matches + ;; that do not occur in strings. The associated regexp matches one + ;; of `\\\\' `\\(' `\\(?:' `\\|' `\\)'. `\\\\' has been included to + ;; avoid highlighting, for example, `\\(' in `\\\\('. + (while (re-search-forward "\\(\\\\\\\\\\)\\(?:\\(\\\\\\\\\\)\\|\\((\\(?:\\?[0-9]*:\\)?\\|[|)]\\)\\)" bound t) + (unless (match-beginning 2) + (let ((face (get-text-property (1- (point)) 'face))) + (when (or (and (listp face) + (memq 'font-lock-string-face face)) + (eq 'font-lock-string-face face)) + (throw 'found t))))))) + (1 'font-lock-regexp-grouping-backslash prepend) + (3 'font-lock-regexp-grouping-construct prepend)) + (lisp--match-hidden-arg + (0 '(face font-lock-warning-face + help-echo "Easy to misread; consider moving the element to the next line") + prepend)) + (lisp--match-confusable-symbol-character + 0 '(face font-lock-warning-face + help-echo "Confusable character"))) + "Highlighting patterns for Emacs Lisp mode.") + ;;;###autoload (define-derived-mode emacs-lisp-mode lisp-data-mode `("ELisp" @@ -451,13 +564,13 @@ be used instead. :group 'lisp (defvar project-vc-external-roots-function) (setq font-lock-defaults (copy-tree font-lock-defaults)) - (setcar font-lock-defaults - '(lisp-el-font-lock-keywords - lisp-el-font-lock-keywords-1 - lisp-el-font-lock-keywords-2)) + (setcar font-lock-defaults '(elisp-font-lock-keywords)) (cl-pushnew 'cursor-sensor-functions (alist-get 'font-lock-extra-managed-props (nthcdr 5 font-lock-defaults))) + (cl-pushnew 'help-echo + (alist-get 'font-lock-extra-managed-props + (nthcdr 5 font-lock-defaults))) (alist-set 'font-lock-fontify-region-function (nthcdr 5 font-lock-defaults) #'elisp-fontify-region) @@ -772,11 +885,15 @@ in `completion-at-point-functions' (which see)." (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))) + ((face) #'facep) ((nil) (lambda (sym) (let ((sym (intern-soft (symbol-name sym)))) (or (boundp sym) (fboundp sym) (featurep sym) + (facep sym) (symbol-plist sym))))))) (beg-end (bounds-of-thing-at-point 'symbol)) (beg (car beg-end)) @@ -866,6 +983,7 @@ namespace but with lower confidence." (ignore-errors (read (current-buffer)))))) (and (symbolp val) val)))) (cond + ((elisp--xref-infer-namespace-1 pos)) ((and (eq (char-before pos) ?\') (eq (char-before (1- pos)) ?#)) ;; #'IDENT @@ -998,6 +1116,19 @@ namespace but with lower confidence." ;; a macro we cannot be sure. (t 'maybe-variable)))))))) +(defun elisp--xref-infer-namespace-1 (pos) + (save-excursion + (beginning-of-defun-raw) + (cl-case (catch 'sym-type + (scope (lambda (type beg len _bin) + (when (<= beg pos (+ beg len)) + (throw 'sym-type type)))) + nil) + ((defface face) 'face) + ((feature) 'feature) + ((defvar variable constant) 'variable) + ((defun function macro special-form top-level major-mode) 'function)))) + (cl-defmethod xref-backend-identifier-at-point ((_backend (eql 'elisp))) (let ((bounds (bounds-of-thing-at-point 'symbol))) (and bounds -- 2.39.5