From 4e80b8d2c12fe7f99a3f8c9afc55362dd376a0a2 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Sat, 18 Jan 2025 14:54:46 +0100 Subject: [PATCH] scope.el,elisp-mode.el: Support and custom types groups --- lisp/emacs-lisp/scope.el | 144 ++++++++++++++++++++++++++++++----- lisp/progmodes/elisp-mode.el | 6 ++ 2 files changed, 131 insertions(+), 19 deletions(-) diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el index 26f1154860a..9efe63bf0dc 100644 --- a/lisp/emacs-lisp/scope.el +++ b/lisp/emacs-lisp/scope.el @@ -88,7 +88,12 @@ 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) +(defun scope-interactive (local intr spec modes) + (when (symbol-with-pos-p intr) + (funcall scope-callback 'special-form + (symbol-with-pos-pos intr) + (length (symbol-name (scope-sym-bare intr))) + nil)) (scope-1 local spec) (dolist (mode modes) (and (symbol-with-pos-p mode) @@ -109,17 +114,26 @@ Optional argument LOCAL is a local context to extend." (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)) + ;; FIXME: `declare' is macro-expanded away, so we never actually see + ;; it in a `lambda'. + (when-let ((form (car body)) + (decl (car-safe form)) + ((or (symbol-with-pos-p decl) + (symbolp decl))) + ((eq (bare-symbol decl) 'declare))) + (when (symbol-with-pos-p decl) + (funcall scope-callback 'macro + (symbol-with-pos-pos decl) + (length (symbol-name (bare-symbol decl))) + nil)) (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)) + (when-let ((form (car body)) + (intr (car-safe form)) + ((or (symbol-with-pos-p intr) + (symbolp intr))) + ((eq (bare-symbol intr) 'interactive))) + (scope-interactive local intr (cadar body) (cddar body)) (setq body (cdr body))) ;; Handle ARGS. (dolist (arg args) @@ -557,6 +571,69 @@ Optional argument LOCAL is a local context to extend." (funcall scope-callback 'type beg (length (symbol-name bare)) nil)) (scope-lambda local args body)) +(defun scope-widget-type (_local form) + (when-let (((memq (scope-sym-bare (car-safe form)) '(quote \`))) + (type (cadr form))) + (scope-widget-type-1 type))) + +(defun scope-widget-type-1 (type) + (cond + ((symbol-with-pos-p type) + (when-let* ((beg (scope-sym-pos type)) (bare (scope-sym-bare type))) + (funcall scope-callback 'widget-type + (symbol-with-pos-pos type) + (length (symbol-name (bare-symbol type))) nil))) + ((consp type) + (let ((head (car type))) + (when-let ((beg (scope-sym-pos head)) (bare (scope-sym-bare head))) + (funcall scope-callback 'widget-type beg (length (symbol-name bare)) nil)) + (when-let ((bare (scope-sym-bare head))) + (scope-widget-type-arguments bare (cdr type))))))) + +(defun scope-widget-type-keyword-arguments (head kw args) + (when-let ((beg (scope-sym-pos kw)) + (len (length (symbol-name (bare-symbol kw))))) + (funcall scope-callback 'constant beg len nil)) + (cond + ((and (memq head '(plist alist)) + (memq kw '(:key-type :value-type))) + (scope-widget-type-1 (car args))) + ((memq kw '(:action :match :match-inline :validate)) + (when-let* ((fun (car args)) + (beg (scope-sym-pos fun)) + (bare (scope-sym-bare fun))) + (funcall scope-callback 'function beg (length (symbol-name bare)) nil)))) + ;; TODO: (restricted-sexp :match-alternatives CRITERIA) + (scope-widget-type-arguments head (cdr args))) + +(defun scope-widget-type-arguments (head args) + (let* ((arg (car args)) + (bare (scope-sym-bare arg))) + (if (keywordp bare) + (scope-widget-type-keyword-arguments head bare (cdr args)) + (scope-widget-type-arguments-1 head args)))) + +(defun scope-widget-type-arguments-1 (head args) + (cl-case head + ((list cons group vector choice radio set repeat) (mapc #'scope-widget-type-1 args)) + ((function-item) + (when-let* ((fun (car args)) + (beg (scope-sym-pos fun)) + (bare (scope-sym-bare fun))) + (funcall scope-callback 'function beg (length (symbol-name bare)) nil))) + ((variable-item) + (when-let* ((var (car args)) + (beg (scope-sym-pos var)) + (bare (scope-sym-bare var))) + (funcall scope-callback 'variable beg (length (symbol-name bare)) nil))))) + +(defun scope-quoted-group (_local sym-form) + (when-let* (((eq (scope-sym-bare (car-safe sym-form)) 'quote)) + (sym (cadr sym-form)) + (beg (scope-sym-pos sym)) + (bare (scope-sym-bare sym))) + (funcall scope-callback 'group beg (length (symbol-name bare)) nil))) + (defvar scope-safe-macros t "Specify which macros are safe to expand. @@ -607,12 +684,24 @@ a (possibly empty) list of safe macros.") (bare (scope-sym-bare alias))) (funcall scope-callback 'defun beg (length (symbol-name bare)) nil))) (custom-declare-variable - (when-let* ((alias-form (car forms)) - ((eq (scope-sym-bare (car-safe alias-form)) 'quote)) - (alias (cadr alias-form)) - (beg (scope-sym-pos alias)) - (bare (scope-sym-bare alias))) - (funcall scope-callback 'defvar beg (length (symbol-name bare)) nil))) + (when-let* ((sym-form (car forms)) + ((eq (scope-sym-bare (car-safe sym-form)) 'quote)) + (sym (cadr sym-form)) + (beg (scope-sym-pos sym)) + (bare (scope-sym-bare sym))) + (funcall scope-callback 'defvar beg (length (symbol-name bare)) nil)) + (when-let* ((props (cdddr forms)) + (symbols-with-pos-enabled t)) + (when-let ((val-form (plist-get props :type))) + (scope-widget-type local val-form)) + (when-let ((val-form (plist-get props :group))) + (scope-quoted-group local val-form)))) + (custom-declare-group + (scope-quoted-group local (car forms)) + (when-let* ((props (cdddr forms)) + (symbols-with-pos-enabled t) + (val-form (plist-get props :group))) + (scope-quoted-group local val-form))) (custom-declare-face (when-let* ((alias-form (car forms)) ((eq (scope-sym-bare (car-safe alias-form)) 'quote)) @@ -625,7 +714,11 @@ a (possibly empty) list of safe macros.") (specs (cadr spec-form)) ((consp specs))) (dolist (spec specs) - (scope-face local (list 'quote (cdr spec)))))) + (scope-face local (list 'quote (cdr spec))))) + (when-let* ((props (cdddr forms)) + (symbols-with-pos-enabled t)) + (when-let ((val-form (plist-get props :group))) + (scope-quoted-group local val-form)))) (throw (when-let* ((tag-form (car forms)) ((memq (scope-sym-bare (car-safe tag-form)) '(quote \`))) @@ -633,7 +726,7 @@ a (possibly empty) list of safe macros.") (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 + (( boundp set symbol-value define-abbrev-table special-variable-p local-variable-p local-variable-if-set-p make-variable-buffer-local @@ -699,7 +792,20 @@ a (possibly empty) list of safe macros.") (prnt (cadr prnt-form)) (beg (scope-sym-pos prnt)) (bare (scope-sym-bare prnt))) - (funcall scope-callback 'type beg (length (symbol-name bare)) nil)))) + (funcall scope-callback 'type beg (length (symbol-name bare)) nil))) + ((define-widget) + (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 'widget-type beg (length (symbol-name bare)) nil)) + (when-let* ((prnt-form (cadr 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 'widget-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)) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index abbdb58ea78..9b718691e39 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -425,7 +425,9 @@ happens in interactive invocations." (special-form "Special form") (throw-tag "`throw'/`catch' tag") (feature "Feature") + (widget-type "Widget type") (type "Type") + (group "Customization group") (condition "`condition-case' condition") (ampersand "Arguments separator") (constant "Constant") @@ -445,7 +447,9 @@ happens in interactive invocations." (special-form 'elisp-special-form) (throw-tag 'elisp-throw-tag) (feature 'elisp-feature) + (widget-type 'font-lock-type-face) (type 'font-lock-type-face) + (group 'font-lock-type-face) (condition 'elisp-condition) (ampersand 'font-lock-type-face) (constant 'font-lock-builtin-face) @@ -887,6 +891,8 @@ in `completion-at-point-functions' (which see)." ((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))) + ((group) (lambda (sym) (get sym 'group-documentation))) ((face) #'facep) ((nil) (lambda (sym) (let ((sym (intern-soft (symbol-name sym)))) -- 2.39.5