Pijul integration for Emacs’ VC version control interface.
;;; vc-pijul.el --- a VC backend for Pijul    -*- lexical-binding: t -*-

;;; Copyright (C) 2004  Jorgen Schaefer <forcer@forcix.cx>
;;; Copyright (C) 2004-2014  Juliusz Chroboczek <jch@pps.univ-paris-diderot.fr>
;;; Copyright (C) 2022  Greg Pfeil <greg@techhnomadic.org>

;; Author: Jorgen Schaefer <forcer@forcix.cx>
;;         Juliusz Chroboczek <jch@pps.univ-paris-diderot.fr>
;;         Greg Pfeil <greg@techhnomadic.org>
;; Maintainer: Greg Pfeil <greg@techhnomadic.org>
;; Keywords: vc
;; Package-Version: 20220926.2130
;; Package-X-Original-Version: 20141122.1326
;; Version: 0.1
;; Package-Requires: ((emacs "24"))

;;; 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, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;;; 02111-1307, USA.

;;; Commentary:

;; Pijul is a distributed version control system, available at
;; http://www.pijul.net/

;; This version of vc-pijul was tested with Emacs 28. It might still work on
;; Emacs 24, but it currently uses features that aren’t available prior to
;; that.

;; A few ideas for this file are directly taken from vc-svn.el.  Thanks to
;; Jim Blandy. This file has been forked from vc-darcs.el. Thanks to Jorgen
;; Schaefer, Juliusz Chroboczek, and Libor Čapák <capak@inputwish.com>.

;; To install, put this file into your load-path and add the following to
;; your emacs init file:

;; (add-to-list 'vc-handled-backends 'Pijul)

;; There are a few reasons why vc is difficult to coerce into using Pijul
;; as a backend.  By default, vc expects files (not trees) to be versioned
;; as nodes in an AND/OR tree, as is done by RCS and CVS.  Recent version
;; of vc allow some customisation of that, which allows smooth integration
;; with e.g. subversion.

;; Pijul doesn't version files at all; a Pijul repository is a collection
;; of patches, and a particular file version is just the set of patches
;; that have been applied in order to build it.  While patches might be
;; reordered when moving between repositories, they usually remain ordered
;; (notable exceptions to that being unpull and optimize); hence,
;; a convenient mental shortcut is to identify a version by the latest
;; patch included in that version.  This is what we do.

;; Internally, Pijul identifies a patch by its hash, which you may obtain
;; by using `pijul log`.  We follow that approach in this code.  However,
;; as a hash might be difficult to remember at times (it's 53 characters
;; long), all commands that might take an interactive argument also accept
;; a regexp identifying a patch name.  See VC-PIJUL-REV-TO-HASH.

;; The fit with vc is still not quite perfect.  A sore point is that vc
;; doesn't normalise versions; hence, if you have a patch called ``Initial
;; import'', you might end up with distinct but identical buffers called
;; vc-pijul.el~Init~, vc-pijul.el~Initial~ and so on.


;;; Code:

(defvar vc-pijul-version-string "0.1"
  "The version string for vc-pijul.el.")

(eval-when-compile
  (require 'xml)
  (require 'vc))

(require 'xml)

(declare-function vc-do-async-command "vc-dispatcher"
                  (buffer root command &rest args))
(declare-function vc-exec-after "vc-dispatcher" (code))
(declare-function vc-setup-buffer "vc-dispatcher" (buf))

(defgroup vc-pijul nil
  "*The Pijul backend for vc."
  :prefix "vc-pijul-"
  :group 'vc)

(defcustom vc-pijul-program-name "pijul"
  "*The name of the Pijul command."
  :type 'string
  :group 'vc-pijul)

(defcustom vc-pijul-program-arguments '()
  "*An a-list of further arguments to pass to Pijul.
Each element consists of a symbol naming the command to work on, and a
list of arguments to pass."
  :type '(alist :key-type symbol :value-type (list string))
  :group 'vc-pijul)


(defvar log-view-per-file-logs)
(defvar log-view-file-re)
(defvar log-view-message-re)
(defvar log-view-font-lock-keywords)
(defvar log-view-vc-fileset)

(declare-function vc-annotate-convert-time "vc-annotate" (time))


(defun vc-pijul-root (file)
  "Return the root Pijul repository directory for FILE, or nil if not found."
  (vc-find-root file ".pijul"))

(defalias 'vc-pijul-find-root 'vc-pijul-root)

(defun vc-pijul-special-file-p (file)
  (let ((file (expand-file-name file)))
    (and (string-match "/.pijul/" file)
         (not (string-match "/.pijul/config" file)))))

(defun vc-pijul-do-command (command okstatus files &rest flags)
  "Run Pijul COMMAND using VC-DO-COMMAND."
  (let ((arguments (cdr (assq command vc-pijul-program-arguments))))
    (apply #'vc-do-command "*vc*" okstatus
           vc-pijul-program-name files (symbol-name command)
           (append arguments flags))))

(defun vc-pijul-changes (&optional files &rest flags)
  "Return a list of hashes of the patches that touch FILES in inverse order."
  (with-temp-buffer
    (apply #'vc-do-command t 0 vc-pijul-program-name files
           "log" (append flags (cons "--hash-only" (and files (list "--")))))
    (nreverse
     (split-string (buffer-substring-no-properties (point-min) (point-max))))))

(defun vc-pijul-hash-p (rev)
  "Return non-nil if REV has the syntax of a Pijul hash."
  (and (= (length rev) 53)
       (string-match "[A-Z0-9]" rev)
       t))

(defun vc-pijul-rev-to-hash (rev files &optional off-by-one)
  (cond
   ((or (null rev) (eq rev t) (equal rev "")) nil)
   ((not off-by-one)
    (cond
     ((vc-pijul-hash-p rev) rev)
     (t (car (last (vc-pijul-changes files "--patch" rev))))))
   (t
    (let ((flags
           (if (vc-pijul-hash-p rev)
               (list "--from-match" (concat "hash " rev))
             (list "--from-patch" rev))))
      (let ((changes (apply #'vc-pijul-changes files flags)))
        (and (cdr changes) (car (last changes 2))))))))

(defun vc-pijul-next-revision (files rev)
  "Return the revision number that follows REV for FILES."
  (vc-pijul-rev-to-hash rev files t))

(defalias 'vc-pijul-next-version 'vc-pijul-next-revision)

(defun vc-pijul-previous-revision (files rev)
  "Return the revision number that precedes REV for FILES."
  (let ((flags
         (if (vc-pijul-hash-p rev)
             (list "--to-match" (concat "hash " rev))
           (list "--to-patch" rev))))
    (let ((changes (apply #'vc-pijul-changes files flags)))
      (cadr changes))))

(defalias 'vc-pijul-previous-version 'vc-pijul-previous-revision)

(defun vc-pijul-revision-granularity () 'repository)


;;; State-querying functions

(defun vc-pijul-registered (file)
  "Return non-nil if FILE is handled by Pijul."
  (cond
   ((vc-pijul-special-file-p file)
    ;; If vc-directory-exclusion-list is set incorrectly, vc-dired will
    ;; query us for all the files under .pijul.  Get rid of them quickly.
    nil)
   (t
    (when (vc-pijul-root file)
      (let* ((file (expand-file-name file))
             (root (vc-pijul-root file))
             (default-directory (file-name-directory file)))
        (with-temp-buffer
          (catch 'found
            (condition-case nil
                (vc-do-command t nil vc-pijul-program-name
                               () "list")
              (error (throw 'found nil)))
            (goto-char (point-min))
            (while (looking-at "[^\n]+")
              ;; Pijul always prints relative to the root
              (let* ((line (match-string 0))
                     (file2 (expand-file-name line root)))
                (when (or
                       (equal file2 file)
                       (equal line "pijul: can't mix match and pending flags"))
                  (throw 'found t))
                (forward-line)))
            nil)))))))

(defun vc-pijul-file-times-equal-p (file1 file2)
  (equal (nth 5 (file-attributes file1)) (nth 5 (file-attributes file2))))

(defun vc-pijul-parse-summary (letter)
  (cond
   ((equal "A" letter) 'added) ; add
   ((equal "D" letter) 'removed) ; delete
   ((equal "M" letter) 'edited) ; edit
   ((equal "MV" letter) 'removed) ; move elsewhere
   ((equal "R" letter) 'edited) ; replacement
   ((equal "RZ" letter) 'edited) ; resurrect zombies
   ((equal "SC" letter) 'edited) ; solve conflict
   ((equal "U" letter) 'unregistered) ; untracked
   ((equal "UC" letter) 'conflict) ; unsolve conflict
   ((equal "UD" letter) 'added) ; undelete
   (t 'unregistered)))

(defun vc-pijul-state (file)
  "Return the state of FILE."
  (with-temp-buffer
    (vc-do-command t nil vc-pijul-program-name file
                   "diff" "--short")
    (goto-char (point-min))
    (cond
     ((looking-at "\\([A-Z]+\\) ")
      (vc-pijul-parse-summary (match-string 1)))
     ((progn (forward-line 1) (looking-at "Error: Path not in repository: "))
      nil)
     (t 'up-to-date))))

(defun vc-pijul-checkout-model (_file)
  "Indicate how FILE is checked out.  This is always IMPLICIT with Pijul."
  'implicit)

(defun vc-pijul-dir-status (dir update-function)
  (let* ((dir (expand-file-name dir))
         (root (vc-pijul-root dir)))
    (vc-do-command t 'async vc-pijul-program-name dir "diff" "--short" "--untracted")
    (vc-exec-after
     `(vc-pijul-dir-status-continuation
       ',root ',update-function nil))))

(defun vc-pijul-dir-status-files (dir files update-function)
  (let* ((dir (expand-file-name dir))
         (root (vc-pijul-root dir)))
    (vc-do-command t 'async vc-pijul-program-name files "diff" "--short" "--untracked")
    (vc-exec-after
     `(vc-pijul-dir-status-continuation
       ',root ',update-function ',files))))

(defun vc-pijul-dir-status-continuation (root update-function files)
  (let* ((l '())
         (doit #'(lambda (file status)
                   ;; The paths printed by Pijul are relative to the root
                   (let ((path (file-relative-name
                                (expand-file-name file root))))
                     (unless (file-directory-p path)
                       (push (list path status nil) l)
                       (setq files (delete path files)))))))
    (goto-char (point-min))
    (while (not (eobp))
      (cond
       ((looking-at "\\([A-Z]+\\) +\\([^ \n]+\\)")
        (funcall doit (match-string 2)
                 (vc-pijul-parse-summary (match-string 1))))
       ((looking-at " * \\([^ \n]+\\) *-> *\\([^ \n]+\\)")
        (funcall doit (match-string 1) 'removed)
        (funcall doit (match-string 2) 'added)))
      (forward-line))
    (funcall update-function (nreverse l) (not (null files))))
  (while (not (null files))
    (let ((file (pop files)))
      (funcall
       update-function
       (list (list file
                   (if (vc-pijul-registered file) 'up-to-date 'unregistered)
                   nil))
       (not (null files))))))

;; Currently, there is not an easy way to tell the default remote from the other
;; remotes (other than parsing the config file), the oldest one the default, and;; order the list chronologically.
(defun vc-pijul-get-remotes (dir)
  "Get the remote repository locations, if any. The default remote will
_probably_ be the first in the list."
  (let ((default-directory (expand-file-name dir)))
    (with-temp-buffer
      (vc-do-command t 0 vc-pijul-program-name nil "remote")
      (search-backward ": ")
      (forward-char 2)
      (kill-rectangle (point-min) (point))
      (nreverse
       (split-string
        (buffer-substring-no-properties (point-min) (1- (point-max)))
        "\n")))))

(defun vc-pijul--dir-header (width k v)
  "Creates a string, stylized as a vc-dir header from a K (a string) and V
(either a string or a list of strings). K will be truncated if it is longer than
the provided width."
  (concat
   (propertize (concat (truncate-string-to-width k width nil ?\s t t) ": ")
               'face
               'vc-dir-header)
   (propertize (cond ((listp v)
                      (mapconcat 'identity
                                 v
                                 (concat "\n" (make-string (+ 2 width) ?\s))))
                     (t
                      v))
               'face
               'vc-dir-header-value)))

(defun vc-pijul-dir-extra-headers (dir)
  (let ((width 11)) ; the width of a header key in vc-dir
    (mapconcat
     'identity
     (nconc
      (let ((root (vc-pijul-root dir)))
        (and root (not (equal (file-truename dir) (file-truename root)))
             (list (vc-pijul--dir-header width "Repository" root))))
      (let ((remotes (vc-pijul-get-remotes dir)))
        (and remotes (list (vc-pijul--dir-header width "Remotes" remotes)))))
     "\n")))

(defun vc-pijul-responsible-p (file)
  "Return non-nil if we feel responsible for FILE,
 which can also be a directory."
  (when
      (and (not (vc-pijul-special-file-p file))
           (not (null (vc-pijul-root file))))
    file))

(defun vc-pijul-could-register (file)
  "Return non-nil if FILE could be registered."
  (and (not (vc-pijul-special-file-p file))
       (not (null (vc-pijul-root file)))))

(defun vc-pijul-working-revision (file)
  "Return the working revision of FILE.
With Pijul, this is simply the hash of the last patch that touched this file."
  (car (vc-pijul-changes file "--limit" "1")))

(defalias 'vc-pijul-workfile-version 'vc-pijul-working-revision)

(defun vc-pijul-workfile-unchanged-p (file)
  "Return non-nil if FILE is unchanged from the repository version."
  (with-temp-buffer
    (vc-do-command t nil vc-pijul-program-name file
                   "diff" "--short")
    (goto-char (point-max))
    (forward-line -1)
    (looking-at "No changes")))

(defun vc-pijul-mode-line-string (file)
  "Return the mode line string to show for FILE."
  (let ((state (vc-state file)))
    (if (eq state 'up-to-date)
        "pijul"
      (format "pijul/%s" (vc-state file)))))


;;; State-changing functions

(defun vc-pijul-create-repo ()
  (vc-pijul-do-command 'init 0 nil))

(defun vc-pijul-register (files &optional _rev _comment)
  "Add FILES to the Pijul repository, and record this.
REV and COMMENT are ignored."
  (vc-pijul-do-command 'add 0 files))

(defun vc-pijul-find-ignore-file (file)
  (format "%s/.ignore" (vc-pijul-root file)))

(defun vc-pijul-checkin (files comment rev)
  "Record FILES to Pijul.  COMMENT is the new comment."
  (when (not (null rev))
    (error "Cannot specify check-in revision with Pijul."))
  (let* ((date (format-time-string "%Y%m%d%H%M%S" nil t))
         (match (string-match "\\`\\(Summary:[ \t]*\\)?\\([^\n]*\\)[ \t\n]*\\'"
                              comment))
         (patch-name (if match
                         (match-string 2 comment)
                       comment))
         (log (if match
                  (substring comment (match-end 0))
                "")))
    (vc-pijul-do-command 'record 'async files "--message" patch-name)
    (with-current-buffer (get-buffer "*vc*")
      (process-send-string nil (format "%s\n%s\n%s" date patch-name log))
      (process-send-eof))))

(defun vc-pijul-find-revision (file rev buffer)
  "Get revision REV of FILE from the Pijul repository."
  (let ((rev (vc-pijul-rev-to-hash rev file)))
    (apply #'vc-do-command buffer 0 vc-pijul-program-name file
           "show" "contents"
           (and rev (list "--match" (concat "hash " rev))))))

(defalias 'vc-pijul-find-version 'vc-pijul-find-revision)

(defun vc-pijul-checkout (file &optional _editable rev)
  "Check out FILE from the Pijul repository.
EDITABLE is ignored."
  (let ((rev (vc-pijul-rev-to-hash rev file)))
    (when (and rev (not (equal rev (vc-pijul-workfile-version file))))
      (error "Cannot checkout old revisions with Pijul."))
    (or (file-exists-p file)
        (vc-pijul-do-command 'reset 0 file))))

(defun vc-pijul--handle-prompt (command args)
  (let* ((root (vc-pijul-root default-directory))
	 (buffer (format "*vc-pijul : %s*" (expand-file-name root))))
    (setq args (split-string
	        (read-shell-command
                 (format "Pijul %s command: " command)
                 (format "%s %s %s" vc-pijul-program-name command (concat args)))
	        " " t))
    (let ((pijul-program (car args))) 
      (setq command (cadr args)
	    args (cddr args))
      (require 'vc-dispatcher)
      (apply #'vc-do-async-command buffer root pijul-program command args))))

(defun vc-pijul-push (arg)
  "Push the current channel."
  (if arg
      (vc-pijul--handle-prompt "push" nil)
    (vc-pijul-do-command 'push 0 nil)))

(defun vc-pijul-pull (arg)
  "Push the current channel."
  (if arg
      (vc-pijul--handle-prompt "pull" nil)
    (vc-pijul-do-command 'pull 0 nil)))

(defun vc-pijul-revert (file &optional contents-done)
  "Revert FILE back to the current workfile version."
  (unless contents-done
    (vc-pijul-do-command 'reset 0 file)))


;;; History functions

(define-derived-mode vc-pijul-log-view-mode log-view-mode "Pijul-Log-View"
  (require 'add-log)
  (set (make-local-variable 'log-view-per-file-logs) nil)
  (set (make-local-variable 'log-view-file-re) "\\`a\\`")
  (set (make-local-variable 'log-view-message-re)
       "^patch \\([0-9a-f]\\{40\\}\\)")
  (set (make-local-variable 'log-view-font-lock-keywords)
       '(("^\\([A-Z][a-z][a-z] .*[0-9]\\)  \\([^<>]+\\) \\(<[^<>]+>\\)"
          (1 'change-log-date)
          (2 'change-log-name)
          (3 'change-log-email))))
  )

(defun vc-pijul-show-log-entry (rev)
  ;; Pretty minimal, but good enough to allow C-x v l to do the right thing
  (cond
   ((equal rev (car (vc-pijul-changes log-view-vc-fileset "--limit" "1")))
    (goto-char (point-min))
    (re-search-forward log-view-message-re)
    (beginning-of-line))
   (t
    nil)))

(defun vc-pijul-print-log
    (files &optional buffer _shortlog _start-revision limit)
  "Print the logfile for the current Pijul repository."
  ;; This is a hack to make C-x v L work
  (when (and (null (cdr files)) (equal (car files) (vc-pijul-root (car files))))
    (setq files nil))
  ;; (let ((start-hash (vc-pijul-rev-to-hash start-revision files)))
    (apply #'vc-do-command buffer 'async vc-pijul-program-name files "log"
           (append
            ;; (and start-hash (list "--to-hash" start-hash))
            (and limit (list "--limit" (format "%d" limit)))
            (and files (list "--")))))

(defun vc-pijul-diff (file &optional rev1 rev2 buffer _async)
  "Show the differences in FILE between revisions REV1 and REV2."
  (let* ((rev1 (vc-pijul-rev-to-hash rev1 file t))
         (rev2 (vc-pijul-rev-to-hash rev2 file))
         (arguments (cdr (assq 'diff vc-pijul-program-arguments)))
         (from (and rev1 (list "--from-match" (concat "hash " rev1))))
         (to (and rev2 (list "--to-match" (concat "hash " rev2)))))
    (apply #'vc-do-command (or buffer "*vc-diff*")
           nil ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=21969
           vc-pijul-program-name file
           "diff"
           (append from to arguments))))

(defun vc-pijul-rename-file (old new)
  "Rename the file OLD to NEW in the pijul repository."
  (vc-pijul-do-command 'move 0 nil old new))

(defun vc-pijul-delete-file (file)
  (delete-file file))

(defun vc-pijul-parse-integer (string)
  (let* ((c (read-from-string string))
         (n (car c)))
    (if (integerp n) n 0)))

(defun vc-pijul-alist-from-rev (_file rev)
  (let ((alist ()))
    (with-temp-buffer
      (vc-do-command t 0 vc-pijul-program-name '() "change" rev)
      (goto-char (point-min))
      (while (progn
               (if (looking-at "\\(.*\\) = '\\(.*\\)'")
                   (let ((key (pcase (match-string 1)
                                ("message" 'message)
                                ("timestamp" 'date)
                                ("name" 'author))))
                     (when key
                       (push (cons key (match-string 2)) alist))))
               (= 0 (forward-line))))
    alist)))

(defun vc-pijul-annotate-command (file buffer &optional rev)
  "Produce an annotated display of fiLE in BUFFER.
For Pijul, hashes and times are stored in text properties."
  (vc-setup-buffer buffer)
  (let* ((_rev (vc-pijul-rev-to-hash rev file))
         (data
          (with-temp-buffer
            (apply #'vc-do-command t 0 vc-pijul-program-name file "credit" nil)
            (let ((current-hash nil)
                  (output ()))
              (goto-char (point-min))
              (while (progn
                       (cond ((looking-at "^\\([A-Z0-9]+\\)\\(?:, [A-Z0-9]+\\)*$")
                              (message (match-string 1))
                              (setq current-hash (match-string 1)))
                             ((looking-at "^> \\(.*\\)$")
                              (message (match-string 1))
                              (push (cons current-hash (match-string 1)) output)))
                       (= 0 (forward-line 1))))
              (nreverse output)))))
    (with-current-buffer buffer
      (let ((reporter
             (and (fboundp 'make-progress-reporter)
                  (make-progress-reporter "Annotating..."
                                          1 (length data))))
            (count 0)
            (now (vc-annotate-convert-time (current-time)))
            (cache '()))
        (dolist (e data)
          (let* ((rev (car e))
                 (line (cdr e))
                 (alist (or (cdr (assoc rev cache))
                            (let ((a (vc-pijul-alist-from-rev file rev)))
                              (push (cons rev a) cache)
                              a)))
                 (author (cdr (assoc 'author alist)))
                 (date (cdr (assoc 'date alist)))
                 (year (substring date 0 4))
                 (month (substring date 5 7))
                 (day (substring date 8 10))
                 (hour (substring date 11 13))
                 (min (substring date 14 16))
                 (sec (substring date 17 19))
                 (time (vc-annotate-convert-time
                        (encode-time
                         (vc-pijul-parse-integer sec)
                         (vc-pijul-parse-integer min)
                         (vc-pijul-parse-integer hour)
                         (vc-pijul-parse-integer day)
                         (vc-pijul-parse-integer month)
                         (vc-pijul-parse-integer year))))
                 (begin (point))
                 )
            (insert (format "%-12s " rev))
            (cond
             ((string-match "<\\([^ <>@]*\\)@.*>" author)
              (setq author (match-string 1 author)))
             ((string-match "[^ <>@]*" author)
              (setq author (match-string 0 author))))
            (insert (format "%-7s "
                            (if (> (length author) 7)
                                (substring author 0 7)
                              author)))
            (insert
             (if (> (- now time) 0.9)
                 (format "%s-%s-%s " year month day)
               (format "%s:%s:%s " hour min sec)))
            (insert line)
            (insert "\n")
            (add-text-properties
             begin (point)
             (list 'vc-pijul-annotate (cons rev time))))
          (setq count (+ count 1))
          (when reporter
            (progress-reporter-update reporter count)))
        (when reporter
          (progress-reporter-done reporter))))))

(defun vc-pijul-annotate-extract-revision-at-line ()
  (car (get-text-property (point) 'vc-pijul-annotate (current-buffer))))

(defun vc-pijul-annotate-time ()
  (cdr (get-text-property (point) 'vc-pijul-annotate (current-buffer))))

(provide 'vc-pijul)
;;; vc-pijul.el ends here