forge-topic.el (39505B)
1 ;;; forge-topic.el --- Topics support -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2018-2022 Jonas Bernoulli 4 5 ;; Author: Jonas Bernoulli <jonas@bernoul.li> 6 ;; Maintainer: Jonas Bernoulli <jonas@bernoul.li> 7 ;; SPDX-License-Identifier: GPL-3.0-or-later 8 9 ;; This file is not part of GNU Emacs. 10 11 ;; Forge is free software; you can redistribute it and/or modify it 12 ;; under the terms of the GNU General Public License as published by 13 ;; the Free Software Foundation; either version 3, or (at your option) 14 ;; any later version. 15 ;; 16 ;; Forge is distributed in the hope that it will be useful, but WITHOUT 17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 18 ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public 19 ;; License for more details. 20 ;; 21 ;; You should have received a copy of the GNU General Public License 22 ;; along with Forge. If not, see http://www.gnu.org/licenses. 23 24 ;;; Code: 25 26 (require 'bug-reference) 27 (require 'markdown-mode) 28 (require 'parse-time) 29 (require 'yaml) 30 31 (require 'forge) 32 (require 'forge-post) 33 34 ;;; Options 35 36 (defcustom forge-topic-list-order '(updated . string>) 37 "Order of topics listed in the status buffer. 38 39 The value has the form (SLOT . PREDICATE), where SLOT is a 40 slot of issue or pullreq objects, and PREDICATE is a function 41 used to order the topics by that slot. Reasonable values 42 include (number . >) and (updated . string>)." 43 :package-version '(forge . "0.1.0") 44 :group 'forge 45 :type '(cons (symbol :tag "Slot") 46 (function :tag "Predicate"))) 47 48 (defcustom forge-topic-list-limit '(60 . 5) 49 "Limit the number of topics listed in the status buffer. 50 51 All unread topics are always shown. If the value of this option 52 has the form (OPEN . CLOSED), then the integer OPEN specifies the 53 maximal number of topics and CLOSED specifies the maximal number 54 of closed topics. IF CLOSED is negative then show no closed 55 topics until the command `forge-toggle-closed-visibility' changes 56 the sign. 57 58 The value can also be an integer, in which case it limits the 59 number of closed topics only." 60 :package-version '(forge . "0.1.0") 61 :group 'forge 62 :type '(choice (number :tag "Maximal number of closed issues") 63 (cons (number :tag "Maximal number of open issues") 64 (number :tag "Maximal number of closed issues")))) 65 66 (defcustom forge-post-heading-format "%a %C\n" 67 "Format for post headings in topic view. 68 69 The following %-sequences are supported: 70 71 `%a' The forge nickname of the author. 72 `%c' The absolute creation date. 73 `%C' The relative creation date." 74 :package-version '(forge . "0.1.0") 75 :group 'forge 76 :type 'string) 77 78 (defcustom forge-post-fill-region t 79 "Whether to call `fill-region' before displaying forge posts." 80 :package-version '(forge . "0.1.0") 81 :group 'forge 82 :type 'boolean) 83 84 (defcustom forge-bug-reference-hooks 85 '(find-file-hook 86 forge-post-mode-hook 87 git-commit-setup-hook 88 magit-mode-hook) 89 "Hooks to which `forge-bug-reference-setup' is added. 90 This variable has to be customized before `forge' is loaded." 91 :package-version '(forge . "0.2.0") 92 :group 'forge 93 :options '(find-file-hook 94 forge-post-mode-hook 95 git-commit-setup-hook 96 magit-mode-hook) 97 :type '(list :convert-widget custom-hook-convert-widget)) 98 99 (defvar-local forge-display-in-status-buffer t 100 "Whether to display topics in the current Magit status buffer.") 101 (put 'forge-display-in-status-buffer 'permanent-local t) 102 103 (defvar forge-format-avatar-function nil 104 "Function used to insert avatars in certain locations. 105 This is experimental and intended for users who wish to 106 implement such a function themselves. See #447.") 107 108 ;;; Faces 109 110 (defface forge-topic-unread 111 '((t :inherit bold)) 112 "Face used for title of unread topics." 113 :group 'forge-faces) 114 115 (defface forge-topic-closed 116 '((t :inherit magit-dimmed)) 117 "Face used for title of closed topics." 118 :group 'forge-faces) 119 120 (defface forge-topic-open 121 '((t :inherit default)) 122 "Face used for title of open topics." 123 :group 'forge-faces) 124 125 (defface forge-topic-merged 126 '((t :inherit magit-dimmed)) 127 "Face used for number of merged pull-requests." 128 :group 'forge-faces) 129 130 (defface forge-topic-unmerged 131 '((t :inherit magit-dimmed :slant italic)) 132 "Face used for number of unmerged pull-requests." 133 :group 'forge-faces) 134 135 (defface forge-topic-label 136 `((t :box ( :line-width ,(if (>= emacs-major-version 28) (cons -1 -1) -1) 137 :style released-button))) 138 "Face used for topic labels." 139 :group 'forge-faces) 140 141 (defface forge-post-author 142 '((t :inherit bold)) 143 "Face used for post author in topic view." 144 :group 'forge-faces) 145 146 (defface forge-post-date 147 '((t :inherit italic)) 148 "Face used for post date in topic view." 149 :group 'forge-faces) 150 151 ;;; Class 152 153 (defclass forge-topic (forge-post) () :abstract t) 154 155 (cl-defmethod forge--object-id ((class (subclass forge-topic)) repo number) 156 "Return the id for a CLASS object in REPO identified by id NUMBER." 157 (base64-encode-string 158 (encode-coding-string 159 (format "%s:%s%s" 160 (base64-decode-string (oref repo id)) 161 (substring (symbol-name class) 162 (length (oref-default class closql-class-prefix))) 163 number) 164 'utf-8) 165 t)) 166 167 (cl-defmethod forge--object-id ((prefix string) number-or-id) 168 (base64-encode-string 169 (encode-coding-string 170 (format "%s:%s" 171 (base64-decode-string prefix) 172 (if (numberp number-or-id) 173 number-or-id 174 ;; Currently every id is base64 encode. Unfortunately 175 ;; we cannot use the ids of Gitlab labels (see comment 176 ;; in the respective `forge--update-labels' method), 177 ;; and have to use their names, which are not encoded. 178 (or (ignore-errors (base64-decode-string number-or-id)) 179 number-or-id))) 180 'utf-8) 181 t)) 182 183 ;;; Query 184 185 (cl-defmethod forge-get-parent ((topic forge-topic)) 186 (forge-get-repository topic)) 187 188 (cl-defmethod forge-get-repository ((topic forge-topic)) 189 (closql-get (forge-db) 190 (oref topic repository) 191 'forge-repository)) 192 193 (cl-defmethod forge-get-topic ((topic forge-topic)) 194 topic) 195 196 (cl-defmethod forge-get-topic ((repo forge-repository) number-or-id) 197 (if (numberp number-or-id) 198 (if (< number-or-id 0) 199 (forge-get-pullreq repo (abs number-or-id)) 200 (or (forge-get-issue repo number-or-id) 201 (forge-get-pullreq repo number-or-id))) 202 (or (forge-get-issue number-or-id) 203 (forge-get-pullreq number-or-id)))) 204 205 (cl-defmethod forge-get-topic ((number integer)) 206 (if (< number 0) 207 (forge-get-pullreq (abs number)) 208 (or (forge-get-issue number) 209 (forge-get-pullreq number)))) 210 211 (cl-defmethod forge-get-topic ((id string)) 212 (or (forge-get-issue id) 213 (forge-get-pullreq id))) 214 215 (cl-defmethod forge-ls-recent-topics ((repo forge-repository) table) 216 (magit--with-repository-local-cache (list 'forge-ls-recent-topics table) 217 (let* ((id (oref repo id)) 218 (limit forge-topic-list-limit) 219 (open-limit (if (consp limit) (car limit) limit)) 220 (closed-limit (if (consp limit) (cdr limit) limit)) 221 (topics (forge-sql [:select * :from $i1 222 :where (and (= repository $s2) 223 (notnull unread-p))] 224 table id))) 225 (mapc (lambda (row) 226 (cl-pushnew row topics :test #'equal)) 227 (if (consp limit) 228 (forge-sql [:select * :from $i1 229 :where (and (= repository $s2) 230 (isnull closed)) 231 :order-by [(desc updated)] 232 :limit $s3] 233 table id open-limit) 234 (forge-sql [:select * :from $i1 235 :where (and (= repository $s2) 236 (isnull closed))] 237 table id))) 238 (when (> closed-limit 0) 239 (mapc (lambda (row) 240 (cl-pushnew row topics :test #'equal)) 241 (forge-sql [:select * :from $i1 242 :where (and (= repository $s2) 243 (notnull closed)) 244 :order-by [(desc updated)] 245 :limit $s3] 246 table id closed-limit))) 247 (cl-sort (mapcar (let ((class (if (eq table 'pullreq) 248 'forge-pullreq 249 'forge-issue))) 250 (lambda (row) 251 (closql--remake-instance class (forge-db) row))) 252 topics) 253 (cdr forge-topic-list-order) 254 :key (lambda (it) (eieio-oref it (car forge-topic-list-order))))))) 255 256 (cl-defmethod forge-ls-topics ((repo forge-repository) 257 class &optional type select) 258 (let* ((table (oref-default class closql-table)) 259 (id (oref repo id)) 260 (rows (pcase-exhaustive type 261 (`open (forge-sql [:select $i1 :from $i2 262 :where (and (= repository $s3) 263 (isnull closed)) 264 :order-by [(desc number)]] 265 (or select '*) table id)) 266 (`closed (forge-sql [:select $i1 :from $i2 267 :where (and (= repository $s3) 268 (notnull closed)) 269 :order-by [(desc number)]] 270 (or select '*) table id)) 271 (`nil (forge-sql [:select $i1 :from $i2 272 :where (= repository $s3) 273 :order-by [(desc number)]] 274 (or select '*) table id))))) 275 (if select 276 rows 277 (mapcar (lambda (row) 278 (closql--remake-instance class (forge-db) row)) 279 rows)))) 280 281 ;;; Utilities 282 283 (cl-defmethod forge--format ((topic forge-topic) slot &optional spec) 284 (forge--format (forge-get-repository topic) slot 285 `(,@spec (?i . ,(oref topic number))))) 286 287 (cl-defmethod forge-visit ((topic forge-topic)) 288 (forge-topic-setup-buffer topic) 289 (forge-topic-mark-read (forge-get-repository topic) topic)) 290 291 (cl-defmethod forge-topic-mark-read ((_ forge-repository) topic) 292 (oset topic unread-p nil)) 293 294 (defun forge--sanitize-string (string) 295 ;; For Gitlab this may also be nil. 296 (if string 297 (replace-regexp-in-string "\r\n" "\n" string t t) 298 "")) 299 300 (defun forge-insert-topics (heading topics prefix) 301 "Under a new section with HEADING, insert TOPICS." 302 (when topics 303 (let ((width (apply #'max 304 (--map (length (number-to-string (oref it number))) 305 topics))) 306 list-section-type topic-section-type) 307 (cond ((forge--childp (car topics) 'forge-issue) 308 (setq list-section-type 'issues) 309 (setq topic-section-type 'issue)) 310 ((forge--childp (car topics) 'forge-pullreq) 311 (setq list-section-type 'pullreqs) 312 (setq topic-section-type 'pullreq))) 313 (magit-insert-section ((eval list-section-type) nil t) 314 (magit-insert-heading 315 (concat (magit--propertize-face (concat heading " ") 316 'magit-section-heading) 317 (magit--propertize-face (format "(%s)" (length topics)) 318 'magit-section-child-count))) 319 (magit-make-margin-overlay nil t) 320 (magit-insert-section-body 321 (dolist (topic topics) 322 (forge-insert-topic topic topic-section-type width prefix)) 323 (insert ?\n) 324 (magit-make-margin-overlay nil t)))))) 325 326 (defun forge-insert-topic (topic &optional topic-section-type width prefix) 327 "Insert TOPIC as a new section. 328 If TOPIC-SECTION-TYPE is provided, it is the section type to use. 329 If WIDTH is provided, it is a fixed width to use for the topic 330 identifier." 331 (unless topic-section-type 332 (setq topic-section-type 333 (cond ((forge--childp topic 'forge-issue) 'issue) 334 ((forge--childp topic 'forge-pullreq) 'pullreq)))) 335 (magit-insert-section ((eval topic-section-type) topic t) 336 (forge--insert-topic-contents topic width prefix))) 337 338 (cl-defmethod forge--format-topic-id ((topic forge-topic) &optional prefix) 339 (propertize (format "%s%s" 340 (or prefix (forge--topic-type-prefix topic)) 341 (oref topic number)) 342 'font-lock-face 'magit-dimmed)) 343 344 (cl-defmethod forge--insert-topic-contents ((topic forge-topic) width prefix) 345 (with-slots (number title unread-p closed) topic 346 (insert (format (if width (format "%%-%is" (1+ width)) "%s") 347 (forge--format-topic-id topic prefix))) 348 (forge--insert-topic-marks topic) 349 (insert " ") 350 (insert (magit-log-propertize-keywords 351 nil (propertize title 'font-lock-face 352 (cond (unread-p 'forge-topic-unread) 353 (closed 'forge-topic-closed) 354 (t 'forge-topic-open))))) 355 (forge--insert-topic-labels topic) 356 (insert "\n") 357 (magit-log-format-author-margin 358 (oref topic author) 359 (format-time-string "%s" (parse-iso8601-time-string (oref topic created))) 360 t))) 361 362 ;;; Mode 363 364 (defvar forge-topic-mode-map 365 (let ((map (make-sparse-keymap))) 366 (define-key map (kbd "C-c C-n") 'forge-create-post) 367 (define-key map (kbd "C-c C-r") 'forge-create-post) 368 (define-key map [remap magit-browse-thing] 'forge-browse-topic) 369 (define-key map [remap magit-visit-thing] 'markdown-follow-link-at-point) 370 (define-key map [mouse-2] 'markdown-follow-link-at-point) 371 map)) 372 373 (define-derived-mode forge-topic-mode magit-mode "View Topic" 374 "View a forge issue or pull-request." 375 (setq-local markdown-translate-filename-function 376 #'forge--markdown-translate-filename-function)) 377 378 (defvar forge-topic-headers-hook 379 '(forge-insert-topic-title 380 forge-insert-topic-state 381 forge-insert-topic-refs 382 forge-insert-topic-milestone 383 forge-insert-topic-labels 384 forge-insert-topic-marks 385 forge-insert-topic-assignees 386 forge-insert-topic-review-requests)) 387 388 (defvar forge-post-section-map 389 (let ((map (make-sparse-keymap))) 390 (define-key map [remap magit-browse-thing] 'forge-browse-post) 391 (define-key map [remap magit-edit-thing] 'forge-edit-post) 392 (define-key map (kbd "C-c C-k") 'forge-delete-comment) 393 map)) 394 395 (defvar-local forge-buffer-topic nil) 396 (defvar-local forge-buffer-topic-ident nil) 397 398 (defun forge-topic-setup-buffer (topic) 399 (let* ((repo (forge-get-repository topic)) 400 (ident (concat (forge--topic-type-prefix topic) 401 (number-to-string (oref topic number)))) 402 (name (format "*forge: %s/%s %s*" 403 (oref repo owner) 404 (oref repo name) 405 ident)) 406 (magit-generate-buffer-name-function (lambda (_mode _value) name)) 407 (current-repo (forge-get-repository nil)) 408 (default-directory (if (and current-repo 409 (eq (oref current-repo id) 410 (oref repo id))) 411 default-directory 412 (or (oref repo worktree) 413 default-directory)))) 414 (magit-setup-buffer #'forge-topic-mode t 415 (forge-buffer-topic topic) 416 (forge-buffer-topic-ident ident)))) 417 418 (defun forge-topic-refresh-buffer () 419 (let ((topic (closql-reload forge-buffer-topic))) 420 (setq forge-buffer-topic topic) 421 (magit-set-header-line-format 422 (format "%s: %s" forge-buffer-topic-ident (oref topic title))) 423 (magit-insert-section (topicbuf) 424 (magit-insert-headers 'forge-topic-headers-hook) 425 (when (and (forge-pullreq-p topic) 426 (not (oref topic merged))) 427 (magit-insert-section (pullreq topic) 428 (magit-insert-heading "Commits") 429 (forge--insert-pullreq-commits topic))) 430 (when-let ((note (oref topic note))) 431 (magit-insert-section (note) 432 (magit-insert-heading "Note") 433 (insert (forge--fontify-markdown note) "\n\n"))) 434 (dolist (post (cons topic (oref topic posts))) 435 (with-slots (author created body) post 436 (magit-insert-section section (post post) 437 (oset section heading-highlight-face 438 'magit-diff-hunk-heading-highlight) 439 (let ((heading 440 (format-spec 441 forge-post-heading-format 442 `((?a . ,(propertize (concat (forge--format-avatar author) 443 (or author "(ghost)")) 444 'font-lock-face 'forge-post-author)) 445 (?c . ,(propertize created 'font-lock-face 'forge-post-date)) 446 (?C . ,(propertize (apply #'format "%s %s ago" 447 (magit--age 448 (float-time 449 (date-to-time created)))) 450 'font-lock-face 'forge-post-date)))))) 451 (add-face-text-property 0 (length heading) 452 'magit-diff-hunk-heading t heading) 453 (magit-insert-heading heading)) 454 (insert (forge--fontify-markdown body) "\n\n")))) 455 (when (and (display-images-p) 456 (fboundp 'markdown-display-inline-images)) 457 (let ((markdown-display-remote-images t)) 458 (markdown-display-inline-images)))))) 459 460 (cl-defmethod magit-buffer-value (&context (major-mode forge-topic-mode)) 461 forge-buffer-topic-ident) 462 463 (defvar forge-topic-title-section-map 464 (let ((map (make-sparse-keymap))) 465 (define-key map [remap magit-edit-thing] 'forge-edit-topic-title) 466 map)) 467 468 (cl-defun forge-insert-topic-title 469 (&optional (topic forge-buffer-topic)) 470 (magit-insert-section (topic-title) 471 (insert (format "%-11s" "Title: ") (oref topic title) "\n"))) 472 473 (defvar forge-topic-state-section-map 474 (let ((map (make-sparse-keymap))) 475 (define-key map [remap magit-edit-thing] 'forge-edit-topic-state) 476 map)) 477 478 (cl-defun forge-insert-topic-state 479 (&optional (topic forge-buffer-topic)) 480 (magit-insert-section (topic-state) 481 (insert (format 482 "%-11s%s\n" "State: " 483 (let ((state (oref topic state))) 484 (magit--propertize-face 485 (symbol-name state) 486 (pcase (list state (forge-pullreq-p (forge-topic-at-point))) 487 (`(merged) 'forge-topic-merged) 488 (`(closed) 'forge-topic-closed) 489 (`(open t) 'forge-topic-unmerged) 490 (`(open) 'forge-topic-open)))))))) 491 492 (defvar forge-topic-milestone-section-map 493 (let ((map (make-sparse-keymap))) 494 (define-key map [remap magit-edit-thing] 'forge-edit-topic-milestone) 495 map)) 496 497 (cl-defun forge-insert-topic-milestone 498 (&optional (topic forge-buffer-topic)) 499 (magit-insert-section (topic-milestone) 500 (insert (format "%-11s" "Milestone: ") 501 (or (forge--get-topic-milestone topic) 502 ;; If the user hasn't pulled this repository yet after 503 ;; updating to db v7, then only the id is available. 504 (oref topic milestone) 505 (propertize "none" 'font-lock-face 'magit-dimmed)) 506 "\n"))) 507 508 (defun forge--get-topic-milestone (topic) 509 (when-let ((id (oref topic milestone))) 510 (caar (forge-sql [:select [title] :from milestone :where (= id $s1)] id)))) 511 512 (defvar forge-topic-labels-section-map 513 (let ((map (make-sparse-keymap))) 514 (define-key map [remap magit-edit-thing] 'forge-edit-topic-labels) 515 map)) 516 517 (cl-defun forge-insert-topic-labels 518 (&optional (topic forge-buffer-topic)) 519 (magit-insert-section (topic-labels) 520 (insert (format "%-11s" "Labels: ")) 521 (if-let ((labels (closql--iref topic 'labels))) 522 (forge--insert-topic-labels topic t labels) 523 (insert (propertize "none" 'font-lock-face 'magit-dimmed))) 524 (insert ?\n))) 525 526 (defun forge--format-topic-labels (topic) 527 (when-let ((labels (closql--iref topic 'labels))) 528 (mapconcat (pcase-lambda (`(,name ,color ,_desc)) 529 (propertize name 'font-lock-face (list :box color))) 530 labels " "))) 531 532 (defun forge--insert-topic-labels (topic &optional skip-separator labels) 533 (pcase-dolist (`(,name ,color ,description) 534 (or labels (closql--iref topic 'labels))) 535 (if skip-separator 536 (setq skip-separator nil) 537 (insert " ")) 538 (let* ((background (forge--sanitize-color color)) 539 (foreground (forge--contrast-color background))) 540 (insert name) 541 (let ((o (make-overlay (- (point) (length name)) (point)))) 542 (overlay-put o 'priority 2) 543 (overlay-put o 'evaporate t) 544 (overlay-put o 'font-lock-face 545 `(( :background ,background 546 :foreground ,foreground) 547 forge-topic-label)) 548 (when description 549 (overlay-put o 'help-echo description)))))) 550 551 (defvar forge-topic-marks-section-map 552 (let ((map (make-sparse-keymap))) 553 (define-key map [remap magit-edit-thing] 'forge-edit-topic-marks) 554 map)) 555 556 (cl-defun forge-insert-topic-marks 557 (&optional (topic forge-buffer-topic)) 558 (magit-insert-section (topic-marks) 559 (insert (format "%-11s" "Marks: ")) 560 (if-let ((marks (closql--iref topic 'marks))) 561 (forge--insert-topic-marks topic t marks) 562 (insert (propertize "none" 'font-lock-face 'magit-dimmed))) 563 (insert ?\n))) 564 565 (defun forge--insert-topic-marks (topic &optional skip-separator marks) 566 (pcase-dolist (`(,name ,face ,description) 567 (or marks (closql--iref topic 'marks))) 568 (if skip-separator 569 (setq skip-separator nil) 570 (insert " ")) 571 (insert name) 572 (let ((o (make-overlay (- (point) (length name)) (point)))) 573 (overlay-put o 'priority 2) 574 (overlay-put o 'evaporate t) 575 (overlay-put o 'font-lock-face (list face 'forge-topic-label)) 576 (when description 577 (overlay-put o 'help-echo description))))) 578 579 (defun forge--sanitize-color (color) 580 (cond ((x-color-values color) color) 581 ;; Discard alpha information. 582 ((string-match-p "\\`#.\\{4\\}\\'" color) (substring color 0 3)) 583 ((string-match-p "\\`#.\\{8\\}\\'" color) (substring color 0 6)) 584 (t "#000000"))) ; Use fallback instead of invalid color. 585 586 (defun forge--contrast-color (color) 587 "Return black or white depending on the luminance of COLOR." 588 (if (> (forge--x-color-luminance color) 0.5) "black" "white")) 589 590 ;; Copy of `rainbow-x-color-luminance'. 591 (defun forge--x-color-luminance (color) 592 "Calculate the luminance of a color string (e.g. \"#ffaa00\", \"blue\"). 593 Return a value between 0 and 1." 594 (let ((values (x-color-values color))) 595 (forge--color-luminance (/ (nth 0 values) 256.0) 596 (/ (nth 1 values) 256.0) 597 (/ (nth 2 values) 256.0)))) 598 599 ;; Copy of `rainbow-color-luminance'. 600 ;; Also see https://en.wikipedia.org/wiki/Relative_luminance. 601 (defun forge--color-luminance (red green blue) 602 "Calculate the luminance of color composed of RED, GREEN and BLUE. 603 Return a value between 0 and 1." 604 (/ (+ (* .2126 red) (* .7152 green) (* .0722 blue)) 256)) 605 606 (cl-defun forge-insert-topic-refs 607 (&optional (topic forge-buffer-topic)) 608 (when (forge-pullreq-p topic) 609 (magit-insert-section (topic-refs) 610 (with-slots (cross-repo-p base-repo base-ref head-repo head-ref) topic 611 (let ((separator (propertize ":" 'font-lock-face 'magit-dimmed)) 612 (deleted (propertize "(deleted)" 'font-lock-face 'magit-dimmed))) 613 (insert (format "%-11s" "Refs: ") 614 (if cross-repo-p 615 (concat base-repo separator base-ref) 616 base-ref) 617 (propertize "..." 'font-lock-face 'magit-dimmed) 618 (if cross-repo-p 619 (if (and head-repo head-ref) 620 (concat head-repo separator head-ref) 621 deleted) 622 (or head-ref deleted)) 623 "\n")))))) 624 625 (defvar forge-topic-assignees-section-map 626 (let ((map (make-sparse-keymap))) 627 (define-key map [remap magit-edit-thing] 'forge-edit-topic-assignees) 628 map)) 629 630 (cl-defun forge-insert-topic-assignees 631 (&optional (topic forge-buffer-topic)) 632 (magit-insert-section (topic-assignees) 633 (insert (format "%-11s" "Assignees: ")) 634 (if-let ((assignees (closql--iref topic 'assignees))) 635 (insert (mapconcat (pcase-lambda (`(,login ,name)) 636 (format "%s%s (@%s)" 637 (forge--format-avatar login) 638 name login)) 639 assignees ", ")) 640 (insert (propertize "none" 'font-lock-face 'magit-dimmed))) 641 (insert ?\n))) 642 643 (defvar forge-topic-review-requests-section-map 644 (let ((map (make-sparse-keymap))) 645 (define-key map [remap magit-edit-thing] 'forge-edit-topic-review-requests) 646 map)) 647 648 (cl-defun forge-insert-topic-review-requests 649 (&optional (topic forge-buffer-topic)) 650 (when (and (forge-github-repository-p (forge-get-repository topic)) 651 (forge-pullreq-p topic)) 652 (magit-insert-section (topic-review-requests) 653 (insert (format "%-11s" "Review-Requests: ")) 654 (if-let ((review-requests (closql--iref topic 'review-requests))) 655 (insert (mapconcat (pcase-lambda (`(,login ,name)) 656 (format "%s%s (@%s)" 657 (forge--format-avatar login) 658 name login)) 659 review-requests ", ")) 660 (insert (propertize "none" 'font-lock-face 'magit-dimmed))) 661 (insert ?\n)))) 662 663 (defun forge--fontify-markdown (text) 664 (with-temp-buffer 665 (delay-mode-hooks 666 (gfm-mode)) 667 (insert text) 668 (font-lock-ensure) 669 (when forge-post-fill-region 670 (fill-region (point-min) (point-max))) 671 (buffer-string))) 672 673 (cl-defmethod forge--topic-type-prefix ((_ forge-topic)) 674 "Get the identifier prefix specific to the type of TOPIC." 675 "#") 676 677 (cl-defmethod forge--topic-type-prefix ((_repo forge-repository) _type) 678 "#") 679 680 (defun forge--markdown-translate-filename-function (file) 681 (if (string-match-p "\\`https?://" file) 682 file 683 (let ((host (oref (forge-get-repository t) githost))) 684 (concat (if (member host ghub-insecure-hosts) "http://" "https://") 685 host 686 (and (not (string-prefix-p "/" file)) "/") 687 file)))) 688 689 (defun forge--format-avatar (author) 690 (if forge-format-avatar-function 691 (funcall forge-format-avatar-function author) 692 "")) 693 694 ;;; Completion 695 696 (defun forge-read-topic (prompt &optional type allow-number) 697 (when (eq type t) 698 (setq type (if current-prefix-arg nil 'open))) 699 (let* ((default (forge-current-topic)) 700 (repo (forge-get-repository (or default t))) 701 (choices (mapcar 702 (apply-partially #'forge--topic-format-choice repo) 703 (cl-sort 704 (nconc 705 (forge-ls-pullreqs repo type [number title id class]) 706 (forge-ls-issues repo type [number title id class])) 707 #'> :key #'car))) 708 (choice (magit-completing-read 709 prompt choices nil nil nil nil 710 (and default 711 (setq default (forge--topic-format-choice default)) 712 (member default choices) 713 (car default))))) 714 (or (cdr (assoc choice choices)) 715 (and allow-number 716 (let ((number (string-to-number choice))) 717 (if (= number 0) 718 (user-error "Not an existing topic or number: %s") 719 number)))))) 720 721 (cl-defmethod forge--topic-format-choice ((topic forge-topic)) 722 (cons (format "%s%s %s" 723 (forge--topic-type-prefix topic) 724 (oref topic number) 725 (oref topic title)) 726 (oref topic id))) 727 728 (cl-defmethod forge--topic-format-choice ((repo forge-repository) args) 729 (pcase-let ((`(,number ,title ,id ,class) args)) 730 (cons (format "%s%s %s" 731 (forge--topic-type-prefix repo class) 732 number 733 title) 734 id))) 735 736 (defun forge-topic-completion-at-point () 737 (let ((bol (line-beginning-position)) 738 repo) 739 (and (looking-back "[!#][0-9]*" bol) 740 (or (not bug-reference-prog-mode) 741 (nth 8 (syntax-ppss))) ; inside comment or string 742 (setq repo (forge-get-repository t)) 743 (looking-back (if (forge--childp repo 'forge-gitlab-repository) 744 "\\(?3:[!#]\\)\\(?2:[0-9]*\\)" 745 "#\\(?2:[0-9]*\\)") 746 bol) 747 (list (match-beginning 2) 748 (match-end 0) 749 (mapcar (lambda (row) 750 (propertize (number-to-string (car row)) 751 :title (format " %s" (cadr row)))) 752 (if (forge--childp repo 'forge-gitlab-repository) 753 (forge-sql [:select [number title] 754 :from $i1 755 :where (= repository $s2) 756 :order-by [(desc updated)]] 757 (if (equal (match-string 3) "#") 758 'issue 759 'pullreq) 760 (oref repo id)) 761 (forge-sql [:select [number title updated] 762 :from pullreq 763 :where (= repository $s1) 764 :union 765 :select [number title updated] 766 :from issue 767 :where (= repository $s1) 768 :order-by [(desc updated)]] 769 (oref repo id)))) 770 :annotation-function (lambda (c) (get-text-property 0 :title c)))))) 771 772 ;;; Parse 773 774 (defun forge--topic-parse-buffer (&optional file) 775 (save-match-data 776 (save-excursion 777 (goto-char (point-min)) 778 ;; Unlike for issues, Github ignores the yaml front-matter for 779 ;; pull-requests. We just assume that nobody tries to use it 780 ;; anyway. If that turned out to be wrong, we would have to 781 ;; deal with it by complicating matters around here. 782 (let ((alist (or (and (forge--childp (forge-get-repository t) 783 'forge-github-repository) 784 (save-excursion (forge--topic-parse-yaml))) 785 (save-excursion (forge--topic-parse-plain))))) 786 (setf (alist-get 'file alist) file) 787 (setf (alist-get 'text alist) (magit--buffer-string nil nil ?\n)) 788 (when (and file (not (alist-get 'prompt alist))) 789 (setf (alist-get 'prompt alist) 790 (file-name-sans-extension (file-name-nondirectory file)))) 791 ;; If there is a yaml front-matter, then it is supposed 792 ;; to have a `title' field, but this may not be the case. 793 (when (and (not file) 794 (not (alist-get 'title alist))) 795 (setf (alist-get 'title alist) 796 (read-string "Title: "))) 797 alist)))) 798 799 (defun forge--topic-parse-yaml () 800 (let (alist beg end) 801 (when (looking-at "^---[\s\t]*$") 802 (forward-line) 803 (setq beg (point)) 804 (when (re-search-forward "^---[\s\t]*$" nil t) 805 (setq end (match-beginning 0)) 806 (setq alist (yaml-parse-string 807 (buffer-substring-no-properties beg end) 808 :object-type 'alist)) 809 (let-alist alist 810 (setf (alist-get 'prompt alist) 811 (format "[%s] %s" .name .about)) 812 (when (and .labels (atom .labels)) 813 (setf (alist-get 'labels alist) (list .labels))) 814 (when (and .assignees (atom .assignees)) 815 (setf (alist-get 'assignees alist) (list .assignees)))))) 816 alist)) 817 818 (defun forge--topic-parse-plain () 819 (let (title body) 820 (when (looking-at "\\`#*") 821 (goto-char (match-end 0))) 822 (setq title (magit--buffer-string (point) (line-end-position) t)) 823 (forward-line) 824 (setq body (magit--buffer-string (point) nil ?\n)) 825 `((title . ,(string-trim title)) 826 (body . ,(string-trim body))))) 827 828 (defun forge--topic-parse-link-buffer () 829 (save-match-data 830 (save-excursion 831 (goto-char (point-min)) 832 (mapcar (lambda (alist) 833 (cons (cons 'prompt (concat (alist-get 'name alist) " -- " 834 (alist-get 'about alist))) 835 alist)) 836 (forge--topic-parse-yaml-links))))) 837 838 (defun forge--topic-parse-yaml-links () 839 (alist-get 'contact_links 840 (yaml-parse-string (buffer-substring-no-properties 841 (point-min) 842 (point-max)) 843 :object-type 'alist 844 :sequence-type 'list))) 845 846 ;;; Templates 847 848 (cl-defgeneric forge--topic-templates (repo class) 849 "Return a list of topic template files for REPO and a topic of CLASS.") 850 851 (cl-defgeneric forge--topic-template (repo class) 852 "Return a topic template alist for REPO and a topic of CLASS. 853 If there are multiple templates, then the user is asked to select 854 one of them. It there are no templates, then return a very basic 855 alist, containing just `text' and `position'.") 856 857 (defun forge--topic-templates-data (repo class) 858 (let ((branch (oref repo default-branch))) 859 (mapcan (lambda (f) 860 (with-temp-buffer 861 (magit-git-insert "cat-file" "-p" (concat branch ":" f)) 862 (if (equal (file-name-nondirectory f) "config.yml") 863 (forge--topic-parse-link-buffer) 864 (list (forge--topic-parse-buffer f))))) 865 (forge--topic-templates repo class)))) 866 867 (cl-defmethod forge--topic-template ((repo forge-repository) 868 (class (subclass forge-topic))) 869 (let ((choices (forge--topic-templates-data repo class))) 870 (if (cdr choices) 871 (let ((c (magit-completing-read 872 (if (eq class 'forge-pullreq) 873 "Select pull-request template" 874 "Select issue template") 875 (--map (alist-get 'prompt it) choices) 876 nil t))) 877 (--first (equal (alist-get 'prompt it) c) choices)) 878 (car choices)))) 879 880 ;;; Bug-Reference 881 882 (when (< emacs-major-version 28) 883 (defun bug-reference-fontify (start end) 884 "Apply bug reference overlays to region." 885 (save-excursion 886 (let ((beg-line (progn (goto-char start) (line-beginning-position))) 887 (end-line (progn (goto-char end) (line-end-position)))) 888 ;; Remove old overlays. 889 (bug-reference-unfontify beg-line end-line) 890 (goto-char beg-line) 891 (while (and (< (point) end-line) 892 (re-search-forward bug-reference-bug-regexp end-line 'move)) 893 (when (and (or (not bug-reference-prog-mode) 894 ;; This tests for both comment and string syntax. 895 (nth 8 (syntax-ppss))) 896 ;; This is the part where this redefinition differs 897 ;; from the original defined in "bug-reference.el". 898 (not (and (derived-mode-p 'magit-status-mode 899 'forge-notifications-mode) 900 (= (match-beginning 0) 901 (line-beginning-position)))) 902 ;; End of additions. 903 ) 904 (let ((overlay (make-overlay (match-beginning 0) (match-end 0) 905 nil t nil))) 906 (overlay-put overlay 'category 'bug-reference) 907 ;; Don't put a link if format is undefined 908 (when bug-reference-url-format 909 (overlay-put overlay 'bug-reference-url 910 (if (stringp bug-reference-url-format) 911 (format bug-reference-url-format 912 (match-string-no-properties 2)) 913 (funcall bug-reference-url-format))))))))))) 914 915 (defun forge-bug-reference-setup () 916 "Setup `bug-reference' in the current buffer. 917 If forge data has been fetched for the current repository, then 918 enable `bug-reference-mode' or `bug-reference-prog-mode' and 919 modify `bug-reference-bug-regexp' if appropriate." 920 (unless bug-reference-url-format 921 (magit--with-safe-default-directory nil 922 (when-let ((repo (forge-get-repository 'full))) 923 (if (>= emacs-major-version 28) 924 (when (derived-mode-p 'magit-status-mode 925 'forge-notifications-mode) 926 (setq-local 927 bug-reference-auto-setup-functions 928 (let ((hook bug-reference-auto-setup-functions)) 929 (list (lambda () 930 ;; HOOK is not allowed to be a lexical var: 931 ;; (run-hook-with-args-until-success 'hook) 932 (catch 'success 933 (dolist (f hook) 934 (when (funcall f) 935 (setq bug-reference-bug-regexp 936 (concat "." bug-reference-bug-regexp)) 937 (throw 'success t))))))))) 938 (setq-local bug-reference-url-format 939 (if (forge--childp repo 'forge-gitlab-repository) 940 (lambda () 941 (forge--format repo 942 (if (equal (match-string 3) "#") 943 'issue-url-format 944 'pullreq-url-format) 945 `((?i . ,(match-string 2))))) 946 (forge--format repo 'issue-url-format '((?i . "%s"))))) 947 (setq-local bug-reference-bug-regexp 948 (if (forge--childp repo 'forge-gitlab-repository) 949 "\\(?3:[!#]\\)\\(?2:[0-9]+\\)" 950 "#\\(?2:[0-9]+\\)"))) 951 (if (derived-mode-p 'prog-mode) 952 (bug-reference-prog-mode 1) 953 (bug-reference-mode 1)) 954 (add-hook 'completion-at-point-functions 955 'forge-topic-completion-at-point nil t))))) 956 957 (when (and (not noninteractive) forge--sqlite-available-p) 958 (dolist (hook forge-bug-reference-hooks) 959 (add-hook hook #'forge-bug-reference-setup))) 960 961 ;;; _ 962 (provide 'forge-topic) 963 ;;; forge-topic.el ends here