summaryrefslogtreecommitdiff
path: root/tablist-filter.el
diff options
context:
space:
mode:
Diffstat (limited to 'tablist-filter.el')
-rw-r--r--tablist-filter.el449
1 files changed, 449 insertions, 0 deletions
diff --git a/tablist-filter.el b/tablist-filter.el
new file mode 100644
index 0000000..6a6f058
--- /dev/null
+++ b/tablist-filter.el
@@ -0,0 +1,449 @@
+;;; tablist-filter.el --- Filter expressions for tablists.
+
+;; Copyright (C) 2013, 2014 Andreas Politz
+
+;; Author: Andreas Politz <politza@fh-trier.de>
+;; Keywords: extensions, lisp
+
+;; 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:
+
+;;
+
+(let (python-mode-hook)
+(require 'semantic/wisent/comp)
+(require 'semantic/wisent/wisent))
+
+;;; Code:
+
+(defvar wisent-eoi-term)
+(declare-function wisent-parse "semantic/wisent/wisent.el")
+
+(defvar tablist-filter-binary-operator
+ '((== . tablist-filter-op-equal)
+ (=~ . tablist-filter-op-regexp)
+ (< . tablist-filter-op-<)
+ (> . tablist-filter-op->)
+ (<= . tablist-filter-op-<=)
+ (>= . tablist-filter-op->=)
+ (= . tablist-filter-op-=)))
+
+(defvar tablist-filter-unary-operator nil)
+
+(defvar tablist-filter-wisent-parser nil)
+
+(defvar tablist-filter-lexer-regexps nil)
+
+(defvar tablist-filter-wisent-grammar
+ '(
+ ;; terminals
+ ;; Use lowercase for better looking error messages.
+ (operand unary-operator binary-operator or and not)
+
+ ;; terminal associativity & precedence
+ ((left binary-operator)
+ (left unary-operator)
+ (left or)
+ (left and)
+ (left not))
+
+ ;; rules
+ (filter-or-empty
+ ((nil))
+ ((?\( ?\)) nil)
+ ((filter) $1))
+ (filter
+ ((operand) $1) ;;Named filter
+ ((operand binary-operator operand) `(,(intern $2) ,$1 ,$3))
+ ((unary-operator operand) `(,(intern $1) ,$2))
+ ((not filter) `(not ,$2))
+ ((filter and filter) `(and ,$1 ,$3))
+ ((filter or filter) `(or ,$1 ,$3))
+ ((?( filter ?)) $2))))
+
+(defun tablist-filter-parser-init (&optional reinitialize interactive)
+ (interactive (list t t))
+ (unless (and tablist-filter-lexer-regexps
+ (not reinitialize))
+ (let ((re (mapcar
+ (lambda (l)
+ (let ((re (regexp-opt
+ (mapcar 'symbol-name
+ (mapcar 'car l)) t)))
+ (if (= (length re) 0)
+ ".\\`" ;;matches nothing
+ re)))
+ (list tablist-filter-binary-operator
+ tablist-filter-unary-operator))))
+ (setq tablist-filter-lexer-regexps
+ (nreverse
+ (cons (concat "\\(?:" (car re) "\\|" (cadr re)
+ "\\|[ \t\f\r\n\"!()]\\|&&\\|||\\)")
+ re)))))
+ (unless (and tablist-filter-wisent-parser
+ (not reinitialize))
+ (let ((wisent-compile-grammar*
+ (symbol-function
+ 'wisent-compile-grammar)))
+ (setq tablist-filter-wisent-parser
+ ;; Trick the byte-compile into not using the byte-compile
+ ;; handler in semantic/wisent/comp.el, since it does not
+ ;; always work (wisent-context-compile-grammar n/a).
+ (funcall wisent-compile-grammar*
+ tablist-filter-wisent-grammar))))
+ (when interactive
+ (message "Parser reinitialized."))
+ nil)
+
+(defun tablist-filter-wisent-lexer ()
+ (cl-destructuring-bind (unary-op binary-op keywords)
+ tablist-filter-lexer-regexps
+ (skip-chars-forward " \t\f\r\n")
+ (cond
+ ((eobp) (list wisent-eoi-term))
+ ((= ?\" (char-after))
+ `(operand , (condition-case err
+ (read (current-buffer))
+ (error (signal (car err) (cons
+ "invalid lisp string"
+ (cdr err)))))))
+ ((looking-at unary-op)
+ (goto-char (match-end 0))
+ `(unary-operator ,(match-string-no-properties 0)))
+ ((looking-at binary-op)
+ (goto-char (match-end 0))
+ `(binary-operator ,(match-string-no-properties 0)))
+ ((looking-at "&&")
+ (forward-char 2)
+ `(and "&&"))
+ ((looking-at "||")
+ (forward-char 2)
+ `(or "||"))
+ ((= ?! (char-after))
+ (forward-char)
+ `(not "!"))
+ ((= ?\( (char-after))
+ (forward-char)
+ `(?\( "("))
+ ((= ?\) (char-after))
+ (forward-char)
+ `(?\) ")"))
+ (t
+ (let ((beg (point)))
+ (when (re-search-forward keywords nil 'move)
+ (goto-char (match-beginning 0)))
+ `(operand ,(buffer-substring-no-properties
+ beg
+ (point))))))))
+
+(defun tablist-filter-parse (filter)
+ (interactive "sFilter: ")
+ (tablist-filter-parser-init)
+ (with-temp-buffer
+ (save-excursion (insert filter))
+ (condition-case error
+ (wisent-parse tablist-filter-wisent-parser
+ 'tablist-filter-wisent-lexer
+ (lambda (msg)
+ (signal 'error
+ (replace-regexp-in-string
+ "\\$EOI" "end of input"
+ msg t t))))
+ (error
+ (signal 'error
+ (append (if (consp (cdr error))
+ (cdr error)
+ (list (cdr error)))
+ (list (point))))))))
+
+(defun tablist-filter-unparse (filter &optional noerror)
+ (cl-labels
+ ((unparse (filter &optional noerror)
+ (cond
+ ((stringp filter)
+ (if (or (string-match (nth 2 tablist-filter-lexer-regexps)
+ filter)
+ (= 0 (length filter)))
+ (format "%S" filter)
+ filter))
+ ((and (eq (car-safe filter) 'not)
+ (= (length filter) 2))
+ (let ((paren (memq (car-safe (nth 1 filter)) '(or and))))
+ (format "!%s%s%s"
+ (if paren "(" "")
+ (unparse (cadr filter) noerror)
+ (if paren ")" ""))))
+ ((and (memq (car-safe filter) '(and or))
+ (= (length filter) 3))
+ (let ((lparen (and (eq (car filter) 'and)
+ (eq 'or (car-safe (car-safe (cdr filter))))))
+ (rparen (and (eq (car filter) 'and)
+ (eq 'or (car-safe (car-safe (cddr filter)))))))
+ (format "%s%s%s %s %s%s%s"
+ (if lparen "(" "")
+ (unparse (cadr filter) noerror)
+ (if lparen ")" "")
+ (cl-case (car filter)
+ (and "&&") (or "||"))
+ (if rparen "(" "")
+ (unparse (car (cddr filter)) noerror)
+ (if rparen ")" ""))))
+ ((and (assq (car-safe filter) tablist-filter-binary-operator)
+ (= (length filter) 3))
+ (format "%s %s %s"
+ (unparse (cadr filter) noerror)
+ (car filter)
+ (unparse (car (cddr filter)) noerror)))
+ ((and (assq (car-safe filter) tablist-filter-unary-operator)
+ (= (length filter) 2))
+ (format "%s %s"
+ (car filter)
+ (unparse (cadr filter) noerror)))
+ ((not filter) "")
+ (t (funcall (if noerror 'format 'error)
+ "Invalid filter: %s" filter)))))
+ (tablist-filter-parser-init)
+ (unparse filter noerror)))
+
+
+(defun tablist-filter-eval (filter id entry &optional named-alist)
+ (cl-labels
+ ((feval (filter)
+ (pcase filter
+ (`(not . ,(and operand (guard (not (cdr operand)))))
+ (not (feval (car operand))))
+ (`(and . ,(and operands (guard (= 2 (length operands)))))
+ (and
+ (feval (nth 0 operands))
+ (feval (nth 1 operands))))
+ (`(or . ,(and operands (guard (= 2 (length operands)))))
+ (or
+ (feval (nth 0 operands))
+ (feval (nth 1 operands))))
+ (`(,op . ,(and operands (guard (= (length operands) 1))))
+ (let ((fn (assq op tablist-filter-unary-operator)))
+ (unless fn
+ (error "Undefined unary operator: %s" op))
+ (funcall fn id entry (car operands))))
+ (`(,op . ,(and operands (guard (= (length operands) 2))))
+ (let ((fn (cdr (assq op tablist-filter-binary-operator))))
+ (unless fn
+ (error "Undefined binary operator: %s" op))
+ (funcall fn id entry (car operands)
+ (cadr operands))))
+ ((guard (stringp filter))
+ (let ((fn (cdr (assoc filter named-alist))))
+ (unless fn
+ (error "Undefined named filter: %s" filter))
+ (if (functionp fn)
+ (funcall fn id entry))
+ (feval
+ (if (stringp fn) (tablist-filter-unparse fn) fn))))
+ (`nil t)
+ (_ (error "Invalid filter: %s" filter)))))
+ (feval filter)))
+
+(defun tablist-filter-get-item-by-name (entry col-name)
+ (let* ((col (cl-position col-name tabulated-list-format
+ :key 'car
+ :test
+ (lambda (s1 s2)
+ (eq t (compare-strings
+ s1 nil nil s2 nil nil t)))))
+ (item (and col (elt entry col))))
+ (unless col
+ (error "No such column: %s" col-name))
+ (if (consp item) ;(LABEL . PROPS)
+ (car item)
+ item)))
+
+(defun tablist-filter-op-equal (id entry op1 op2)
+ "COLUMN == STRING : Matches if COLUMN's entry is equal to STRING."
+ (let ((item (tablist-filter-get-item-by-name entry op1)))
+ (string= item op2)))
+
+(defun tablist-filter-op-regexp (id entry op1 op2)
+ "COLUMN =~ REGEXP : Matches if COLUMN's entry matches REGEXP."
+ (let ((item (tablist-filter-get-item-by-name entry op1)))
+ (string-match op2 item)))
+
+(defun tablist-filter-op-< (id entry op1 op2)
+ "COLUMN < NUMBER : Matches if COLUMN's entry is less than NUMBER."
+ (tablist-filter-op-numeric '< id entry op1 op2))
+
+(defun tablist-filter-op-> (id entry op1 op2)
+ "COLUMN > NUMBER : Matches if COLUMN's entry is greater than NUMBER."
+ (tablist-filter-op-numeric '> id entry op1 op2))
+
+(defun tablist-filter-op-<= (id entry op1 op2)
+ "COLUMN <= NUMBER : Matches if COLUMN's entry is less than or equal to NUMBER."
+ (tablist-filter-op-numeric '<= id entry op1 op2))
+
+(defun tablist-filter-op->= (id entry op1 op2)
+ "COLUMN >= NUMBER : Matches if COLUMN's entry is greater than or equal to NUMBER."
+ (tablist-filter-op-numeric '>= id entry op1 op2))
+
+(defun tablist-filter-op-= (id entry op1 op2)
+ "COLUMN = NUMBER : Matches if COLUMN's entry as a number is equal to NUMBER."
+ (tablist-filter-op-numeric '= id entry op1 op2))
+
+(defun tablist-filter-op-numeric (op id entry op1 op2)
+ (let ((item (tablist-filter-get-item-by-name entry op1)))
+ (funcall op (string-to-number item)
+ (string-to-number op2))))
+
+(defun tablist-filter-help (&optional temporary)
+ (interactive)
+ (cl-labels
+ ((princ-op (op)
+ (princ (car op))
+ (princ (concat (make-string (max 0 (- 4 (length (symbol-name (car op)))))
+ ?\s)
+ "- "
+ (car (split-string
+ (or (documentation (cdr op))
+ (format "FIXME: Not documented: %s"
+ (cdr op)))
+ "\n" t))
+ "\n"))))
+ (with-temp-buffer-window
+ "*Help*"
+ (if temporary
+ '((lambda (buf alist)
+ (let ((win
+ (or (display-buffer-reuse-window buf alist)
+ (display-buffer-in-side-window buf alist))))
+ (fit-window-to-buffer win)
+ win))
+ (side . bottom)))
+ nil
+ (princ "Filter entries with the following operators.\n\n")
+ (princ "&& - FILTER1 && FILTER2 : Locical and.\n")
+ (princ "|| - FILTER1 || FILTER2 : Locical or.\n")
+ (dolist (op tablist-filter-binary-operator)
+ (princ-op op))
+ (princ "! - ! FILTER : Locical not.\n\n")
+ (dolist (op tablist-filter-unary-operator)
+ (princ-op op))
+ (princ "\"...\" may be used to quote names and values if necessary,
+and \(...\) to group expressions.")
+ (with-current-buffer standard-output
+ (help-mode)))))
+
+;;
+;; **Filter Functions
+;;
+
+;; filter ::= nil | named | fn | (OP OP1 [OP2])
+
+(defun tablist-filter-negate (filter)
+ "Return a filter not matching filter."
+ (cond
+ ((eq (car-safe filter) 'not)
+ (cadr filter))
+ (filter
+ (list 'not filter))))
+
+(defun tablist-filter-push (filter new-filter &optional or-p)
+ "Return a filter combining FILTER and NEW-FILTER.
+
+By default the filters are and'ed, unless OR-P is non-nil."
+ (if (or (null filter)
+ (null new-filter))
+ (or filter
+ new-filter)
+ (list (if or-p 'or 'and)
+ filter new-filter)))
+
+(defun tablist-filter-pop (filter)
+ "Remove the first operator or operand from filter.
+
+If filter starts with a negation, return filter unnegated,
+if filter starts with a dis- or conjuction, remove the first operand,
+if filter is nil, raise an error,
+else return nil."
+ (pcase filter
+ (`(,(or `and `or) . ,tail)
+ (car (cdr tail)))
+ (`(not . ,op1)
+ (car op1))
+ (_ (unless filter
+ (error "Filter is empty")))))
+
+(defun tablist-filter-map (fn filter)
+ (pcase filter
+ (`(,(or `and `or `not) . ,tail)
+ (cons (car filter)
+ (mapcar (lambda (f)
+ (tablist-filter-map fn f))
+ tail)))
+ (_ (funcall fn filter))))
+
+
+;;
+;; Reading filter
+;;
+
+(defvar tablist-filter-edit-history nil)
+(defvar tablist-filter-edit-display-help t)
+
+(defun tablist-filter-edit-filter (prompt &optional
+ initial-filter history
+ validate-fn)
+ (let* ((str (tablist-filter-unparse initial-filter))
+ (filter initial-filter)
+ (validate-fn (or validate-fn 'identity))
+ error done)
+ (save-window-excursion
+ (when tablist-filter-edit-display-help
+ (tablist-filter-help t))
+ (while (not done)
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (when error
+ (when (car error)
+ (goto-char (+ (field-beginning)
+ (car error)))
+ (skip-chars-backward " \t\n"))
+ (minibuffer-message "%s" (cdr error))
+ (setq error nil)))
+ (setq str (propertize
+ (read-string prompt str
+ (or history 'tablist-filter-edit-history)))
+ done t))
+ (condition-case err
+ (progn
+ (setq filter (tablist-filter-parse str))
+ (funcall validate-fn filter))
+ (error
+ (setq done nil)
+ (setq error (cons (car-safe (cddr err)) nil))
+ (when (car error)
+ (setq str (with-temp-buffer
+ (insert str)
+ (goto-char (car error))
+ (set-text-properties
+ (progn
+ (skip-chars-backward " \t\n")
+ (backward-char)
+ (point))
+ (min (car error) (point-max))
+ '(face error rear-nonsticky t))
+ (buffer-string))))
+ (setcdr error (error-message-string err)))))
+ filter)))
+
+(provide 'tablist-filter)
+;;; tablist-filter.el ends here
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-31 23:41:41 +0000