;;; vc-pijul.el --- VC support for Pijul -*- lexical-binding: t; -*-
;; Copyright (C) 2022 Sévère Durand
;; Author: Sévère Durand <mmemmew@gmail.com>
;; Keywords: vc, tools, files
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This file implements support for the version control system PIJUL.
;;
;; See https://pijul.org for details about pijul.
;;
;; See the comments in the beginning of "vc.el" for information about
;; how to add a new backend to vc.
;;; Code:
;;; Clear the cache to force re-loading
(put 'pijul 'vc-functions nil)
;;; Variables
(defcustom vc-pijul-program "pijul"
"Name of the pijul command (excluding any arguments)."
:type 'string)
;;; VC backend functions
(defun vc-pijul-revision-granularity ()
"Pijul numbers at the repository-level, by hashes."
(declare (pure t) (side-effect-free t))
'repository)
(defun vc-pijul-update-on-retrieve-tag ()
"Tag support of pijul is unstable in my opinion."
(declare (pure t) (side-effect-free t))
nil)
;; NOTE: This is a cheap approximation that is autoloaded.
;; If it finds a possible match it loads this file and runs the real
;; function.
;;;###autoload (defun vc-pijul-registered (file)
;;;###autoload "Return non-nil if FILE is registered with pijul."
;;;###autoload (cond ((vc-find-root file ".pijul")
;;;###autoload (load "vc-pijul" nil t)
;;;###autoload (vc-pijul-registered file)))
(defun vc-pijul-registered (file)
"Return non-nil if FILE is registered with pijul."
(let ((root (vc-find-root file ".pijul")))
(cond
(root
(let ((file (file-relative-name file root)))
(with-temp-buffer
(cond
((vc-pijul--out-ok "ls")
(goto-char (point-min))
(and
(re-search-forward (format "^%s$" (regexp-quote file))
nil t)
t)))))))))
(declare-function rx-to-string "rx" (form &optional no-group))
(defun vc-pijul--point-status ()
"Return the status for the current line.
It is assumed that the point is at the beginning of a line, and
the line is the output from \"pijul diff\" for some file."
(cond
((= (point) (point-max)) 'up-to-date)
((looking-at-p
(rx-to-string '(seq bol
(or ?A "UD" ?D)
(or 32 ?,))
t))
'added)
((looking-at-p
(rx-to-string '(seq bol
(or "MV" "U")
(or 32 ?,))
t))
'unregistered)
((looking-at-p "^D[ ,]") 'removed)
((looking-at-p
(rx-to-string '(seq bol
(or "SC" "UC" ?M ?R "RZ")
(or 32 ?,))
t))
'edited)))
;; NOTE: "pijul diff file" returns the addition of FILE even if FILE
;; is not tracked by the repository. I think this is a bug. But this
;; means I have to call `vc-pijul-registered' first.
(defun vc-pijul-state (file)
"Return the current version control state of FILE.
See `vc-state' for details on the states.
Currently this returns nil for ignored files as well.
This returns `unregistered' for files that are renamed, and
returns `added' for files that are renamed from other files."
(cond
((vc-pijul-registered file)
(let* ((root (vc-find-root file ".pijul"))
(file (file-relative-name file root)))
(with-temp-buffer
(cond
((vc-pijul--out-ok "diff" "--short" file)
(goto-char (point-min))
(vc-pijul--point-status))))))
('unregistered)))
(defun vc-pijul-root (file)
"Return the root directory for a FILE in a pijul repository."
(vc-find-root file ".pijul"))
(defalias 'vc-pijul-responsible-p #'vc-pijul-root)
(defun vc-pijul--dir-status-sentinel (hash update-function)
"Collect the information from the buffer, and update HASH.
Call UPDATE-FUNCTION to notify vc-dir."
(goto-char (point-min))
(while (re-search-forward
(rx-to-string
'(seq bol
(one-or-more
(any (?a . ?z) (?A . ?Z) ?,))
32
(group
(one-or-more not-newline))
#xa)
t)
nil t)
(forward-line -1)
(puthash (match-string-no-properties 1)
(vc-pijul--point-status)
hash)
(forward-line 1))
(let (result)
(maphash
(lambda (k v)
(setq result (cons (list k v) result)))
hash)
(funcall update-function result nil)))
(declare-function vc-exec-after "vc-dispatcher" (code))
(declare-function vc-set-async-update "vc-dispatcher" (process-buffer))
(defun vc-pijul-dir-status-files (dir files update-function)
"Return the status of FILES in DIR.
UPDATE-FUNCTION is used as the call-back for the asynchronous
computation involved.
See the comments at the top of \"vc.el\" for more information."
;; REVIEW: I do not know if this is really robust and correct. More
;; tests in need.
(let ((default-directory dir)
(pijul-hash (make-hash-table :test #'equal)))
(apply #'vc-pijul--async "diff" (current-buffer)
"--untracked"
"--short"
files)
(vc-run-delayed
(vc-pijul--dir-status-sentinel pijul-hash update-function))))
(defun vc-pijul-dir-extra-headers (dir)
"Return extra backend headers for DIR.
The extra headers should include the channel information and the
remote information."
;; FIXME: I have not yet found a way to obtain the remote
;; information from pijul.
(let ((remote "not implemented yet")
(channel
(with-temp-buffer
(cond
((vc-pijul--out-ok "channel")
(goto-char (point-min))
(cond
((re-search-forward "^* " nil t)
(buffer-substring-no-properties
(point) (point-at-eol)))
((buffer-string))))))))
(concat
(propertize "Channel : " 'face 'vc-dir-header)
(propertize channel 'face 'vc-dir-header-value)
"\n"
(propertize "Remote : " 'face 'vc-dir-header)
(propertize remote 'face 'vc-dir-header-value)
"\n")))
;; REVIEW: I am not sure if this is the right thing to do here.
(defun vc-pijul-working-revision (file)
"Return the last change that affected FILE or \"0\" if it is \
added but not commited yet."
(with-temp-buffer
(cond
((vc-pijul--out-ok "log" "--hash-only" "--limit" "1" "--" file)
(cond
((/= (point-min) (point-max))
(buffer-substring-no-properties (point-min) (1- (point))))
("0"))))))
;; NOTE: Why require FILES as an argument? Is there a system that may
;; change the checkout model for different files?
(defun vc-pijul-checkout-model (_files)
"Pijul does not lock FILES."
(declare (pure t) (side-effect-free t))
'implicit)
(defun vc-pijul-create-repo ()
"Initialize an empty repository."
(vc-pijul--call nil "init"))
(defun vc-pijul-register (files &optional _comment)
"Register FILES into pijul.
COMMENT is ignored.
`vc-register-switches' will be passed to pijul."
(let ((args
(cond
((stringp vc-register-switches)
(cons vc-register-switches files))
((listp vc-register-switches)
(append vc-register-switches files))
(files))))
(with-temp-buffer
(apply #'vc-pijul--call t "add" args)
(buffer-string))))
(defun vc-pijul-unregister (files)
"Unregister FILES from pijul."
(with-temp-buffer
(apply #'vc-pijul--call t "remove" files)
(buffer-string)))
(defun vc-pijul--split-on-first-line (str)
"Split STR on the first line.
That is, return a cons cell whose `car' is the first line of STR
and whose `cdr' is the rest of STR.
Note that newlines between the first line and the subsequent
lines will be removed.
If STR contains no newlines, just return a list with a single
element STR."
(save-match-data
(let ((first-newline (string-match "\n" str)))
(cond
(first-newline
(cons (substring str 0 first-newline)
(let ((rest (substring str (1+ first-newline))))
(cond
((string-match "\n+" rest)
(substring rest (match-end 0)))
(rest)))))
((list str))))))
(defun vc-pijul-checkin (files comment &optional _rev)
"Commit FILES into pijul.
COMMENT is the commit message to use.
REV is simply ignored."
(let* ((support-description-p
(with-temp-buffer
(vc-pijul--call t "rec" "--help")
(goto-char (point-min))
(cond
((re-search-forward
(rx-to-string
'(seq bol (zero-or-more space) "--description")
t)
nil t)
t))))
(checkin-message
(cond
((string-prefix-p "Summary: " comment)
(substring comment 9))
(comment)))
(args
(cond
((stringp vc-checkin-switches)
(cons vc-checkin-switches files))
((listp vc-checkin-switches)
(append vc-checkin-switches files))
(files)))
(args
(append
(list "--all" "-m"
(replace-regexp-in-string "^Summary: " "" comment))
(list "--all")
(cond
(support-description-p
(let* ((splitted
(vc-pijul--split-on-first-line checkin-message))
(title (car splitted))
(body (cdr splitted)))
(append
(list "--message" title)
(cond
((not (string-empty-p body))
(list "--description" body))))))
((list "--message" checkin-message)))
args)))
(with-temp-buffer
(apply #'vc-pijul--call t "rec" args))))
(defun vc-pijul-print-log
(files buffer &optional shortlog start-revision limit)
"Print logs for FILES into BUFFER.
SHORTLOG non-nil means to only show short versions of logs. It
is currently broken.
LIMIT non-nil and number means to only show that many logs.
(defun vc-pijul-find-revision (file rev buffer)
"Fetch REVISION for FILE and put into BUFFER.
I don't know how to do this without creating a new channel. But
it is weird to create a new channel just to do this thing."
(user-error "unimplemented!"))
(defun vc-pijul-checkout (file &optional rev)
"Check out REVISION for FILE.
I don't know how to do this without creating a new channel. But
it is weird to create a new channel just to do this thing."
(user-error "unimplemented!"))
(defun vc-pijul-revert (file &optional contents-done)
"Revert FILE to the working revision.
If CONTENTS-DONE is non-nil, we only need to remove the FILE, if
it is already added but not commited yet."
(cond
(contents-done
(cond ((eq (vc-pijul-state file) 'added)
(vc-pijul--out-ok "remove" file))))
((vc-pijul--out-ok "reset" file))))
(defvar vc-pijul-pull-push-history nil
"The history of pull and push operations.")
(defun vc-pijul-pull (prompt)
"Pull from a remote.
If prompt is non-nil, ask for the location of the remote."
(let ((remote (cond
(prompt
(read-string "Pull from remote: "
nil 'vc-pijul-pull-push-history))
(""))))
(with-temp-buffer
(apply #'vc-pijul--call t
"pull" (split-string remote " "))
(buffer-string))))
(defvar log-view-message-re)
(defvar log-view-file-re)
(defvar log-view-font-lock-keywords)
(defvar log-view-per-file-logs)
(defvar log-view-expanded-log-entry-function)
(defvar pijul-log-view-format
(list
(rx-to-string
'(seq bol "Change"
(one-or-more space)
(group-n 1
(one-or-more
(any
(?a . ?z)
(?A . ?Z)
digit)))
(any ?\n ?\r))
t)
(list 1 ''log-view-message))
"The format for `vc-pijul-log-view-mode'.
The first element is the regular expression to match the first
line of a log. Its first capture group is required to match
exactly the revision number.
The following elements are font lock keywords.")
(define-derived-mode vc-pijul-log-view-mode log-view-mode
"Pijul-Log-View"
"Major mode for viewing logs of pijul."
;; We need some faces from add-log.
(require 'add-log)
;; There are no file markers, so this should match nothing.
(setq-local log-view-file-re regexp-unmatchable)
(setq-local log-view-per-file-logs nil)
(setq-local log-view-message-re (car pijul-log-view-format))
(setq-local log-view-font-lock-keywords
(cons
pijul-log-view-format
(list
(list
;; only email
(rx-to-string
'(seq bol "Author:"
(one-or-more space)
(group-n 1
(one-or-more
(any
(?a . ?z) (?A . ?Z)
(?0 . ?9) ?_ ?. ?+ ?-))
?@
(one-or-more
(any
(?a . ?z) (?A . ?Z)
(?0 . ?9) ?_ ?. ?-))))
t)
(list 1 ''change-log-email))
(list
;; only name
(rx-to-string
'(seq bol "Author:"
(one-or-more space)
(group-n 1 (one-or-more (not (or ?< ?\n ?\r))))
(zero-or-more space))
t)
(list 1 ''change-log-name))
(list
;; name and email
(rx-to-string
'(seq bol "Author:"
(one-or-more space)
(group-n 1 (+? (not ?<)))
(zero-or-more space)
?<
(group-n 2
(one-or-more
(any
(?a . ?z) (?A . ?Z)
(?0 . ?9) ?_ ?+ ?- ?.))
?@
(one-or-more
(any
(?a . ?z) (?A . ?Z)
(?0 . ?9) ?_ ?- ?.)))
?>)
t)
(list 1 ''change-log-name)
(list 2 ''change-log-email))
(list
;; Date
(rx-to-string
'(seq bol "Date:"
(one-or-more space)
(group-n 1 (one-or-more not-newline)))
t)
(list 1 ''change-log-date))))))
(defun vc-pijul-print-log
(files buffer &optional shortlog start-revision limit)
"Print logs for FILES into BUFFER.
SHORTLOG non-nil means to only show short versions of logs. It
is currently broken.
LIMIT non-nil and number means to only show that many logs.
START-REVISION is not currently supported."
(let ((args
(append
(cond ((integerp limit)
(list "--limit" (format "%d" limit))))
(cons "--" files))))
(vc-setup-buffer buffer)
(with-current-buffer buffer
(let ((inhibit-read-only t))
(apply #'vc-do-command
buffer
'async
vc-pijul-program
nil
(cons "log" args))))))
START-REVISION is not currently supported."
(let* ((files (mapcar #'expand-file-name files))
(files
(delq
nil
(mapcar (lambda (file)
(cond
((string=
file
(expand-file-name (vc-pijul-root file)))
nil)
(file)))
files)))
(args
(append
(cond ((integerp limit)
(list "--limit" (format "%d" limit))))
(cons "--" files))))
(vc-setup-buffer buffer)
(with-current-buffer buffer
(let ((inhibit-read-only t))
;; (message "%S" args)
(apply #'vc-pijul--async "log" buffer args)))))
;; TODO: Other log-related functionalities. Postponed.
(declare-function log-edit-mode "log-edit" ())
(declare-function log-edit-toggle-header "log-edit" (header value))
(declare-function log-edit-extract-headers "log-edit" (headers string))
(declare-function log-edit--toggle-amend "log-edit" (last-msg-fn))
(defun vc-pijul-diff (files &optional _rev1 rev2 buffer async)
"Insert the diff for FILES into BUFFER, or the *vc-diff* buffer if \
BUFFER is nil.
If ASYNC is non-nil, run ascynchronously.
In principle REV1 and REV2 should be used as anchors of
comparisons, but I have not yet found what this means to pijul."
;; NOTE: According to
;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=21969, perhaps we
;; shall always run diff synchronously. But I want to try the
;; ascynchronous implementation first.
(cond
(async
;; TODO: I don't know how to convert the output of "pijul diff" to
;; the format Emacs expects.
(cond
((null rev2) (apply #'vc-pijul--async "diff" buffer files))
((apply #'vc-pijul--async "change" buffer (list rev2))))
1)))
(defun vc-pijul-find-ignore-file (file)
"Return the .ignore file that controls FILE."
(expand-file-name ".ignore" (vc-pijul-root file)))
(defun vc-pijul-previous-revision (file rev)
"Return the previous revision of REV for FILE.
If there is no previous revision return nil."
(with-temp-buffer
(cond
((apply
#'vc-pijul--out-ok
(append (list "log" "--hash-only" "--")
(cond (file (list file)))))
(goto-char (point-min))
(cond
((search-forward rev nil t)
(forward-line 1)
(cond
((< (point) (point-max))
(buffer-substring (point) (point-at-eol))))))))))
(defun vc-pijul-next-revision (file rev)
"Return the next revision of REV for FILE.
If there is no next revision return nil."
(with-temp-buffer
(cond
((vc-pijul--out-ok
"log" "--hash-only" "--" file)
(goto-char (point-min))
(cond
((search-forward rev nil t)
(forward-line 0)
(cond
((> (point) (point-min))
(forward-line -1)
(buffer-substring (point) (point-at-eol))))))))))
(defun vc-pijul-delete-file (file)
"Delete FILE from the repository and the working copy."
(vc-pijul--call nil "remove" file)
(delete-file file))
(defun vc-pijul-rename-file (old new)
(vc-pijul--call nil "move" old new))
(defun vc-pijul--out-ok (command &rest arguments)
"Call COMMAND with ARGUMENTS.
Return t if and only if the command successfully exits."
(zerop (apply #'vc-pijul--call '(t nil) command arguments)))
(defun vc-pijul--call (buffer command &rest arguments)
"Call \"pijul\" with subcommand \"COMMAND\" and ARGUMENTS.
BUFFER is passed to `process-file'.
Return `100' if `vc-pijul-program' is not found on the variable
`exec-path'."
(let ((program-name (executable-find vc-pijul-program)))
(cond
(program-name
(let (process-file-side-effects)
(apply #'process-file
program-name nil buffer nil command arguments)))
(100))))
(defun vc-pijul--async (command buffer &rest arguments)
"Run pijul with COMMAND and BUFFER asynchronously.
ARGUMENTS are fed to pijul at the end."
(apply #'vc-do-command
buffer 'async vc-pijul-program
nil command arguments))
(provide 'vc-pijul)
;;; vc-pijul.el ends here