;;; tablist-filter.el --- Filter expressions for tablists. -*- lexical-binding:t -*-
;; 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:
;;
(defvar python-mode-hook)
(let (python-mode-hook) ;FIXME: Why?
(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