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