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