1 ;;; vc-got.el --- VC backend for Game of Trees VCS   -*- lexical-binding: t; -*-
2 
3 ;; Copyright (C) 2020, 2021 Omar Polo
4 ;; Copyright (C) 2020, 2021 Timo Myyrä
5 
6 ;; Author: Omar Polo <op@omarpolo.com>
7 ;;         Timo Myyrä <timo.myyra@bittivirhe.fi>
8 ;; URL: https://git.omarpolo.com/vc-got/
9 ;; Keywords: vc tools
10 ;; Version: 0
11 ;; Package-Requires: ((emacs "25.1"))
12 
13 ;; This program is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
17 
18 ;; This program is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
21 ;; GNU General Public License for more details.
22 
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
25 
26 ;;; Commentary:
27 
28 ;; This file contains a VC backend for the Game of Trees (got) version
29 ;; control system.
30 
31 ;; Backend implementation status
32 ;;
33 ;; Function marked with `*' are required, those with `-' are optional.
34 ;;
35 ;; FUNCTION NAME                        STATUS
36 ;;
37 ;; BACKEND PROPERTIES:
38 ;; * revision-granularity               DONE
39 ;; - update-on-retrieve-tag             XXX: what should this do?
40 ;;
41 ;; STATE-QUERYING FUNCTIONS:
42 ;; * registered                         DONE
43 ;; * state                              DONE
44 ;; - dir-status-files                   DONE
45 ;; - dir-extra-headers                  DONE
46 ;; - dir-printer                        DONE
47 ;; - status-fileinfo-extra              NOT IMPLEMENTED
48 ;; * working-revision                   DONE
49 ;; * checkout-model                     DONE
50 ;; - mode-line-string                   DONE
51 ;;
52 ;; STATE-CHANGING FUNCTIONS:
53 ;; * create-repo                        NOT IMPLEMENTED
54 ;;      I don't think got init does what this function is supposed to
55 ;;      do.
56 ;; * register                           DONE
57 ;; - responsible-p                      DONE
58 ;; - receive-file                       NOT NEEDED, default `register' is fine
59 ;; - unregister                         DONE
60 ;; * checkin                            DONE
61 ;; * find-revision                      DONE
62 ;; * checkout                           NOT IMPLEMENTED
63 ;;      I'm not sure how to properly implement this.  Does filling
64 ;;      FILE with the find-revision do the trick?  Or use got update?
65 ;; * revert                             DONE
66 ;; - merge-file                         NOT IMPLEMENTED
67 ;; - merge-branch                       DONE
68 ;; - merge-news                         NOT IMPLEMENTED
69 ;; - pull                               DONE
70 ;; - push                               DONE
71 ;; - steal-lock                         NOT NEEDED, `got' is not using locks
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 NEEDED
76 ;;      got notice by itself when a file doesn't have any pending
77 ;;      conflicts to be resolved.
78 ;; - find-admin-dir                     NOT NEEDED
79 ;;
80 ;; HISTORY FUNCTIONS
81 ;; * print-log                          DONE
82 ;; * log-outgoing                       DONE
83 ;; * log-incoming                       DONE
84 ;; - log-search                         DONE
85 ;; - log-view-mode                      DONE
86 ;; - show-log-entry                     NOT IMPLEMENTED
87 ;; - comment-history                    NOT IMPLEMENTED
88 ;; - update-changelog                   NOT IMPLEMENTED
89 ;; * diff                               DONE
90 ;; - revision-completion-table          DONE
91 ;; - annotate-command                   DONE
92 ;; - annotate-time                      DONE
93 ;; - annotate-current-time              NOT NEEDED
94 ;;      the default time handling is enough.
95 ;; - annotate-extract-revision-at-line  DONE
96 ;; - region-history                     NOT IMPLEMENTED
97 ;; - region-history-mode                NOT IMPLEMENTED
98 ;; - mergebase                          NOT IMPLEMENTED
99 ;;
100 ;; TAG SYSTEM
101 ;; - create-tag                         DONE
102 ;; - retrieve-tag                       DONE
103 ;;
104 ;; MISCELLANEOUS                        NOT IMPLEMENTED
105 ;; - make-version-backups-p             NOT NEEDED, `got' works fine locally
106 ;; - root                               DONE
107 ;; - ignore                             NOT NEEDED, the default action is good
108 ;; - ignore-completion-table            NOT NEEDED, the default action is good
109 ;; - find-ignore-file                   DONE
110 ;; - previous-revision                  DONE
111 ;; - next-revision                      DONE
112 ;; - log-edit-mode                      NOT IMPLEMENTED
113 ;; - check-headers                      NOT NEEDED, `got' does not use headers
114 ;; - delete-file                        DONE
115 ;; - rename-file                        NOT IMPLEMENTED
116 ;; - find-file-hook                     DONE
117 ;; - extra-menu                         NOT IMPLEMENTED
118 ;; - extra-dir-menu                     NOT IMPLEMENTED, same as above
119 ;; - conflicted-files                   DONE
120 ;; - repository-url                     DONE
121 
122 ;; TODO: vc-git has most function that starts with:
123 ;;
124 ;;    (let* ((root (vc-git-root default-directory))
125 ;;           (buffer (format "*vc-git : %s*" (expand-file-name root)))
126 ;;           ...)
127 ;;      ...)
128 ;;
129 ;; we should 1) investigate if also other backends do something like
130 ;; this (or if there is a better way) and 2) try to do the same.
131 
132 ;;; Code:
133 
134 (eval-when-compile
135   (require 'subr-x))
136 
137 (require 'cl-lib)
138 (require 'seq)
139 (require 'vc)
140 (require 'vc-annotate)
141 
142 ;; FIXME: avoid loading this?  We only need it for
143 ;; log-edit-extract-headers in vc-got-checkin.
144 (require 'log-edit)
145 
146 ;; FIXME: avoid loading this?  We only need it for
147 ;; vc-dir-filename-mouse-map in our custom printer.
148 (require 'vc-dir)
149 
150 ;; FIXME: avoid loading this?  We only need it for
151 ;; compilation-{directory,arguments}.
152 (require 'compile)
153 
154 ;; FIXME: avoid loading this?  We only need it for
155 ;; log-view-{file-re,per-file-logs,message-re}.
156 (require 'log-view)
157 
158 (defgroup vc-got nil
159   "VC GoT backend."
160   :group 'vc)
161 
162 (defcustom vc-got-program "got"
163   "Name of the Got executable (excluding any arguments)."
164   :type 'string)
165 
166 (defcustom vc-got-diff-switches t
167   "String or list of strings specifying switches for Got diff under VC.
168 If nil, use the value of `vc-diff-switches'.  If t, use no switches."
169   :type '(choice (const :tag "Unspecified" nil)
170                  (const :tag "None" t)
171                  (string :tag "Argument String")
172                  (repeat :tag "Argument List" :value ("") string)))
173 
174 ;; helpers
175 (defmacro vc-got--with-emacs-version<= (version &rest body)
176   "Eval BODY only when the Emacs version in greater or equal VERSION."
177   (declare (debug body)
178            (indent defun))
179   (when (version<= version emacs-version)
180     `(progn ,@body)))
181 
182 (defun vc-got--program-version ()
183   "Return string representing the got version."
184   (let (process-file-side-effects)
185     (with-temp-buffer
186       (vc-got--call "-V")
187       (substring (buffer-string) 4 -1))))
188 
189 (defun vc-got-root (file)
190   "Return the work tree root for FILE, or nil."
191   (vc-find-root file ".got"))
192 
193 (defmacro vc-got-with-worktree (file &rest body)
194   "Evaluate BODY in the work tree directory of FILE."
195   (declare (debug t) (indent defun))
196   `(when-let (default-directory (vc-got-root ,file))
197      ,@body))
198 
199 (defun vc-got--repo-root ()
200   "Return the path to the repository root.
201 Assume `default-directory' is inside a got worktree."
202   (vc-got-with-worktree default-directory
203     (with-temp-buffer
204       (insert-file-contents ".got/repository")
205       (string-trim (buffer-string) "" "\n"))))
206 
207 (defun vc-got--call (&rest args)
208   "Call `vc-got-program' with ARGS.
209 The output will be placed in the current buffer."
210   (apply #'process-file vc-got-program nil (current-buffer) nil
211          (apply #'nconc (mapcar (lambda (s) (if (listp s) s (list s))) args))))
212 
213 (defun vc-got--add (files)
214   "Add FILES to got, passing `vc-register-switches' to the command invocation."
215   (with-temp-buffer
216     (vc-got--call "add" vc-register-switches "--" files)))
217 
218 (defun vc-got--log (&optional path limit start-commit stop-commit
219                               search-pattern reverse)
220   "Execute the log command in the worktree of PATH in the current buffer.
221 LIMIT limits the maximum number of commit returned.
222 
223 START-COMMIT: start traversing history at the specified commit.
224 STOP-COMMIT: stop traversing history at the specified commit.
225 SEARCH-PATTERN: limit to log messages matched by the regexp given.
226 REVERSE: display the log messages in reverse order.
227 
228 Return nil if the command failed or if PATH isn't included in any
229 worktree."
230   (let ((process-file-side-effects nil))
231     (vc-got-with-worktree (or path default-directory)
232       (when (zerop
233              (save-excursion
234                (vc-got--call "log"
235                              (and limit (list "-l" (format "%s" limit)))
236                              (and start-commit (list "-c" start-commit))
237                              (and stop-commit (list "-x" stop-commit))
238                              (and search-pattern (list "-s" search-pattern))
239                              (and reverse '("-R"))
240                              "--"
241                              path)))
242         (save-excursion
243           (delete-matching-lines
244            "^-----------------------------------------------$")
245           t)))))
246 
247 (defun vc-got--status (status-codes dir-or-file &optional files)
248   "Return a list of lists '(FILE STATUS STAGE-STATUS).
249 DIR-OR-FILE can be either a directory or a file.  If FILES is
250 given, return the status of those files, otherwise the status of
251 DIR-OR-FILE.  STATUS-CODES is either nil, or a string that's
252 passed as the -s flag to got status to limit the types of status
253 to report (e.g. \"CD\" to report only conflicts and deleted
254 files)."
255   (with-temp-buffer
256     (let* ((default-directory (expand-file-name
257                                (if (file-directory-p dir-or-file)
258                                    dir-or-file
259                                  (file-name-directory dir-or-file))))
260            (root (vc-got-root default-directory))
261            (process-file-side-effects))
262       (when (zerop (vc-got--call "status"
263                                  (and status-codes (list "-s" status-codes))
264                                  "--"
265                                  (or files dir-or-file)))
266         (goto-char (point-min))
267         (cl-loop until (eobp)
268                  collect (vc-got--parse-status-line root)
269                  do (forward-line))))))
270 
271 (defun vc-got--parse-status-line (root)
272   "Parse a line of the the output of status.
273 ROOT is the root of the repo."
274   ;; the format of each line is
275   ;; <status-char> <stage-char> <spc> <filename> \n
276   (let* ((file-status (prog1 (vc-got--parse-status-char
277                               (char-after))
278                         (forward-char)))
279          (stage-status (let* ((c (char-after)))
280                          (prog1
281                              (when (member c '(?M ?A ?D))
282                                c)
283                            (forward-char))))
284          (filename (progn
285                      (forward-char)
286                      (buffer-substring (point)
287                                        (line-end-position)))))
288     (list (file-relative-name (expand-file-name filename root)
289                               default-directory)
290           (or file-status (and stage-status 'up-to-date))
291           stage-status)))
292 
293 (defun vc-got--parse-status-char (c)
294   "Parse status char C into a symbol accepted by `vc-state'."
295   (cl-case c
296     (?M 'edited)
297     (?A 'added)
298     (?D 'removed)
299     (?C 'conflict)
300     (?! 'missing)
301     (?~ 'edited) ; XXX: what does it means for a file to be ``obstructed''?
302     (?? 'unregistered)
303     (?m 'edited) ; modified file modes
304     (?N nil)))
305 
306 (defun vc-got--tree-parse ()
307   "Parse into an alist the output of got tree -i in the current buffer."
308   (goto-char (point-min))
309   (let (alist)
310     (while (re-search-forward "^\\([[:word:]]+\\) \\(?:.+\\)+$" nil t)
311       (push (cons (match-string 2) (match-string 1)) alist))
312     alist))
313 
314 (defun vc-got--tree (commit path)
315   "Return an alist representing the got tree command output.
316 The outputted tree will be localised in the given PATH at the
317 given COMMIT."
318   (vc-got-with-worktree path
319     (let ((process-file-side-effects nil))
320       (with-temp-buffer
321         (when (zerop (vc-got--call "tree" "-c" commit "-i" "--" path))
322           (vc-got--tree-parse))))))
323 
324 (defun vc-got--cat (commit obj-id)
325   "Execute got cat -c COMMIT OBJ-ID in the current buffer."
326   (let (process-file-side-effects)
327     (zerop (vc-got--call "cat" "-c" commit obj-id))))
328 
329 (defun vc-got--revert (&rest files)
330   "Execute got revert FILES."
331   (vc-got-with-worktree (car files)
332     (with-temp-buffer
333       (zerop (vc-got--call "revert" "--" files)))))
334 
335 (defun vc-got--list-branches ()
336   "Return an alist of (branch . commit)."
337   (let (process-file-side-effects)
338     (with-temp-buffer
339       (when (zerop (vc-got--call "branch" "-l"))
340         (let (alist)
341           (goto-char (point-min))
342           (while (re-search-forward "^\\* \\(.+\\): \\([[:word:]]+\\)$" nil t)
343             (push (cons (match-string 1) (match-string 2)) alist))
344           alist)))))
345 
346 (defun vc-got--current-branch ()
347   "Return the current branch."
348   (let (process-file-side-effects)
349     (with-temp-buffer
350       (when (zerop (vc-got--call "branch"))
351         (string-trim (buffer-string) "" "\n")))))
352 
353 (defun vc-got--integrate (branch)
354   "Integrate BRANCH into the current one."
355   (with-temp-buffer
356     (zerop (vc-got--call "integrate" branch))))
357 
358 (defun vc-got--update (branch &optional paths)
359   "Update to a different commit or BRANCH.
360 Optionally restrict the update operation to files at or within
361 the specified PATHS."
362   (with-temp-buffer
363     (unless (zerop (vc-got--call "update" "-b" branch "--" paths))
364       (error "[vc-got] can't update to branch %s: %s"
365              branch
366              (buffer-string)))))
367 
368 (defun vc-got--diff (&rest files)
369   "Call got diff against FILES.
370 The result will be stored in the current buffer."
371   (let (process-file-side-effects)
372     (zerop (vc-got--call "diff"
373                          (vc-switches 'got 'diff)
374                          "--"
375                          (mapcar #'file-relative-name files)))))
376 
377 (defun vc-got--unstage (file-or-directory)
378   "Unstage all the staged hunks at or within FILE-OR-DIRECTORY.
379 If it's nil, unstage every staged changes across the entire work
380 tree."
381   (zerop (vc-got--call "unstage" "--" file-or-directory)))
382 
383 (defun vc-got--remove (file &optional force keep-local)
384   "Use got to remove FILE.
385 If FORCE is non-nil perform the operation even if a file contains
386 local modification.  If KEEP-LOCAL is non-nil keep the affected
387 files on disk."
388   (vc-got-with-worktree (or file default-directory)
389     (with-temp-buffer
390       (zerop (vc-got--call "remove"
391                            (and force "-f")
392                            (and keep-local "-k")
393                            "--"
394                            file)))))
395 
396 (defun vc-got--ref ()
397   "Return a list of all references."
398   (let ((process-file-side-effects nil)
399         (re "^refs/\\(heads\\|remotes\\|tags\\)/\\(.*\\):")
400         ;; hardcoding HEAD because it's always present and the regexp
401         ;; won't match it.
402         (table (list "HEAD")))
403     (vc-got-with-worktree default-directory
404       (with-temp-buffer
405         (when (zerop (vc-got--call "ref" "-l"))
406           (goto-char (point-min))
407           (while (re-search-forward re nil t)
408             (push (match-string 2) table))
409           table)))))
410 
411 (defun vc-got--branch (name)
412   "Try to create and switch to the branch called NAME."
413   (let (process-file-side-effects)
414     (vc-got-with-worktree default-directory
415       (with-temp-buffer
416         (if (zerop (vc-got--call "branch" "--" name))
417             t
418           (error "[vc-got] can't create branch %s: %s" name
419                  (buffer-string)))))))
420 
421 
422 ;; Backend properties
423 
424 (defun vc-got-revision-granularity ()
425   "Got has REPOSITORY granularity."
426   'repository)
427 
428 (defun vc-got-update-on-retrieve-tag ()
429   "Like vc-git, vc-got don't need to buffers on `retrieve-tag'."
430   nil)
431 
432 
433 ;; State-querying functions
434 
435 ;;;###autoload (defun vc-got-registered (file)
436 ;;;###autoload   "Return non-nil if FILE is registered with got."
437 ;;;###autoload   (when (vc-find-root file ".got")
438 ;;;###autoload     (load "vc-got" nil t)
439 ;;;###autoload     (vc-got-registered file)))
440 
441 (defun vc-got-registered (file)
442   "Return non-nil if FILE is registered with got."
443   (if (file-directory-p file)
444       nil                               ; got doesn't track directories
445     (when (vc-find-root file ".got")
446       (let ((s (vc-got-state file)))
447         (not (or (eq s 'unregistered)
448                  (null s)))))))
449 
450 (defun vc-got-state (file)
451   "Return the current version control state of FILE.  See `vc-state'."
452   (unless (file-directory-p file)
453     (let (process-file-side-effects)
454       ;; Manually calling got status and checking the result inline to
455       ;; avoid building the data structure in vc-got--status.
456       (with-temp-buffer
457         (when (zerop (vc-got--call "status" "--" file))
458           (goto-char (point-min))
459           (if (eobp)
460               'up-to-date
461             (vc-got--parse-status-char (char-after))))))))
462 
463 (defun vc-got--dir-filter-files (files)
464   "Remove ., .. and .got from FILES."
465   (cl-loop for file in files
466            unless (or (string= file "..")
467                       (string= file ".")
468                       (string= file ".got"))
469            collect file))
470 
471 (defun vc-got-dir-status-files (dir files update-function)
472   "Build the status for FILES in DIR.
473 The builded result is given to the callback UPDATE-FUNCTION.  If
474 FILES is nil, consider all the files in DIR."
475   (let* ((fs (vc-got--dir-filter-files (or files (directory-files dir))))
476          ;; XXX: we call with files, wich will probably be nil on the
477          ;; first run, so we catch deleted, missing and edited files
478          ;; in subdirectories.
479          (res (vc-got--status nil dir files))
480          double-check)
481     (cl-loop for file in fs
482              do (when (and (not (cdr (assoc file res #'string=)))
483                            (not (file-directory-p file))
484                            ;; if file doesn't exists, it's a
485                            ;; untracked file that was removed.
486                            (file-exists-p file))
487                   ;; if we don't know the status of a file here, it's
488                   ;; either up-to-date or ignored.  Save it for a
489                   ;; double check
490                   (push file double-check)))
491     (cl-loop with statuses = (vc-got--status nil dir double-check)
492              for file in double-check
493              unless (eq 'unregistered (cadr (assoc file statuses #'string=)))
494              do (push (list file 'up-to-date nil) res))
495     (funcall update-function res nil)))
496 
497 (defun vc-got-dir-extra-headers (dir)
498   "Return a string for the `vc-dir' buffer heading for directory DIR."
499   (let ((remote (vc-got-repository-url dir)))
500     (concat (propertize "Repository : " 'face 'font-lock-type-face)
501             (vc-got--repo-root) "\n"
502             (when remote
503               (concat
504                (propertize "Remote URL : " 'face 'font-lock-type-face)
505                (vc-got-repository-url dir) "\n"))
506             (propertize "Branch     : " 'face 'font-lock-type-face)
507             (vc-got--current-branch))))
508 
509 (defun vc-got-dir-printer (info)
510   "Pretty-printer for the vc-dir-fileinfo structure INFO."
511   (let* ((isdir (vc-dir-fileinfo->directory info))
512          (state (if isdir "" (vc-dir-fileinfo->state info)))
513          (stage-state (vc-dir-fileinfo->extra info))
514          (filename (vc-dir-fileinfo->name info)))
515     (insert
516      "  "
517      (propertize
518       (format "%c" (if (vc-dir-fileinfo->marked info) ?* ? ))
519       'face 'font-lock-type-face)
520      "  "
521      (propertize
522       (format "%-12s" state)
523       'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face)
524                   ((memq state '(missing conflict)) 'font-lock-warning-face)
525                   ((eq state 'edited) 'font-lock-constant-face)
526                   (t 'font-lock-variable-name-face))
527       'mouse-face 'highlight
528       'keymap (vc-got--with-emacs-version<= "28.0.50"
529                 vc-dir-status-mouse-map))
530 
531      "   " (propertize
532             (if stage-state
533                 (format "%c" stage-state)
534               " ")
535             'face (cond ((memq stage-state '(?A ?E)) 'font-lock-constant-face)
536                         ((eq stage-state ?R) 'font-lock-warning-face)
537                         (t 'font-lock-variable-name-face)))
538      "    "
539      (propertize filename
540                  'face (if isdir 'font-lock-comment-delimiter-face
541                          'font-lock-function-name-face)
542                  'help-echo
543                  (if isdir
544                      (concat
545                       "Directory\n"
546                       "VC operations can be applied to it\n"
547                       "mouse-3: Pop-up menu")
548                    "File\nmouse-3: Pop-up menu")
549                  'mouse-face 'highlight
550                  'keymap vc-dir-filename-mouse-map))))
551 
552 (defun vc-got-working-revision (file)
553   "Return the last commit that touched FILE or \"0\" if it's newly added."
554   (or
555    (with-temp-buffer
556      (when (vc-got--log file 1)
557        (let (start)
558          (goto-char (point-min))
559          (forward-word)                 ; skip "commit"
560          (forward-char)                 ; skip the space
561          (setq start (point))           ; store start of the SHA
562          (forward-word)                 ; goto SHA end
563          (buffer-substring start (point)))))
564    ;; special case: if this file is added but has no previous commits
565    ;; touching it, got log will fail (as expected), but we have to
566    ;; return "0".
567    (when (eq (vc-got-state file) 'added)
568      "0")))
569 
570 (defun vc-got-checkout-model (_files)
571   "Return the checkout model.
572 Got uses an implicit checkout model for every file."
573   'implicit)
574 
575 (defun vc-got-mode-line-string (file)
576   "Return the VC mode line string for FILE."
577   (vc-got-with-worktree file
578     (let ((def (vc-default-mode-line-string 'Got file)))
579       (concat (substring def 0 4) (vc-got--current-branch)))))
580 
581 
582 ;; state-changing functions
583 
584 (defun vc-got-create-repo (_backend)
585   "Create an empty repository in the current directory."
586   (error "[vc-got] create-repo not implemented"))
587 
588 (defun vc-got-register (files &optional _comment)
589   "Register FILES, passing `vc-register-switches' to the backend command."
590   (vc-got--add files))
591 
592 (defalias 'vc-got-responsible-p #'vc-got-root)
593 
594 (defun vc-got-unregister (file)
595   "Unregister FILE."
596   (vc-got--remove file t t))
597 
598 (defun vc-got-checkin (files comment &optional _rev)
599   "Commit FILES with COMMENT as commit message."
600   (with-temp-buffer
601     (unless (zerop (vc-got--call "commit" "-m"
602                                  (log-edit-extract-headers nil comment)
603                                  "--"
604                                  files))
605       (error "[vc-got] can't commit: %s" (buffer-string)))))
606 
607 (defun vc-got-find-revision (file rev buffer)
608   "Fill BUFFER with the content of FILE in the given revision REV."
609   (when-let (obj-id (assoc file (vc-got--tree rev file) #'string=))
610     (with-current-buffer buffer
611       (vc-got-with-worktree file
612         (vc-got--cat rev obj-id)))))
613 
614 (defun vc-got-checkout (_file &optional _rev)
615   "Checkout revision REV of FILE.
616 If REV is t, checkout from the head."
617   (error "[vc-got] checkout not implemented"))
618 
619 (defun vc-got-revert (file &optional _content-done)
620   "Revert FILE back to working revision."
621   (vc-got--revert file))
622 
623 (defun vc-got-merge-branch ()
624   "Prompt for a branch and integrate it into the current one."
625   ;; XXX: be smart and try to "got rebase" if "got integrate" fails?
626   (let* ((branches (cl-loop for (branch . commit) in (vc-got--list-branches)
627                             collect branch))
628          (branch (completing-read "Merge from branch: " branches)))
629     (when branch
630       (vc-got--integrate branch))))
631 
632 (defun vc-got--proc-filter (proc s)
633   "Custom output filter for async process PROC.
634 It's like `vc-process-filter' but supports \r inside S."
635   (let ((buffer (process-buffer proc)))
636     (when (buffer-live-p buffer)
637       (with-current-buffer buffer
638         (save-excursion
639           (let ((buffer-undo-list t)
640                 (inhibit-read-only t))
641             (goto-char (process-mark proc))
642             (if (not (string-match ".*\r\\(.*\\)" s))
643                 (insert s)
644               ;; handle \r
645               (end-of-line)
646               (let ((end (point)))
647                 (beginning-of-line)
648                 (delete-region (point) end))
649               (insert (match-string 1 s)))
650             (set-marker (process-mark proc) (point))))))))
651 
652 (defun vc-got--push-pull (cmd op prompt)
653   "Execute CMD OP, or prompt the user if PROMPT is non-nil."
654   (let ((buffer (format "*vc-got : %s*" (expand-file-name default-directory))))
655     (when-let (cmd (if prompt
656                        (split-string
657                         (read-shell-command (format "%s %s command: " cmd op)
658                                             (format "%s %s " cmd op))
659                         " " t)
660                      (list cmd op)))
661       (apply #'vc-do-async-command buffer default-directory cmd)
662       ;; this comes from vc-git.el.  We're using git to push, so in
663       ;; part it makes sense, but we should revisit for full Got
664       ;; support.
665       (with-current-buffer buffer
666         (vc-compilation-mode 'got)
667         (let ((comp-cmd (mapconcat #'identity cmd " "))
668               (proc (get-buffer-process buffer)))
669           (setq-local compile-command comp-cmd)
670           (setq-local compilation-directory default-directory)
671           (setq-local compilation-arguments (list comp-cmd
672                                                   nil
673                                                   (lambda (_ign) buffer)
674                                                   nil))
675           ;; Setup a custom process filter that handles \r.
676           (set-process-filter proc #'vc-got--proc-filter)))
677       (vc-set-async-update buffer))))
678 
679 ;; TODO: this could be expanded.  After a pull the worktree needs to
680 ;; be updated, either with a ``got update -b branch-name'' and
681 ;; eventually a rebase.
682 (defun vc-got-pull (prompt)
683   "Execute a pull prompting for the full command if PROMPT is not nil."
684   (let ((default-directory (vc-got-root default-directory)))
685     (vc-got--push-pull vc-got-program "fetch" prompt)))
686 
687 (defun vc-got-push (prompt)
688   "Run git push (not got!) in the repository dir.
689 If PROMPT is non-nil, prompt for the git command to run."
690   (let ((default-directory (vc-got--repo-root)))
691     (vc-got--push-pull vc-got-program "send" prompt)))
692 
693 
694 ;; History functions
695 
696 (defun vc-got-print-log (files buffer &optional _shortlog start-revision limit)
697   "Insert the revision log for FILES into BUFFER.
698 LIMIT limits the number of commits, optionally starting at
699 START-REVISION."
700   (with-current-buffer buffer
701     ;; the *vc-diff* may be read only
702     (let ((inhibit-read-only t))
703       (cl-loop for file in files
704                do (vc-got--log (file-relative-name file)
705                                limit
706                                start-revision)))))
707 
708 (defun vc-got-log-outgoing (buffer remote-location)
709   "Fill BUFFER with the diff between the local worktree branch and REMOTE-LOCATION."
710   (vc-setup-buffer buffer)
711   (let ((rl (vc-got-next-revision
712              nil
713              (if (or (not remote-location) (string-empty-p remote-location))
714                  (concat "origin/" (vc-got--current-branch))
715                remote-location)))
716         (inhibit-read-only t))
717     (with-current-buffer buffer
718       (vc-got--log nil nil nil rl))))
719 
720 (defun vc-got-incoming (buffer remote-location)
721   "Fill BUFFER with the diff between the REMOTE-LOCATION and the local worktree branch."
722   (let ((rl (if (or (not remote-location) (string-empty-p remote-location))
723                 (concat "origin/" (vc-got--current-branch))
724               remote-location))
725         (inhibit-read-only t))
726     (with-current-buffer buffer
727       (vc-got--log nil nil (vc-got--current-branch) rl))))
728 
729 (defun vc-got-log-search (buffer pattern)
730   "Search commits for PATTERN and write the results found in BUFFER."
731   (with-current-buffer buffer
732     (let ((inhibit-read-only t))
733       (vc-got--log nil nil nil nil pattern))))
734 
735 (define-derived-mode vc-got-log-view-mode log-view-mode "Got-Log-View"
736   "Got-specific log-view mode.
737 Heavily inspired by `vc-git-log-view-mode'."
738   (require 'add-log)
739   (setq-local log-view-file-re regexp-unmatchable)
740   (setq-local log-view-per-file-logs nil)
741   (setq-local log-view-message-re "^commit +\\([0-9a-z]+\\)")
742   (setq-local log-view-font-lock-keywords
743               (append
744                `((,log-view-message-re (1 'change-log-acknowledgment)))
745                ;; Handle the case:
746                ;; user: foo@bar
747                '(("^from: \\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
748                   (1 'change-log-email))
749                  ;; Handle the case:
750                  ;; user: FirstName LastName <foo@bar>
751                  ("^from: \\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
752                   (1 'change-log-name)
753                   (2 'change-log-email))
754                  ("^date: \\(.+\\)" (1 'change-log-date))))))
755 
756 ;; TODO: async
757 ;; TODO: return 0 or 1
758 (defun vc-got-diff (files &optional rev1 rev2 buffer _async)
759   "Insert into BUFFER (or *vc-diff*) the diff for FILES from REV1 to REV2."
760   (let* ((buffer (get-buffer-create (or buffer "*vc-diff*")))
761          (inhibit-read-only t))
762     (with-current-buffer buffer
763       (vc-got-with-worktree (or (car files)
764                                 default-directory)
765         (if (and (null rev1)
766                  (null rev2))
767             (dolist (file files)
768               (vc-got--diff file))
769           ;; TODO: if rev1 is nil, diff from the current version until
770           ;; rev2.
771           ;;
772           ;; TODO: if rev2 is nil as well, diff against an empty tree
773           ;; (i.e. get the patch from `got log -p rev1')
774           ;;
775           ;; TODO: it would be nice to optionally include FILES here,
776           ;; it would make the `=' key on the *Annotate* buffer do the
777           ;; right thing, but AFAICS got doesn't provide something
778           ;; like this.  Probably only hacking something with ``log
779           ;; -p'' and filtering?
780           (vc-got--diff rev1 rev2))))))
781 
782 (defun vc-got-revision-completion-table (_files)
783   "Return a completion table for existing revisions.
784 Ignores FILES because GoT doesn't have the concept of ``file
785 revisions''; instead, like with git, you have tags and branches."
786   (letrec ((table (lazy-completion-table
787                    table (lambda () (vc-got--ref)))))
788     table))
789 
790 (defun vc-got-annotate-command (file buf &optional rev)
791   "Show annotated contents of FILE in buffer BUF.  If given, use revision REV."
792   (let (process-file-side-effects)
793     (with-current-buffer buf
794       ;; FIXME: vc-ensure-vc-buffer won't recognise this buffer as managed
795       ;; by got unless vc-parent-buffer points to a buffer managed by got.
796       ;; investigate why this is needed.
797       (setq-local vc-parent-buffer (find-file-noselect file))
798       (vc-got--call "blame"
799                     (when rev (list "-c" rev))
800                     "--"
801                     file))))
802 
803 (defconst vc-got--annotate-re
804   (concat "^[0-9]\\{1,\\}) " ; line number followed by )
805           "\\([a-z0-9]+\\) " ; SHA-1 of commit
806           "\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\) " ; year-mm-dd
807           "\\([^ ]\\)+ ")    ; author
808   "Regexp to match annotation output lines.
809 
810 Provides capture groups for:
811 1. revision id
812 2. date of commit
813 3. author of commit")
814 
815 (defconst vc-got--commit-re "^commit \\([a-z0-9]+\\)"
816   "Regexp to match commit lines.
817 
818 Provides capture group for the commit revision id.")
819 
820 (defun vc-got-annotate-time ()
821   "Return the time of the next line of annotation at or after point.
822 Value is returned as floating point fractional number of days."
823   (save-excursion
824     (beginning-of-line)
825     (when (looking-at vc-got--annotate-re)
826       (let ((str (match-string-no-properties 2)))
827         (vc-annotate-convert-time
828          (encode-time 0 0 0
829                       (string-to-number (substring str 8 10))
830                       (string-to-number (substring str 5 7))
831                       (string-to-number (substring str 0 4))))))))
832 
833 (defun vc-got-annotate-extract-revision-at-line ()
834   "Return revision corresponding to the current line or nil."
835   (save-excursion
836     (beginning-of-line)
837     (when (looking-at vc-got--annotate-re)
838       (match-string-no-properties 1))))
839 
840 
841 ;; Tag system
842 
843 (defun vc-got--tag-callback (tag)
844   "`log-edit' callback for `vc-got-create-tag'.
845 Creates the TAG using the content of the current buffer."
846   (interactive)
847   (let ((msg (buffer-substring-no-properties (point-min)
848                                              (point-max))))
849     (with-temp-buffer
850       (unless (zerop (vc-got--call "tag"
851                                    "-m"
852                                    (log-edit-extract-headers nil msg)
853                                    "--"
854                                    tag))
855         (error "[vc-got] can't create tag %s: %s" tag (buffer-string))))))
856 
857 (defun vc-got-create-tag (_dir name branchp)
858   "Attach the tag NAME to the state of the worktree.
859 DIR is ignored (tags are global, not per-file).  If BRANCHP is
860 true, NAME should create a new branch otherwise it will pop-up a
861 `log-edit' buffer to provide the tag message."
862   ;; TODO: vc reccomends to ensure that all the file are in a clean
863   ;; state, but is it useful?
864   (if branchp
865       (vc-got--branch name)
866     (let ((buf (get-buffer-create "*vc-got tag*")))
867       (with-current-buffer buf
868         (erase-buffer)
869         (save-excursion
870           (insert "Summary: tag " name "\n\n"))
871         (move-end-of-line 1)
872         (switch-to-buffer buf)
873         (log-edit (lambda ()
874                     (interactive)
875                     (unwind-protect
876                         (vc-got--tag-callback name)
877                       (kill-buffer buf))))))))
878 
879 (defun vc-got-retrieve-tag (dir name _update)
880   "Switch to the tag NAME for files at or below DIR."
881   (let ((default-directory dir))
882     (vc-got--update name dir)))
883 
884 
885 ;; Miscellaneous
886 
887 (defun vc-got-find-ignore-file (file)
888   "Return the gitignore file that controls FILE."
889   (expand-file-name ".gitignore"
890                     (vc-got-root file)))
891 
892 (defun vc-got-previous-revision (file rev)
893   "Return the revision number that precedes REV for FILE or nil."
894   (with-temp-buffer
895     (vc-got--log file 2 rev nil nil t)
896     (goto-char (point-min))
897     (keep-lines "^commit")
898     (when (looking-at vc-got--commit-re)
899       (match-string-no-properties 1))))
900 
901 (defun vc-got-next-revision (file rev)
902   "Return the revision number that follows REV for FILE or nil."
903   (with-temp-buffer
904     (vc-got--log file nil nil rev)
905     (keep-lines "^commit" (point-min) (point-max))
906     (goto-char (point-max))
907     (forward-line -1)    ; return from empty line to last actual commit
908     (unless (= (point) (point-min))
909       (forward-line -1)
910       (when (looking-at vc-got--commit-re)
911         (match-string-no-properties 1)))))
912 
913 (defun vc-got-delete-file (file)
914   "Delete FILE locally and mark it deleted in work tree."
915   (vc-got--remove file t))
916 
917 (defun vc-got-find-file-hook ()
918   "Activate `smerge-mode' if there is a conflict."
919   ;; just like vc-git-find-file-hook
920   (when (and buffer-file-name
921              (eq (vc-state buffer-file-name 'Got) 'conflict)
922              (save-excursion
923                (goto-char (point-min))
924                (re-search-forward "^<<<<<<< " nil 'noerror)))
925     (smerge-start-session)
926     (vc-message-unresolved-conflicts buffer-file-name)))
927 
928 (defun vc-got-conflicted-files (dir)
929   "Return the list of files with conflicts in directory DIR."
930   (let* ((root (vc-got-root dir))
931          (default-directory root)
932          (process-file-side-effects nil))
933     (cl-loop for (file status _) in (vc-got--status "C" ".")
934              when (and (eq status 'conflict)
935                        (file-in-directory-p file dir))
936              collect file)))
937 
938 (defun vc-got-repository-url (_file &optional remote-name)
939   "Return URL for REMOTE-NAME, or for \"origin\" if nil."
940   (let* ((default-directory (vc-got--repo-root))
941          (remote-name (or remote-name "origin"))
942          (heading (concat "[remote \"" remote-name "\"]"))
943          (conf (cond ((file-exists-p ".git/config") ".git/config")
944                      ((file-exists-p ".git")        nil)
945                      ((file-exists-p "config")      "config")))
946          found)
947     (when conf
948       (with-temp-buffer
949         (insert-file-contents conf)
950         (goto-char (point-min))
951         (when (search-forward heading nil t)
952           (forward-line)
953           (while (and (not found)
954                       (looking-at ".*=") ; too broad?
955                       (not (= (point) (point-max))))
956             (when (looking-at ".*url = \\(.*\\)")
957               (setq found (match-string-no-properties 1)))
958             (forward-line))
959           found)))))
960 
961 (provide 'vc-got)
962 ;;; vc-got.el ends here