From 1dd933e602c51016eece8ec24663b877cee0a5f0 Mon Sep 17 00:00:00 2001 From: Kyle Meyer Date: Sat, 14 Jul 2018 01:12:23 -0400 Subject: Hello, Pluto Provide support for creating/modifying views and setting metadata. All of git-annex's view commands are exposed, and most of the "setting" features of the 'git annex metadata' command are supported. Of the remaining bits, I intend to support only the --force flag (needed for setting metadata a directory's files). The user interface may still require a good amount of tweaking, but things seem to be in a working state. --- annexview.el | 604 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 604 insertions(+) create mode 100644 annexview.el (limited to 'annexview.el') diff --git a/annexview.el b/annexview.el new file mode 100644 index 0000000..a05992a --- /dev/null +++ b/annexview.el @@ -0,0 +1,604 @@ +;;; annexview.el --- Dired interface for git-annex views -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Kyle Meyer + +;; Author: Kyle Meyer +;; URL: https://gitlab.com/kyleam/annexview +;; 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 . + +;;; 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 'stringp) + + +;;; 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)) + (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/ + (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 -- cgit v1.2.3