diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/tablist-20170219.1935/tablist.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/tablist-20170219.1935/tablist.el | 1941 |
1 files changed, 1941 insertions, 0 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/tablist-20170219.1935/tablist.el b/configs/shared/emacs/.emacs.d/elpa/tablist-20170219.1935/tablist.el new file mode 100644 index 000000000000..1fbfb313528e --- /dev/null +++ b/configs/shared/emacs/.emacs.d/elpa/tablist-20170219.1935/tablist.el @@ -0,0 +1,1941 @@ +;;; tablist.el --- Extended tabulated-list-mode -*- lexical-binding: t -*- + +;; Copyright (C) 2013, 2014 Andreas Politz + +;; Author: Andreas Politz <politza@fh-trier.de> +;; Keywords: extensions, lisp +;; Package: tablist +;; Version: 0.70 +;; Package-Requires: ((emacs "24.3")) + +;; 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This package adds marks and filters to tabulated-list-mode. It +;; also kind of puts a dired face on tabulated list buffers. +;; +;; It can be used by deriving from tablist-mode and some features by +;; using tablist-minor-mode inside a tabulated-list-mode buffer. +;; + +;;; Code: + +(require 'cl-lib) +(require 'ring) +(require 'tabulated-list) +(require 'dired) +(require 'tablist-filter) + +;; +;; *Macros +;; + +(defmacro tablist-save-marks (&rest body) + "Eval body, while preserving all marks." + (let ((marks (make-symbol "marks"))) + `(let (,marks) + (save-excursion + (goto-char (point-min)) + (let ((re "^\\([^ ]\\)")) + (while (re-search-forward re nil t) + (push (cons (tabulated-list-get-id) + (tablist-get-mark-state)) + ,marks)))) + (unwind-protect + (progn ,@body) + (save-excursion + (dolist (m ,marks) + (let ((id (pop m))) + (goto-char (point-min)) + (while (and id (not (eobp))) + (when (equal id (tabulated-list-get-id)) + (tablist-put-mark-state m) + (setq id nil)) + (forward-line))))))))) + +(defmacro tablist-with-remembering-entry (&rest body) + "Remember where body left of and restore previous position. + +If the current entry is still visible, move to it. Otherwise move +to the next visible one after it. If that also fails, goto to +the beginning of the buffer. Finally move point to the major +column." + (declare (indent 0) (debug t)) + (let ((re (make-symbol "re")) + (id (make-symbol "id")) + (col (make-symbol "col"))) + `(let ((,re + (replace-regexp-in-string + "[\t ]+" "[\t ]*" (regexp-quote + (or (thing-at-point 'line) "")) + t t)) + (,id (tabulated-list-get-id)) + (,col (tablist-current-column))) + (progn + ,@body + (let (success pos) + (goto-char (point-min)) + (setq pos (point)) + (while (and (setq success (re-search-forward ,re nil t)) + (> (point) (prog1 pos (setq pos (point)))) + (forward-line -1) + (not (equal ,id (tabulated-list-get-id)))) + (forward-line)) + (unless success + (goto-char (point-min)) + (while (and (not (eobp)) + (not success)) + (if (equal (tabulated-list-get-id) ,id) + (setq success t) + (forward-line)))) + (unless (and success (not (invisible-p (point)))) + (goto-char (point-min))) + (tablist-skip-invisible-entries) + (tablist-move-to-column + (or ,col (car (tablist-major-columns)))) + (dolist (win (get-buffer-window-list)) + (set-window-point win (point)))))))) + +(defmacro tablist-with-filter-displayed (&rest body) + "Display the current filter in the mode while evalling BODY." + (let ((state (make-symbol "state"))) + `(let ((,state (tablist-display-filter 'state))) + (tablist-display-filter t) + (unwind-protect + (progn ,@body) + (tablist-display-filter ,state))))) + +;; +;; *Mode Maps +;; + +(defvar tablist-mode-filter-map + (let ((kmap (make-sparse-keymap))) + (define-key kmap "p" 'tablist-pop-filter) + (define-key kmap "r" 'tablist-push-regexp-filter) + (define-key kmap "=" 'tablist-push-equal-filter) + (define-key kmap "n" 'tablist-push-numeric-filter) + (define-key kmap "!" 'tablist-negate-filter) + (define-key kmap "t" 'tablist-toggle-first-filter-logic) + (define-key kmap "/" 'tablist-display-filter) + (define-key kmap "z" 'tablist-suspend-filter) + + (define-key kmap "a" 'tablist-push-named-filter) + (define-key kmap "s" 'tablist-name-current-filter) + (define-key kmap "D" 'tablist-delete-named-filter) + (define-key kmap "d" 'tablist-deconstruct-named-filter) + (define-key kmap "e" 'tablist-edit-filter) + (define-key kmap "C" 'tablist-clear-filter) + kmap)) + +(defvar tablist-mode-mark-map + (let ((kmap (make-sparse-keymap))) + (define-key kmap "c" 'tablist-change-marks) + (define-key kmap "!" 'tablist-unmark-all-marks) + (define-key kmap "r" 'tablist-mark-items-regexp) + (define-key kmap "n" 'tablist-mark-items-numeric) + (define-key kmap "m" 'tablist-mark-forward) + kmap)) + +(defvar tablist-mode-regexp-map + (let ((kmap (make-sparse-keymap))) + ;; (define-key kmap "&" 'tablist-flag-gargabe-items) + (define-key kmap "m" 'tablist-mark-items-regexp) + kmap)) + +(defvar tablist-minor-mode-map + (let ((kmap (make-sparse-keymap))) + (define-key kmap "m" 'tablist-mark-forward) + (define-key kmap (kbd "DEL") 'tablist-unmark-backward) + (define-key kmap "k" 'tablist-do-kill-lines) + (define-key kmap "U" 'tablist-unmark-all-marks) + (define-key kmap "u" 'tablist-unmark-forward) + (define-key kmap "t" 'tablist-toggle-marks) + + (define-key kmap (kbd "TAB") 'tablist-forward-column) + (define-key kmap "\t" 'tablist-forward-column) + (define-key kmap [backtab] 'tablist-backward-column) + + (define-key kmap "%" tablist-mode-regexp-map) + (define-key kmap "*" tablist-mode-mark-map) + (define-key kmap "/" tablist-mode-filter-map) + + ;; (define-key kmap "e" 'tablist-edit-column) + ;; (define-key kmap "i" 'tablist-insert-entry) + (define-key kmap "s" 'tablist-sort) + (define-key kmap [remap back-to-indentation] 'tablist-move-to-major-column) + (define-key kmap [remap next-line] 'tablist-next-line) + (define-key kmap [remap previous-line] 'tablist-previous-line) + (define-key kmap "<" 'tablist-shrink-column) + (define-key kmap ">" 'tablist-enlarge-column) + (define-key kmap "q" 'tablist-quit) + (define-key kmap "G" 'tablist-revert) + (define-key kmap (kbd "C-c C-e") 'tablist-export-csv) + kmap)) + +(defvar tablist-mode-map + (let ((kmap (copy-keymap tablist-minor-mode-map))) + (set-keymap-parent kmap tabulated-list-mode-map) + (define-key kmap "d" 'tablist-flag-forward) + (define-key kmap (kbd "RET") 'tablist-find-entry) + (define-key kmap "f" 'tablist-find-entry) + ;; (define-key kmap "~" 'tablist-flag-gargabe-items) + (define-key kmap "D" 'tablist-do-delete) + (define-key kmap "C" 'tablist-do-copy) + (define-key kmap "R" 'tablist-do-rename) + (define-key kmap "x" 'tablist-do-flagged-delete) + ;; (define-key kmap "F" 'tablist-find-marked-items) + ;; (define-key kmap (kbd "C-o") 'tablist-display-item) + kmap)) + +;; +;; *Variables +;; + +;; Marking +(defvar tablist-umark-filtered-entries t) +(defvar tablist-marker-char dired-marker-char + "The character used for marking.") +(defvar tablist-marker-face 'dired-mark + "The face used for the mark character.") +(defvar tablist-marked-face 'dired-marked + "The face used for marked major columns.") + +;; Operations +(defvar-local tablist-operations-function nil + "A function for handling operations on the entries. + +The function is called with varying number of arguments, while +the first one is always a symbol describing one of the following +operations. + +`supported-operations' + +This is the only mandatory operation. There are no other +arguments and the function should return a list of symbols of +supported operations. + +`delete' + +The 2nd argument will be a list of entry ID's. The function +should somehow delete these entries and update +`tabulated-list-entries'. + +`find-entry' + +The 2nd argument is the ID of an entry. The function should +somehow find/display this entry, i.e. a kind of default +operation. + +`edit-column' + +The function is called with 3 further arguments: ID, INDEX and +NEW-COLUMN, where ID represents the entry to edit, INDEX is the index +of the column and NEW-COLUMN is the proposed new value for this +column. It should either + +i. return a new edited complete entry and update +`tabulated-list-entries', or + +ii. throw an error, if NEW-COLUMN is not a valid value for this +column. + +`complete' + +The function is called with 4 further arguments: ID, INDEX, +STRING and POS, where ID represents an entry, INDEX is the index +of the column to complete, STRING it's current value and POS an +offset of the current position of point into STRING. + +The function should return a collection for this column, suitable +as argument for the function `completion-in-region'.") + +;; Differentiating columns +(defvar-local tablist-major-columns nil + "Columns used to mark and when querying.") + +;; Filter +(defvar-local tablist-current-filter nil) +(defvar-local tablist-filter-suspended nil) +(defvar tablist-named-filter nil) + +;; History variables +(defvar tablist-column-name-history nil) + +;; Hooks +(defvar tablist-selection-changed-functions nil + "A hook run when ever point moves to a different entry.") + +;; Context Window +(defvar-local tablist-context-window nil) +(defvar-local tablist-context-window-function nil) +(defvar tablist-context-window-display-action + `((display-buffer-reuse-window + tablist-display-buffer-split-below-and-attach) + (window-height . 0.25) + (inhibit-same-window . t))) + +;; +;; *Setup +;; + +(defvar savehist-additional-variables) +(add-hook 'savehist-save-hook + (lambda nil + (add-to-list 'savehist-additional-variables 'tablist-named-filter))) + +;;;###autoload +(define-minor-mode tablist-minor-mode + nil nil nil nil + (unless (derived-mode-p 'tabulated-list-mode) + (error "Buffer is not in Tabulated List Mode")) + (tablist-init (not tablist-minor-mode))) + +;;;###autoload +(define-derived-mode tablist-mode tabulated-list-mode "TL" + (tablist-init)) + +(defun tablist-init (&optional disable) + (let ((cleaned-misc (cl-remove 'tablist-current-filter + mode-line-misc-info :key 'car))) + (cond + ((not disable) + (set (make-local-variable 'mode-line-misc-info) + (append + (list + (list 'tablist-current-filter + '(:eval (format " [%s]" + (if tablist-filter-suspended + "suspended" + "filtered"))))))) + (add-hook 'post-command-hook + 'tablist-selection-changed-handler nil t) + (add-hook 'tablist-selection-changed-functions + 'tablist-context-window-update nil t)) + (t + (setq mode-line-misc-info cleaned-misc) + (remove-hook 'post-command-hook + 'tablist-selection-changed-handler t) + (remove-hook 'tablist-selection-changed-functions + 'tablist-context-window-update t))))) + +(defun tablist-quit () + (interactive) + (tablist-hide-context-window) + (quit-window)) + +(defvar-local tablist-selected-id nil) +(defvar tablist-edit-column-minor-mode) + +(defun tablist-selection-changed-handler () + (unless tablist-edit-column-minor-mode + (let ((id tablist-selected-id) + (selected (tabulated-list-get-id))) + (unless (eq selected id) + (setq tablist-selected-id selected) + (run-hook-with-args + 'tablist-selection-changed-functions + tablist-selected-id))))) + +(defvar tablist-context-window-update--timer nil) + +(defun tablist-context-window-update (&optional id) + (when (and tablist-context-window-function + (window-live-p tablist-context-window) + (not tablist-edit-column-minor-mode)) + (unless id + (setq id (tabulated-list-get-id))) + (when (timerp tablist-context-window-update--timer) + (cancel-timer tablist-context-window-update--timer)) + (setq tablist-context-window-update--timer + (run-with-idle-timer 0.1 nil + (lambda (fn window) + (when (window-live-p window) + (with-selected-window window + (set-window-dedicated-p nil nil) + (save-selected-window + (funcall fn id)) + (when (window-live-p (selected-window)) + (set-window-dedicated-p nil t))))) + tablist-context-window-function + tablist-context-window)))) + +(defun tablist-display-context-window () + (interactive) + (unless tablist-context-window-function + (error "No function for handling a context is defined")) + (unless (window-live-p tablist-context-window) + (setq tablist-context-window + (display-buffer + (current-buffer) + tablist-context-window-display-action))) + (prog1 + tablist-context-window + (tablist-context-window-update))) + +(defun tablist-hide-context-window () + (interactive) + (when (window-live-p tablist-context-window) + (let ((ignore-window-parameters t)) + (delete-window tablist-context-window))) + (setq tablist-context-window nil)) + +(defun tablist-toggle-context-window () + (interactive) + (if (window-live-p tablist-context-window) + (tablist-hide-context-window) + (tablist-display-context-window))) + +;; +;; *Marking +;; + +(defun tablist-revert () + "Revert the list with marks preserved, position kept." + (interactive) + (tablist-save-marks + (tablist-with-remembering-entry + (tabulated-list-revert)))) + +(defun tablist-major-columns () + (if (null tablist-major-columns) + (number-sequence 0 (1- (length tabulated-list-format))) + (if (numberp tablist-major-columns) + (list tablist-major-columns) + tablist-major-columns))) + +(defun tablist-put-mark (&optional pos) + "Put a mark before the entry at POS. + +POS defaults to point. Use `tablist-marker-char', +`tablist-marker-face', `tablist-marked-face' and +`tablist-major-columns' to determine how to mark and what to put +a face on." + (when (or (null tabulated-list-padding) + (< tabulated-list-padding 1)) + (setq tabulated-list-padding 1) + (tabulated-list-revert)) + (save-excursion + (and pos (goto-char pos)) + (unless (tabulated-list-get-id) + (error "No entry at this position")) + (let ((inhibit-read-only t)) + (tabulated-list-put-tag + (string tablist-marker-char)) + (put-text-property + (point-at-bol) + (1+ (point-at-bol)) + 'face tablist-marker-face) + (let ((columns (tablist-column-offsets))) + (dolist (c (tablist-major-columns)) + (when (and (>= c 0) + (< c (length columns))) + (let ((beg (+ (point-at-bol) + (nth c columns))) + (end (if (= c (1- (length columns))) + (point-at-eol) + (+ (point-at-bol) + (nth (1+ c) columns))))) + (cond + ((and tablist-marked-face + (not (eq tablist-marker-char ?\s))) + (tablist--save-face-property beg end) + (put-text-property + beg end 'face tablist-marked-face)) + (t (tablist--restore-face-property beg end)))))))))) + +(defun tablist-mark-forward (&optional arg interactive) + "Mark ARG entries forward. + +ARG is interpreted as a prefix-arg. If interactive is non-nil, +maybe use the active region instead of ARG. + +See `tablist-put-mark' for how entries are marked." + (interactive (list current-prefix-arg t)) + (cond + ;; Mark files in the active region. + ((and interactive (use-region-p)) + (save-excursion + (goto-char (region-beginning)) + (beginning-of-line) + (tablist-repeat-over-lines + (1+ (count-lines + (point) + (save-excursion + (goto-char (region-end)) + (beginning-of-line) + (point)))) + 'tablist-put-mark))) + ;; Mark the current (or next ARG) files. + (t + (tablist-repeat-over-lines + (prefix-numeric-value arg) + 'tablist-put-mark)))) + +(defun tablist-mark-backward (&optional arg interactive) + "Mark ARG entries backward. + +See `tablist-mark-forward'." + (interactive (list current-prefix-arg t)) + (tablist-mark-forward (- (prefix-numeric-value arg)) + interactive)) + +(defun tablist-unmark-forward (&optional arg interactive) + "Unmark ARG entries forward. + +See `tablist-mark-forward'." + (interactive (list current-prefix-arg t)) + (let ((tablist-marker-char ?\s) + tablist-marked-face) + (tablist-mark-forward arg interactive))) + +(defun tablist-unmark-backward (&optional arg interactive) + "Unmark ARG entries backward. + +See `tablist-mark-forward'." + (interactive (list current-prefix-arg t)) + (let ((tablist-marker-char ?\s) + tablist-marked-face) + (tablist-mark-backward arg interactive))) + +(defun tablist-flag-forward (&optional arg interactive) + "Flag ARG entries forward. + +See `tablist-mark-forward'." + (interactive (list current-prefix-arg t)) + (let ((tablist-marker-char ?D) + (tablist-marked-face 'dired-flagged)) + (tablist-mark-forward arg interactive))) + +(defun tablist-change-marks (old new) + "Change all OLD marks to NEW marks. + +OLD and NEW are both characters used to mark files." + (interactive + (let* ((cursor-in-echo-area t) + (old (progn (message "Change (old mark): ") (read-char))) + (new (progn (message "Change %c marks to (new mark): " old) + (read-char)))) + (list old new))) + (when (eq new ?\n) + (error "Mark character \\n is not allowed")) + (let ((default-mark-p (equal tablist-marker-char new)) + (tablist-marker-char old)) + (save-excursion + (tablist-map-over-marks + (lambda nil + (pcase new + (?D + (tablist-flag-forward 1)) + (_ + (let ((tablist-marker-char new) + (tablist-marked-face + (and default-mark-p + tablist-marked-face))) + (tablist-put-mark))))))))) + +(defun tablist-unmark-all-marks (&optional marks interactive) + "Remove alls marks in MARKS. + +MARKS should be a string of mark characters to match and defaults +to all marks. Interactively, remove all marks, unless a prefix +arg was given, in which case ask about which ones to remove. +Give a message, if interactive is non-nil. + +Returns the number of unmarked marks." + (interactive + (list (if current-prefix-arg + (read-string "Remove marks: ")) t)) + (let ((re (if marks + (tablist-marker-regexp marks) + "^[^ ]")) + (removed 0)) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward re nil t) + (let ((tablist-marker-char ?\s) + tablist-marker-face + tablist-marked-face) + (tablist-put-mark)) + (cl-incf removed))) + (when interactive + (message "Removed %d marks" removed)) + removed)) + +(defun tablist-toggle-marks () + "Unmark all marked and mark all unmarked entries. + +See `tablist-put-mark'." + (interactive) + (let ((marked-re (tablist-marker-regexp)) + (not-marked-re + (let ((tablist-marker-char ?\s)) + (tablist-marker-regexp)))) + (save-excursion + (goto-char (point-min)) + (tablist-skip-invisible-entries) + (while (not (eobp)) + (cond + ((looking-at marked-re) + (save-excursion (tablist-unmark-backward -1))) + ((looking-at not-marked-re) + (tablist-put-mark))) + (tablist-forward-entry))) + (tablist-move-to-major-column))) + +(defun tablist-get-marked-items (&optional arg distinguish-one-marked) + "Return marked or ARG entries." + (let ((items (save-excursion + (tablist-map-over-marks + (lambda () (cons (tabulated-list-get-id) + (tabulated-list-get-entry))) + arg nil distinguish-one-marked)))) + (if (and distinguish-one-marked + (eq (car items) t)) + items + (nreverse items)))) + +(defun tablist-mark-items-regexp (column-name regexp) + "Mark entries matching REGEXP in column COLUMN-NAME." + (interactive + (tablist-read-regexp-filter "Mark" current-prefix-arg )) + (tablist-map-with-filter + 'tablist-put-mark + `(=~ ,column-name ,regexp))) + +(defun tablist-mark-items-numeric (binop column-name operand) + "Mark items fulfilling BINOP with arg OPERAND in column COLUMN-NAME. + +First the column's value is coerced to a number N. Then the test +proceeds as \(BINOP N OPERAND\)." + (interactive + (tablist-read-numeric-filter "Mark" current-prefix-arg)) + (tablist-map-with-filter + 'tablist-put-mark + `(,binop ,column-name ,operand))) + +(defun tablist-map-over-marks (fn &optional arg show-progress + distinguish-one-marked) + (prog1 + (cond + ((and arg (integerp arg)) + (let (results) + (tablist-repeat-over-lines + arg + (lambda () + (if show-progress (sit-for 0)) + (push (funcall fn) results))) + (if (< arg 0) + (nreverse results) + results))) + (arg + ;; non-nil, non-integer ARG means use current item: + (tablist-skip-invisible-entries) + (unless (eobp) + (list (funcall fn)))) + (t + (cl-labels ((search (re) + (let (sucess) + (tablist-skip-invisible-entries) + (while (and (setq sucess + (re-search-forward re nil t)) + (invisible-p (point))) + (tablist-forward-entry)) + sucess))) + (let ((regexp (tablist-marker-regexp)) + next-position results found) + (save-excursion + (goto-char (point-min)) + ;; remember position of next marked file before BODY + ;; can insert lines before the just found file, + ;; confusing us by finding the same marked file again + ;; and again and... + (setq next-position (and (search regexp) + (point-marker)) + found (not (null next-position))) + (while next-position + (goto-char next-position) + (if show-progress (sit-for 0)) + (push (funcall fn) results) + ;; move after last match + (goto-char next-position) + (forward-line 1) + (set-marker next-position nil) + (setq next-position (and (search regexp) + (point-marker))))) + (if (and distinguish-one-marked (= (length results) 1)) + (setq results (cons t results))) + (if found + results + (unless (or (eobp) (invisible-p (point))) + (list (funcall fn)))))))) + (tablist-move-to-major-column))) + +(defun tablist-marker-regexp (&optional marks) + "Return a regexp matching marks in MARKS. + +MARKS should be a string of mark characters to match and defaults +to the current value of `tablist-marker-char' as a string." + (concat (format "^[%s]" + (or marks (string tablist-marker-char))))) + +(defun tablist-get-mark-state () + "Return the mark state of the entry at point." + (save-excursion + (beginning-of-line) + (when (looking-at "^\\([^ ]\\)") + (let ((mark (buffer-substring + (match-beginning 1) + (match-end 1)))) + (tablist-move-to-major-column) + (list (aref mark 0) + (get-text-property 0 'face mark) + (get-text-property (point) 'face)))))) + +(defun tablist-put-mark-state (state) + "Set the mark of the entry at point according to STATE. + +STATE is a return value of `tablist-get-mark-state'." + (cl-destructuring-bind (tablist-marker-char + tablist-marker-face + tablist-marked-face) + state + (tablist-put-mark))) + +(defun tablist-mark-prompt (arg items) + "Return a string suitable for use in a tablist prompt." + ;; distinguish-one-marked can cause the first element to be just t. + (if (eq (car items) t) (setq items (cdr items))) + (let ((count (length items))) + (if (= count 1) + (car items) + ;; more than 1 item: + (if (integerp arg) + ;; abs(arg) = count + ;; Perhaps this is nicer, but it also takes more screen space: + ;;(format "[%s %d items]" (if (> arg 0) "next" "previous") + ;; count) + (format "[next %d item%s]" + arg (dired-plural-s arg)) + (format "%c [%d item%s]" dired-marker-char count + (dired-plural-s count)))))) + +;; +;; *Movement +;; + +(defun tablist-forward-entry (&optional n) + "Move past the next N unfiltered entries." + (unless n (setq n 1)) + (while (and (> n 0) + (not (eobp))) + (forward-line) + (when (invisible-p (point)) + (tablist-skip-invisible-entries)) + (cl-decf n)) + (while (and (< n 0) + (not (bobp))) + (forward-line -1) + (when (invisible-p (point)) + (tablist-skip-invisible-entries t)) + (cl-incf n)) + n) + +(defun tablist-next-line (&optional n) + (interactive "p") + (when (and (< n 0) + (save-excursion + (end-of-line 0) + (tablist-skip-invisible-entries t) + (bobp))) + (signal 'beginning-of-buffer nil)) + (when (and (> n 0) + (save-excursion + (tablist-forward-entry) + (eobp))) + (signal 'end-of-buffer nil)) + + (let ((col (tablist-current-column))) + (tablist-forward-entry (or n 1)) + (if col + (tablist-move-to-column col) + (tablist-move-to-major-column)))) + +(defun tablist-previous-line (&optional n) + (interactive "p") + (tablist-next-line (- (or n 1)))) + +(defun tablist-repeat-over-lines (arg function) + "Call FUNCTION for the next ARG entries." + ;; Move out of potentially invisble area. + (tablist-skip-invisible-entries) + (let ((pos (make-marker))) + (while (and (> arg 0) + (not (eobp))) + (cl-decf arg) + (save-excursion + (tablist-forward-entry) + (move-marker pos (1+ (point)))) + (unless (eobp) + (save-excursion (funcall function))) + ;; Advance to the next line--actually, to the line that *was* next. + ;; (If FUNCTION inserted some new lines in between, skip them.) + (goto-char pos)) + (while (and (< arg 0) (not (bobp))) + (cl-incf arg) + (tablist-forward-entry -1) + (save-excursion (funcall function))) + (move-marker pos nil) + (tablist-move-to-major-column))) + +(defun tablist-move-to-column (n) + "Move to the N'th list column." + (interactive "p") + (when (tabulated-list-get-id) + (let ((columns (tablist-column-offsets))) + (when (or (< n 0) + (>= n (length columns))) + (error "No such column: %s" n)) + (beginning-of-line) + (forward-char (nth n columns)) + (when (and (plist-get (nthcdr 3 (elt tabulated-list-format n)) + :right-align) + (not (= n (1- (length columns))))) + (forward-char (1- (car (cdr (elt tabulated-list-format n))))))))) + +(defun tablist-move-to-major-column (&optional first-skip-invisible-p) + "Move to the first major column." + (interactive (list t)) + (when first-skip-invisible-p + (tablist-skip-invisible-entries)) + (tablist-move-to-column (car (tablist-major-columns)))) + +(defun tablist-forward-column (n) + "Move n columns forward, while wrapping around." + (interactive "p") + (unless (tabulated-list-get-id) + (error "No entry on this line")) + (let* ((columns (tablist-column-offsets)) + (current (1- (length columns)))) + ;; find current column + (while (and (>= current 0) + (> (nth current columns) + (current-column))) + (cl-decf current)) + ;; there may be an invisible spec here + (when (bolp) + (forward-char)) + ;; before any columns + (when (< current 0) + (goto-char (+ (point-at-bol) (if (> n 0) + (car columns) + (car (last columns))))) + (setq n (* (cl-signum n) (1- (abs n))))) + (when (/= n 0) + (tablist-move-to-column + (mod (+ current n) (length columns)))))) + +(defun tablist-backward-column (n) + "Move n columns backward, while wrapping around." + (interactive "p") + (tablist-forward-column (- n))) + +;; +(defun tablist-skip-invisible-entries (&optional backward) + "Skip invisible entries BACKWARD or forward. + +Do nothing, if the entry at point is visible. Otherwise move to +the beginning of the next visible entry in the direction +determined by BACKWARD. + +Return t, if point is now in a visible area." + + (cond + ((and backward + (not (bobp)) + (get-text-property (point) 'invisible)) + (when (get-text-property (1- (point)) 'invisible) + (goto-char (previous-single-property-change + (point) + 'invisible nil (point-min)))) + (forward-line -1)) + ((and (not backward) + (not (eobp)) + (get-text-property (point) 'invisible)) + (goto-char (next-single-property-change + (point) + 'invisible nil (point-max))))) + (not (invisible-p (point)))) + +;; +;; *Operations +;; + +(defun tablist-yes-or-no-p (operation arg items) + "Query the user whether to proceed with some operation. + +Operation should be a symbol or string describing the operation, +ARG the prefix-arg of the command used in +`tablist-get-marked-items' or elsewhere, to get the ITEMS." + + (let ((pp-items (mapcar 'tablist-pretty-print-entry + (mapcar 'cdr items))) + dired-no-confirm + (op-str (upcase-initials + (if (stringp operation) + operation + (symbol-name operation))))) + (dired-mark-pop-up + (format " *%s*" op-str) nil + pp-items + dired-deletion-confirmer + (format "%s %s " + op-str + (tablist-mark-prompt arg pp-items))))) + +(defun tablist-operation-available-p (op) + (and (functionp tablist-operations-function) + (memq op (funcall tablist-operations-function + 'supported-operations)))) + +(defun tablist-do-delete (&optional arg) + "Delete ARG entries." + (interactive "P") + (unless (tablist-operation-available-p 'delete) + (error "Deleting entries is not available in this buffer")) + (let ((items (tablist-get-marked-items arg))) + (when (tablist-yes-or-no-p 'delete arg items) + (tablist-do-kill-lines arg) + (funcall tablist-operations-function + 'delete (mapcar 'car items)) + (tablist-move-to-major-column)))) + +(defun tablist-do-flagged-delete (&optional interactive) + "Delete all entries marked with a D." + (interactive "p") + (let* ((tablist-marker-char ?D)) + (if (save-excursion + (goto-char (point-min)) + (re-search-forward (tablist-marker-regexp) nil t)) + (tablist-do-delete) + (or (not interactive) + (message "(No deletions requested)"))))) + +(defun tablist-do-kill-lines (&optional arg interactive) + "Remove ARG lines from the display." + (interactive (list current-prefix-arg t)) + (save-excursion + (let ((positions + (tablist-map-over-marks 'point arg)) + (inhibit-read-only t)) + (dolist (pos positions) + (goto-char pos) + (tabulated-list-delete-entry)) + (when interactive + (message (format "Killed %d line%s" + (length positions) + (dired-plural-s (length positions)))))))) + +(defun tablist-do-operation (arg fn operation &optional delete-p revert-p) + "Operate on marked items. + +ARG should be the `current-prefix-arg', FN is a function of two +arguments \(ID ENTRY\) handling the operation. It gets called +repeatly with all marked items. OPERATION is a symbol or string +describing the operation, it is used for display. + +Optional non-nil DELETE-P means, remove the items from the display. +Optional REVERT-P means, revert the display afterwards." + (let ((items (tablist-get-marked-items arg))) + (unless items + (error "No items marked")) + (when (tablist-yes-or-no-p operation arg items) + (when delete-p + (tablist-do-kill-lines arg)) + (dolist (item items) + (funcall fn (car item))) + (when revert-p + (tablist-revert)) + (tablist-move-to-major-column)))) + +;; +;; *Editing +;; +(defvar tablist-edit-column-minor-mode-map + (let ((kmap (make-sparse-keymap))) + (set-keymap-parent kmap (current-global-map)) + (define-key kmap [remap self-insert-command] 'self-insert-command) + (define-key kmap "\r" 'tablist-edit-column-commit) + (define-key kmap (kbd "C-g") 'tablist-edit-column-quit) + (define-key kmap (kbd "C-c C-c") 'tablist-edit-column-commit) + (define-key kmap (kbd "C-c C-q") 'tablist-edit-column-quit) + (define-key kmap "\t" 'tablist-edit-column-complete) + (define-key kmap (kbd "TAB") 'tablist-edit-column-complete) + (define-key kmap [remap end-of-buffer] 'end-of-line) + (define-key kmap [remap beginning-of-buffer] 'beginning-of-line) + (define-key kmap [remap mark-whole-buffer] 'tablist-edit-column-mark-field) + kmap)) + +(define-minor-mode tablist-edit-column-minor-mode + "" nil nil nil + (unless (or tablist-minor-mode + (derived-mode-p 'tablist-mode)) + (error "Not in a tablist buffer")) + (cond + (tablist-edit-column-minor-mode + (add-to-list 'mode-line-misc-info + '(tablist-edit-column-minor-mode "[edit]")) + (add-hook 'post-command-hook 'tablist-edit-column-constrain-point nil t) + (read-only-mode -1)) + (t + (remove-hook 'post-command-hook 'tablist-edit-column-constrain-point t) + (read-only-mode 1)))) + +(defun tablist-edit-column (&optional n) + (interactive "P") + (unless n (setq n (tablist-current-column))) + (tablist-assert-column-editable n) + (let* ((offsets (append (tablist-column-offsets) + (list (- (point-at-eol) + (point-at-bol))))) + (beg (+ (point-at-bol) + (nth n offsets))) + (end (+ (point-at-bol) + (nth (1+ n) offsets))) + (entry (tabulated-list-get-entry beg)) + (inhibit-read-only t) + (inhibit-field-text-motion t) + (alist `((entry . ,entry) + (column . ,n) + (id . ,(tabulated-list-get-id beg)))) + ov) + (goto-char beg) + (delete-region beg end) + (add-text-properties + (point-at-bol) (point-at-eol) + '(read-only t field t)) + (unless (= beg (point-at-bol)) + (put-text-property (1- beg) beg 'rear-nonsticky t)) + (save-excursion + ;; Keep one read-only space at the end for keeping text + ;; properties. + (insert + (propertize + (concat + (tablist-nth-entry n entry) + (propertize " " + 'display `(space :align-to ,(- end (point-at-bol))))) + 'field nil + 'front-sticky '(tablist-edit) + 'rear-nonsticky '(read-only field) + 'tablist-edit alist)) + (setq end (point))) + (add-text-properties + (1- end) end '(read-only t field 'tablist-edit-end)) + (setq ov (make-overlay beg end)) + (overlay-put ov 'priority 9999) + (overlay-put ov 'face '(:background "deep sky blue" :foreground "white")) + (overlay-put ov 'evaporate t) + (overlay-put ov 'tablist-edit t) + (tablist-edit-column-minor-mode 1))) + +(defun tablist-edit-column-quit () + (interactive) + (tablist-edit-column-commit t)) + +(defun tablist-edit-column-commit (&optional abandon-edit) + (interactive (list current-prefix-arg)) + (let ((inhibit-read-only t) + (inhibit-field-text-motion t) + bounds) + (condition-case nil + (setq bounds (tablist-edit-column-bounds)) + (error + (tablist-edit-column-minor-mode -1) + (tabulated-list-revert) + (put-text-property (point-min) (point-max) + 'tablist-edit nil) + (error "Unable to complete the edit"))) + (let* ((beg (car bounds)) + (end (cdr bounds)) + (alist (get-text-property beg 'tablist-edit)) + (column (cdr (assq 'column alist))) + (id (cdr (assq 'id alist))) + (entry (cdr (assq 'entry alist))) + (item (buffer-substring-no-properties beg (1- end)))) + + (unless abandon-edit + ;; Throws an error, if item is invalid. + (setq entry (funcall tablist-operations-function + 'edit-column id column item))) + (tablist-edit-column-minor-mode -1) + (remove-overlays beg end 'tablist-edit t) + (put-text-property beg end 'tablist-edit nil) + (delete-region (point-at-bol) (1+ (point-at-eol))) + (save-excursion + (tabulated-list-print-entry id entry)) + (forward-char (nth column (tablist-column-offsets)))))) + +(defun tablist-edit-column-complete () + (interactive) + (unless (tablist-operation-available-p 'complete) + (error "Completion not available")) + (cl-destructuring-bind (beg &rest end) + (tablist-edit-column-bounds t) + (let* ((string (buffer-substring-no-properties + beg end)) + (alist (get-text-property beg 'tablist-edit)) + (completions (funcall tablist-operations-function + 'complete + (cdr (assq 'id alist)) + (cdr (assq 'column alist)) + string + (- (point) beg)))) + (unless completions + (error "No completions available")) + (completion-in-region beg end completions)))) + +(defun tablist-column-editable (n) + (and (tablist-operation-available-p 'edit-column) + (not (tablist-column-property n :read-only)))) + +(defun tablist-assert-column-editable (n) + (unless (and (>= n 0) + (< n (length tabulated-list-format))) + (error "Invalid column number: %s" n)) + (unless (tablist-operation-available-p 'edit-column) + (error "Editing columns not enabled in this buffer")) + (when (tablist-column-property n :read-only) + (error "This column is read-only"))) + +(defun tablist-edit-column-constrain-point () + (unless tablist-edit-column-minor-mode + (error "Not editing a column")) + (unless (get-text-property (point) 'tablist-edit) + (let ((bounds (tablist-edit-column-bounds))) + (when bounds + (if (> (point) (cdr bounds)) + (goto-char (1- (cdr bounds))) + (goto-char (car bounds))) + (point))))) + +(defun tablist-edit-column-bounds (&optional skip-final-space) + (unless tablist-edit-column-minor-mode + (error "Not editing a column")) + (let ((pos (next-single-property-change + (point) 'tablist-edit)) + beg end) + (cond + ((null pos) + (setq end (previous-single-property-change + (point-max) 'tablist-edit) + beg (previous-single-property-change + end 'tablist-edit))) + ((get-text-property pos 'tablist-edit) + (setq beg pos + end (next-single-property-change + pos 'tablist-edit))) + (pos + (setq end pos + beg (previous-single-property-change + pos 'tablist-edit)))) + + (unless (and beg end (get-text-property beg 'tablist-edit)) + (error "Unable to locate edited text")) + (cons beg (if skip-final-space (1- end) end)))) + +(defun tablist-edit-column-mark-field () + (interactive) + (push-mark (field-beginning)) + (push-mark (field-end) nil t) + (goto-char (field-beginning))) + +(defun tablist-find-entry (&optional id) + (interactive) + (unless (tablist-operation-available-p 'find-entry) + (error "Finding entries not supported in this buffer")) + (funcall tablist-operations-function + 'find-entry + (or id (tabulated-list-get-id)))) + +;; +;; *Utility +;; + +(defun tablist-column-property (n prop) + (plist-get + (nthcdr 3 (aref tabulated-list-format n)) + prop)) + +(defun tablist-current-column () + "Return the column number at point. + +Returns nil, if point is before the first column." + (let ((column + (1- (cl-position + (current-column) + (append (tablist-column-offsets) + (list most-positive-fixnum)) + :test (lambda (column offset) (> offset column)))))) + (when (>= column 0) + column))) + +(defun tablist-column-offsets () + "Return a list of column positions. + +This is a list of offsets from the beginning of the line." + (let ((cc tabulated-list-padding) + columns) + (dotimes (i (length tabulated-list-format)) + (let* ((c (aref tabulated-list-format i)) + (len (nth 1 c)) + (pad (or (plist-get (nthcdr 3 c) :pad-right) + 1))) + (push cc columns) + (when (numberp len) + (cl-incf cc len)) + (when pad + (cl-incf cc pad)))) + (nreverse columns))) + +(defun tablist-pretty-print-entry (item) + (mapconcat (lambda (i) + (tablist-nth-entry i item)) + (tablist-major-columns) " ")) + +(defun tablist--save-face-property (beg end) + ;; We need to distinguish ,,not set'' from ''no face''. + (unless (and (text-property-not-all beg end 'face nil) + (< beg end)) + (put-text-property beg (1+ beg) 'face 'default)) + (unless (text-property-not-all beg end 'tablist-saved-face nil) + (tablist-copy-text-property beg end 'face 'tablist-saved-face))) + +(defun tablist--restore-face-property (beg end) + (when (text-property-not-all beg end 'tablist-saved-face nil) + (tablist-copy-text-property beg end 'tablist-saved-face 'face))) + +(defun tablist-copy-text-property (beg end from to) + "Copy text property FROM to TO in region BEG to END." + (let ((inhibit-read-only t)) + (save-excursion + (while (< beg end) + (goto-char beg) + (put-text-property + (point) + (setq beg (next-single-property-change + (point) from nil end)) + to + (get-text-property (point) from)))))) + +;; +(defun tablist-read-column-name (arg &optional prompt default) + "Read the name of a column using ARG. + +If ARG is a number, return column ARG. +If ARG is nil, return DEFAULT or the current column. +Else ask the user, using PROMPT and DEFAULT." + (cond + ((numberp arg) + (or (tablist-column-name + (prefix-numeric-value arg)) + (error "No such column: %d" (prefix-numeric-value arg)))) + ((null arg) + (or default + (tablist-column-name + (or (tablist-current-column) + (car (tablist-major-columns)) + 0)))) + (t + (let* ((default (or default + (tablist-column-name + (car (tablist-major-columns))))) + (result + (completing-read + (format "%s %s: " + (or prompt "Use column") + (if default + (format "(default %s)" + default) + "")) + (tablist-column-names) + nil t nil 'tablist-column-name-history))) + (if (> (length result) 0) + result + (if (not default) + (error "No column selected") + default)))))) + +(defun tablist-column-name (n) + "Return the name of column N." + (when (and n + (>= n 0) + (< n (length tabulated-list-format))) + (substring-no-properties + (car (elt tabulated-list-format n)) 0))) + +(defun tablist-column-names () + "Return a list of all column-names." + (mapcar 'tablist-column-name + (number-sequence 0 (1- (length tabulated-list-format))))) + +(defun tablist-nth-entry (n &optional entry) + (unless entry (setq entry (tabulated-list-get-entry))) + (when (and entry + (>= n 0) + (< n (length entry))) + (let ((str (elt entry n))) + (if (stringp str) + str + (car str))))) + +(defun tablist-major-column-name () + "Return a list of the major column names." + (tablist-column-name (car (tablist-major-columns)))) + +(defun tablist-export-csv (&optional separator always-quote-p + invisible-p out-buffer display-p) + "Export a tabulated list to a CSV format. + +Use SEPARATOR (or ;) and quote if necessary (or always if +ALWAYS-QUOTE-P is non-nil). Only consider non-filtered entries, +unless invisible-p is non-nil. Create a buffer for the output or +insert it after point in OUT-BUFFER. Finally if DISPLAY-P is +non-nil, display this buffer. + +Return the output buffer." + + (interactive (list nil t nil nil t)) + (unless (derived-mode-p 'tabulated-list-mode) + (error "Not in Tabulated List Mode")) + (unless (stringp separator) + (setq separator (string (or separator ?\;)))) + (let* ((outb (or out-buffer + (get-buffer-create + (format "%s.csv" (buffer-name))))) + (escape-re (format "[%s\"\n]" separator)) + (header (tablist-column-names))) + (unless (buffer-live-p outb) + (error "Expected a live buffer: %s" outb)) + (cl-labels + ((printit (entry) + (insert + (mapconcat + (lambda (e) + (unless (stringp e) + (setq e (car e))) + (if (or always-quote-p + (string-match escape-re e)) + (concat "\"" + (replace-regexp-in-string "\"" "\"\"" e t t) + "\"") + e)) + entry separator)) + (insert ?\n))) + (with-current-buffer outb + (let ((inhibit-read-only t)) + (erase-buffer) + (printit header))) + (save-excursion + (goto-char (point-min)) + (unless invisible-p + (tablist-skip-invisible-entries)) + (while (not (eobp)) + (let* ((entry (tabulated-list-get-entry))) + (with-current-buffer outb + (let ((inhibit-read-only t)) + (printit entry))) + (if invisible-p + (forward-line) + (tablist-forward-entry))))) + (if display-p + (display-buffer outb)) + outb))) + +;; + +(defun tablist-enlarge-column (&optional column width) + "Enlarge column COLUMN by WIDTH. + +This function is lazy and therfore pretty slow." + (interactive + (list nil (* (prefix-numeric-value current-prefix-arg) + 3))) + (unless column (setq column (tablist-current-column))) + (unless column + (error "No column given and no entry at point")) + (unless width (setq width 1)) + (when (or (not (numberp column)) + (< column 0) + (>= column (length tabulated-list-format))) + (error "No such column: %d" column)) + (when (= column (1- (length tabulated-list-format))) + (error "Can't resize last column")) + + (let* ((cur-width (cadr (elt tabulated-list-format column)))) + (setcar (cdr (elt tabulated-list-format column)) + (max 3 (+ cur-width width))) + (tablist-with-remembering-entry + (tablist-save-marks + (tabulated-list-init-header) + (tabulated-list-print))))) + +(defun tablist-shrink-column (&optional column width) + (interactive + (list nil (* (prefix-numeric-value current-prefix-arg) + 3))) + (tablist-enlarge-column column (- (or width 1)))) + +;; *Sorting +;; + +(defun tablist-sort (&optional column) + "Sort the tabulated-list by COLUMN. + +COLUMN may be either a name or an index. The default compare +function is given by the `tabulated-list-format', which see. + +This function saves the current sort column and the inverse +sort-direction in the variable `tabulated-list-sort-key', which +also determines the default COLUMN and direction. + +The main difference to `tabulated-list-sort' is, that this +function sorts the buffer in-place and it ignores a nil sort +entry in `tabulated-list-format' and sorts on the column +anyway (why not ?)." + + (interactive + (list + (if (null current-prefix-arg) + (tablist-column-name + (or (tablist-current-column) + (car (tablist-major-columns)) + 0)) + (tablist-read-column-name + '(4) "Sort by column" + (tablist-column-name (car (tablist-major-columns))))))) + + (unless column + (setq column (or (car tabulated-list-sort-key) + (tablist-column-name (car (tablist-major-columns))) + (tablist-column-name 0)))) + (when (numberp column) + (let ((column-name (tablist-column-name column))) + (unless column-name + (error "No such column: %d" column)) + (setq column column-name))) + + (setq tabulated-list-sort-key + (cons column + (if (equal column (car tabulated-list-sort-key)) + (cdr tabulated-list-sort-key)))) + + (let* ((entries (if (functionp tabulated-list-entries) + (funcall tabulated-list-entries) + tabulated-list-entries)) + (reverse (cdr tabulated-list-sort-key)) + (n (tabulated-list--column-number ;;errors if column is n/a + (car tabulated-list-sort-key))) + (compare-fn (nth 2 (aref tabulated-list-format n)))) + + (when (or (null compare-fn) + (eq compare-fn t)) + (setq compare-fn + (lambda (a b) + (setq a (aref (cadr a) n)) + (setq b (aref (cadr b) n)) + (string< (if (stringp a) a (car a)) + (if (stringp b) b (car b)))))) + + (unless compare-fn + (error "This column cannot be sorted: %s" column)) + + (setcdr tabulated-list-sort-key (not reverse)) + ;; Presort the entries and hash the result and sort the buffer. + (setq entries (sort (copy-sequence entries) compare-fn)) + (let ((hash (make-hash-table :test 'equal))) + (dotimes (i (length entries)) + (puthash (caar entries) i hash) + (setq entries (cdr entries))) + (tablist-with-remembering-entry + (goto-char (point-min)) + (tablist-skip-invisible-entries) + (let ((inhibit-read-only t)) + (sort-subr + nil 'tablist-forward-entry 'end-of-line + (lambda () + (gethash (tabulated-list-get-id) hash 0)) + nil (if reverse '< '>)))) + (tablist-move-to-column n) + ;; Make the sort arrows display. + (tabulated-list-init-header)))) + +;; +;; *Filter +;; + +(defun tablist-read-filter-name (prompt) + (let ((filter (cdr (assq major-mode tablist-named-filter)))) + (unless filter + (error "No filter defined for %s mode" mode-name)) + (let ((name (completing-read + (format "%s: " prompt) + filter + nil t))) + (unless (> (length name) 0) + (error "No filter selected")) + name))) + +(defun tablist-apply-filter (&optional filter) + "Apply FILTER to the current tabulated list. + +FILTER defaults to `tablist-current-filter'." + (unless filter (setq filter tablist-current-filter)) + (tablist-filter-unhide-buffer) + (when (and filter + (null tablist-filter-suspended)) + (tablist-with-remembering-entry + (tablist-map-with-filter + (lambda nil + (if tablist-umark-filtered-entries + (save-excursion (tablist-unmark-forward))) + (tablist-filter-hide-entry)) + (tablist-filter-negate filter)))) + (force-mode-line-update)) + +(defadvice tabulated-list-print (after tabulated-list activate) + "Reapply the filter." + (when (or tablist-minor-mode + (derived-mode-p 'tablist-mode)) + (tablist-apply-filter))) + +(defun tablist-eval-filter (filter) + (tablist-filter-eval + filter + (tabulated-list-get-id) + (tabulated-list-get-entry) + (cdr (assq major-mode tablist-named-filter)))) + +(defun tablist-map-with-filter (fn filter &optional show-progress + distinguish-one-marked) + "Call FN for every unfiltered entry matching FILTER." + (prog1 + (cl-labels ((search () + (tablist-skip-invisible-entries) + (while (and (not (eobp)) + (not (tablist-eval-filter filter))) + (tablist-forward-entry)) + (unless (eobp) + (point-marker)))) + (let (next-position results) + (save-excursion + (goto-char (point-min)) + (setq next-position (search)) + (while next-position + (goto-char next-position) + (if show-progress (sit-for 0)) + (push (funcall fn) results) + ;; move after last match + (goto-char next-position) + (forward-line 1) + (set-marker next-position nil) + (setq next-position (search))) + (if (and distinguish-one-marked (= (length results) 1)) + (setq results (cons t results)))))))) + +;; +;; **Filter Commands +;; +(defun tablist-push-filter (filter &optional interactive or-p) + (setq tablist-current-filter + (tablist-filter-push + tablist-current-filter + filter or-p)) + (tablist-apply-filter) + (when interactive + (tablist-display-filter-temporarily))) + +(defun tablist-pop-filter (&optional n interactive) + "Remove the first N filter components." + (interactive (list (prefix-numeric-value current-prefix-arg) t)) + (while (and tablist-current-filter + (> n 0)) + (setq tablist-current-filter + (tablist-filter-pop + tablist-current-filter)) + (cl-decf n)) + (tablist-apply-filter) + (when interactive + (when (> n 0) + (message "The filter is empty.")) + (tablist-display-filter-temporarily)) + n) + +(defun tablist-negate-filter (&optional interactive) + "Negate the current filter." + (interactive (list t)) + (setq tablist-current-filter + (tablist-filter-negate + tablist-current-filter)) + (tablist-apply-filter) + (when interactive + (tablist-display-filter-temporarily))) + +(defun tablist-toggle-first-filter-logic () + "Toggle between and/or for the first filter operand." + (interactive) + (setq tablist-current-filter + (pcase tablist-current-filter + (`(or ,x1 ,x2) + `(and ,x1 ,x2)) + (`(and ,x1 ,x2) + `(or ,x1 ,x2)) + (`(not ,x) x) + (x `(not ,x)))) + (tablist-apply-filter) + (tablist-display-filter-temporarily)) + +(defun tablist-suspend-filter (&optional flag) + "Temporarily disable filtering according to FLAG. + +Interactively, this command toggles filtering." + (interactive + (list (not tablist-filter-suspended))) + (let ((state tablist-filter-suspended)) + (unless (eq (not (not state)) + (not (not flag))) + (set (make-local-variable 'tablist-filter-suspended) flag) + (tablist-apply-filter)))) + +(defun tablist-read-regexp-filter (operation arg) + (let ((column-name (tablist-read-column-name arg))) + (list + column-name + (let ((re + (read-regexp (format "%s where %s matches: " operation column-name)))) + (unless (> (length re) 0) + (error "No regexp given")) + re)))) + +(defun tablist-read-equal-filter (operation arg) + (let ((column-name (tablist-read-column-name arg))) + (list + column-name + (read-string (format "%s where %s equals: " operation column-name))))) + +(defun tablist-read-numeric-filter (operation arg) + (let* ((entry (tabulated-list-get-entry 1)) + (default (cl-some + (lambda (idx) + (let ((value (tablist-nth-entry idx entry))) + (when (or (not (eq 0 (string-to-number value))) + (equal "0" value)) + (tablist-column-name idx)))) + (number-sequence 0 (length entry)))) + (column-name (tablist-read-column-name arg nil default)) + (op (completing-read + (format "%s %s matching binary op: " operation column-name) + '("=" "<" ">" "<=" ">=") nil t)) + oper) + + (when (equal "" op) + (error "No operation selected")) + (setq op (intern op)) + (setq oper (number-to-string + (read-number + (format "%s where %s %s " operation column-name op)))) + + (list op column-name oper))) + +(defun tablist-push-regexp-filter (column-name regexp) + "Add a new filter matching REGEXP in COLUMN-NAME. + +The filter is and'ed with the current filter. Use +`tablist-toggle-first-filter-logic' to change this." + (interactive + (tablist-with-filter-displayed + (tablist-read-regexp-filter "Filter" current-prefix-arg))) + (tablist-push-filter + `(=~ ,column-name ,regexp) + (called-interactively-p 'any))) + +(defun tablist-push-equal-filter (column-name string) + "Add a new filter whre string equals COLUMN-NAME's value. + +The filter is and'ed with the current filter. Use +`tablist-toggle-first-filter-logic' to change this." + (interactive + (tablist-with-filter-displayed + (tablist-read-equal-filter "Filter" current-prefix-arg))) + (tablist-push-filter + `(== ,column-name ,string) + (called-interactively-p 'any))) + +(defun tablist-push-numeric-filter (op column-name 2nd-arg) + "Add a new filter matching a numeric predicate. + +The filter is and'ed with the current filter. Use +`tablist-toggle-first-filter-logic' to change this." + (interactive + (tablist-with-filter-displayed + (tablist-read-numeric-filter "Filter" current-prefix-arg))) + (tablist-push-filter + `(,op ,column-name ,2nd-arg) + (called-interactively-p 'any))) + +(defun tablist-push-named-filter (name) + "Add a named filter called NAME. + +Named filter are saved in the variable `tablist-named-filter'." + (interactive + (tablist-with-filter-displayed + (list + (tablist-read-filter-name "Add filter")))) + (when (and name (symbolp name)) + (setq name (symbol-name name))) + (tablist-push-filter name (called-interactively-p 'any))) + +(defun tablist-delete-named-filter (name &optional mode) + (interactive + (tablist-with-filter-displayed + (list + (tablist-read-filter-name "Delete filter")))) + (setq tablist-current-filter + (tablist-filter-map + (lambda (f) + (when (equal f name) + (setq f (tablist-get-named-filter f))) + f) + tablist-current-filter)) + (unless mode (setq mode major-mode)) + (let ((mode-filter + (assq mode tablist-named-filter))) + (when mode-filter + (setcdr mode-filter + (cl-remove name (cdr mode-filter) + :test 'equal :key 'car))))) + +(defun tablist-name-current-filter (name) + (interactive + (list (tablist-with-filter-displayed + (read-string + "Add name for current filter: ")))) + (unless tablist-current-filter + (error "Filter is empty")) + (unless (> (length name) 0) + (error "No name given")) + (tablist-put-named-filter + name (if (stringp tablist-current-filter) + (tablist-get-named-filter + tablist-current-filter) + tablist-current-filter)) + (setq tablist-current-filter name) + (force-mode-line-update)) + +(defun tablist-deconstruct-named-filter () + (interactive) + (let (found) + (setq tablist-current-filter + (tablist-filter-map + (lambda (f) + (when (and (not found) + (stringp f)) + (setq found t) + (let ((df (tablist-get-named-filter f))) + (unless df + (error "Filter is not defined: %s" f)) + (setq f df))) + f) + tablist-current-filter)) + (unless found + (error "No named filter found")) + (force-mode-line-update))) + +(defun tablist-filter-names (&optional mode) + (mapcar 'car (cdr (assq (or mode major-mode) + tablist-named-filter)))) + +(defun tablist-get-named-filter (name &optional mode) + (cdr (assoc name + (cdr (assq (or mode major-mode) + tablist-named-filter))))) + +(defun tablist-put-named-filter (name filter &optional mode) + (unless mode (setq mode major-mode)) + (let ((mode-filter + (assq mode tablist-named-filter))) + (unless mode-filter + (setq mode-filter (cons mode nil)) + (push mode-filter tablist-named-filter)) + (let ((entry (assoc name mode-filter))) + (if entry + (setcdr entry filter) + (setcdr mode-filter + (list (cons name filter))))))) + +(defun tablist-validate-named-filter (filter) + (tablist-filter-map + (lambda (f) + (when (and (stringp f) + (null (tablist-get-named-filter f))) + (error "Undefined named filter: %s (defined: %s)" f + (mapconcat 'identity (tablist-filter-names) ",")))) + filter)) + +(defun tablist-edit-filter () + (interactive) + (setq tablist-current-filter + (tablist-with-filter-displayed + (tablist-filter-edit-filter + "Edit filter: " + tablist-current-filter + nil + 'tablist-validate-named-filter))) + (tablist-apply-filter)) + +(defun tablist-clear-filter () + (interactive) + (setq tablist-current-filter nil) + (tablist-apply-filter)) + +;; **Displaying filter +;; + +(defconst tablist-display-filter-mode-line-tag nil) + +(defun tablist-display-filter (&optional flag) + "Display the current filter according to FLAG. + +If FLAG has the value 'toggle, toggle it's visibility. +If FLAG has the 'state, then do nothing but return the current +visibility." + (interactive (list 'toggle)) + (let* ((tag 'tablist-display-filter-mode-line-tag) + (displayed-p (not (not (assq tag mode-line-format))))) + (if (eq flag 'state) + displayed-p + (let ((display-p (not (not (if (eq flag 'toggle) + (not displayed-p) + flag))))) + (unless (eq displayed-p display-p) + (setq mode-line-format + (if display-p + (list (cons tag mode-line-format) + '(:eval + (replace-regexp-in-string + "%" "%%" + (concat + (propertize "Filter: " 'face 'minibuffer-prompt) + (and tablist-filter-suspended + "[suspended] ") + (if tablist-current-filter + (tablist-filter-unparse + tablist-current-filter t) + "[none]"))))) + (cdr (assq tag mode-line-format))))) + (force-mode-line-update) + display-p)))) + +(defun tablist-display-filter-temporarily () + (tablist-with-filter-displayed + (sit-for 9999))) + +;; +;; **Hiding/Unhiding Entries +;; +(defun tablist-filter-set-entry-hidden (flag &optional pos) + (save-excursion + (when pos (goto-char pos)) + (beginning-of-line) + (let ((inhibit-read-only t)) + (add-text-properties + (point-at-bol) + (1+ (point-at-eol)) + `(invisible ,flag))))) + +(defun tablist-filter-hide-entry (&optional pos) + (interactive) + (tablist-filter-set-entry-hidden t pos)) + +(defun tablist-filter-unhide-entry (&optional pos) + (tablist-filter-set-entry-hidden nil pos)) + +(defun tablist-filter-unhide-buffer () + (let ((inhibit-read-only t)) + (remove-text-properties + (point-min) (point-max) + '(invisible)))) + +(defun tablist-window-attach (awindow &optional window) + "Attach AWINDOW to WINDOW. + +This has the following effect. Whenever WINDOW, defaulting to +the selected window, stops displaying the buffer it currently +displays (e.g., by switching buffers or because it was deleted) +AWINDOW is deleted." + (unless window (setq window (selected-window))) + (let ((buffer (window-buffer window)) + (hook (make-symbol "window-attach-hook"))) + (fset hook + (lambda () + (when (or (not (window-live-p window)) + (not (eq buffer (window-buffer window)))) + (remove-hook 'window-configuration-change-hook + hook) + ;; Deleting windows inside wcch may cause errors in + ;; windows.el . + (run-with-timer + 0 nil (lambda (win) + (when (and (window-live-p win) + (not (eq win (selected-window)))) + (delete-window win))) + awindow)))) + (add-hook 'window-configuration-change-hook hook))) + +(defun tablist-display-buffer-split-below-and-attach (buf alist) + "Display buffer action using `tablist-window-attach'." + (let ((window (selected-window)) + (height (cdr (assq 'window-height alist))) + newwin) + (when height + (when (floatp height) + (setq height (round (* height (frame-height))))) + (setq height (- (max height window-min-height)))) + (setq newwin (window--display-buffer + buf + (split-window-below height) + 'window alist display-buffer-mark-dedicated)) + (tablist-window-attach newwin window) + newwin)) + +(defun tablist-generate-sorter (column compare-fn &optional read-fn) + "Generate a sort function for `tabulated-list' entries. + +Example: + + \(tablist-generate-sorter 0 '< 'string-to-number\) + +would create a sort function sorting `tabulated-list-entries' on +the 0-th column as numbers by the less-than relation." + + (lambda (e1 e2) + (funcall compare-fn + (funcall (or read-fn 'identity) + (aref (cadr e1) column)) + (funcall read-fn + (aref (cadr e2) column))))) + +(provide 'tablist) +;;; tablist.el ends here |