426 lines
16 KiB
EmacsLisp
426 lines
16 KiB
EmacsLisp
|
;;; forge-post.el --- Post support -*- lexical-binding:t -*-
|
||
|
|
|
||
|
|
;; Copyright (C) 2018-2026 Jonas Bernoulli
|
||
|
|
|
||
|
|
;; Author: Jonas Bernoulli <emacs.forge@jonas.bernoulli.dev>
|
||
|
|
;; Maintainer: Jonas Bernoulli <emacs.forge@jonas.bernoulli.dev>
|
||
|
|
|
||
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||
|
|
|
||
|
|
;; This file 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.
|
||
|
|
;;
|
||
|
|
;; This file 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 this file. If not, see <https://www.gnu.org/licenses/>.
|
||
|
|
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(require 'markdown-mode)
|
||
|
|
|
||
|
|
(require 'forge)
|
||
|
|
|
||
|
|
;;; Options
|
||
|
|
|
||
|
|
(defcustom forge-post-mode-hook
|
||
|
|
'(visual-line-mode
|
||
|
|
turn-on-flyspell)
|
||
|
|
"Hook run after entering Forge-Post mode.
|
||
|
|
This hook is run early on while setting up a buffer to edit a post.
|
||
|
|
If you want to make changes to the already populated buffer, instead
|
||
|
|
use `forge-edit-post-hook'."
|
||
|
|
:package-version '(forge . "0.2.0")
|
||
|
|
:group 'forge
|
||
|
|
:type 'hook
|
||
|
|
:options '(visual-line-mode
|
||
|
|
turn-on-flyspell))
|
||
|
|
|
||
|
|
(defcustom forge-edit-post-hook
|
||
|
|
'(forge-create-pullreq-insert-single-commit-message
|
||
|
|
forge-create-pullreq-show-diff)
|
||
|
|
"Hook run after setting up a buffer to edit a post.
|
||
|
|
Consult the variable `forge-edit-post-action' to determine the action;
|
||
|
|
one of `new-discussion', `new-issue', `new-pullreq', `reply' and `edit'."
|
||
|
|
:package-version '(forge . "0.6.0")
|
||
|
|
:group 'forge
|
||
|
|
:type 'hook
|
||
|
|
:options '(forge-create-pullreq-insert-single-commit-message
|
||
|
|
forge-create-pullreq-insert-branch-description
|
||
|
|
forge-create-pullreq-show-diff))
|
||
|
|
|
||
|
|
(defcustom forge-post-fallback-directory
|
||
|
|
(locate-user-emacs-file "forge-drafts/")
|
||
|
|
"Directory used to store post drafts for locally unavailable repositories.
|
||
|
|
Normally drafts are stored inside the Git directory. If that does not
|
||
|
|
exist (or its location is unknown), then this directory is used instead."
|
||
|
|
:package-version '(forge . "0.4.7")
|
||
|
|
:group 'forge
|
||
|
|
:type 'directory)
|
||
|
|
|
||
|
|
;;; Class
|
||
|
|
|
||
|
|
(defclass forge-post (forge-object) () :abstract t)
|
||
|
|
|
||
|
|
;;; Query
|
||
|
|
;;;; Get
|
||
|
|
|
||
|
|
(cl-defmethod forge-get-parent ((post forge-post))
|
||
|
|
(forge-get-topic post))
|
||
|
|
|
||
|
|
(cl-defmethod forge-get-repository ((post forge-post))
|
||
|
|
(forge-get-repository (forge-get-topic post)))
|
||
|
|
|
||
|
|
;;;; Current
|
||
|
|
|
||
|
|
(defun forge-post-at-point (&optional assert)
|
||
|
|
"Return the post at point.
|
||
|
|
If there is no such post and DEMAND is non-nil, then signal
|
||
|
|
an error."
|
||
|
|
(or (magit-section-value-if '(issue pullreq post))
|
||
|
|
(and assert (user-error "There is no post at point"))))
|
||
|
|
|
||
|
|
(defun forge-comment-at-point (&optional assert)
|
||
|
|
"Return the comment at point.
|
||
|
|
If there is no such comment and DEMAND is non-nil, then signal
|
||
|
|
an error."
|
||
|
|
(or (and (magit-section-value-if '(post))
|
||
|
|
(let ((post (oref (magit-current-section) value)))
|
||
|
|
(and (or (forge-pullreq-post-p post)
|
||
|
|
(forge-issue-post-p post))
|
||
|
|
post)))
|
||
|
|
(and assert (user-error "There is no comment at point"))))
|
||
|
|
|
||
|
|
;;; Utilities
|
||
|
|
|
||
|
|
(cl-defmethod forge--format ((post forge-post) slot &optional spec)
|
||
|
|
(forge--format (forge-get-topic post) slot
|
||
|
|
`(,@spec (?I . ,(oref post number)))))
|
||
|
|
|
||
|
|
;;; Mode
|
||
|
|
|
||
|
|
(defvar-keymap forge-post-mode-map
|
||
|
|
"<remap> <forge--item-menu>" #'forge-post-menu
|
||
|
|
"C-c C-e" #'forge-post-menu
|
||
|
|
"C-c C-c" #'forge-post-submit
|
||
|
|
"<remap> <evil-save-and-close>" #'forge-post-submit
|
||
|
|
"<remap> <evil-save-modified-and-close>" #'forge-post-submit
|
||
|
|
"C-c C-k" #'forge-post-cancel
|
||
|
|
"<remap> <kill-buffer>" #'forge-post-cancel
|
||
|
|
"<remap> <ido-kill-buffer>" #'forge-post-cancel
|
||
|
|
"<remap> <iswitchb-kill-buffer>" #'forge-post-cancel
|
||
|
|
"<remap> <evil-quit>" #'forge-post-cancel)
|
||
|
|
|
||
|
|
(define-derived-mode forge-post-mode gfm-mode "Forge-Post"
|
||
|
|
"Major mode for editing topic posts."
|
||
|
|
:interactive nil)
|
||
|
|
|
||
|
|
(defvar-local forge--pre-post-buffer nil)
|
||
|
|
(defvar-local forge--pre-post-winconf nil)
|
||
|
|
|
||
|
|
(defvar-local forge--submit-post-function nil)
|
||
|
|
|
||
|
|
(defvar-local forge-edit-post-action nil
|
||
|
|
"The action being carried out by editing this post buffer.
|
||
|
|
One of `new-discussion', `new-issue', `new-pullreq', `reply' and `edit'.")
|
||
|
|
|
||
|
|
(defvar-local forge--buffer-post-object nil)
|
||
|
|
(defvar-local forge--buffer-template nil)
|
||
|
|
(defvar-local forge--buffer-category nil)
|
||
|
|
(defvar-local forge--buffer-milestone nil)
|
||
|
|
(defvar-local forge--buffer-labels nil)
|
||
|
|
(defvar-local forge--buffer-assignees nil)
|
||
|
|
(defvar-local forge--buffer-base-branch nil)
|
||
|
|
(defvar-local forge--buffer-head-branch nil)
|
||
|
|
(defvar-local forge--buffer-draft-p nil)
|
||
|
|
|
||
|
|
(defun forge--setup-post-buffer ( obj-or-action submit file header
|
||
|
|
&optional bindings fn)
|
||
|
|
(declare (indent defun))
|
||
|
|
(let* ((prevbuf (current-buffer))
|
||
|
|
(winconf (current-window-configuration))
|
||
|
|
(action (cond ((symbolp obj-or-action) obj-or-action)
|
||
|
|
((forge--childp obj-or-action 'forge-topic) 'reply)
|
||
|
|
((forge--childp obj-or-action 'forge-post) 'edit)))
|
||
|
|
(obj (if (symbolp obj-or-action)
|
||
|
|
(forge-get-repository :tracked)
|
||
|
|
obj-or-action))
|
||
|
|
(repo (forge-get-repository obj))
|
||
|
|
(header (forge--format obj header))
|
||
|
|
(file (forge--post-expand-file-name (forge--format obj file) repo))
|
||
|
|
(_ (make-directory (file-name-directory file) t))
|
||
|
|
(buffer (find-file-noselect file))
|
||
|
|
(resume (forge--post-resume-p file buffer)))
|
||
|
|
(with-current-buffer buffer
|
||
|
|
(forge-post-mode)
|
||
|
|
(magit-set-header-line-format header)
|
||
|
|
(setq forge--pre-post-buffer prevbuf)
|
||
|
|
(setq forge--pre-post-winconf winconf)
|
||
|
|
(forge-set-buffer-repository)
|
||
|
|
(setq forge-edit-post-action action)
|
||
|
|
(setq forge--buffer-post-object obj)
|
||
|
|
(setq forge--submit-post-function submit)
|
||
|
|
(pcase-dolist (`(,var ,val) bindings)
|
||
|
|
(set-local var val)
|
||
|
|
(when (eq var 'forge--buffer-template)
|
||
|
|
(let-alist forge--buffer-template
|
||
|
|
(setq forge--buffer-assignees .assignees)
|
||
|
|
(setq forge--buffer-labels .labels)
|
||
|
|
(setq forge--buffer-draft-p .draft))))
|
||
|
|
(cond-let
|
||
|
|
(resume)
|
||
|
|
((not (memq action '(new-discussion new-issue new-pullreq))))
|
||
|
|
([template (alist-get 'text forge--buffer-template)]
|
||
|
|
(unless (string-prefix-p "# " template)
|
||
|
|
(insert "# \n\n"))
|
||
|
|
(insert template)
|
||
|
|
(goto-char 3))
|
||
|
|
((insert "# ")))
|
||
|
|
(when fn
|
||
|
|
(funcall fn)))
|
||
|
|
(run-hook-wrapped 'forge-edit-post-hook
|
||
|
|
(lambda (fn) (with-current-buffer buffer (funcall fn)) nil))
|
||
|
|
(message (substitute-command-keys
|
||
|
|
"Use \\[forge-post-menu] to set fields and submit or abort"))
|
||
|
|
(forge--display-post-buffer buffer)))
|
||
|
|
|
||
|
|
(defun forge--display-post-buffer (buf)
|
||
|
|
(magit-display-buffer buf #'display-buffer))
|
||
|
|
|
||
|
|
(defun forge--post-expand-file-name (file repo)
|
||
|
|
(if-let ((worktree (oref repo worktree)))
|
||
|
|
(expand-file-name (concat "magit/posts/" file) (magit-gitdir worktree))
|
||
|
|
(expand-file-name (with-slots (githost owner name) repo
|
||
|
|
(format "%s_%s-%s_%s" githost owner name file))
|
||
|
|
forge-post-fallback-directory)))
|
||
|
|
|
||
|
|
(defun forge--post-resume-p (file buffer)
|
||
|
|
(and (file-exists-p file)
|
||
|
|
(> (file-attribute-size (file-attributes file)) 0)
|
||
|
|
(progn (forge--display-post-buffer buffer)
|
||
|
|
(or (magit-read-char-case "" nil
|
||
|
|
(?r "[r]esume editing this draft" t)
|
||
|
|
(?d "[d]iscard and start over?"))
|
||
|
|
(progn (erase-buffer)
|
||
|
|
nil)))))
|
||
|
|
|
||
|
|
(defun forge-create-pullreq-insert-single-commit-message ()
|
||
|
|
"When creating a pull-request from a single commit, insert its message."
|
||
|
|
(when-let* ((source forge--buffer-head-branch)
|
||
|
|
(target forge--buffer-base-branch)
|
||
|
|
(_(= (car (magit-rev-diff-count source target)) 1)))
|
||
|
|
(when (alist-get 'text forge--buffer-template)
|
||
|
|
(goto-char (point-max))
|
||
|
|
(unless (eq (char-before) ?\n)
|
||
|
|
(insert ?\n))
|
||
|
|
(insert "\n<!-- Message of single commit: -->\n\n"))
|
||
|
|
(magit-rev-insert-format "%B" source)
|
||
|
|
(when (= (char-before (1- (point))) ?\n)
|
||
|
|
(delete-char -1))
|
||
|
|
(goto-char 3)))
|
||
|
|
|
||
|
|
(defun forge-create-pullreq-insert-branch-description ()
|
||
|
|
"When creating a pull-request, insert branch description, if any.
|
||
|
|
Insert the value of `branch.BRANCH.description' of the source BRANCH."
|
||
|
|
(when-let* ((source forge--buffer-head-branch)
|
||
|
|
(description (magit-get "branch"
|
||
|
|
(cdr (magit-split-branch-name source))
|
||
|
|
"description")))
|
||
|
|
(when (or (alist-get 'text forge--buffer-template)
|
||
|
|
(> (point-max) 3))
|
||
|
|
(goto-char (point-max))
|
||
|
|
(unless (eq (char-before) ?\n)
|
||
|
|
(insert ?\n))
|
||
|
|
(insert "\n<!-- Branch description: -->\n\n"))
|
||
|
|
(insert description)
|
||
|
|
(goto-char 3)))
|
||
|
|
|
||
|
|
(defun forge-create-pullreq-show-diff ()
|
||
|
|
"When creating a pull-request, show diff for the branch's changes."
|
||
|
|
(when (eq forge-edit-post-action 'new-pullreq)
|
||
|
|
(magit-diff-setup-buffer
|
||
|
|
(format "%s...%s"
|
||
|
|
forge--buffer-base-branch
|
||
|
|
forge--buffer-head-branch)
|
||
|
|
nil (car (magit-diff-arguments)) nil 'committed t)))
|
||
|
|
|
||
|
|
(defun forge--post-buffer-text ()
|
||
|
|
(save-match-data
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-min))
|
||
|
|
(skip-chars-forward "\s\t\n")
|
||
|
|
(let (title body)
|
||
|
|
(when (looking-at "^#*[\s\t]*")
|
||
|
|
(goto-char (match-end 0)))
|
||
|
|
(setq title (buffer-str (point) (line-end-position)))
|
||
|
|
(forward-line)
|
||
|
|
(setq body (buffer-str (point)))
|
||
|
|
(cons (string-trim title)
|
||
|
|
(string-trim body))))))
|
||
|
|
|
||
|
|
(defun forge--post-submit-callback (&optional full-pull)
|
||
|
|
(let* ((file buffer-file-name)
|
||
|
|
(winconf forge--pre-post-winconf)
|
||
|
|
(editbuf (current-buffer))
|
||
|
|
(prevbuf forge--pre-post-buffer)
|
||
|
|
(topic (ignore-errors (forge-get-topic forge--buffer-post-object)))
|
||
|
|
(repo (forge-get-repository (or topic forge--buffer-post-object))))
|
||
|
|
(lambda (value &optional headers status req)
|
||
|
|
(run-hook-with-args 'forge-post-submit-callback-hook
|
||
|
|
value headers status req)
|
||
|
|
(delete-file file t)
|
||
|
|
(let ((dir (file-name-directory file)))
|
||
|
|
(unless (cddr (directory-files dir nil nil t))
|
||
|
|
(delete-directory dir nil t)))
|
||
|
|
(when (buffer-live-p editbuf)
|
||
|
|
(with-current-buffer editbuf
|
||
|
|
(magit-mode-bury-buffer 'kill)))
|
||
|
|
(forge--maybe-restore-winconf winconf)
|
||
|
|
(with-current-buffer
|
||
|
|
(if (buffer-live-p prevbuf) prevbuf (current-buffer))
|
||
|
|
(if (or (not full-pull)
|
||
|
|
(oref repo selective-p))
|
||
|
|
(forge--pull-topic repo (or topic (alist-get 'number value)))
|
||
|
|
(forge--pull repo))))))
|
||
|
|
|
||
|
|
(defun forge--post-submit-errorback ()
|
||
|
|
(lambda (error &rest _)
|
||
|
|
(error "Failed to submit post: %S" error)))
|
||
|
|
|
||
|
|
(defun forge--maybe-restore-winconf (winconf)
|
||
|
|
(when (and winconf
|
||
|
|
(eq (window-configuration-frame winconf)
|
||
|
|
(selected-frame)))
|
||
|
|
(set-window-configuration winconf)))
|
||
|
|
|
||
|
|
;;; Commands
|
||
|
|
|
||
|
|
(transient-define-prefix forge-post-menu ()
|
||
|
|
"Dispatch a post creation command."
|
||
|
|
[["Set"
|
||
|
|
:if (lambda ()
|
||
|
|
(and (forge-github-repository-p (forge-get-repository :tracked))
|
||
|
|
(string-prefix-p "new-"
|
||
|
|
(file-name-nondirectory buffer-file-name))))
|
||
|
|
("-m" forge-new-topic-set-milestone)
|
||
|
|
("-l" forge-new-topic-set-labels)
|
||
|
|
("-a" forge-new-topic-set-assignees)
|
||
|
|
("-d" forge-new-pullreq-toggle-draft)]
|
||
|
|
["Actions"
|
||
|
|
("C-c" "Submit" forge-post-submit)
|
||
|
|
("C-k" "Cancel" forge-post-cancel)]])
|
||
|
|
|
||
|
|
(defun forge-post-submit ()
|
||
|
|
"Submit the post that is being edited in the current buffer."
|
||
|
|
(interactive)
|
||
|
|
(save-buffer)
|
||
|
|
(funcall forge--submit-post-function
|
||
|
|
(forge-get-repository forge--buffer-post-object)
|
||
|
|
forge--buffer-post-object))
|
||
|
|
|
||
|
|
(defun forge-post-cancel ()
|
||
|
|
"Cancel the post that is being edited in the current buffer."
|
||
|
|
(interactive)
|
||
|
|
(save-buffer)
|
||
|
|
(let ((winconf forge--pre-post-winconf))
|
||
|
|
(when (yes-or-no-p "Also delete draft? ")
|
||
|
|
(dired-delete-file buffer-file-name nil magit-delete-by-moving-to-trash))
|
||
|
|
(magit-mode-bury-buffer 'kill)
|
||
|
|
(forge--maybe-restore-winconf winconf)))
|
||
|
|
|
||
|
|
(defclass forge--new-topic-set-slot-command (transient-lisp-variable)
|
||
|
|
((name :initarg :name)
|
||
|
|
(reader :initarg :reader)
|
||
|
|
(formatter :initarg :formatter)
|
||
|
|
(format :initform " %k %d")
|
||
|
|
(description :initform (lambda (obj)
|
||
|
|
(with-slots (name variable formatter) obj
|
||
|
|
(if-let* ((value (symbol-value variable))
|
||
|
|
(value (funcall formatter value)))
|
||
|
|
(format "%s %s" name value)
|
||
|
|
(format "%s" name)))))))
|
||
|
|
|
||
|
|
(transient-define-infix forge-new-topic-set-milestone ()
|
||
|
|
"Set milestone for the topic being created."
|
||
|
|
:class 'forge--new-topic-set-slot-command
|
||
|
|
:variable 'forge--buffer-milestone
|
||
|
|
:name "milestone"
|
||
|
|
:reader (lambda (&rest _) (forge-read-topic-milestone))
|
||
|
|
:formatter (lambda (milestone) (propertize milestone 'face 'forge-topic-label))
|
||
|
|
:if (lambda () (equal (file-name-nondirectory buffer-file-name) "new-issue")))
|
||
|
|
|
||
|
|
(transient-define-infix forge-new-topic-set-labels ()
|
||
|
|
"Set labels for the topic being created."
|
||
|
|
:class 'forge--new-topic-set-slot-command
|
||
|
|
:variable 'forge--buffer-labels
|
||
|
|
:name "labels"
|
||
|
|
:reader (lambda (&rest _) (forge-read-topic-labels))
|
||
|
|
:formatter (##forge--format-labels % t)
|
||
|
|
:if (lambda () (equal (file-name-nondirectory buffer-file-name) "new-issue")))
|
||
|
|
|
||
|
|
(transient-define-infix forge-new-topic-set-assignees ()
|
||
|
|
"Set assignees for the pull-request being created."
|
||
|
|
:class 'forge--new-topic-set-slot-command
|
||
|
|
:variable 'forge--buffer-assignees
|
||
|
|
:name "assignees"
|
||
|
|
:reader (lambda (&rest _) (forge-read-topic-assignees))
|
||
|
|
:formatter #'forge--format-topic-assignees
|
||
|
|
:if (lambda () (equal (file-name-nondirectory buffer-file-name) "new-issue")))
|
||
|
|
|
||
|
|
(transient-define-infix forge-new-pullreq-toggle-draft ()
|
||
|
|
"Toggle whether the pull-request being created is a draft."
|
||
|
|
:class 'forge--new-topic-set-slot-command
|
||
|
|
:variable 'forge--buffer-draft-p
|
||
|
|
:name "draft"
|
||
|
|
:reader (lambda (&rest _) (not forge--buffer-draft-p))
|
||
|
|
:description (lambda ()
|
||
|
|
(format (propertize "[%s]" 'face 'transient-delimiter)
|
||
|
|
(propertize "draft" 'face
|
||
|
|
(if forge--buffer-draft-p
|
||
|
|
'transient-value
|
||
|
|
'transient-inactive-value))))
|
||
|
|
:if (lambda () (equal (file-name-nondirectory buffer-file-name) "new-pullreq")))
|
||
|
|
|
||
|
|
;;; Notes
|
||
|
|
|
||
|
|
(defclass forge-note (forge-post) ())
|
||
|
|
|
||
|
|
(defvar-keymap forge-note-section-map
|
||
|
|
"<remap> <magit-edit-thing>" #'forge-edit-topic-note)
|
||
|
|
|
||
|
|
(defun forge--save-note (_repo topic)
|
||
|
|
(let ((value (string-trim (buffer-str))))
|
||
|
|
(oset topic note (if (equal value "") nil value)))
|
||
|
|
(delete-file buffer-file-name t)
|
||
|
|
(let ((dir (file-name-directory buffer-file-name)))
|
||
|
|
(unless (cddr (directory-files dir nil nil t))
|
||
|
|
(delete-directory dir)))
|
||
|
|
(let ((prevbuf forge--pre-post-buffer))
|
||
|
|
(magit-mode-bury-buffer 'kill)
|
||
|
|
(forge-refresh-buffer prevbuf)))
|
||
|
|
|
||
|
|
;;; _
|
||
|
|
;; Local Variables:
|
||
|
|
;; read-symbol-shorthands: (
|
||
|
|
;; ("and$" . "cond-let--and$")
|
||
|
|
;; ("thread$" . "cond-let--thread$")
|
||
|
|
;; ("when$" . "cond-let--when$")
|
||
|
|
;; ("and-let*" . "cond-let--and-let*")
|
||
|
|
;; ("and-let" . "cond-let--and-let")
|
||
|
|
;; ("if-let*" . "cond-let--if-let*")
|
||
|
|
;; ("if-let" . "cond-let--if-let")
|
||
|
|
;; ("when-let*" . "cond-let--when-let*")
|
||
|
|
;; ("when-let" . "cond-let--when-let")
|
||
|
|
;; ("while-let*" . "cond-let--while-let*")
|
||
|
|
;; ("while-let" . "cond-let--while-let")
|
||
|
|
;; ("buffer-string" . "buffer-string")
|
||
|
|
;; ("buffer-str" . "forge--buffer-substring-no-properties"))
|
||
|
|
;; End:
|
||
|
|
(provide 'forge-post)
|
||
|
|
;;; forge-post.el ends here
|