RFC: Automatic setup for bug-reference-mode

[Tassilo Horn <tsdh@gnu.org>]

Hi all,

I've been working on a feature to setup bug-reference-mode automatically
in common cases, i.e., make it guess the right
`bug-reference-url-format' and `bug-reference-bug-regexp' automatically
(if not already set).

Attach is my first attempt at doing so and I'd welcome comments.

What it achieves in the current state:

  - Setup according to VCS information
    - Only for Git at the moment (Is there a generic way to get the VCS
      URL?)
    - Project on savannah => setup GNU debbugs instance
    - GitHub: support #17 and namespace/project#17 links (both issues
      and PRs)
    - GitLab: support #17 issue links and !18 merge request including
      cross-project namespace/project#18 references.
  - Setup according to Gnus newsgroup, To, From, Cc
    - Probably too lax but works for setting our GNU debbugs instance
      for emacs-devel and other emacs-related mailing lists and
      newsgroups.

Bye,
Tassilo

--8<---------------cut here---------------start------------->8---
2 files changed, 142 insertions(+), 4 deletions(-)
lisp/progmodes/bug-reference.el | 139 +++++++++++++++++++++++++++++++++++++++-
lisp/vc/vc.el                   |   7 +-

modified   lisp/progmodes/bug-reference.el
@@ -60,6 +60,7 @@ bug-reference-url-format
 you need to add a `bug-reference-url-format' property to it:
 \(put \\='my-bug-reference-url-format \\='bug-reference-url-format t)
 so that it is considered safe, see `enable-local-variables'.")
+(make-variable-buffer-local 'bug-reference-url-format)
 
 ;;;###autoload
 (put 'bug-reference-url-format 'safe-local-variable
@@ -75,6 +76,7 @@ bug-reference-bug-regexp
   :type 'regexp
   :version "24.3"			; previously defconst
   :group 'bug-reference)
+(make-variable-buffer-local 'bug-reference-bug-regexp)
 
 ;;;###autoload
 (put 'bug-reference-bug-regexp 'safe-local-variable 'stringp)
@@ -139,6 +141,139 @@ bug-reference-push-button
 	(when url
 	  (browse-url url))))))
 
+(defcustom bug-reference-setup-functions nil
+  "A list of function for setting up bug-reference mode.
+A setup function should return non-nil if it set
+`bug-reference-bug-regexp' and `bug-reference-url-format'
+appropiately for the current buffer.  The functions are called in
+sequence stopping as soon as one signalled a successful setup.
+They are only called if the two variables aren't set already,
+e.g., by a local variables section.
+
+Also see `bug-reference-default-setup-functions'.
+
+The `bug-reference-setup-functions' take preference over
+`bug-reference-default-setup-functions', i.e., they are
+called before the latter."
+  :type '(list function)
+  :version "28.1"
+  :group 'bug-reference)
+
+(defun bug-reference-try-setup-from-vc ()
+  "Try setting up `bug-reference-bug-regexp' and
+`bug-reference-url-format' from the version control system of the
+current file."
+  (when (buffer-file-name)
+    (let* ((backend (vc-responsible-backend (buffer-file-name) t))
+           (url (pcase backend
+                  ('Git (string-trim
+                         (shell-command-to-string
+                          "git ls-remote --get-url"))))))
+      (cl-flet ((maybe-set (url-rx bug-rx bug-url-fmt)
+                           (when (string-match url-rx url)
+                             (setq bug-reference-bug-regexp bug-rx)
+                             (setq bug-reference-url-format
+                                   (if (functionp bug-url-fmt)
+                                       (funcall bug-url-fmt)
+                                     bug-url-fmt)))))
+        (when (and url
+                   ;; If there's a space in the url, it's propably an
+                   ;; error message.
+                   (not (string-match-p "[[:space:]]" url)))
+          (or
+           ;; GNU projects on savannah.  FIXME: Only a fraction of
+           ;; them uses debbugs.
+           (maybe-set "git\\.\\(sv\\|savannah\\)\\.gnu\\.org:"
+                      "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
+                      "https://debbugs.gnu.org/%s")
+           ;; GitHub projects.  Here #17 may refer to either an issue
+           ;; or a pull request but visiting the issue/17 web page
+           ;; will automatically redirect to the pull/17 page if 17 is
+           ;; a PR.  Explicit user/project#17 links to possibly
+           ;; different projects are also supported.
+           (maybe-set
+            "[/@]github.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
+            "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)"
+            (lambda ()
+              (let ((ns-project (match-string 1 url)))
+                (lambda ()
+                  (concat "https://github.com/"
+                          (or
+                           ;; Explicit user/proj#18 link.
+                           (match-string 1)
+                           ns-project)
+                          "/issues/"
+                          (match-string 2))))))
+           ;; GitLab projects.  Here #18 is an issue and !17 is a
+           ;; merge request.  Explicit namespace/project#18 references
+           ;; to possibly different projects are also supported.
+           (maybe-set
+            "[/@]gitlab.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
+            "\\(?1:[.A-Za-z0-9_/-]+\\)?\\(?3:#\\|!\\)\\(?2:[0-9]+\\)"
+            (lambda ()
+              (let ((ns-project (match-string 1 url)))
+                (lambda ()
+                  (concat "https://gitlab.com/"
+                          (or (match-string 1)
+                              ns-project)
+                          "/-/"
+                          (if (string= (match-string 3) "#")
+                              "issues/"
+                            "merge_requests/")
+                          (match-string 2))))))))))))
+
+(defun bug-reference-try-setup-from-gnus ()
+  (when (and (memq major-mode '(gnus-summary-mode gnus-article-mode))
+             (boundp 'gnus-newsgroup-name)
+             gnus-newsgroup-name)
+    (let ((debbugs-regexp
+           ;; TODO: Obviously there are more, so add them.
+           (regexp-opt '("emacs" "auctex" "reftex"
+                         "-devel@gnu.org" "ding@gnus.org"))))
+      (when (or (string-match-p debbugs-regexp gnus-newsgroup-name)
+                (and
+                 gnus-article-buffer
+                 (with-current-buffer gnus-article-buffer
+                   (let ((headers (mail-header-extract)))
+                     (when headers
+                       (or (string-match-p
+                            debbugs-regexp
+                            (or (mail-header 'from headers) ""))
+                           (string-match-p
+                            debbugs-regexp
+                            (or (mail-header 'to headers) ""))
+                           (string-match-p
+                            debbugs-regexp
+                            (or (mail-header 'cc headers) ""))))))))
+        (setq bug-reference-bug-regexp
+              "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)")
+        (setq bug-reference-url-format
+              "https://debbugs.gnu.org/%s")))))
+
+;;;###autoload
+(defvar bug-reference-default-setup-functions
+  (list #'bug-reference-try-setup-from-vc
+        #'bug-reference-try-setup-from-gnus)
+  "Like `bug-reference-setup-functions' for packages to hook in.")
+
+(defun bug-reference--init ()
+  "Initialize `bug-reference-mode'."
+  (progn
+    ;; Automatic setup only if the variables aren't already set, e.g.,
+    ;; by a local variables section in the file.
+    (unless (and bug-reference-bug-regexp
+                 bug-reference-url-format)
+      (or
+       (with-demoted-errors
+           "Error while running bug-reference-setup-functions: %S"
+         (run-hook-with-args-until-success
+          'bug-reference-setup-functions))
+       (with-demoted-errors
+           "Error while running bug-reference-default-setup-functions: %S"
+         (run-hook-with-args-until-success
+          'bug-reference-default-setup-functions))))
+    (jit-lock-register #'bug-reference-fontify)))
+
 ;;;###autoload
 (define-minor-mode bug-reference-mode
   "Toggle hyperlinking bug references in the buffer (Bug Reference mode)."
@@ -146,7 +281,7 @@ bug-reference-mode
   ""
   nil
   (if bug-reference-mode
-      (jit-lock-register #'bug-reference-fontify)
+      (bug-reference--init)
     (jit-lock-unregister #'bug-reference-fontify)
     (save-restriction
       (widen)
@@ -159,7 +294,7 @@ bug-reference-prog-mode
   ""
   nil
   (if bug-reference-prog-mode
-      (jit-lock-register #'bug-reference-fontify)
+      (bug-reference--init)
     (jit-lock-unregister #'bug-reference-fontify)
     (save-restriction
       (widen)
modified   lisp/vc/vc.el
@@ -957,7 +957,7 @@ vc-backend-for-registration
       (throw 'found bk))))
 
 ;;;###autoload
-(defun vc-responsible-backend (file)
+(defun vc-responsible-backend (file &optional no-error)
   "Return the name of a backend system that is responsible for FILE.
 
 If FILE is already registered, return the
@@ -967,7 +967,10 @@ vc-responsible-backend
 
 Note that if FILE is a symbolic link, it will not be resolved --
 the responsible backend system for the symbolic link itself will
-be reported."
+be reported.
+
+If NO-ERROR is nil, signal an error that no VC backend is
+responsible for the given file."
   (or (and (not (file-directory-p file)) (vc-backend file))
       (catch 'found
 	;; First try: find a responsible backend.  If this is for registration,
--8<---------------cut here---------------end--------------->8---