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