master 0db50c3: Support forges by type rather than by host

[Tassilo Horn]

branch: master
commit 0db50c3fd5580cfa077d81c484a29f2821ceb02d
Author: Tassilo Horn <tsdh@gnu.org>
Commit: Tassilo Horn <tsdh@gnu.org>

    Support forges by type rather than by host
    
    Formerly, bug-reference-setup-from-vc-alist basically had one entry
    per host (like gitlab.com).  Restructure so that it's easy to add new
    hosts being just an instance of some type of forge such as SourceHut,
    Gitea, or GitLab.
    
    While we're at it, add support for gitea.com, salsa.debian.org, and
    framagit.org, the latter two being GitLab instances.
    
    * lisp/progmodes/bug-reference.el (bug-reference-gitea-instances)
    (bug-reference-gitlab-instances,bug-reference-sourcehut-instances):
    New variables listing online instances of those forges.
    (bug-reference--setup-from-vc-alist): New function (and variable for
    caching) using the former three new variables to generate suitable VC
    auto-setup alist.
    (bug-reference-try-setup-from-vc): Use both
    bug-reference-setup-from-vc-alist and
    bug-reference--setup-from-vc-alist.
---
 lisp/progmodes/bug-reference.el | 234 ++++++++++++++++++++++++----------------
 1 file changed, 143 insertions(+), 91 deletions(-)

diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index 9b9c58e..c0c9d5e 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -153,95 +153,144 @@ The second subexpression should match the bug reference 
(usually a number)."
                     (push (match-string i url) groups))
                   (funcall bug-url-fmt (nreverse groups))))))
 
-(defvar bug-reference-setup-from-vc-alist
-  `(;;
-    ;; GNU projects on savannah.
-    ;;
-    ;; Not all of them use debbugs but that doesn't really matter
-    ;; because the auto-setup is only performed if
-    ;; `bug-reference-url-format' and `bug-reference-bug-regexp'
-    ;; aren't set already.
-    ("git\\.\\(?:sv\\|savannah\\)\\.gnu\\.org:"
-     "\\<\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)\\>"
-     ,(lambda (_) "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.
-    ("[/@]github.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
-     "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>"
-     ,(lambda (groups)
-        (let ((ns-project (nth 1 groups)))
-          (lambda ()
-            (concat "https://github.com/";
-                    (or
-                     ;; Explicit user/proj#18 link.
-                     (match-string 1)
-                     ns-project)
-                    "/issues/"
-                    (match-string 2))))))
-    ;;
-    ;; Codeberg projects.
-    ;;
-    ;; The systematics is exactly as for Github projects.
-    ("[/@]codeberg.org[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
-     "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>"
-     ,(lambda (groups)
-        (let ((ns-project (nth 1 groups)))
-          (lambda ()
-            (concat "https://codeberg.org/";
-                    (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 or namespace/project!17 references to
-    ;; possibly different projects are also supported.
-    ("[/@]gitlab.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
-     "\\(?1:[.A-Za-z0-9_/-]+\\)?\\(?3:[#!]\\)\\(?2:[0-9]+\\)\\>"
-     ,(lambda (groups)
-        (let ((ns-project (nth 1 groups)))
-          (lambda ()
-            (concat "https://gitlab.com/";
-                    (or (match-string 1)
-                        ns-project)
-                    "/-/"
-                    (if (string= (match-string 3) "#")
-                        "issues/"
-                      "merge_requests/")
-                    (match-string 2))))))
-    ;;
-    ;; Sourcehut projects.
-    ;;
-    ;; #19 is an issue.  Other project's issues can be referenced as
-    ;; #~user/project#19.
-    ;;
-    ;; Caveat: The code assumes that a project on git.sr.ht or
-    ;; hg.sr.ht has a tracker of the same name on todo.sh.ht.  That's
-    ;; a very common setup but all sr.ht services are loosely coupled,
-    ;; so you can have a repo without tracker, or a repo with a
-    ;; tracker using a different name, etc.  So we can only try to
-    ;; make a good guess.
-    ("[/@]\\(?:git\\|hg\\).sr.ht[/:]\\(~[.A-Za-z0-9_/-]+\\)"
-     "\\(~[.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>"
-     ,(lambda (groups)
-        (let ((ns-project (nth 1 groups)))
-          (lambda ()
-            (concat "https://todo.sr.ht/";
-                    (or
-                     ;; Explicit user/proj#18 link.
-                     (match-string 1)
-                     ns-project)
-                    "/"
-                    (match-string 2)))))))
+(defvar bug-reference-gitea-instances '("gitea.com"
+                                        "codeberg.org")
+  "List of Gitea forge instances.
+When the value is changed after bug-reference has already been
+loaded, and performed an auto-setup, evaluate
+`(bug-reference--setup-from-vc-alist t)' for rebuilding the value
+of `bug-reference--setup-from-vc-alist'.")
+
+(defvar bug-reference-gitlab-instances '("gitlab.com"
+                                         "salsa.debian.org"
+                                         "framagit.org")
+  "List of GitLab forge instances.
+When the value is changed after bug-reference has already been
+loaded, and performed an auto-setup, evaluate
+`(bug-reference--setup-from-vc-alist t)' for rebuilding the value
+of `bug-reference--setup-from-vc-alist'.")
+
+(defvar bug-reference-sourcehut-instances '("sr.ht")
+  "List of SourceHut forge instances.
+When the value is changed after bug-reference has already been
+loaded, and performed an auto-setup, evaluate
+`(bug-reference--setup-from-vc-alist t)' for rebuilding the value
+of `bug-reference--setup-from-vc-alist'.")
+
+(defvar bug-reference--setup-from-vc-alist nil
+  "An alist for setting up ‘bug-reference-mode’ based on VC URL.
+This is like `bug-reference-setup-from-vc-alist' but generated
+for the known free software forges from the variables
+`bug-reference-gitea-instances',
+`bug-reference-gitlab-instances', and
+`bug-reference-sourcehut-instances'.")
+
+(defun bug-reference--setup-from-vc-alist (&optional rebuild)
+  (if (and bug-reference--setup-from-vc-alist
+           (null rebuild))
+      bug-reference--setup-from-vc-alist
+    (setq bug-reference--setup-from-vc-alist
+          `(;;
+            ;; GNU projects on savannah.
+            ;;
+            ;; Not all of them use debbugs but that doesn't really
+            ;; matter because the auto-setup is only performed if
+            ;; `bug-reference-url-format' and
+            ;; `bug-reference-bug-regexp' aren't set already.
+            ("git\\.\\(?:sv\\|savannah\\)\\.gnu\\.org:"
+             "\\<\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)\\>"
+             ,(lambda (_) "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.
+            ("[/@]github.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
+             "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>"
+             ,(lambda (groups)
+                (let ((ns-project (nth 1 groups)))
+                  (lambda ()
+                    (concat "https://github.com/";
+                            (or
+                             ;; Explicit user/proj#18 link.
+                             (match-string 1)
+                             ns-project)
+                            "/issues/"
+                            (match-string 2))))))
+            ;;
+            ;; Gitea instances.
+            ;;
+            ;; The systematics is exactly as for Github projects.
+            (,(concat "[/@]"
+                      (regexp-opt bug-reference-gitea-instances t)
+                      "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git")
+             "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>"
+             ,(lambda (groups)
+                (let ((host (nth 1 groups))
+                      (ns-project (nth 2 groups)))
+                  (lambda ()
+                    (concat "https://"; host "/"
+                            (or
+                             ;; Explicit user/proj#18 link.
+                             (match-string 1)
+                             ns-project)
+                            "/issues/"
+                            (match-string 2))))))
+            ;;
+            ;; GitLab instances.
+            ;;
+            ;; Here #18 is an issue and !17 is a merge request.
+            ;; Explicit namespace/project#18 or namespace/project!17
+            ;; references to possibly different projects are also
+            ;; supported.
+            (,(concat "[/@]"
+                      (regexp-opt bug-reference-gitlab-instances t)
+                      "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git")
+             "\\(?1:[.A-Za-z0-9_/-]+\\)?\\(?3:[#!]\\)\\(?2:[0-9]+\\)\\>"
+             ,(lambda (groups)
+                (let ((host (nth 1 groups))
+                      (ns-project (nth 2 groups)))
+                  (lambda ()
+                    (concat "https://"; host "/"
+                            (or (match-string 1)
+                                ns-project)
+                            "/-/"
+                            (if (string= (match-string 3) "#")
+                                "issues/"
+                              "merge_requests/")
+                            (match-string 2))))))
+            ;;
+            ;; Sourcehut instances.
+            ;;
+            ;; #19 is an issue.  Other project's issues can be
+            ;; #referenced as ~user/project#19.
+            ;;
+            ;; Caveat: The code assumes that a project on git.sr.ht or
+            ;; hg.sr.ht has a tracker of the same name on todo.sh.ht.
+            ;; That's a very common setup but all sr.ht services are
+            ;; loosely coupled, so you can have a repo without
+            ;; tracker, or a repo with a tracker using a different
+            ;; name, etc.  So we can only try to make a good guess.
+            (,(concat "[/@]\\(?:git\\|hg\\)."
+                      (regexp-opt bug-reference-sourcehut-instances t)
+                      "[/:]\\(~[.A-Za-z0-9_/-]+\\)")
+             "\\(~[.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>"
+             ,(lambda (groups)
+                (let ((host (nth 1 groups))
+                      (ns-project (nth 2 groups)))
+                  (lambda ()
+                    (concat "https://todo."; host "/"
+                            (or
+                             ;; Explicit user/proj#18 link.
+                             (match-string 1)
+                             ns-project)
+                            "/"
+                            (match-string 2))))))))))
+
+(defvar bug-reference-setup-from-vc-alist nil
   "An alist for setting up `bug-reference-mode' based on VC URL.
 
 Each element has the form (URL-REGEXP BUG-REGEXP URL-FORMAT-FN).
@@ -256,7 +305,8 @@ URL-REGEXP against the VCS URL and returns the value to be 
set as
 (defun bug-reference-try-setup-from-vc ()
   "Try setting up `bug-reference-mode' based on VC information.
 Test each configuration in `bug-reference-setup-from-vc-alist'
-and apply it if applicable."
+and `bug-reference--setup-from-vc-alist' and apply it if
+applicable."
   (let ((file-or-dir (or buffer-file-name
                          ;; Catches modes such as vc-dir and Magit.
                          default-directory)))
@@ -269,7 +319,9 @@ and apply it if applicable."
                     (vc-call-backend backend 'repository-url)))))
         (when url
           (catch 'found
-            (dolist (config bug-reference-setup-from-vc-alist)
+            (dolist (config (append
+                             bug-reference-setup-from-vc-alist
+                             (bug-reference--setup-from-vc-alist)))
               (when (apply #'bug-reference-maybe-setup-from-vc
                            url config)
                 (throw 'found t)))))))))