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