New feature: etags-regen-mode

* lisp/progmodes/etags-regen.el: New file (bug#67687).

* etc/NEWS: Mention the addition.

* .dir-locals.el: Add this project's settings for
etags-regen-regexp-alist and etags-regen-ignores.

.dir-locals.el

@@ -8,6 +8,12 @@
          (vc-git-annotate-switches . "-w")
          (bug-reference-url-format . "https://debbugs.gnu.org/%s")
 	 (diff-add-log-use-relative-names . t)
+         (etags-regen-regexp-alist
+          .
+          ((("c" "objc") .
+            ("/[ \t]*DEFVAR_[A-Z_ \t(]+\"\\([^\"]+\\)\"/\\1/"
+             "/[ \t]*DEFVAR_[A-Z_ \t(]+\"[^\"]+\",[ \t]\\([A-Za-z0-9_]+\\)/\\1/"))))
+         (etags-regen-ignores . ("test/manual/etags/"))
          (vc-prepare-patches-separately . nil)))
  (c-mode . ((c-file-style . "GNU")
             (c-noise-macro-names . ("INLINE" "NO_INLINE" "ATTRIBUTE_NO_SANITIZE_UNDEFINED"

etc/NEWS

@@ -1265,6 +1265,11 @@ the needs of users with red-green or blue-yellow color deficiency.
 The Info manual "(modus-themes) Top" describes the details and
 showcases all their customization options.
 
+** New global minor mode 'etags-regen-mode'.
+This minor mode generates the tags table automatically based on the
+current project configuration, and later updates it as you edit the
+files and save the changes.
+
 
 * Incompatible Lisp Changes in Emacs 30.1
 

lisp/progmodes/etags-regen.el

@@ -0,0 +1,431 @@
+;;; etags-regen.el --- Auto-(re)regenerating tags  -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021-2023 Free Software Foundation, Inc.
+
+;; Author: Dmitry Gutov <dmitry@gutov.dev>
+;; Keywords: tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Simple automatic tags generation with updates on save.
+;;
+;; This mode provides automatic indexing for Emacs "go to definition"
+;; feature, the `xref-go-forward' command (bound to `M-.' by default).
+;;
+;; At the moment reindexing works off before/after-save-hook, but to
+;; handle more complex changes (for example, the user switching to
+;; another branch from the terminal) we can look into plugging into
+;; something like `filenotify'.
+;;
+;; Note that this feature disables itself if the user has some tags
+;; table already visited (with `M-x visit-tags-table', or through an
+;; explicit prompt triggered by some feature that requires tags).
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defgroup etags-regen nil
+  "Auto-(re)generating tags."
+  :group 'tools)
+
+(defvar etags-regen--tags-file nil)
+(defvar etags-regen--tags-root nil)
+(defvar etags-regen--new-file nil)
+
+(declare-function project-root "project")
+(declare-function project-files "project")
+(declare-function dired-glob-regexp "dired")
+
+(defcustom etags-regen-program (executable-find "etags")
+  "Name of the etags program used by `etags-regen-mode'.
+
+If you only have `ctags' installed, you can also set this to
+\"ctags -e\".  Some features might not be supported this way."
+  ;; Always having our 'etags' here would be easier, but we can't
+  ;; always rely on it being installed.  So it might be ctags's etags.
+  :type 'file
+  :version "30.1")
+
+(defcustom etags-regen-tags-file "TAGS"
+  "Name of the tags file to create inside the project by `etags-regen-mode'.
+
+The value should either be a simple file name (no directory
+specified), or a function that accepts the project root directory
+and returns a distinct absolute file name for its tags file.  The
+latter possibility is useful when you prefer to store the tag
+files somewhere else, for example in `temporary-file-directory'."
+  :type '(choice (string :tag "File name")
+                 (function :tag "Function that returns file name"))
+  :version "30.1")
+
+(defcustom etags-regen-program-options nil
+  "List of additional options for etags program invoked by `etags-regen-mode'."
+  :type '(repeat string)
+  :version "30.1")
+
+(defcustom etags-regen-regexp-alist nil
+  "Mapping of languages to etags regexps for `etags-regen-mode'.
+
+These regexps are used in addition to the tags made with the
+standard parsing based on the language.
+
+The value must be a list where each element has the
+form (LANGUAGES . TAG-REGEXPS) where both LANGUAGES and
+TAG-REGEXPS are lists of strings.
+
+Each language should be one of the recognized by etags, see
+`etags --help'.  Each tag regexp should be a string in the format
+documented for the `--regex' arguments (without `{language}').
+
+We currently support only Emacs's etags program with this option."
+  :type '(repeat
+          (cons
+           :tag "Languages group"
+           (repeat (string :tag "Language name"))
+           (repeat (string :tag "Tag Regexp"))))
+  :version "30.1")
+
+;;;###autoload
+(put 'etags-regen-regexp-alist 'safe-local-variable
+     (lambda (value)
+       (and (listp value)
+            (seq-every-p
+             (lambda (group)
+               (and (consp group)
+                    (listp (car group))
+                    (listp (cdr group))
+                    (seq-every-p #'stringp (car group))
+                    (seq-every-p #'stringp (cdr group))))
+             value))))
+
+;; We have to list all extensions: etags falls back to Fortran
+;; when it cannot determine the type of the file.
+;; http://lists.gnu.org/archive/html/emacs-devel/2018-01/msg00323.html
+(defcustom etags-regen-file-extensions
+  '("rb" "js" "py" "pl" "el" "c" "cpp" "cc" "h" "hh" "hpp"
+    "java" "go" "cl" "lisp" "prolog" "php" "erl" "hrl"
+    "F" "f" "f90" "for" "cs" "a" "asm" "ads" "adb" "ada")
+  "Code file extensions for `etags-regen-mode'.
+
+File extensions to generate the tags for."
+  :type '(repeat (string :tag "File extension"))
+  :version "30.1")
+
+;;;###autoload
+(put 'etags-regen-file-extensions 'safe-local-variable
+     (lambda (value) (and (listp value) (seq-every-p #'stringp value))))
+
+;; FIXME: We don't support root anchoring yet.
+(defcustom etags-regen-ignores nil
+  "Additional ignore rules, in the format of `project-ignores'."
+  :type '(repeat
+          (string :tag "Glob to ignore"))
+  :version "30.1")
+
+;;;###autoload
+(put 'etags-regen-ignores 'safe-local-variable
+     (lambda (value) (and (listp value) (seq-every-p #'stringp value))))
+
+(defvar etags-regen--errors-buffer-name "*etags-regen-tags-errors*")
+
+(defvar etags-regen--rescan-files-limit 100)
+
+(defun etags-regen--all-mtimes (proj)
+  (let ((files (etags-regen--all-files proj))
+        (mtimes (make-hash-table :test 'equal))
+        file-name-handler-alist)
+    (dolist (f files)
+      (condition-case nil
+          (puthash f
+                   (file-attribute-modification-time
+                    (file-attributes f))
+                   mtimes)
+        (file-missing nil)))
+    mtimes))
+
+(defun etags-regen--choose-tags-file (proj)
+  (if (functionp etags-regen-tags-file)
+      (funcall etags-regen-tags-file (project-root proj))
+    (expand-file-name etags-regen-tags-file (project-root proj))))
+
+(defun etags-regen--refresh (proj)
+  (save-excursion
+    (let* ((tags-file (etags-regen--choose-tags-file proj))
+           (tags-mtime (file-attribute-modification-time
+                        (file-attributes tags-file)))
+           (all-mtimes (etags-regen--all-mtimes proj))
+           added-files
+           changed-files
+           removed-files)
+      (etags-regen--visit-table tags-file (project-root proj))
+      (set-buffer (get-file-buffer tags-file))
+      (dolist (file (tags-table-files))
+        (let ((mtime (gethash file all-mtimes)))
+          (cond
+           ((null mtime)
+            (push file removed-files))
+           ((time-less-p tags-mtime mtime)
+            (push file changed-files)
+            (remhash file all-mtimes))
+           (t
+            (remhash file all-mtimes)))))
+      (maphash
+       (lambda (key _value)
+         (push key added-files))
+       all-mtimes)
+      (if (> (+ (length added-files)
+                (length changed-files)
+                (length removed-files))
+             etags-regen--rescan-files-limit)
+          (progn
+            (message "etags-regen: Too many changes, falling back to full rescan")
+            (etags-regen--tags-cleanup))
+        (dolist (file (nconc removed-files changed-files))
+          (etags-regen--remove-tag file))
+        (when (or changed-files added-files)
+          (apply #'etags-regen--append-tags
+                 (nconc changed-files added-files)))
+        (when (or changed-files added-files removed-files)
+          (let ((save-silently t)
+                (message-log-max nil))
+            (save-buffer 0)))))))
+
+(defun etags-regen--maybe-generate ()
+  (let (proj)
+    (when (and etags-regen--tags-root
+               (not (file-in-directory-p default-directory
+                                         etags-regen--tags-root)))
+      (etags-regen--tags-cleanup))
+    (when (and (not etags-regen--tags-root)
+               ;; If existing table is visited that's not generated by
+               ;; this mode, skip all functionality.
+               (not (or tags-file-name
+                        tags-table-list))
+               (file-exists-p (etags-regen--choose-tags-file
+                               (setq proj (project-current)))))
+      (message "Found existing tags table, refreshing...")
+      (etags-regen--refresh proj))
+    (when (and (not (or tags-file-name
+                        tags-table-list))
+               (setq proj (or proj (project-current))))
+      (message "Generating new tags table...")
+      (let ((start (time-to-seconds)))
+        (etags-regen--tags-generate proj)
+        (message "...done (%.2f s)" (- (time-to-seconds) start))))))
+
+(defun etags-regen--all-files (proj)
+  (let* ((root (project-root proj))
+         (default-directory root)
+         ;; TODO: Make the scanning more efficient, e.g. move the
+         ;; filtering by glob to project (project-files-filtered...).
+         (files (project-files proj))
+         (match-re (concat
+                    "\\."
+                    (regexp-opt etags-regen-file-extensions)
+                    "\\'"))
+         (ir-start (1- (length root)))
+         (ignores-regexps
+          (mapcar #'etags-regen--ignore-regexp
+                  etags-regen-ignores)))
+    (cl-delete-if
+     (lambda (f) (or (not (string-match-p match-re f))
+                (string-match-p "/\\.#" f) ;Backup files.
+                (cl-some (lambda (ignore) (string-match ignore f ir-start))
+                         ignores-regexps)))
+     files)))
+
+(defun etags-regen--ignore-regexp (ignore)
+  (require 'dired)
+  ;; It's somewhat brittle to rely on Dired.
+  (let ((re (dired-glob-regexp ignore)))
+    ;; We could implement root anchoring here, but \\= doesn't work in
+    ;; string-match :-(.
+    (concat (unless (eq ?/ (aref re 3)) "/")
+            ;; Cutting off the anchors added by `dired-glob-regexp'.
+            (substring re 2 (- (length re) 2))
+            ;; This way we allow a glob to match against a directory
+            ;; name, or a file name.  And when it ends with / already,
+            ;; no need to add the anchoring.
+            (unless (eq ?/ (aref re (- (length re) 3)))
+              ;; Either match a full name segment, or eos.
+              "\\(?:/\\|\\'\\)"))))
+
+(defun etags-regen--tags-generate (proj)
+  (let* ((root (project-root proj))
+         (default-directory root)
+         (files (etags-regen--all-files proj))
+         (tags-file (etags-regen--choose-tags-file proj))
+         (ctags-p (etags-regen--ctags-p))
+         (command (format "%s %s %s - -o %s"
+                          etags-regen-program
+                          (mapconcat #'identity
+                                     (etags-regen--build-program-options ctags-p)
+                                     " ")
+                          ;; ctags's etags requires '-L' for stdin input.
+                          (if ctags-p "-L" "")
+                          tags-file)))
+    (with-temp-buffer
+      (mapc (lambda (f)
+              (insert f "\n"))
+            files)
+      (shell-command-on-region (point-min) (point-max) command
+                               nil nil etags-regen--errors-buffer-name t))
+    (etags-regen--visit-table tags-file root)))
+
+(defun etags-regen--visit-table (tags-file root)
+  ;; Invalidate the scanned tags after any change is written to disk.
+  (add-hook 'after-save-hook #'etags-regen--update-file)
+  (add-hook 'before-save-hook #'etags-regen--mark-as-new)
+  (setq etags-regen--tags-file tags-file
+        etags-regen--tags-root root)
+  (visit-tags-table etags-regen--tags-file))
+
+(defun etags-regen--ctags-p ()
+  (string-search "Ctags"
+                 (shell-command-to-string
+                  (format "%s --version" etags-regen-program))))
+
+(defun etags-regen--build-program-options (ctags-p)
+  (when (and etags-regen-regexp-alist ctags-p)
+    (user-error "etags-regen-regexp-alist is not supported with Ctags"))
+  (nconc
+   (mapcan
+    (lambda (group)
+      (mapcan
+       (lambda (lang)
+         (mapcar (lambda (regexp)
+                   (concat "--regex="
+                           (shell-quote-argument
+                            (format "{%s}%s" lang regexp))))
+                 (cdr group)))
+       (car group)))
+    etags-regen-regexp-alist)
+   (mapcar #'shell-quote-argument
+           etags-regen-program-options)))
+
+(defun etags-regen--update-file ()
+  ;; TODO: Maybe only do this when Emacs is idle for a bit.  Or defer
+  ;; the updates and do them later in bursts when the table is used.
+  (let* ((file-name buffer-file-name)
+         (tags-file-buf (and etags-regen--tags-root
+                             (get-file-buffer etags-regen--tags-file)))
+         (relname (concat "/" (file-relative-name file-name
+                                                  etags-regen--tags-root)))
+         (ignores etags-regen-ignores)
+         pr should-scan)
+    (save-excursion
+      (when tags-file-buf
+        (cond
+         ((and etags-regen--new-file
+               (kill-local-variable 'etags-regen--new-file)
+               (setq pr (project-current))
+               (equal (project-root pr) etags-regen--tags-root)
+               (member file-name (project-files pr)))
+          (set-buffer tags-file-buf)
+          (setq should-scan t))
+         ((progn (set-buffer tags-file-buf)
+                 (etags-regen--remove-tag file-name))
+          (setq should-scan t))))
+      (when (and should-scan
+                 (not (cl-some
+                       (lambda (ignore)
+                         (string-match-p
+                          (etags-regen--ignore-regexp ignore)
+                          relname))
+                       ignores)))
+        (etags-regen--append-tags file-name)
+        (let ((save-silently t)
+              (message-log-max nil))
+          (save-buffer 0))))))
+
+(defun etags-regen--remove-tag (file-name)
+  (goto-char (point-min))
+  (when (search-forward (format "\f\n%s," file-name) nil t)
+    (let ((start (match-beginning 0)))
+      (search-forward "\f\n" nil 'move)
+      (let ((inhibit-read-only t))
+        (delete-region start
+                       (if (eobp)
+                           (point)
+                         (- (point) 2)))))
+    t))
+
+(defun etags-regen--append-tags (&rest file-names)
+  (goto-char (point-max))
+  (let ((options (etags-regen--build-program-options (etags-regen--ctags-p)))
+        (inhibit-read-only t))
+    ;; XXX: call-process is significantly faster, though.
+    ;; Like 10ms vs 20ms here.  But `shell-command' makes it easy to
+    ;; direct stderr to a separate buffer.
+    (shell-command
+     (format "%s %s %s -o -"
+             etags-regen-program (mapconcat #'identity options " ")
+             (mapconcat #'identity file-names " "))
+     t etags-regen--errors-buffer-name))
+  ;; FIXME: Is there a better way to do this?
+  ;; Completion table is the only remaining place where the
+  ;; update is not incremental.
+  (setq-default tags-completion-table nil))
+
+(defun etags-regen--mark-as-new ()
+  (when (and etags-regen--tags-root
+             (not buffer-file-number))
+    (setq-local etags-regen--new-file t)))
+
+(defun etags-regen--tags-cleanup ()
+  (when etags-regen--tags-file
+    (let ((buffer (get-file-buffer etags-regen--tags-file)))
+      (and buffer
+           (kill-buffer buffer)))
+    (tags-reset-tags-tables)
+    (setq tags-file-name nil
+          tags-table-list nil
+          etags-regen--tags-file nil
+          etags-regen--tags-root nil))
+  (remove-hook 'after-save-hook #'etags-regen--update-file)
+  (remove-hook 'before-save-hook #'etags-regen--mark-as-new))
+
+(defvar etags-regen-mode-map (make-sparse-keymap))
+
+;;;###autoload
+(define-minor-mode etags-regen-mode
+  "Minor mode to automatically generate and update tags tables.
+
+This minor mode generates the tags table automatically based on
+the current project configuration, and later updates it as you
+edit the files and save the changes.
+
+If you select a tags table manually (for example, using
+\\[visit-tags-table]), then this mode will be effectively
+disabled for the entire session.  Use \\[tags-reset-tags-tables]
+to countermand the effect of a previous \\[visit-tags-table]."
+  :global t
+  (if etags-regen-mode
+      (progn
+        (advice-add 'etags--xref-backend :before
+                    #'etags-regen--maybe-generate)
+        (advice-add 'tags-completion-at-point-function :before
+                    #'etags-regen--maybe-generate))
+    (advice-remove 'etags--xref-backend #'etags-regen--maybe-generate)
+    (advice-remove 'tags-completion-at-point-function #'etags-regen--maybe-generate)
+    (etags-regen--tags-cleanup)))
+
+(provide 'etags-regen)
+
+;;; etags-regen.el ends here