config

Personal configuration.
git clone git://code.dwrz.net/config
Log | Files | Refs

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