1 ;; vc-got-stage.el --- Stage changes in vc-got diff buffers  -*- lexical-binding: t; -*-
2 
3 (eval-when-compile
4   (require 'subr-x))
5 
6 (defgroup vc-got-stage nil
7   "Stage hunks in vc-got diff buffers"
8   :group 'faces
9   :prefix "vc-got-stage-")
10 
11 (defface vc-got-stage-staged-face
12     '((t (:foreground "red" :background "yellow")))
13   "Face used to highlight the staged mark on changes."
14   :group 'vc-got-stage)
15 
16 (defvar vc-got-stage-fileset nil
17   "The files diffed in the last call to `vc-got-diff'.")
18 
19 (defvar vc-got-stage-overlay-priority 0
20   "Specify overlay priority.
21 Higher values means higher priority.  DON'T use negative numbers.")
22 
23 (defvar vc-got-stage--overlays nil
24   "The list of overlays.")
25 
26 (defvar vc-got-stage-prefix-map
27   (let ((map (make-sparse-keymap)))
28     (define-key map (kbd "A") #'vc-got-stage-apply)
29     (define-key map (kbd "b") #'vc-got-stage-beginning-of-change)
30     (define-key map (kbd "e") #'vc-got-stage-end-of-change)
31     (define-key map (kbd "n") #'vc-got-stage-next-change)
32     (define-key map (kbd "p") #'vc-got-stage-prev-change)
33     (define-key map (kbd "t") #'vc-got-stage-toggle-mark)
34     map)
35   "Keymap for function `vc-got-stage-mode'.")
36 
37 ;;;###autoload
38 (define-minor-mode vc-got-stage-mode
39   "Stage hunks in vc-got diff buffers.
40 
41 \\{vc-got-stage-mode-map}"
42   :group vc-got-stage
43   :keymap (let ((map (make-sparse-keymap)))
44             (define-key map (kbd "C-c g") vc-got-stage-prefix-map)
45             map))
46 
47 ;;;###autoload (defun vc-got-stage-activate ()
48 ;;;###autoload   "Activate vg-got-stage-mode if the current buffer is a vc-got diff."
49 ;;;###autoload   (when-let (root (vc-find-root default-directory ".got"))
50 ;;;###autoload     (vc-got-stage-mode +1)))
51 
52 (defun vc-got-stage-activate ()
53   "Activate vg-got-stage-mode if the current buffer is a vc-got diff."
54   (message "VC got stage activate? %s" (vc-find-root default-directory ".got"))
55   (when-let (root (vc-find-root default-directory ".got"))
56     (vc-got-stage-mode +1)))
57 
58 ;;;###autoload (add-hook 'diff-mode-hook #'vc-got-stage-activate)
59 (add-hook 'diff-mode-hook #'vc-got-stage-activate)
60 
61 (defun vc-got-stage--in-change ()
62   "T if the point is in a line that's part of a change."
63   (save-excursion
64     (beginning-of-line)
65     (when-let (ch (char-after))
66       (or (= ch ?\-)
67           (= ch ?\+)))))
68 
69 (defun vc-got-stage--change-marked-p ()
70   "T if the current change is marked."
71   (let ((p (point)))
72     (cl-loop
73        for overlay in vc-got-stage--overlays
74        if (and (overlay-start overlay)
75                (= p (overlay-start overlay)))
76        return t
77        finally (return nil))))
78 
79 (defun vc-got-stage--compute-y-or-n (buf)
80   "Fill BUF with ``y'' or ``n'' lines for staging purpose."
81   (save-excursion
82     (goto-char (point-min))
83     (let ((p (point)))
84       (while (not (= p (progn (vc-got-stage-next-change)
85                               (point))))
86         (setq p (point))
87         (if (vc-got-stage--change-marked-p)
88             (with-current-buffer buf
89               (insert "y\n"))
90           (with-current-buffer buf
91             (insert "n\n")))))))
92 
93 (defun vc-got-stage--apply-impl (script tmp-file)
94   "Apply the stages using SCRIPT as script (TMP-FILE is the path)."
95   (interactive "P")
96   (let* ((default-directory (vc-find-root default-directory ".got"))
97          (stage-buf         (get-buffer-create "*vc-got-stage*")))
98     (unless (zerop (apply #'process-file "got" nil stage-buf nil "unstage"
99                           (mapcar #'file-relative-name vc-got-stage-fileset)))
100       (pop-to-buffer stage-buf)
101       (error "Got unstage failed"))
102     (vc-got-stage--compute-y-or-n script)
103     (with-current-buffer script
104       (save-buffer))
105     (unless (zerop (apply #'process-file "got" nil stage-buf nil "stage" "-p"
106                           "-F" tmp-file (mapcar #'file-relative-name
107                                                 vc-got-stage-fileset)))
108       (pop-to-buffer stage-buf)
109       (error "Got stage failed"))))
110 
111 (defun vc-got-stage-apply ()
112   "Apply the stages.
113 This will first reset the stages of all the involved files, then
114 stage the marked changes."
115   (interactive)
116   (let* ((tmp-file (make-temp-file "vc-got-stage-script"))
117          (script   (find-file-noselect tmp-file)))
118     (unwind-protect
119          (vc-got-stage--apply-impl script tmp-file)
120       (kill-buffer script)
121       (delete-file tmp-file))))
122 
123 (defun vc-got-stage-beginning-of-change ()
124   "Goto the beginning of the current change."
125   (interactive)
126   (ignore-errors
127     (beginning-of-line)
128     (while (vc-got-stage--in-change)
129       (forward-line -1))
130     (forward-line)))
131 
132 (defun vc-got-stage-end-of-change ()
133   "Goto the end of the current change."
134   (interactive)
135   (ignore-errors
136     (beginning-of-line)
137     (while (vc-got-stage--in-change)
138       (forward-line))
139     (forward-line -1)))
140 
141 (defun vc-got-stage--prevnext-change (n)
142   "Goto next/previous change by N."
143   (let ((start (point)))
144     (beginning-of-line)
145     (while (and (not (= (point) (if (= n -1)
146                                     (point-min)
147                                   (point-max))))
148                 (vc-got-stage--in-change))
149       (forward-line n))
150     (while (let ((face (get-text-property (point) 'face)))
151              (and (not (= (point) (if (= n -1)
152                                       (point-min)
153                                     (point-max))))
154                   (or (eq face 'diff-hunk-header)
155                       (eq face 'diff-header)
156                       (eq face 'diff-context))))
157       (forward-line n))
158     (if (= n -1)
159         (vc-got-stage-beginning-of-change))
160     (unless (vc-got-stage--in-change)
161       (goto-char start)
162       (message "No prev/next change"))))
163 
164 (defun vc-got-stage-prev-change ()
165   "Goto previous change."
166   (interactive)
167   (vc-got-stage--prevnext-change -1))
168 
169 (defun vc-got-stage-next-change ()
170   "Goto next change."
171   (interactive)
172   (vc-got-stage--prevnext-change +1))
173 
174 (defun vc-got-stage--delete-overlay-at (point)
175   "Delete overlays at POINT.
176 Return t if something was deleted."
177   (let (delp)
178     (cl-delete-if (lambda (overlay)
179                     (let ((start (overlay-start overlay)))
180                       ;; silently drop dangling overlays
181                       (cond ((not start)
182                              t)
183                             ((= point start)
184                              (delete-overlay overlay)
185                              (setq delp t)))))
186                   vc-got-stage--overlays)
187     delp))
188 
189 (defun vc-got-stage-toggle-mark ()
190   "Toggle the staged status on the change at point."
191   (interactive)
192   (when (vc-got-stage--in-change)
193     (save-excursion
194       (vc-got-stage-beginning-of-change)
195       (unless (vc-got-stage--delete-overlay-at (point))
196         (let ((overlay (make-overlay (point) (point))))
197           (overlay-put overlay
198                        'before-string
199                        (propertize "A"
200                                    'display '(left-fringe right-triangle)
201                                    'face    'vc-got-stage-staged-face))
202           (push overlay vc-got-stage--overlays))))))
203 
204 (provide 'vc-got-stage)
205 ;;; vc-got-stage.el ends here