;; bug-reference.el --- buttonize bug references  -*- lexical-binding: t; -*-

;; Copyright (C) 2008-2020 Free Software Foundation, Inc.

;; Author: Tom Tromey <tromey@redhat.com>
;; Created: 21 Mar 2007
;; 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:

;; This file provides minor modes for putting clickable overlays on
;; references to bugs.  A bug reference is text like "PR foo/29292";
;; this is mapped to a URL using a user-supplied format.

;; Two minor modes are provided.  One works on any text in the buffer;
;; the other operates only on comments and strings.

;;; Code:

(defgroup bug-reference nil
  "Hyperlinking references to bug reports"
  ;; Somewhat arbitrary, by analogy with eg goto-address.
  :group 'comm)

(defvar bug-reference-map
  (let ((map (make-sparse-keymap)))
    (define-key map [mouse-2] 'bug-reference-push-button)
    (define-key map (kbd "C-c RET") 'bug-reference-push-button)
    map)
  "Keymap used by bug reference buttons.")

;; E.g., "https://gcc.gnu.org/PR%s"
(defvar bug-reference-url-format nil
  "Format used to turn a bug number into a URL.
The bug number is supplied as a string, so this should have a single %s.
This can also be a function designator; it is called without arguments
 and should return a string.
It can use `match-string' to get parts matched against
`bug-reference-bug-regexp', specifically:
 1. issue kind (bug, patch, rfe &c)
 2. issue number.

There is no default setting for this, it must be set per file.
If you set it to a symbol in the file Local Variables section,
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
     (lambda (s)
       (or (stringp s)
           (and (symbolp s)
                (get s 'bug-reference-url-format)))))

(defcustom bug-reference-bug-regexp
  "\\([Bb]ug ?#?\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z+-]+/\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
  "Regular expression matching bug references.
The second subexpression should match the bug reference (usually a number)."
  :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)

(defun bug-reference-set-overlay-properties ()
  "Set properties of bug reference overlays."
  (put 'bug-reference 'evaporate t)
  (put 'bug-reference 'face 'link)
  (put 'bug-reference 'mouse-face 'highlight)
  (put 'bug-reference 'help-echo "mouse-1, C-c RET: visit this bug")
  (put 'bug-reference 'keymap bug-reference-map)
  (put 'bug-reference 'follow-link t))

(bug-reference-set-overlay-properties)

(defun bug-reference-unfontify (start end)
  "Remove bug reference overlays from the region between START and END."
  (dolist (o (overlays-in start end))
    (when (eq (overlay-get o 'category) 'bug-reference)
      (delete-overlay o))))

(defvar bug-reference-prog-mode)

(defun bug-reference-fontify (start end)
  "Apply bug reference overlays to the region between START and END."
  (save-excursion
    (let ((beg-line (progn (goto-char start) (line-beginning-position)))
	  (end-line (progn (goto-char end) (line-end-position))))
      ;; Remove old overlays.
      (bug-reference-unfontify beg-line end-line)
      (goto-char beg-line)
      (while (and (< (point) end-line)
		  (re-search-forward bug-reference-bug-regexp end-line 'move))
	(when (or (not bug-reference-prog-mode)
		  ;; This tests for both comment and string syntax.
		  (nth 8 (syntax-ppss)))
	  (let ((overlay (make-overlay (match-beginning 0) (match-end 0)
				       nil t nil)))
	    (overlay-put overlay 'category 'bug-reference)
	    ;; Don't put a link if format is undefined
	    (when bug-reference-url-format
              (overlay-put overlay 'bug-reference-url
                           (if (stringp bug-reference-url-format)
                               (format bug-reference-url-format
                                       (match-string-no-properties 2))
                             (funcall bug-reference-url-format))))))))))

;; Taken from button.el.
(defun bug-reference-push-button (&optional pos _use-mouse-action)
  "Open URL corresponding to the bug reference at POS."
  (interactive
   (list (if (integerp last-command-event) (point) last-command-event)))
  (if (and (not (integerp pos)) (eventp pos))
      ;; POS is a mouse event; switch to the proper window/buffer
      (let ((posn (event-start pos)))
	(with-current-buffer (window-buffer (posn-window posn))
	  (bug-reference-push-button (posn-point posn) t)))
    ;; POS is just normal position.
    (dolist (o (overlays-at pos))
      ;; It should only be possible to have one URL overlay.
      (let ((url (overlay-get o 'bug-reference-url)))
	(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.

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.  TODO: Support user/project#17 references linking
           ;; to possibly different than the current project.
           (maybe-set "[/@]github.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
                      "\\(#\\)\\([0-9]+\\)"
                      (lambda ()
                        (concat "https://github.com/"
                                (match-string 1 url)
                                "/issues/%s")))
           ;; GitLab projects.
           (maybe-set "[/@]gitlab.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
                      "\\(#\\|!\\)\\([0-9]+\\)"
                      (lambda ()
                        (let ((user-project (match-string 1 url)))
                          (lambda ()
                            (concat "https://gitlab.com/"
                                    user-project
                                    "/-/"
                                    (if (string= (match-string 1) "#")
                                        "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
    (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)."
  nil
  ""
  nil
  (if bug-reference-mode
      (bug-reference--init)
    (jit-lock-unregister #'bug-reference-fontify)
    (save-restriction
      (widen)
      (bug-reference-unfontify (point-min) (point-max)))))

;;;###autoload
(define-minor-mode bug-reference-prog-mode
  "Like `bug-reference-mode', but only buttonize in comments and strings."
  nil
  ""
  nil
  (if bug-reference-prog-mode
      (bug-reference--init)
    (jit-lock-unregister #'bug-reference-fontify)
    (save-restriction
      (widen)
      (bug-reference-unfontify (point-min) (point-max)))))

(provide 'bug-reference)
;;; bug-reference.el ends here