path: root/annexview.el

;;; annexview.el --- Dired interface for git-annex views  -*- lexical-binding: t; -*-

;; Copyright (C) 2018 Kyle Meyer

;; Author: Kyle Meyer <kyle@kyleam.com>
;; URL: https://git.kyleam.com/annexview/about
;; Keywords: vc, files, tools
;; Version: 0.1.0
;; Package-Requires: ((emacs "25.1"))

;; 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:

;; Annexview provides a Dired interface for modifying git-annex
;; metadata [0] and for creating metadata-driven views [1].
;;
;; Modification commands:
;;                                   git annex metadata ...
;;   annexview-field-set-value    =>  --set field=value
;;   annexview-field-init-value   =>  --set field?=value
;;   annexview-field-add-value    =>  --set field+=value
;;   annexview-field-remove-value =>  --set field-=value
;;
;;   annexview-add-tag            =>  --tag tag
;;   annexview-remove-tag         =>  --unset tag
;;   annexview-remove-field       =>  --remove field
;;
;; View commands:
;;
;;   annexview-create-view        => git annex view ARGS
;;   annexview-vadd               => git annex vadd ARGS
;;   annexview-vfilter            => git annex vfilter ARGS
;;   annexview-vpop               => git annex vpop N
;;
;; Miscellaneous commands:
;;
;;   annexview-checkout-view      => git checkout views/VIEW
;;   annexview-show-metadeta      => git annex metadata FILE
;;
;; These commands are available under `annexview-map', which you can
;; bind to a key in Dired buffers.  If you use git-annex.el [2], the
;; recommended keybinding of "@v" can be configured with
;;
;;     (with-eval-after-load 'git-annex
;;       (define-key git-annex-dired-map "v" 'annexview-map))
;;
;; [0]: https://git-annex.branchable.com/metadata/
;; [1]: https://git-annex.branchable.com/tips/metadata_driven_views/
;; [2]: https://github.com/jwiegley/git-annex-el


;;; Code:

(require 'cl-lib)
(require 'dired)
(require 'json)

(require 'subr-x)

(declare-function magit-git-lines "magit-git" (&rest args))
(declare-function magit-git-string "magit-git" (&rest args))
(declare-function magit-call-git "magit-process" (&rest args))
(declare-function magit-process-buffer "magit-process" (&optional nodisplay))


;;; Options

(defgroup annexview nil
  "Dired interface to git-annex metadata-driven views."
  :prefix "annexview-"
  :group 'files)

(defcustom annexview-use-magit (and (require 'magit nil t) t)
  "Whether to use Magit functions to call git."
  :type 'boolean)

(defcustom annexview-git-executable
  (if (boundp 'magit-git-executable) magit-git-executable "git")
  "Invoke git like this.
And invoke git-annex by using \"annex\" as the subcommand."
  :type 'string)


;;; Metadata inspection

(defun annexview--read-json-item ()
  (let ((json-object-type 'alist)
        (json-array-type 'list)
        (json-key-type 'string)
        (json-false nil)
        (json-null nil))
    (json-read)))

(defun annexview-git-lines (&rest args)
  (if annexview-use-magit
      (magit-git-lines args)
    (with-temp-buffer
      (when (= 0 (apply #'call-process annexview-git-executable
                        nil '(t nil) nil args))
        (split-string (buffer-string) "\n" t)))))

(defun annexview-git-string (&rest args)
  (if annexview-use-magit
      (magit-git-string args)
    (car (apply #'annexview-git-lines args))))

(defun annexview-call-git (&rest args)
  (if annexview-use-magit
      (unless (= 0 (magit-call-git args))
        (magit-process-buffer))
    (let ((temp-buffer-show-function (lambda (_)))
          (buffer-name "*annexview-call-git-output*"))
      (with-output-to-temp-buffer buffer-name
        (unless (= 0 (apply #'call-process annexview-git-executable
                            nil standard-output nil args))
          (display-buffer buffer-name))))))

(defun annexview-call-git-annex (&rest args)
  (apply #'annexview-call-git "annex" args))

(defvar annexview-git-annex-hash nil)
(defun annexview-git-annex-hash ()
  (or annexview-git-annex-hash
      (annexview-git-string "rev-parse" "--verify" "git-annex")))

;; TODO: There probably needs to be a local variable that can be used
;; to disable the cache for repositories where reading in all the
;; metadata would be too slow.  When the cache is disabled, commands
;; that use cached values for completion would have to instead read
;; plain input.

(defvar annexview--cache nil)
(defmacro annexview--with-cache (key &rest body)
  (declare (indent 1) (debug (body)))
  (let ((keyvar (cl-gensym "keyvar"))
        (cached (cl-gensym "cached"))
        (result (cl-gensym "result")))
    `(let* ((,keyvar (cons ,key (expand-file-name default-directory)))
            (,cached (cdr (assoc ,keyvar annexview--cache)))
            (annexview-git-annex-hash (annexview-git-annex-hash)))
       (if (equal annexview-git-annex-hash
                  (cdr (assq :hash ,cached)))
           (cdr (assq :result ,cached))
         (setq annexview--cache
               (cl-delete-if (lambda (x)
                               (and (equal (car x) ,keyvar)
                                    (not (equal annexview-git-annex-hash
                                                (cdr (assq :hash x))))))
                             annexview--cache))
         (let ((,result ,(macroexp-progn body)))
           (push (list ,keyvar
                       (cons :hash annexview-git-annex-hash)
                       (cons :result ,result))
                 annexview--cache)
           ,result)))))

(defun annexview-metadata-key-fields ()
  "Return a hash table mapping a git-annex key to its metadata."
  (annexview--with-cache :key-fields
    (with-temp-buffer
      (if (/= 0 (call-process annexview-git-executable nil t nil
                              "annex" "metadata" "--json" "--all"))
          (error "`git annex metadata' call failed")
        (let ((table (make-hash-table :test #'equal)))
          (goto-char (point-min))
          (let (item)
            (while (and (not (eobp))
                        (setq item (annexview--read-json-item)))
              (puthash (or (cdr (assoc "key" item))
                           (error "Incorrect assumption: key always present"))
                       (cdr (assoc "fields" item))
                       table)
              (skip-syntax-forward " ")))
          table)))))

(defun annexview-file-keys (files)
  "Return the git-annex key for each file in FILES."
  (annexview--with-cache (cons :lookupkey files)
    (apply #'annexview-git-lines "annex" "lookupkey" files)))

(defun annexview-fields (&optional files)
  "Return the metadata field and values for the repository.
If FILES is non-nil, restrict the result to fields attached to
those files.  The result is structured as a list of lists, where
the first item of each list is the field name and the remaining
items are the field values."
  (annexview--with-cache (cons :fields files)
    (let* ((md (annexview-metadata-key-fields))
           (keys (or (and files
                          (annexview-file-keys files))
                     (hash-table-keys md)))
           (flat (make-hash-table :test #'equal)))
      (dolist (key keys)
        (pcase-dolist (`(,field . ,values) (gethash key md))
          (when (not (string-suffix-p "lastchanged" field))
            (puthash field
                     (append values (gethash field flat))
                     flat))))
      (let (fields)
        (maphash (lambda (field values)
                   (push (cons field
                               (sort (delete-dups values) #'string-lessp))
                         fields))
                 flat)
        fields))))

(defun annexview-field-names (&optional files)
  "Return the field names for the repository.
If FILES is non-nil, restrict the result to fields attached to
those files."
  (annexview--with-cache (cons :field-names files)
    (mapcar #'car (annexview-fields files))))

(defun annexview-field-values (field &optional files)
  "Return the values of FIELD that are present in the repository.
If FILES is non-nil, restrict the result to values attached to
those files."
  (annexview--with-cache (list :field-values field files)
    (cdr (assoc field (annexview-fields files)))))

(defun annexview-tags (&optional files)
  "Return all tags in the repository.
If FILES is non-nil, restrict tags that are attached to those
files."
  (annexview--with-cache (cons :tags files)
    (annexview-field-values "tag" files)))


;;; Metadata display and modification

(defun annexview--dired-files ()
  (dired-get-marked-files
   nil
   (and current-prefix-arg
        (prefix-numeric-value current-prefix-arg))))

;;;###autoload
(defun annexview-show-metadeta (files)
  "Display metadata fields attached to FILES.

Interactively, a non-nil prefix argument is interpreted as a
numeric value for `dired-get-marked-files's ARG.

$ git annex metadata FILES"
  (interactive (list (annexview--dired-files)))
  (with-output-to-temp-buffer "*annexview-metadata*"
    (apply #'call-process annexview-git-executable
           nil standard-output nil "annex" "metadata" files)))

(defun annexview-set (files args)
  "Set metadata of FILES.
ARGS should be a list of (OPERATOR FIELD VALUE) cells, where
OPERATOR is a symbol matching a `git annex metadata --set'
operator (= += ?= -=)."
  ;; We might want to expose a clever interactive spec for this, but
  ;; for now use it as the plumbing for single element set commands.
  (apply
   #'annexview-call-git-annex
   "metadata"
   (append (cl-mapcan
            (lambda (arg)
              (list "--set"
                    (pcase arg
                      ((and `(,op ,field ,value)
                            (guard (memq op '(= += \?= -=))))
                       (concat field (symbol-name op) value))
                      (_
                       (user-error "Unrecognized argument: %s" arg)))))
            args)
           (cons "--" files))))

(defun annexview--read-new-value (field op files)
  "Read a new value for addition operators (= ?= +=).
OP is the operator shown in the prompt.  If there is a single
file, the candidates include only values for FIELD that aren't
already attached to the file.  Otherwise, the collection is
comprised of all current values for FIELD."
  (completing-read (concat field op)
                   (if (= 1 (length files))
                       (cl-set-difference (annexview-field-values field)
                                          (annexview-field-values field files)
                                          :test #'equal)
                     (annexview-field-values field))))

;; TODO: Decide how to deal with --force (used for recursively setting
;; metadata for files within a directory).

;;;###autoload
(defun annexview-field-set-value (field value files)
  "Set the VALUE for the FIELD attached to FILES.

Interactively, a non-nil prefix argument is interpreted as a
numeric value for `dired-get-marked-files's ARG.

$ git annex metadata --set FIELD=VALUES FILES"
  (interactive
   (let* ((files (annexview--dired-files))
          (field (completing-read "Field: " (annexview-field-names))))
     (list field
           (annexview--read-new-value field "=" files)
           files)))
  (annexview-set files `((= ,field ,value))))

;;;###autoload
(defun annexview-field-init-value (field value files)
  "Initialize the VALUE for the FIELD attached to FILES.

Interactively, a non-nil prefix argument is interpreted as a
numeric value for `dired-get-marked-files's ARG.

$ git annex metadata --set FIELD?=VALUES FILES"
  (interactive
   (let* ((files (annexview--dired-files))
          ;; TODO: This could filter out fields that are on all files
          ;; because ?= on those would be a noop.
          (field (completing-read "Field: " (annexview-field-names))))
     (list field
           (annexview--read-new-value field "?=" files)
           files)))
  (annexview-set files `((\?= ,field ,value))))

;;;###autoload
(defun annexview-field-add-value (field value files)
  "Add a VALUE to the FIELD attached to FILES.

Interactively, a non-nil prefix argument is interpreted as a
numeric value for `dired-get-marked-files's ARG.

$ git annex metadata --set FIELD+=VALUES FILES"
  (interactive
   (let* ((files (annexview--dired-files))
          (field (completing-read "Field: " (annexview-field-names))))
     (list field
           (annexview--read-new-value field "+=" files)
           files)))
  (annexview-set files `((+= ,field ,value))))

;;;###autoload
(defun annexview-field-remove-value (field value files)
  "Remove a VALUE of FIELD attached to FILES.

Interactively, a non-nil prefix argument is interpreted as a
numeric value for `dired-get-marked-files's ARG.

$ git annex metadata --set FIELD-=VALUES FILES"
  (interactive
   (let* ((files (annexview--dired-files))
          (field (completing-read "Field: " (annexview-field-names files))))
     (list field
           (completing-read (format "%s-=" field)
                            (annexview-field-values field files))
           files)))
  (annexview-set files `((-= ,field ,value))))

;;;###autoload
(defun annexview-add-tag (tag files)
  "Attach TAG to FILES.

Interactively, a non-nil prefix argument is interpreted as a
numeric value for `dired-get-marked-files's ARG.

$ git annex metadata --set tag+=TAG FILES"
  (interactive
   (let ((files (annexview--dired-files)))
     (list
      (completing-read
       "Tag: "
       (if (= 1 (length files))
           (cl-set-difference (annexview-field-values 'tag)
                              (annexview-field-values 'tag files)
                              :test #'equal)
         (annexview-field-values 'tag)))
      files)))
  (annexview-set files `((+= "tag" ,tag))))

;;;###autoload
(defun annexview-remove-tag (tag files)
  "Remove TAG from FILES.

Interactively, a non-nil prefix argument is interpreted as a
numeric value for `dired-get-marked-files's ARG.

$ git annex metadata --set tag-=TAG FILES"
  (interactive
   (let ((files (dired-get-marked-files
                 nil (and current-prefix-arg
                          (prefix-numeric-value current-prefix-arg)))))
     (list (completing-read "Tag: " (annexview-field-values "tag" files))
           files)))
  (annexview-set files `((-= "tag" ,tag))))

;;;###autoload
(defun annexview-remove-field (field files)
  "Remove all FIELD values attached to FILES.

Interactively, a non-nil prefix argument is interpreted as a
numeric value for `dired-get-marked-files's ARG.

$ git annex metadata --remove FIELD FILES"
  (interactive
   (let ((files (annexview--dired-files)))
     (list (completing-read "Field: " (annexview-field-names files))
           files)))
  (apply #'annexview-call-git-annex "metadata" "--remove" field
         "--" files))


;;; Metadata views

;;; For completion
;;
;; TODO: Make helm use plain `completing-read' here.  Also check how
;; Ivy handles it.
;;
;; TODO: Semicolon is a bad delimiter because it could be in field
;; value.  What's better?

(defvar annexview-input-field-value-re
  (rx string-start
      ;; previous completed input
      (group (zero-or-more (zero-or-more not-newline) ":")
             ;; field key
             (group (any alnum)
                    (zero-or-more (any alnum "_" "." "-")))
             ;; assignment operator
             (group (or "=" "+=" "?=" "-=" "!=")))
      ;; input being currently completed
      (group (zero-or-more (not (any "=" ":"))))
      string-end)
  "Regexp that matches when the current completion is a field value.")

(defvar annexview-input-previous-item-re
  (rx string-start
      (group (zero-or-more not-newline)
             (or ":" ":!" "!"))
      (group (zero-or-more (not (any "!"))))
      string-end)
  "Regexp that matches when previous values have been completed.")

(defun annexview--completion-info (string)
  (cond
   ((string= "!" string)
    (list :negated "!" (substring string 1)))
   ((string-match annexview-input-field-value-re string)
    (list (match-string 2 string)
          (match-string 1 string)
          (match-string 4 string)))
   ((string-match annexview-input-previous-item-re string)
    (let ((previous (match-string 1 string))
          (current (match-string 2 string)))
      (list (if (string-suffix-p "!" previous) :negated :previous-input)
            previous
            current)))
   (t
    (list :plain "" string))))

(defun annexview-completion-function (string _predicate &optional flag)
  (when (memq flag '(nil t lambda))
    (pcase-let ((`(,type ,previous ,current)
                 (annexview--completion-info string)))
      (let ((ctable (pcase type
                      (`:negated
                       (annexview-tags))
                      ((or :plain :previous-input)
                       (append (annexview-field-names)
                               (annexview-tags)))
                      (`,field
                       (annexview-field-values field)))))
        (cond
         ((eq flag nil)
          (let ((rtn (try-completion current ctable)))
            (when (stringp rtn)
              (setq rtn
                    (concat previous current (substring rtn (length current))
                            (cond ((member rtn (annexview-tags)) ":")
                                  ((member rtn (annexview-field-names))
                                   ;; This could be = or !=.  Let's
                                   ;; assume that = is more likely to
                                   ;; be the desired one.
                                   "=")))))
            rtn))
         ((eq flag t)
          (all-completions current ctable))
         ((eq flag 'lambda)
          (and (assoc current ctable) t)))))))

(defvar annexview-completion-history nil)

(defun annexview-completing-read (prompt)
  (let ((annexview-git-annex-hash (annexview-git-annex-hash)))
    (split-string (completing-read prompt
                                   #'annexview-completion-function
                                   nil nil nil 'annexview-completion-history)
                  ":" 'omit-nulls "[: ]+")))

(defun annexview--dired-revert ()
  (when (eq major-mode 'dired-mode)
    (dired-revert))
  (goto-char (point-min))
  (dired-goto-next-file))

;; TODO: The current view should be indicated in some way (mode line
;; or in the Dired buffer).

;;;###autoload
(defun annexview-create-view (args)
  "Enter a git-annex view.
$ git annex view ARGS"
  (interactive (list (annexview-completing-read "View args: ")))
  (apply #'annexview-call-git-annex "view" args)
  (annexview--dired-revert))

;;;###autoload
(defun annexview-vadd (args)
  "Add subdirectories to a git-annex view.
$ git annex vadd ARGS"
  (interactive (list (annexview-completing-read "View args: ")))
  (apply #'annexview-call-git-annex "vadd" args)
  (annexview--dired-revert))

;;;###autoload
(defun annexview-vfilter (args)
  "Filter the current git-annex view.
$ git annex vfilter ARGS"
  (interactive (list (annexview-completing-read "View args: ")))
  (apply #'annexview-call-git-annex "vfilter" args)
  (annexview--dired-revert))

;;;###autoload
(defun annexview-vpop (&optional n)
  "Pop to Nth previous view.
$ git annex vpop N"
  (interactive "p")
  (setq n (or n 1))
  (funcall #'annexview-call-git-annex "vpop" (number-to-string n))
  (annexview--dired-revert))

;;;###autoload
(defun annexview-vcycle ()
  "Cycle order of view subdirectories.
$ git annex vcycle"
  (interactive)
  (funcall #'annexview-call-git-annex "vcycle")
  (annexview--dired-revert))

(defun annexview-views ()
  "Return a list of git-annex views."
  (mapcar (lambda (branch) (substring branch 6)) ;; views/<view name>
          (annexview-git-lines
           "for-each-ref" "--format=%(refname:short)" "refs/heads/views")))

;;;###autoload
(defun annexview-checkout-view (branch)
  "Switch to view on BRANCH.
Note that when you checkout a view branch directly, git-annex
does not consider you to be in a view, so commands like
`annexview-vpop' won't work."
  (interactive
   (list (concat "views/"
                 (completing-read "View: " (annexview-views) nil t))))
  (apply #'annexview-call-git (list  "checkout" branch))
  (annexview--dired-revert))


;;; Bindings

;;;###autoload
(defvar annexview-map
  (let ((map (make-sparse-keymap)))
    ;; Inspecting
    (define-key map "s" #'annexview-show-metadeta)
    ;; Modifying
    (define-key map "+" #'annexview-add-tag)
    (define-key map "-" #'annexview-remove-tag)
    (define-key map "=" #'annexview-field-set-value)
    (define-key map "R" #'annexview-remove-field)
    (define-key map "a" #'annexview-field-add-value)
    (define-key map "i" #'annexview-field-init-value)
    (define-key map "r" #'annexview-field-remove-value)
    ;;  Viewing
    (define-key map "a" #'annexview-vadd)
    (define-key map "c" #'annexview-checkout-view)
    (define-key map "f" #'annexview-vfilter)
    (define-key map "p" #'annexview-vpop)
    (define-key map "v" #'annexview-create-view)
    (define-key map (kbd "TAB") #'annexview-vcycle)
    map)
  "Keymap for Annexview commands.")
;;;###autoload
(fset 'annexview-map annexview-map)

(provide 'annexview)
;;; annexview.el ends here