diff options
| -rw-r--r-- | .dir-locals.el | 4 | ||||
| -rw-r--r-- | .gitignore | 3 | ||||
| -rw-r--r-- | Makefile | 33 | ||||
| -rw-r--r-- | README.md | 6 | ||||
| -rw-r--r-- | annexview-tests.el | 197 | ||||
| -rw-r--r-- | annexview.el | 604 |
6 files changed, 847 insertions, 0 deletions
diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..8759a39 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,4 @@ +((nil + (sentence-end-double-space . t)) + (emacs-lisp-mode + (indent-tabs-mode . nil))) diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..d0c3bfa --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*.elc +/annexview-autoloads.el +/config.mk diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..c09861c --- /dev/null +++ b/Makefile @@ -0,0 +1,33 @@ + +-include config.mk + +DASH_DIR ?= /dev/null +GHUB_DIR ?= /dev/null +WITH_EDITOR_DIR ?= /dev/null +MAGIT_POPUP_DIR ?= /dev/null +MAGIT_DIR ?= /dev/null + +EMACSBIN ?= emacs + +LOAD_PATH = -L $(DASH_DIR) -L $(WITH_EDITOR_DIR) -L $(GHUB_DIR) \ + -L $(MAGIT_POPUP_DIR) -L $(MAGIT_DIR) +BATCH = $(EMACSBIN) -Q --batch $(LOAD_PATH) + +all: annexview.elc annexview-autoloads.el + +.PHONY: test +test: annexview.elc + @$(BATCH) -L . -l annexview-tests.el \ + --eval "(ert-run-tests-batch-and-exit '(not (tag interactive)))" + +.PHONY: clean +clean: + $(RM) *.elc annexview-autoloads.el + +%.elc: %.el + @$(BATCH) -f batch-byte-compile $< + +%-autoloads.el: %.el + @$(BATCH) --eval \ + "(let ((make-backup-files nil)) \ + (update-file-autoloads \"$(CURDIR)/$<\" t \"$(CURDIR)/$@\"))" diff --git a/README.md b/README.md new file mode 100644 index 0000000..0441704 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +Annexview is an Emacs Dired interface for modifying [git-annex +metadata][0] and for creating [metadata-driven views][1]. See the +package commentary for more details. + +[0]: https://git-annex.branchable.com/metadata/ +[1]: https://git-annex.branchable.com/tips/metadata_driven_views/ diff --git a/annexview-tests.el b/annexview-tests.el new file mode 100644 index 0000000..62d1d7a --- /dev/null +++ b/annexview-tests.el @@ -0,0 +1,197 @@ +;;; annexview-tests.el --- Tests for Annexview + +;; Copyright (C) 2018 Kyle Meyer <kyle@kyleam.com> +;; +;; License: GPLv3 + +;;; Code: + +(require 'cl-lib) +(require 'ert) +(require 'subr-x) + +(require 'annexview) + +;;; Utilities + +;; Originally modified from Magit's magit-with-test-directory. +(defmacro annexview-with-test-directory (&rest body) + (declare (indent 0) (debug t)) + (let ((dir (make-symbol "dir"))) + `(let ((,dir (file-name-as-directory (make-temp-file "annexview-" t))) + (process-environment process-environment)) + (push "GIT_AUTHOR_NAME=A U Thor" process-environment) + (push "GIT_AUTHOR_EMAIL=a.u.thor@example.com" process-environment) + (condition-case err + (cl-letf (((symbol-function #'message) #'format)) + (let ((default-directory ,dir)) + ,@body)) + (error (message "Keeping test directory: %s" ,dir) + (signal (car err) (cdr err)))) + (delete-directory ,dir t)))) + +(defun annexview-tests-commit-annex-file (filename) + (with-temp-file (expand-file-name filename) + (insert (symbol-name (gensym "content")))) + (annexview-call-git-annex "add" filename) + (annexview-call-git "commit" (concat "-mAdd " filename))) + +(defmacro annexview-with-test-repo (&rest body) + (declare (indent 0) (debug t)) + `(annexview-with-test-directory + (annexview-call-git "init" ".") + (annexview-call-git "annex" "init" "test-repo") + (annexview-tests-commit-annex-file "foo") + (annexview-tests-commit-annex-file "bar") + (annexview-call-git-annex + "metadata" "--tag" "foo-tag0" "--tag" "foo-tag1" "--" "foo") + (annexview-call-git-annex "metadata" "--set" "f=bar-field" "--" "bar") + (annexview-call-git-annex "metadata" "--set" "year=2017" "--" "foo") + (annexview-call-git-annex "metadata" "--set" "year=2018" "--" "bar") + (unwind-protect + (progn ,@body) + (call-process "chmod" nil nil nil "-R" "777" ".")))) + +(defun annexview-string-sort (seq) + (sort seq #'string-lessp)) + + +;;; Inspection + +(ert-deftest annexview-metadata-key-fields () + (annexview-with-test-repo + (let ((assert-things + (lambda () + (let ((values (apply #'append (hash-table-values + (annexview-metadata-key-fields))))) + (should (member (list "tag" "foo-tag0" "foo-tag1") values)) + (should (member (list "f" "bar-field") values)) + (should (member (list "year" "2017") values)) + (should (member (list "year" "2018") values)))))) + (funcall assert-things) + ;; Dumb test of cache + (cl-letf (((symbol-function #'annexview--read-json-item) + (lambda () (error "Shouldn't be called")))) + (funcall assert-things))))) + +(ert-deftest annexview-fields () + (annexview-with-test-repo + (let ((values (annexview-fields))) + (should (= (length values) 3)) + (should (member (list "tag" "foo-tag0" "foo-tag1") values)) + (should (member (list "f" "bar-field") values)) + (should (member (list "year" "2017" "2018") values))) + (let ((foo-values (annexview-fields (list "foo")))) + (should (member (list "tag" "foo-tag0" "foo-tag1") + foo-values)) + (should (member (list "year" "2017") + foo-values))))) + +(ert-deftest annexview-field-names () + (annexview-with-test-repo + (should (equal (annexview-string-sort (annexview-field-names)) + (list "f" "tag" "year"))) + (should (equal (annexview-field-names (list "bar")) + (list "f" "year"))))) + +(ert-deftest annexview-field-values () + (annexview-with-test-repo + (should (equal (annexview-string-sort (annexview-field-values "year")) + (list "2017" "2018"))) + (should (equal (annexview-string-sort + (annexview-field-values "year" (list "foo"))) + (list "2017"))))) + +(ert-deftest annexview-field-values () + (annexview-with-test-repo + (should (equal (annexview-string-sort (annexview-tags)) + (list "foo-tag0" "foo-tag1"))) + (should (equal (annexview-string-sort (annexview-tags (list "foo"))) + (list "foo-tag0" "foo-tag1"))) + (should-not (annexview-tags (list "bar"))))) + + +;;; Modification + +(ert-deftest annexview-set () + (let ((assert-things + (lambda () + (should (equal (annexview-string-sort + (annexview-field-names (list "bar"))) + (list "f" "year"))) + (should (equal (annexview-field-values "f" (list "bar")) + (list "bar-field"))) + (should (equal (annexview-field-values "year" (list "bar")) + (list "2000"))) + (should (equal (annexview-field-values "tag" (list "foo")) + (list "foo-tag0" "tag-new")))))) + (annexview-with-test-repo + (annexview-set (list "foo") '((+= "tag" "tag-new") + (-= "tag" "foo-tag1"))) + (annexview-set (list "bar") '((\?= "f" "ignored") + (= "year" "2000"))) + (funcall assert-things)) + ;; Single item commands + (annexview-with-test-repo + (annexview-field-add-value "tag" "tag-new" (list "foo")) + (annexview-field-remove-value "tag" "foo-tag1" (list "foo")) + (annexview-field-init-value "f" "ignored" (list "bar")) + (annexview-field-set-value "year" "2000" (list "bar")) + (funcall assert-things)) + ;; Single item commands, with tag variants + (annexview-with-test-repo + (annexview-add-tag "tag-new" (list "foo")) + (annexview-remove-tag "foo-tag1" (list "foo")) + (annexview-field-init-value "f" "ignored" (list "bar")) + (annexview-field-set-value "year" "2000" (list "bar")) + (funcall assert-things)))) + +(ert-deftest annexview-remove-field () + (annexview-with-test-repo + (should (annexview-field-values "year" (list "foo" "bar"))) + (annexview-remove-field "year" (list "foo" "bar")) + (should-not (annexview-field-values "year" (list "foo" "bar"))))) + + +;;; Completion + +(ert-deftest annexview--completion-info () + (pcase-dolist (`(,string . ,expected) + '(("blah" . (:plain "" "blah")) + ("!neg" . (:negated "!" "neg")) + ("prev=v:curr" . (:previous-input "prev=v:" "curr")) + ("prev!=v:" . (:previous-input "prev!=v:" "")))) + (should (equal (annexview--completion-info string) + expected)))) + + +;;; Views + +(ert-deftest annexview-views () + (annexview-with-test-repo + (annexview-create-view (list "year=*")) + (should (file-exists-p "2017")) + (should (file-exists-p "2018")) + ;; vpop + (annexview-vpop) + (should-not (file-exists-p "2017")) + (should-not (file-exists-p "2018")) + ;; vcycle + (annexview-create-view (list "tag=*" "year=*")) + (should (equal (annexview-string-sort (annexview-views)) + (list "tag=_;year=_" "year=_"))) + (should (file-exists-p "foo-tag0")) + (should (file-exists-p "foo-tag1")) + (annexview-vcycle) + (should (file-exists-p "2017")) + (should (file-exists-p "2017/foo-tag0")) + ;; vfilter + (annexview-create-view (list "year=*")) + (annexview-vfilter (list "tag=foo-tag0")) + (should (file-exists-p "2017")) + (should-not (file-exists-p "2018")) + ;; vadd + (annexview-create-view (list "tag=*")) + (annexview-vadd (list "year=*")) + (should (file-exists-p "2017")) + (should (file-exists-p "2017/foo-tag0")))) 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 <kyle@kyleam.com> +;; 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 <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 '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/<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 |