1 ;;; vc-got-stage.el --- Stage functionalities for vc-got  -*- lexical-binding: t; -*-
2 
3 ;; Copyright (C) 2021  Omar Polo
4 
5 ;; Author: Omar Polo <op@omarpolo.com>
6 ;; Keywords: vc
7 
8 ;; This program is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
12 
13 ;; This program is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;; GNU General Public License for more details.
17 
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
20 
21 ;;; Commentary:
22 
23 ;; Stage-related functions for vc-got.  This allows vc-got to stage
24 ;; and commit individual chunks and not entire filesets.
25 
26 ;;; Code:
27 
28 (require 'log-edit)
29 (require 'rx)
30 (require 'vc)
31 
32 (defvar vc-got-program)                 ;vc-got.el
33 (declare-function vc-got--diff    "vc-got")
34 (declare-function vc-got--unstage "vc-got" (file))
35 (declare-function vc-got--status  "vc-got" (status-codes dir &rest files))
36 (declare-function vc-got-checkin  "vc-got" (fileset comment))
37 (declare-function vc-got-root     "vc-got" (dir-or-file))
38 
39 (defvar vc-got-stage--process nil
40   "The got stage process.")
41 
42 (defvar vc-got-stage--fileset nil
43   "Remaining fileset to process.")
44 
45 (defun vc-got-stage--assert-proc ()
46   "Assert no vc-got-stage process is running."
47   (when (process-live-p vc-got-stage--process)
48     (error "A vc-got-stage-files is already in progress")))
49 
50 (defun vc-got-stage-files (fileset)
51   "Interactively stage hunks from files in FILESET."
52   (interactive (list (cadr (vc-deduce-fileset))))
53   (vc-got-stage--assert-proc)
54   (if (not fileset)
55       (message "[vc-got] nothing to stage.")
56     (setq vc-got-stage--fileset fileset)
57     (vc-got-stage--next)))
58 
59 (defun vc-got-stage--next ()
60   "Process next file in stage list."
61   (vc-got-stage--assert-proc)
62   (let ((file (car vc-got-stage--fileset)))
63     (if (not file)
64         (progn (kill-buffer (process-buffer vc-got-stage--process))
65                (message "[vc-got] stage done."))
66       (setq vc-got-stage--fileset (cdr vc-got-stage--fileset))
67       (let ((buf (get-buffer-create "*vc-got-stage*")))
68         (pop-to-buffer buf)
69         (with-current-buffer buf
70           (buffer-disable-undo)
71           (erase-buffer)
72           (read-only-mode)
73           (unless (derived-mode-p 'diff-mode)
74             (diff-mode)))
75         (setq vc-got-stage--process
76               (make-process :name "got"
77                             :buffer buf
78                             :command (list vc-got-program "stage" "-p" file)
79                             :connection 'pty
80                             :filter #'vc-got-stage--filter
81                             :sentinel #'vc-got-stage--sentinel))))))
82 
83 (defun vc-got-stage--kill-separators ()
84   "Kill the separator lines in interactive got stage."
85   (save-excursion
86     (forward-line -2)
87     (kill-line)
88     (goto-char (point-min))
89     (kill-line)))
90 
91 (defun vc-got-stage--filter (proc string)
92   "Filter for got stage process.
93 PROC is the process, STRING part of its output."
94   (let ((buf (process-buffer proc)))
95     (when (buffer-live-p buf)
96       (let ((inhibit-read-only t))
97         (with-current-buffer buf
98           (goto-char (point-max))
99           (insert string)
100           (save-excursion
101             (beginning-of-line)
102             (when (looking-at (rx bol
103                                   (group (zero-or-one "un")
104                                          "stage"
105                                          (zero-or-more anychar)
106                                          "?")))
107               (let ((msg (match-string 1)))
108                 (kill-line)             ; kill the question
109                 (vc-got-stage--kill-separators)
110                 (process-send-string buf
111                                      (condition-case nil
112                                          (if (y-or-n-p msg) "y\n" "n\n")
113                                        (quit "q\n")))
114                 (erase-buffer)))))))))
115 
116 (defun vc-got-stage--sentinel (_proc event)
117   "Sentinel for got stage process.
118 Should be only called when EVENT is finished."
119   (when (string= event "finished\n")
120     (vc-got-stage--next)))
121 
122 ;; TODO: make this interactive just as stage is
123 (defun vc-got-stage-unstage (fileset)
124   "Unstage staged hunks in FILESET."
125   (interactive (list (cadr (vc-deduce-fileset))))
126   (vc-got-stage--assert-proc)
127   (if fileset
128       (dolist (file fileset)
129         (vc-got--unstage file))
130     (vc-got--unstage nil)))
131 
132 (defun vc-got-stage-diff (fileset)
133   "Pop a buffer with the staged diff for FILESET.
134 If FILESET is nil, show the diff for every staged hunks."
135   (interactive (list (cadr (vc-deduce-fileset))))
136   (with-current-buffer (get-buffer-create "*vc-diff*")
137     (pop-to-buffer (current-buffer))
138     (let ((inhibit-read-only t))
139       (erase-buffer)
140       (diff-mode)
141       (if fileset
142           (dolist (file fileset)
143             (vc-got--diff "-s" file))
144         (vc-got--diff "-s")))))
145 
146 (defun vc-got-stage-commit ()
147   "Commit staged hunks."
148   (interactive)
149   (let* ((default-directory (vc-got-root default-directory))
150          (buf (get-buffer-create "*vc-got-stage-commit*"))
151          (status (vc-got--status "MAD" "."))
152          (staged-files (cl-loop for (file _ staged) in status
153                                 when staged
154                                 collect file)))
155     (pop-to-buffer buf)
156     (log-edit (lambda ()
157                 (interactive)
158                 (let ((msg (buffer-substring-no-properties (point-min)
159                                                            (point-max))))
160                   (kill-buffer)
161                   (vc-got-checkin nil msg)))
162               t
163               `((log-edit-listfun . ,(lambda ()
164                                        (mapcar #'file-relative-name
165                                                staged-files)))))))
166 
167 (provide 'vc-got-stage)
168 ;;; vc-got-stage.el ends here