;;; github-topics.el --- Lookup PRs matching a query -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2025 Ag Ibragimov
;;
;; Author: Ag Ibragimov <agzam.ibragimov@gmail.com>
;; Maintainer: Ag Ibragimov <agzam.ibragimov@gmail.com>
;; Created: March 29, 2025
;; Modified: August 10, 2026
;; Package-Version: 20260810.2321
;; Package-Revision: 6086960d85bc
;; Keywords: vc matching tools
;; Homepage: https://github.com/agzam/github-topics
;; Package-Requires: ((emacs "29.4") (ts "0.3"))
;;
;; SPDX-License-Identifier: GPL-3.0-or-later
;;
;; This file is not part of GNU Emacs.
;;
;;; Commentary:
;;
;; Search through GitHub for a matching string or other criteria.
;; Uses gh cli to send the query and puts the results into a nice
;; org-mode outlined buffer.
;;
;;; Code:

(require 'cl-lib)
(require 'ts)
(require 'parse-time)
(require 'thingatpt)
(require 'url-parse)

(defgroup github-topics nil
  "Lookup PRs matching a query."
  :group 'github-topics)

(defcustom github-topics-default-orgs nil
  "Default GH Orgs to search for PRs."
  :group 'github-topics
  :type '(repeat symbol))

(defcustom github-topics-convert-body-with-pandoc t
  "Convert body of pull-request to `org-mode'.
If nil - keeps the body in markdown - might be slightly faster.
Can be set to the explicit path to pandoc in the system."
  :group 'github-topics
  :type '(choice
          (boolean :tag "Use default pandoc if available")
          (string :tag "Explicit path to pandoc executable")))

(defcustom github-topics-prs-buffer-hook nil
  "Triggers on `github-topics-find-prs' buffer with the list of PRs.
takes a single parameter - the buffer pointer."
  :group 'github-topics
  :type 'hook)

(defun github-topics--time-ago (iso8601-time-str)
  "Convert ISO8601-TIME-STR in the past - into relative time description."
  (let* ((time-obj (parse-iso8601-time-string iso8601-time-str))
         (unix-timestamp (float-time time-obj))
         (diff (- (float-time) unix-timestamp)))
    (cond
     ((<= diff 60) "just now")
     (t (concat (car (split-string (ts-human-format-duration diff) ","))
                " ago")))))

(defun github-topics--body->org (body)
  "Converts the BODY of GitHub Pull-Request to Org-mode format.

The conversion works only if pandoc is detected in the system, otherwise
it wraps it into a source block."
  (with-temp-buffer
    (if-let* ((pandoc (when github-topics-convert-body-with-pandoc
                        (if (stringp github-topics-convert-body-with-pandoc)
                            github-topics-convert-body-with-pandoc
                          (executable-find "pandoc")))))
        (progn
          (insert body)
          (shell-command-on-region
           (point-min)
           (point-max)
           (concat pandoc " --wrap=none -f markdown -t org")
           nil t)

          ;; remove all property drawers
          (goto-char (point-min))
          (while (re-search-forward "^[ \t]*:PROPERTIES:\n\\(?:.*\n\\)*?[ \t]*:END:\n" nil t)
            (replace-match ""))

          ;; increase outline levels to match the main doc
          (let ((level-increase 2))
            (goto-char (point-min))
            (while (re-search-forward "^\\(\\*+\\)\\( \\)" nil t)
              (replace-match
               (concat
                (make-string (+ (length (match-string 1)) level-increase) ?*)
                "\\2")))))
      (progn
        (insert (replace-regexp-in-string "\r" "" body))
        (goto-char (point-max))
        (insert (format "\n#+end_src\n"))
        (goto-char (point-min))
        (insert (format "#+begin_src markdown\n"))))
    (buffer-substring (point-min) (point-max))))

(defface github-topics-pr-open
  '((((background dark)) :foreground "#3fb950")
    (t :foreground "#1a7f37"))
  "Face for open pull-requests."
  :group 'github-topics)

(defface github-topics-pr-merged
  '((((background dark)) :foreground "#a371f7")
    (t :foreground "#8250df"))
  "Face for merged pull-requests."
  :group 'github-topics)

(defface github-topics-pr-closed
  '((((background dark)) :foreground "#f85149")
    (t :foreground "#cf222e"))
  "Face for closed pull-requests."
  :group 'github-topics)

(defface github-topics-pr-draft
  '((((background dark)) :foreground "#8b949e")
    (t :foreground "#59636e"))
  "Face for draft pull-requests."
  :group 'github-topics)

(defconst github-topics--pr-states
  '((open   "O" github-topics-pr-open   "nf-oct-git_pull_request")
    (merged "M" github-topics-pr-merged "nf-oct-git_merge")
    (closed "C" github-topics-pr-closed "nf-oct-git_pull_request_closed")
    (draft  "D" github-topics-pr-draft  "nf-oct-git_pull_request_draft"))
  "Letter, face and nerd-icons glyph name per pull-request state.")

(defun github-topics--pr-state (pr)
  "Derive the state of PR: `open', `merged', `closed' or `draft'.
Draft applies only to open pull-requests, mirroring how GitHub
labels them."
  (let-alist pr
    (pcase .state
      ("merged" 'merged)
      ("closed" 'closed)
      (_ (if (eq .isDraft t) 'draft 'open)))))

(declare-function nerd-icons-octicon "ext:nerd-icons")

(defun github-topics--nerd-icons-p ()
  "Non-nil when nerd-icons can be used for state glyphs."
  (require 'nerd-icons nil t))

(defun github-topics--pr-state-indicator (state)
  "Colored glyph (or letter, when nerd-icons is absent) for STATE."
  (pcase-let ((`(,letter ,face ,icon-name)
               (alist-get state github-topics--pr-states)))
    (or (when (github-topics--nerd-icons-p)
          ;; older nerd-icons may lack a glyph name - fall back to letters
          (ignore-errors (nerd-icons-octicon icon-name :face face)))
        (propertize (concat letter ".") 'face face))))

(defvar github-topics--pr-json-fields
  '(title url repository author number state isDraft createdAt body)
  "Fields requested from gh for each found pull-request.")

(defun github-topics--fetch-prs (gh orgs-str query-string extra-params)
  "Fetch pull-requests with GH executable, return a sequence of alists.
ORGS-STR, QUERY-STRING and EXTRA-PARAMS are spliced into the
\\='gh search prs\\=' command as-is."
  (let* ((fields (mapconcat #'symbol-name github-topics--pr-json-fields ","))
         (cmd-args (format "search prs %s \"%s\" %s --json \"%s\""
                           orgs-str query-string extra-params fields)))
    (thread-first
      gh (concat " " cmd-args)
      shell-command-to-string
      (json-parse-string :object-type 'alist))))

(defvar github-topics--body-org-cache (make-hash-table :test #'equal)
  "PR url -> body converted for display.  Avoids re-running pandoc.")

(defun github-topics--pr-body-org (pr)
  "Body of PR converted for display, cached per PR url."
  (let-alist pr
    (or (gethash .url github-topics--body-org-cache)
        (puthash .url (github-topics--body->org .body)
                 github-topics--body-org-cache))))

(defun github-topics--insert-pr (pr level)
  "Insert PR details into the current buffer as Org, heading at LEVEL.
Shared by the results buffer and the consult preview, so both
render pull-requests identically."
  (let-alist pr
    (insert (format "%s [[%s][%s #%s]]\n"
                    (make-string level ?*) .url .title .number))
    (insert (format "%s by: [[%s][%s]] %s\n\n"
                    (upcase .state)
                    .author.url
                    .author.login
                    (github-topics--time-ago .createdAt)))
    (insert (github-topics--pr-body-org pr))
    (insert "\n")))

(defun github-topics--prs-buffer (prs search-url desc)
  "Build an Org buffer with PRS grouped by repository, return it.
SEARCH-URL becomes the link in the buffer header, DESC the buffer
name.  Runs `github-topics-prs-buffer-hook' at the end but does
not display the buffer - that is the caller's job, and embark
exporters in particular must not display anything themselves."
  (let ((buf (get-buffer-create (format "*%s*" desc))))
    (with-current-buffer buf
      (read-only-mode -1)
      (erase-buffer)
      (insert
       (format "[[%s][%s]]\n" search-url desc))
      (insert "#+STARTUP: show2levels\n\n")
      (thread-last
        prs
        (seq-group-by (lambda (rec)
                        (let-alist rec .repository.nameWithOwner)))
        (seq-do
         (lambda (group)
           (insert (format "* %s\n" (car group)))
           (dolist (rec (cdr group))
             (github-topics--insert-pr rec 2))
           (insert "\n"))))
      (org-mode)
      (read-only-mode +1)
      (goto-char (point-min))
      (run-hook-with-args 'github-topics-prs-buffer-hook buf))
    buf))

(defun github-topics--render-prs-buffer (prs search-url desc)
  "Show PRS in an Org buffer, see `github-topics--prs-buffer'.
SEARCH-URL and DESC are passed through."
  (pop-to-buffer (github-topics--prs-buffer prs search-url desc)))

(defvar github-topics-query-history nil
  "History of GitHub PR search queries.")

(defvar github-topics--session-prs (make-hash-table :test #'equal)
  "Candidate string -> PR alist for the most recent search.")

(defvar github-topics--last-search nil
  "Plist with :url and :desc describing the most recent search.")

(defun github-topics--pr-candidate (pr)
  "Format PR as an \\='org/repo#number\\=' completion candidate."
  (let-alist pr
    (format "%s#%s" .repository.nameWithOwner .number)))

(defun github-topics--prs->candidates (prs)
  "Reset the session state and return candidate strings for PRS."
  (clrhash github-topics--session-prs)
  (clrhash github-topics--body-org-cache)
  (mapcar (lambda (pr)
            (let ((cand (github-topics--pr-candidate pr)))
              (puthash cand pr github-topics--session-prs)
              cand))
          (append prs nil)))

(defun github-topics--candidate-pr (cand)
  "Resolve candidate string CAND to its PR alist, if known."
  (gethash (substring-no-properties cand) github-topics--session-prs))

(defun github-topics--annotate-pr (cand width)
  "Annotation for candidate CAND: state indicator and title.
WIDTH is the widest candidate, used to align annotations."
  (when-let* ((pr (github-topics--candidate-pr cand)))
    (let-alist pr
      (concat
       (make-string (+ 2 (max 0 (- width (string-width cand)))) ?\s)
       (github-topics--pr-state-indicator (github-topics--pr-state pr))
       " " .title))))

(defun github-topics--candidate-url (cand)
  "URL of the pull-request designated by CAND.
When the session hash has no record of CAND (e.g. embark handed us
a bare string after the session ended), reconstruct the URL from
the \\='org/repo#number\\=' shape of the candidate itself."
  (or (when-let* ((pr (github-topics--candidate-pr cand)))
        (let-alist pr .url))
      (when (string-match "\\`\\([^/#[:space:]]+/[^/#[:space:]]+\\)#\\([0-9]+\\)\\'"
                          (substring-no-properties cand))
        (format "https://github.com/%s/pull/%s"
                (match-string 1 cand) (match-string 2 cand)))
      (user-error "Cannot infer PR url from: %s" cand)))

(defun github-topics-browse-pr (cand)
  "Open the GitHub page of the pull-request designated by CAND."
  (interactive "sPR (org/repo#number): ")
  (browse-url (github-topics--candidate-url cand)))

(defun github-topics-copy-pr-url (cand)
  "Copy the URL of the pull-request designated by CAND."
  (interactive "sPR (org/repo#number): ")
  (let ((url (github-topics--candidate-url cand)))
    (kill-new url)
    (message "Copied: %s" url)))

(declare-function consult--read "ext:consult")
(declare-function consult--buffer-preview "ext:consult")

(defun github-topics--use-consult-p ()
  "Non-nil when the consult front-end should be used."
  (require 'consult nil t))

(defconst github-topics--preview-buffer-name "*github-topics preview*"
  "Name of the transient PR preview buffer.
Deliberately not space-prefixed: `font-lock-mode' silently refuses
to activate in \"invisible\" buffers, leaving the preview bare.")

(defun github-topics--pr-preview-buffer (pr)
  "Build an Org buffer with the details of PR, return it.
Full `org-mode' on purpose: the preview must be fontified and
decorated exactly like the results buffer."
  (let ((buf (get-buffer-create github-topics--preview-buffer-name)))
    (with-current-buffer buf
      (erase-buffer)
      (unless (derived-mode-p 'org-mode) (org-mode))
      (github-topics--insert-pr pr 1)
      (goto-char (point-min)))
    buf))

(defun github-topics--pr-preview ()
  "Consult state function previewing PRs in a temporary Org buffer."
  (let ((preview (consult--buffer-preview)))
    (lambda (action cand)
      (pcase action
        ('preview
         (funcall preview 'preview
                  (when-let* ((pr (and cand (github-topics--candidate-pr cand))))
                    (github-topics--pr-preview-buffer pr))))
        ('exit
         ;; un-display the preview before consult's teardown, then drop it
         (funcall preview 'preview nil)
         (funcall preview 'exit cand)
         (when-let* ((buf (get-buffer github-topics--preview-buffer-name)))
           (kill-buffer buf)))
        ('return (funcall preview 'return cand))))))

(defun github-topics--consult-prs (prs)
  "Present PRS in the minibuffer via consult, then browse the pick."
  (let* ((cands (github-topics--prs->candidates prs))
         (width (apply #'max (mapcar #'string-width cands)))
         (pick (consult--read
                cands
                :prompt "GitHub PRs: "
                :category 'github-topics-pr
                :annotate (lambda (cand) (github-topics--annotate-pr cand width))
                :state (github-topics--pr-preview)
                :require-match t
                :sort nil)))
    (unless (github-topics--candidate-pr pick)
      ;; a forced minibuffer exit can smuggle raw input past :require-match
      (user-error "Not a PR from the current search: %s" pick))
    (github-topics-browse-pr pick)))

(defun github-topics-embark-export-prs (candidates)
  "Export CANDIDATES into the Org buffer, like the non-consult flow.
Meant to be used as an embark exporter for the
`github-topics-pr' category."
  (let ((prs (delq nil (mapcar #'github-topics--candidate-pr candidates))))
    (if (seq-empty-p prs)
        (user-error "No PR data to export - re-run the search first")
      ;; embark's exporter contract: leave the export buffer current and
      ;; let embark rename it, quit the minibuffer and display it
      (set-buffer
       (github-topics--prs-buffer
        prs
        (plist-get github-topics--last-search :url)
        (plist-get github-topics--last-search :desc))))))

(defvar-keymap github-topics-pr-map
  :doc "Actions for GitHub PR candidates.
Gets `embark-general-map' as parent when embark loads."
  "RET" #'github-topics-browse-pr
  "b" #'github-topics-browse-pr
  "y" #'github-topics-copy-pr-url)

(defvar embark-general-map)
(defvar embark-keymap-alist)
(defvar embark-exporters-alist)
(defvar embark-default-action-overrides)

(with-eval-after-load 'embark
  (set-keymap-parent github-topics-pr-map embark-general-map)
  (add-to-list 'embark-keymap-alist '(github-topics-pr . github-topics-pr-map))
  (add-to-list 'embark-exporters-alist '(github-topics-pr . github-topics-embark-export-prs))
  (add-to-list 'embark-default-action-overrides '(github-topics-pr . github-topics-browse-pr)))

(defun github-topics-find-prs (&optional query-string orgs)
  "Find PRs in ORGS, containing QUERY-STRING.

With a universal argument - open the query in the browser.

With two - ignore `github-topics-default-orgs', effectively searching on
all of GitHub; same as calling the function with ORGS = `'none'.

QUERY-STRING parameter may contain not only the search query but
additional `gh CLI` options as well, e.g. `--sort created`.
Search query and extra arguments always must be separated by ' -- '."
  (interactive)
  (let* ((query+params (thread-first
                         query-string
                         (or query-string
                             (read-string "Search GitHub for: "
                                          (symbol-name (symbol-at-point))
                                          'github-topics-query-history))
                         (split-string "-- " nil " +")))
         (query-string (cl-first query+params))
         (extra-params (or (cl-first (cl-rest query+params)) ""))
         (orgs (if (eq 16 (car current-prefix-arg))
                   'none (or orgs github-topics-default-orgs)))
         (orgs-user-readable (if (eq orgs 'none)
                                 "all"
                               (mapconcat
                                (lambda (x) (format "'%s'" x)) orgs " and ")))
         (user-msg (format "Searching GitHub for '%s' in %s orgs %s"
                           query-string orgs-user-readable
                           (if (string-blank-p extra-params) ""
                             (format "with parameters %s" extra-params))))
         (gh (or (executable-find "gh") (user-error "'gh' cmd-line tool not found")))
         (orgs-str (if (eq orgs 'none) ""
                     (mapconcat (lambda (x) (format "--owner %s" x))
                                orgs " ")))
         (search-page-url (let* ((web-cmd (format "%s search prs %s \"%s\" %s --web" gh orgs-str query-string extra-params))
                                 (process-environment (append '("BROWSER=echo") process-environment)))
                            (string-trim (shell-command-to-string web-cmd)))))
    (when (string-match-p "--" query-string)
      (user-error "Query and arguments must be separated by ' -- '"))
    (unless (url-type (url-generic-parse-url search-page-url))
      (user-error "Error: '%s'" search-page-url))
    (if (eq 4 (car current-prefix-arg)) (browse-url search-page-url)
      (message "%s" user-msg)
      (let ((res (github-topics--fetch-prs gh orgs-str query-string extra-params)))
        (if (seq-empty-p res)
            (message "No PRs for: %s" user-msg)
          (setq github-topics--last-search (list :url search-page-url :desc user-msg))
          (if (github-topics--use-consult-p)
              ;; deferred, so the minibuffer opens outside the dynamic
              ;; extent of embark's target injection when this command
              ;; itself runs as an embark action: embark force-exits
              ;; every minibuffer its action opens, smuggling the
              ;; original target string past :require-match
              (run-at-time 0 nil #'github-topics--consult-prs res)
            (github-topics--render-prs-buffer res search-page-url user-msg)))))))

(provide 'github-topics)
;;; github-topics.el ends here
