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