tablist-filter.el (16195B)
1 ;;; tablist-filter.el --- Filter expressions for tablists. -*- lexical-binding:t -*- 2 3 ;; Copyright (C) 2013, 2014 Andreas Politz 4 5 ;; Author: Andreas Politz <politza@fh-trier.de> 6 ;; Keywords: extensions, lisp 7 8 ;; This program is free software; you can redistribute it and/or modify 9 ;; it under the terms of the GNU General Public License as published by 10 ;; the Free Software Foundation, either version 3 of the License, or 11 ;; (at your option) any later version. 12 13 ;; This program is distributed in the hope that it will be useful, 14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 ;; GNU General Public License for more details. 17 18 ;; You should have received a copy of the GNU General Public License 19 ;; along with this program. If not, see <http://www.gnu.org/licenses/>. 20 21 ;;; Commentary: 22 23 ;; 24 25 (defvar python-mode-hook) 26 (let (python-mode-hook) ;FIXME: Why? 27 (require 'semantic/wisent/comp) 28 (require 'semantic/wisent/wisent)) 29 30 ;;; Code: 31 32 (defvar wisent-eoi-term) 33 (declare-function wisent-parse "semantic/wisent/wisent.el") 34 35 ;; 36 ;; *Variables 37 ;; 38 39 (defvar tablist-filter-binary-operator 40 '((== . tablist-filter-op-equal) 41 (=~ . tablist-filter-op-regexp) 42 (< . tablist-filter-op-<) 43 (> . tablist-filter-op->) 44 (<= . tablist-filter-op-<=) 45 (>= . tablist-filter-op->=) 46 (= . tablist-filter-op-=))) 47 48 (defvar tablist-filter-unary-operator nil) 49 50 (defvar tablist-filter-wisent-parser nil) 51 52 (defvar tablist-filter-lexer-regexps nil) 53 54 (defvar tablist-filter-wisent-grammar 55 '( 56 ;; terminals 57 ;; Use lowercase for better looking error messages. 58 (operand unary-operator binary-operator or and not) 59 60 ;; terminal associativity & precedence 61 ((left binary-operator) 62 (left unary-operator) 63 (left or) 64 (left and) 65 (left not)) 66 67 ;; rules 68 (filter-or-empty 69 ((nil)) 70 ((?\( ?\)) nil) 71 ((filter) $1)) 72 (filter 73 ((operand) $1) ;;Named filter 74 ((operand binary-operator operand) `(,(intern $2) ,$1 ,$3)) 75 ((unary-operator operand) `(,(intern $1) ,$2)) 76 ((not filter) `(not ,$2)) 77 ((filter and filter) `(and ,$1 ,$3)) 78 ((filter or filter) `(or ,$1 ,$3)) 79 ((?\( filter ?\)) $2)))) 80 81 ;; 82 ;; *Filter Parsing 83 ;; 84 85 (defun tablist-filter-parser-init (&optional reinitialize interactive) 86 (interactive (list t t)) 87 (unless (and tablist-filter-lexer-regexps 88 (not reinitialize)) 89 (let ((re (mapcar 90 (lambda (l) 91 (let ((re (regexp-opt 92 (mapcar 'symbol-name 93 (mapcar 'car l)) t))) 94 (if (= (length re) 0) 95 ".\\`" ;;matches nothing 96 re))) 97 (list tablist-filter-binary-operator 98 tablist-filter-unary-operator)))) 99 (setq tablist-filter-lexer-regexps 100 (nreverse 101 (cons (concat "\\(?:" (car re) "\\|" (cadr re) 102 "\\|[ \t\f\r\n\"!()]\\|&&\\|||\\)") 103 re))))) 104 (unless (and tablist-filter-wisent-parser 105 (not reinitialize)) 106 (let ((wisent-compile-grammar* 107 (symbol-function 108 'wisent-compile-grammar))) 109 (setq tablist-filter-wisent-parser 110 ;; Trick the byte-compile into not using the byte-compile 111 ;; handler in semantic/wisent/comp.el, since it does not 112 ;; always work (wisent-context-compile-grammar n/a). 113 (funcall wisent-compile-grammar* 114 tablist-filter-wisent-grammar)))) 115 (when interactive 116 (message "Parser reinitialized.")) 117 nil) 118 119 (defun tablist-filter-wisent-lexer () 120 (cl-destructuring-bind (unary-op binary-op keywords) 121 tablist-filter-lexer-regexps 122 (skip-chars-forward " \t\f\r\n") 123 (cond 124 ((eobp) (list wisent-eoi-term)) 125 ((= ?\" (char-after)) 126 `(operand , (condition-case err 127 (read (current-buffer)) 128 (error (signal (car err) (cons 129 "invalid lisp string" 130 (cdr err))))))) 131 ((looking-at unary-op) 132 (goto-char (match-end 0)) 133 `(unary-operator ,(match-string-no-properties 0))) 134 ((looking-at binary-op) 135 (goto-char (match-end 0)) 136 `(binary-operator ,(match-string-no-properties 0))) 137 ((looking-at "&&") 138 (forward-char 2) 139 `(and "&&")) 140 ((looking-at "||") 141 (forward-char 2) 142 `(or "||")) 143 ((= ?! (char-after)) 144 (forward-char) 145 `(not "!")) 146 ((= ?\( (char-after)) 147 (forward-char) 148 `(?\( "(")) 149 ((= ?\) (char-after)) 150 (forward-char) 151 `(?\) ")")) 152 (t 153 (let ((beg (point))) 154 (when (re-search-forward keywords nil 'move) 155 (goto-char (match-beginning 0))) 156 `(operand ,(buffer-substring-no-properties 157 beg 158 (point)))))))) 159 160 (defun tablist-filter-parse (filter) 161 (interactive "sFilter: ") 162 (tablist-filter-parser-init) 163 (with-temp-buffer 164 (save-excursion (insert filter)) 165 (condition-case error 166 (wisent-parse tablist-filter-wisent-parser 167 'tablist-filter-wisent-lexer 168 (lambda (msg) 169 (signal 'error 170 (replace-regexp-in-string 171 "\\$EOI" "end of input" 172 msg t t)))) 173 (error 174 (signal 'error 175 (append (if (consp (cdr error)) 176 (cdr error) 177 (list (cdr error))) 178 (list (point)))))))) 179 180 (defun tablist-filter-unparse (filter &optional noerror) 181 (cl-labels 182 ((unparse (filter &optional noerror) 183 (cond 184 ((stringp filter) 185 (if (or (string-match (nth 2 tablist-filter-lexer-regexps) 186 filter) 187 (= 0 (length filter))) 188 (format "%S" filter) 189 filter)) 190 ((and (eq (car-safe filter) 'not) 191 (= (length filter) 2)) 192 (let ((paren (memq (car-safe (nth 1 filter)) '(or and)))) 193 (format "!%s%s%s" 194 (if paren "(" "") 195 (unparse (cadr filter) noerror) 196 (if paren ")" "")))) 197 ((and (memq (car-safe filter) '(and or)) 198 (= (length filter) 3)) 199 (let ((lparen (and (eq (car filter) 'and) 200 (eq 'or (car-safe (car-safe (cdr filter)))))) 201 (rparen (and (eq (car filter) 'and) 202 (eq 'or (car-safe (car-safe (cddr filter))))))) 203 (format "%s%s%s %s %s%s%s" 204 (if lparen "(" "") 205 (unparse (cadr filter) noerror) 206 (if lparen ")" "") 207 (cl-case (car filter) 208 (and "&&") (or "||")) 209 (if rparen "(" "") 210 (unparse (car (cddr filter)) noerror) 211 (if rparen ")" "")))) 212 ((and (assq (car-safe filter) tablist-filter-binary-operator) 213 (= (length filter) 3)) 214 (format "%s %s %s" 215 (unparse (cadr filter) noerror) 216 (car filter) 217 (unparse (car (cddr filter)) noerror))) 218 ((and (assq (car-safe filter) tablist-filter-unary-operator) 219 (= (length filter) 2)) 220 (format "%s %s" 221 (car filter) 222 (unparse (cadr filter) noerror))) 223 ((not filter) "") 224 (t (funcall (if noerror 'format 'error) 225 "Invalid filter: %s" filter))))) 226 (tablist-filter-parser-init) 227 (unparse filter noerror))) 228 229 (defun tablist-filter-eval (filter id entry &optional named-alist) 230 (cl-labels 231 ((feval (filter) 232 (pcase filter 233 (`(not . ,(and operand (guard (not (cdr operand))))) 234 (not (feval (car operand)))) 235 (`(and . ,(and operands (guard (= 2 (length operands))))) 236 (and 237 (feval (nth 0 operands)) 238 (feval (nth 1 operands)))) 239 (`(or . ,(and operands (guard (= 2 (length operands))))) 240 (or 241 (feval (nth 0 operands)) 242 (feval (nth 1 operands)))) 243 (`(,op . ,(and operands (guard (= (length operands) 1)))) 244 (let ((fn (assq op tablist-filter-unary-operator))) 245 (unless fn 246 (error "Undefined unary operator: %s" op)) 247 (funcall fn id entry (car operands)))) 248 (`(,op . ,(and operands (guard (= (length operands) 2)))) 249 (let ((fn (cdr (assq op tablist-filter-binary-operator)))) 250 (unless fn 251 (error "Undefined binary operator: %s" op)) 252 (funcall fn id entry (car operands) 253 (cadr operands)))) 254 ((guard (stringp filter)) 255 (let ((fn (cdr (assoc filter named-alist)))) 256 (unless fn 257 (error "Undefined named filter: %s" filter)) 258 (if (functionp fn) 259 (funcall fn id entry)) 260 (feval 261 (if (stringp fn) (tablist-filter-unparse fn) fn)))) 262 (`nil t) 263 (_ (error "Invalid filter: %s" filter))))) 264 (feval filter))) 265 266 ;; 267 ;; *Filter Operators 268 ;; 269 270 (defun tablist-filter-get-item-by-name (entry col-name) 271 (let* ((col (cl-position col-name tabulated-list-format 272 :key 'car 273 :test 274 (lambda (s1 s2) 275 (eq t (compare-strings 276 s1 nil nil s2 nil nil t))))) 277 (item (and col (elt entry col)))) 278 (unless col 279 (error "No such column: %s" col-name)) 280 (if (consp item) ;(LABEL . PROPS) 281 (car item) 282 item))) 283 284 (defun tablist-filter-op-equal (_id entry op1 op2) 285 "COLUMN == STRING : Matches if COLUMN's entry is equal to STRING." 286 (let ((item (tablist-filter-get-item-by-name entry op1))) 287 (string= item op2))) 288 289 (defun tablist-filter-op-regexp (_id entry op1 op2) 290 "COLUMN =~ REGEXP : Matches if COLUMN's entry matches REGEXP." 291 (let ((item (tablist-filter-get-item-by-name entry op1))) 292 (string-match op2 item))) 293 294 (defun tablist-filter-op-< (id entry op1 op2) 295 "COLUMN < NUMBER : Matches if COLUMN's entry is less than NUMBER." 296 (tablist-filter-op-numeric '< id entry op1 op2)) 297 298 (defun tablist-filter-op-> (id entry op1 op2) 299 "COLUMN > NUMBER : Matches if COLUMN's entry is greater than NUMBER." 300 (tablist-filter-op-numeric '> id entry op1 op2)) 301 302 (defun tablist-filter-op-<= (id entry op1 op2) 303 "COLUMN <= NUMBER : Matches if COLUMN's entry is less than or equal to NUMBER." 304 (tablist-filter-op-numeric '<= id entry op1 op2)) 305 306 (defun tablist-filter-op->= (id entry op1 op2) 307 "COLUMN >= NUMBER : Matches if COLUMN's entry is greater than or equal to NUMBER." 308 (tablist-filter-op-numeric '>= id entry op1 op2)) 309 310 (defun tablist-filter-op-= (id entry op1 op2) 311 "COLUMN = NUMBER : Matches if COLUMN's entry as a number is equal to NUMBER." 312 (tablist-filter-op-numeric '= id entry op1 op2)) 313 314 (defun tablist-filter-op-numeric (op _id entry op1 op2) 315 (let ((item (tablist-filter-get-item-by-name entry op1))) 316 (funcall op (string-to-number item) 317 (string-to-number op2)))) 318 319 (defun tablist-filter-help (&optional temporary) 320 (interactive) 321 (cl-labels 322 ((princ-op (op) 323 (princ (car op)) 324 (princ (concat (make-string (max 0 (- 4 (length (symbol-name (car op))))) 325 ?\s) 326 "- " 327 (car (split-string 328 (or (documentation (cdr op)) 329 (format "FIXME: Not documented: %s" 330 (cdr op))) 331 "\n" t)) 332 "\n")))) 333 (with-temp-buffer-window 334 "*Help*" 335 (if temporary 336 '((lambda (buf alist) 337 (let ((win 338 (or (display-buffer-reuse-window buf alist) 339 (display-buffer-in-side-window buf alist)))) 340 (fit-window-to-buffer win) 341 win)) 342 (side . bottom))) 343 nil 344 (princ "Filter entries with the following operators.\n\n") 345 (princ "&& - FILTER1 && FILTER2 : Locical and.\n") 346 (princ "|| - FILTER1 || FILTER2 : Locical or.\n") 347 (dolist (op tablist-filter-binary-operator) 348 (princ-op op)) 349 (princ "! - ! FILTER : Locical not.\n\n") 350 (dolist (op tablist-filter-unary-operator) 351 (princ-op op)) 352 (princ "\"...\" may be used to quote names and values if necessary, 353 and \(...\) to group expressions.") 354 (with-current-buffer standard-output 355 (help-mode))))) 356 357 ;; 358 ;; *Filter Functions 359 ;; 360 361 ;; filter ::= nil | named | fn | (OP OP1 [OP2]) 362 363 (defun tablist-filter-negate (filter) 364 "Return a filter not matching filter." 365 (cond 366 ((eq (car-safe filter) 'not) 367 (cadr filter)) 368 (filter 369 (list 'not filter)))) 370 371 (defun tablist-filter-push (filter new-filter &optional or-p) 372 "Return a filter combining FILTER and NEW-FILTER. 373 374 By default the filters are and'ed, unless OR-P is non-nil." 375 (if (or (null filter) 376 (null new-filter)) 377 (or filter 378 new-filter) 379 (list (if or-p 'or 'and) 380 filter new-filter))) 381 382 (defun tablist-filter-pop (filter) 383 "Remove the first operator or operand from filter. 384 385 If filter starts with a negation, return filter unnegated, 386 if filter starts with a dis- or conjunction, remove the first operand, 387 if filter is nil, raise an error, 388 else return nil." 389 (pcase filter 390 (`(,(or `and `or) . ,tail) 391 (car (cdr tail))) 392 (`(not . ,op1) 393 (car op1)) 394 (_ (unless filter 395 (error "Filter is empty"))))) 396 397 (defun tablist-filter-map (fn filter) 398 (pcase filter 399 (`(,(or `and `or `not) . ,tail) 400 (cons (car filter) 401 (mapcar (lambda (f) 402 (tablist-filter-map fn f)) 403 tail))) 404 (_ (funcall fn filter)))) 405 406 ;; 407 ;; *Reading Filter 408 ;; 409 410 (defvar tablist-filter-edit-history nil) 411 (defvar tablist-filter-edit-display-help t) 412 413 (defun tablist-filter-edit-filter (prompt &optional 414 initial-filter history 415 validate-fn) 416 (let* ((str (tablist-filter-unparse initial-filter)) 417 (filter initial-filter) 418 (validate-fn (or validate-fn 'identity)) 419 error done) 420 (save-window-excursion 421 (when tablist-filter-edit-display-help 422 (tablist-filter-help t)) 423 (while (not done) 424 (minibuffer-with-setup-hook 425 (lambda () 426 (when error 427 (when (car error) 428 (goto-char (+ (field-beginning) 429 (car error))) 430 (skip-chars-backward " \t\n")) 431 (minibuffer-message "%s" (cdr error)) 432 (setq error nil))) 433 (setq str (propertize 434 (read-string prompt str 435 (or history 'tablist-filter-edit-history))) 436 done t)) 437 (condition-case err 438 (progn 439 (setq filter (tablist-filter-parse str)) 440 (funcall validate-fn filter)) 441 (error 442 (setq done nil) 443 (setq error (cons (car-safe (cddr err)) nil)) 444 (when (car error) 445 (setq str (with-temp-buffer 446 (insert str) 447 (goto-char (car error)) 448 (set-text-properties 449 (progn 450 (skip-chars-backward " \t\n") 451 (backward-char) 452 (point)) 453 (min (car error) (point-max)) 454 '(face error rear-nonsticky t)) 455 (buffer-string)))) 456 (setcdr error (error-message-string err))))) 457 filter))) 458 459 (provide 'tablist-filter) 460 ;; Local Variables: 461 ;; outline-regexp: ";;\\(\\(?:[;*]+ \\| \\*+\\)[^\s\t\n]\\|###autoload\\)\\|(" 462 ;; indent-tabs-mode: nil 463 ;; End: 464 ;;; tablist-filter.el ends here