1 ;; vc-got.el --- Game of Tree backend for VC -*- lexical-binding: t; -*-
2 
3 ;; Copyright © 2020 Omar Polo <op@omarpolo.com>
4 
5 ;; This file is not part of GNU Emacs.
6 
7 ;; This file is free software.
8 ;;
9 ;; Permission to use, copy, modify, and distribute this software for
10 ;; any purpose with or without fee is hereby granted, provided that
11 ;; the above copyright notice and this permission notice appear in all
12 ;; copies.
13 ;;
14 ;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
15 ;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
16 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
17 ;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
18 ;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
19 ;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
20 ;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
21 ;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
22 
23 ;; Author: Omar Polo <op@omarpolo.com>
24 ;; URL: https://git.omarpolo.com/vc-got
25 ;; Keywords: vc vc-backend
26 
27 ;;; Commentary
28 
29 ;; Backend implementation status
30 ;;
31 ;; Function marked with `*' are required, those with `-' are optional.
32 ;;
33 ;; FUNCTION NAME                        STATUS
34 ;;
35 ;; BACKEND PROPERTIES:
36 ;; * revision-granularity               DONE
37 ;; - update-on-retrieve-tag             XXX: what should this do?
38 ;;
39 ;; STATE-QUERYING FUNCTIONS:
40 ;; * registered                         DONE
41 ;; * state                              DONE
42 ;; - dir-status-files                   DONE
43 ;; - dir-extra-headers                  DONE
44 ;; - dir-printer                        NOT IMPLEMENTED
45 ;; - status-fileinfo-extra              NOT IMPLEMENTED
46 ;; * working-revision                   DONE
47 ;; * checkout-model                     DONE
48 ;; - mode-line-string                   DONE
49 ;;
50 ;; STATE-CHANGING FUNCTIONS:
51 ;; * create-repo                        NOT IMPLEMENTED
52 ;;      I don't think got init does what this function is supposed to
53 ;;      do.
54 ;; * register                           DONE
55 ;; - responsible-p                      DONE
56 ;; - receive-file                       NOT IMPLEMENTED
57 ;; - unregister                         NOT IMPLEMENTED
58 ;;      use remove?
59 ;; * checkin                            DONE
60 ;; * find-revision                      DONE
61 ;; * checkout                           NOT IMPLEMENTED
62 ;;      I'm not sure how to properly implement this.  Does filling
63 ;;      FILE with the find-revision do the trick?  Or use got update?
64 ;; * revert                             DONE
65 ;; - merge-file                         NOT IMPLEMENTED
66 ;; - merge-branch                       DONE
67 ;; - merge-news                         NOT IMPLEMENTED
68 ;; - pull                               DONE
69 ;; - push                               DONE
70 ;;      uses git
71 ;; - steal-lock                         NOT IMPLEMENTED
72 ;; - modify-change-comment              NOT IMPLEMENTED
73 ;;      can be implemented via histedit, if I understood correctly
74 ;;      what it is supposed to do.
75 ;; - mark-resolved                      NOT IMPLEMENTED
76 ;; - find-admin-dir                     NOT IMPLEMENTED
77 ;;
78 ;; HISTORY FUNCTIONS
79 ;; * print-log                          DONE
80 ;; * log-outgoing                       DONE
81 ;; * log-incoming                       NOT IMPLEMENTED
82 ;; - log-search                         DONE
83 ;; - log-view-mode                      NOT IMPLEMENTED
84 
85 ;; TODO: use the idiom
86 ;;      (let (process-file-side-effects) ...)
87 ;; when the got command WON'T change the file.  This can enable some
88 ;; emacs optimizations
89 
90 ;; TODO: vc-git has most function that starts with:
91 ;;
92 ;;    (let* ((root (vc-git-root default-directory))
93 ;;           (buffer (format "*vc-git : %s*" (expand-file-name root)))
94 ;;           ...)
95 ;;      ...)
96 ;;
97 ;; we should 1) investigate if also other backends do something like
98 ;; this (or if there is a better way) and 2) try to do the same.
99 
100 ;;; Code:
101 
102 (eval-when-compile
103   (require 'subr-x))
104 
105 (require 'cl-lib)
106 (require 'cl-seq)
107 (require 'seq)
108 (require 'vc)
109 
110 (require 'vc-got-stage)
111 
112 (defvar vc-got-cmd "got"
113   "The got command.")
114 
115 ;; helpers
116 
117 (defun vc-got-root (file)
118   "Return the work tree root for FILE, or nil."
119   (or (vc-file-getprop file 'got-root)
120       (vc-file-setprop file 'got-root (vc-find-root file ".got"))))
121 
122 (defmacro vc-got-with-worktree (file &rest body)
123   "Evaluate BODY in the work tree directory of FILE."
124   (declare (indent defun))
125   `(when-let (default-directory (vc-got-root ,file))
126      ,@body))
127 
128 (defun vc-got--repo-root ()
129   "Return the path to the repository root.
130 Assume `default-directory' is inside a got worktree."
131   (vc-got-with-worktree default-directory
132     (with-temp-buffer
133       (insert-file-contents ".got/repository")
134       (string-trim (buffer-string) nil "\n"))))
135 
136 (defun vc-got--call (&rest args)
137   "Call `vc-got-cmd' in the `default-directory' with ARGS and put the output in the current buffer."
138   (apply #'process-file vc-got-cmd nil (current-buffer) nil args))
139 
140 (defun vc-got--add (files)
141   "Add FILES to got, passing `vc-register-switches' to the command invocation."
142   (with-temp-buffer
143     (apply #'vc-got--call "add" (append vc-register-switches files))))
144 
145 (defun vc-got--log (&optional path limit start-commit stop-commit search-pattern)
146   "Execute the log command in the worktree of PATH.
147 The output in the current buffer.
148 
149 LIMIT limits the maximum number of commit returned.
150 
151 START-COMMIT: start traversing history at the specified commit.
152 STOP-COMMIT: stop traversing history at the specified commit.
153 SEARCH-PATTERN: limit to log messages matched by the regexp given.
154 
155 Return nil if the command failed or if PATH isn't included in any
156 worktree."
157   (vc-got-with-worktree (or path default-directory)
158     (zerop
159      (apply #'vc-got--call
160             (cl-remove-if #'null
161                           (flatten-list
162                            (list "log"
163                                  (when limit (list "-l" (format "%s" limit)))
164                                  (when start-commit (list "-c" start-commit))
165                                  (when stop-commit (list "-x" stop-commit))
166                                  (when search-pattern (list "-s" search-pattern))
167                                  path)))))))
168 
169 (defun vc-got--status (dir-or-file &rest files)
170   "Return the output of ``got status''.
171 
172 DIR-OR-FILE can be either a directory or a file.  If FILES is
173 given, return the status of those files, otherwise the status of
174 DIR-OR-FILE."
175   (vc-got-with-worktree dir-or-file
176     (with-temp-buffer
177       (if files
178           (apply #'vc-got--call "status" files)
179         (vc-got--call "status" dir-or-file))
180       (buffer-string))))
181 
182 (defun vc-got--parse-status-flag (flag)
183   "Parse FLAG, see `vc-state'."
184   ;; got outputs nothing if the file is up-to-date
185   (if (string-empty-p flag)
186       'up-to-date
187     ;; trying to follow the order of the manpage
188     (cl-case (aref flag 0)
189       (?M 'edited)
190       (?A 'added)
191       (?D 'removed)
192       (?C 'conflict)
193       (?! 'missing)
194       (?~ 'edited) ;XXX: what does it means for a file to be ``obstructed''?
195       (?? 'unregistered)
196       (?m 'edited) ;modified file modes
197       (?N nil))))
198 
199 (defun vc-got--parse-status (output)
200   "Parse the OUTPUT of got status and return an alist of (FILE . STATUS)."
201   ;; XXX: the output of got is line-oriented and will break if
202   ;; filenames contains spaces or newlines.
203   (cl-loop for line in (split-string output "\n" t)
204            collect (cl-destructuring-bind (status file) (split-string line " " t " ")
205                      `(,file . ,(vc-got--parse-status-flag status)))))
206 
207 (defun vc-got--tree-parse ()
208   "Parse into an alist the output of got tree -i in the current buffer."
209   (goto-char (point-min))
210   (cl-loop
211    until (= (point) (point-max))
212    collect (let* ((obj-start (point))
213                   (_ (forward-word))
214                   (obj (buffer-substring obj-start (point)))
215                   (_ (forward-char))         ;skip the space
216                   (filename-start (point))
217                   (_ (move-end-of-line nil))
218                   (filename (buffer-substring filename-start (point))))
219              ;; goto the start of the next line
220              (forward-line)
221              (move-beginning-of-line nil)
222              `(,filename . ,obj))))
223 
224 (defun vc-got--tree (commit path)
225   (vc-got-with-worktree path
226     (with-temp-buffer
227       (vc-got--call "tree" "-c" commit "-i" path)
228       (vc-got--tree-parse))))
229 
230 (defun vc-got--cat (commit obj-id)
231   "Execute got cat -c COMMIT OBJ-ID in the current buffer."
232   (vc-got--call "cat" "-c" commit obj-id))
233 
234 (defun vc-got--revert (&rest files)
235   "Execute got revert FILES..."
236   (vc-got-with-worktree (car files)
237     (with-temp-buffer
238       (apply #'vc-got--call "revert" files))))
239 
240 (defun vc-got--list-branches ()
241   "Return an alist of (branch . commit)."
242   (with-temp-buffer
243     (when (zerop (vc-got--call "branch" "-l"))
244       (goto-char (point-min))
245       (cl-loop
246        until (= (point) (point-max))
247        ;; parse the `* $branchname: $commit', from the end
248        collect (let* ((_ (move-end-of-line nil))
249                       (end-commit (point))
250                       (_ (backward-word))
251                       (start-commit (point))
252                       (_ (backward-char 2))
253                       (end-branchname (point))
254                       (_ (move-beginning-of-line nil))
255                       (_ (forward-char 2))
256                       (start-branchname (point))
257                       (branchname (buffer-substring start-branchname end-branchname))
258                       (commit (buffer-substring start-commit end-commit)))
259                  (forward-line)
260                  (move-beginning-of-line nil)
261                  `(,branchname . ,commit))))))
262 
263 (defun vc-got--current-branch ()
264   "Return the current branch."
265   (with-temp-buffer
266     (when (zerop (vc-got--call "branch"))
267       (string-trim (buffer-string) "" "\n"))))
268 
269 (defun vc-got--integrate (branch)
270   "Integrate BRANCH into the current one."
271   (with-temp-buffer
272     (vc-got--call "integrate" branch)))
273 
274 (defun vc-got--diff (&rest args)
275   "Call got diff with ARGS.  The result will be stored in the current buffer."
276   (apply #'vc-got--call "diff"
277          (mapcar #'file-relative-name args)))
278 
279 
280 ;; Backend properties
281 
282 (defun vc-got-revision-granularity ()
283   "Got has REPOSITORY granularity."
284   'repository)
285 
286 ;; XXX: what this should do?  The description is not entirely clear
287 (defun vc-got-update-on-retrieve-tag ()
288   nil)
289 
290 
291 ;; State-querying functions
292 
293 ;;;###autoload (defun vc-got-registered (file)
294 ;;;###autoload   "Return non-nil if FILE is registered with got."
295 ;;;###autoload   (when (vc-find-root file ".got")
296 ;;;###autoload     (load "vc-got" nil t)
297 ;;;###autoload     (vc-got-registered file)))
298 
299 (defun vc-got-registered (file)
300   "Return non-nil if FILE is registered with got."
301   (if (file-directory-p file)
302       nil                               ;got doesn't track directories
303     (when (vc-find-root file ".got")
304       (let ((status (vc-got--status file)))
305         (not (or (string-prefix-p "?" status)
306                  (string-prefix-p "N" status)))))))
307 
308 ;; (vc-got-registered "/usr/ports/mystuff/net/td")
309 ;; (vc-got-registered "/usr/ports/mystuff/net/td/Makefile")
310 ;; (vc-got-registered "/usr/ports/mystuff/tmp")
311 ;; (vc-got-registered "/usr/ports/mystuff/no-existant")
312 
313 (defun vc-got-state (file)
314   "Return the current version control state of FILE.  See `vc-state'."
315   (unless (file-directory-p file)
316     (vc-got--parse-status-flag (vc-got--status file))))
317 
318 ;; (vc-got-state "/usr/ports/mystuff/net/td")
319 ;; (vc-got-state "/usr/ports/mystuff/net/td/Makefile")
320 ;; (vc-got-state "/usr/ports/mystuff/tmp")
321 ;; (vc-got-state "/usr/ports/mystuff/non-existant")
322 
323 (defun vc-got-dir-status-files (dir files update-function)
324   (let* ((files (seq-filter (lambda (file)
325                               (and (not (string= file ".."))
326                                    (not (string= file "."))
327                                    (not (string= file ".got"))))
328                             (or files
329                                 (directory-files dir))))
330          (statuses (vc-got--parse-status
331                     (apply #'vc-got--status dir files)))
332          (default-directory dir))
333     (cl-loop
334      with result = nil
335      for file in files
336      do (setq result
337               (cons
338                (if (file-directory-p file)
339                    (list file 'unregistered nil)
340                  (if-let (status (cdr (assoc file statuses #'string=)))
341                      (list file status nil)
342                    (list file 'up-to-date nil)))
343                result))
344      finally (funcall update-function result nil))))
345 
346 ;; (let ((dir "/usr/ports/mystuff"))
347 ;;   (vc-got-dir-status-files dir nil (lambda (res _t)
348 ;;                                      (message "got %s" res))))
349 
350 (defun vc-got-dir-extra-headers (_dir)
351   (concat
352    (propertize "Branch     : " 'face 'font-lock-type-face)
353    (vc-got--current-branch)))
354 
355 (defun vc-got-working-revision (file)
356   "Return the id of the last commit that touched the FILE or \"0\" for a new (but added) file."
357   (or
358    (with-temp-buffer
359      (when (vc-got--log file 1)
360        (let (start)
361          (goto-char (point-min))
362          (forward-line 1)               ;skip the ----- line
363          (forward-word)                 ;skip "commit"
364          (forward-char)                 ;skip the space
365          (setq start (point))           ;store start of the SHA
366          (forward-word)                 ;goto SHA end
367          (buffer-substring start (point)))))
368    ;; special case: if this file is added but has no previous commits
369    ;; touching it, got log will fail (as expected), but we have to
370    ;; return "0".
371    (when (eq (vc-got-state file) 'added)
372      "0")))
373 
374 ;; (vc-got-working-revision "/usr/ports/mystuff/non-existant")
375 ;; (vc-got-working-revision "/usr/ports/mystuff/CVS")
376 ;; (vc-got-working-revision "/usr/ports/mystuff/tmp")
377 ;; (vc-got-working-revision "/usr/ports/mystuff/net/td/Makefile")
378 
379 (defun vc-got-checkout-model (_files)
380   'implicit)
381 
382 (defun vc-got-mode-line-string (file)
383   "Return the VC mode line string for FILE."
384   (vc-got-with-worktree file
385     (let ((def (vc-default-mode-line-string 'Got file)))
386       (concat (substring def 0 4) (vc-got--current-branch)))))
387 
388 
389 ;; state-changing functions
390 
391 (defun vc-got-create-repo (_backend)
392   (error "vc got: create-repo not implemented"))
393 
394 (defun vc-got-register (files &optional _comment)
395   "Register FILES, passing `vc-register-switches' to the backend command."
396   (vc-got--add files))
397 
398 (defalias 'vc-got-responsible-p #'vc-got-root)
399 
400 (defun vc-got-checkin (files comment &optional _rev)
401   "Commit FILES with COMMENT as commit message."
402   (with-temp-buffer
403     (apply #'vc-got--call "commit" "-m"
404            ;; emacs add ``Summary:'' at the start of the commit
405            ;; message.  vc-git doesn't seem to treat this specially.
406            ;; Since it's annoying, remove it.
407            (string-remove-prefix "Summary: " comment)
408            files)))
409 
410 (defun vc-got-find-revision (file rev buffer)
411   "Fill BUFFER with the content of FILE in the given revision REV."
412   (when-let (obj-id (assoc file (vc-got--tree rev file) #'string=))
413     (with-current-buffer buffer
414       (vc-got-with-worktree file
415         (vc-got--cat rev obj-id)))))
416 
417 (defun vc-got-find-ignore-file (file)
418   "Return the gitignore file that controls FILE."
419   (expand-file-name ".gitignore"
420                     (vc-got-root file)))
421 
422 (defun vc-got-checkout (_file &optional _rev)
423   "Checkout revision REV of FILE.  If REV is t, checkout from the head."
424   (error "vc got: checkout not implemented"))
425 
426 (defun vc-got-revert (file &optional _content-done)
427   "Revert FILE back to working revision."
428   (vc-got--revert file))
429 
430 (defun vc-got-merge-branch ()
431   "Prompt for a branch and integrate it into the current one."
432   ;; XXX: be smart and try to "got rebase" if "got integrate" fails?
433   (let* ((branches (cl-loop for (branch . commit) in (vc-got--list-branches)
434                             collect branch))
435          (branch (completing-read "Merge from branch: " branches)))
436     (when branch
437       (vc-got--integrate branch))))
438 
439 (defun vc-got--push-pull (cmd op prompt root)
440   "Execute CMD OP, or prompt the user if PROMPT is non-nil.
441 ROOT is the worktree root."
442   (let ((buffer (format "*vc-got : %s*" (expand-file-name root))))
443     (when-let (cmd (if prompt
444                        (split-string
445                         (read-shell-command (format "%s %s command: " cmd op)
446                                             (format "%s %s" cmd op))
447                         " " t)
448                      (list cmd op)))
449       (apply #'vc-do-command buffer 0 (car cmd) nil (cdr cmd)))))
450 
451 (defun vc-got-pull (prompt)
452   "Execute got pull, prompting the user for the full command if PROMPT is not nil."
453   (vc-got--push-pull vc-got-cmd "fetch" prompt (vc-got-root default-directory)))
454 
455 (defun vc-got-push (prompt)
456   "Run git push (not got!) in the repository dir.
457 If PROMPT is non-nil, prompt for the git command to run."
458   (let* ((root (vc-got-root default-directory))
459          (default-directory (vc-got--repo-root)))
460     (vc-got--push-pull "git" "push" prompt root)))
461 
462 (defun vc-got-print-log (files buffer &optional _shortlog start-revision limit)
463   "Insert the revision log for FILES into BUFFER.
464 
465 LIMIT limits the number of commits, optionally starting at START-REVISION."
466   (with-current-buffer buffer
467     ;; the *vc-diff* may be read only
468     (let ((inhibit-read-only t))
469       (cl-loop for file in files
470                do (vc-got--log (file-relative-name file) limit start-revision)))))
471 
472 ;; XXX: this includes also the latest commit in REMOTE-LOCATION.
473 (defun vc-got-log-outgoing (buffer remote-location)
474   "Fill BUFFER with the diff between the local worktree branch and REMOTE-LOCATION."
475   (vc-setup-buffer buffer)
476   (let ((rl (if (or (not remote-location) (string-empty-p remote-location))
477                 (concat "origin/" (vc-got--current-branch))
478               remote-location))
479         (inhibit-read-only t))
480     (with-current-buffer buffer
481       (vc-got--log nil nil nil rl))))
482 
483 ;; XXX: vc.el specify only pattern, but in reality this takes a buffer
484 ;; and a pattern.
485 (defun vc-got-log-search (buffer pattern)
486   "Search commits for PATTERN and write the results found in BUFFER."
487   (with-current-buffer buffer
488     (let ((inhibit-read-only t))
489       (vc-got--log nil nil nil nil pattern))))
490 
491 ;; TODO: async
492 ;; TODO: we should append (vc-switches 'got 'diff) to the switches.
493 ;;       This by default is ("-u") and causes an error.
494 ;; TODO: return 0 or 1
495 (defun vc-got-diff (files &optional rev1 rev2 buffer _async)
496   "Insert into BUFFER (or *vc-diff*) the diff for FILES from REV1 to REV2."
497   (message "vc-got: debug: files is %s" files)
498   (let* ((buffer (get-buffer-create (or buffer "*vc-diff*")))
499          (inhibit-read-only t))
500     (with-current-buffer buffer
501       (vc-got-stage-mode +1)
502       ;; TODO: this shouldn't be done in an unconditioned fashion.  If
503       ;; we're diffing two revision, we can't stage hunks; we can
504       ;; stage only when diffing the local modifications.
505       (setq vc-got-stage-fileset files)
506       (vc-got-with-worktree (car files)
507         (cond ((and (null rev1)
508                     (null rev2))
509                (apply #'vc-got--diff files))
510               (t (error "Not implemented")))))))
511 
512 (provide 'vc-got)
513 ;;; vc-got.el ends here