contrib/lisp/org-interactive-query.el

   1 ;;; org-interactive-query.el --- Interactive modification of agenda query
   2 ;;
   3 ;; Copyright 2007-2014 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Christopher League <league at contrapunctus dot net>
   6 ;; Version: 1.0
   7 ;; Keywords: org, wp
   8 ;;
   9 ;; This file is not part of GNU Emacs.
  10 ;;
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23 ;;
  24 ;;; Commentary:
  25 ;;
  26
  27 ;; This library implements interactive modification of a tags/todo query
  28 ;; in the org-agenda.  It adds 4 keys to the agenda
  29 ;;
  30 ;; /   add a keyword as a positive selection criterion
  31 ;; \   add a keyword as a newgative selection criterion
  32 ;; =   clear a keyword from the selection string
  33 ;; ;
  34
  35 (require 'org)
  36
  37 (org-defkey org-agenda-mode-map "=" 'org-agenda-query-clear-cmd)
  38 (org-defkey org-agenda-mode-map "/" 'org-agenda-query-and-cmd)
  39 (org-defkey org-agenda-mode-map ";" 'org-agenda-query-or-cmd)
  40 (org-defkey org-agenda-mode-map "\\" 'org-agenda-query-not-cmd)
  41
  42 ;;; Agenda interactive query manipulation
  43
  44 (defcustom org-agenda-query-selection-single-key t
  45   "Non-nil means query manipulation exits after first change.
  46 When nil, you have to press RET to exit it.
  47 During query selection, you can toggle this flag with `C-c'.
  48 This variable can also have the value `expert'.  In this case, the window
  49 displaying the tags menu is not even shown, until you press C-c again."
  50   :group 'org-agenda
  51   :type '(choice
  52           (const :tag "No" nil)
  53           (const :tag "Yes" t)
  54           (const :tag "Expert" expert)))
  55
  56 (defun org-agenda-query-selection (current op table &optional todo-table)
  57   "Fast query manipulation with single keys.
  58 CURRENT is the current query string, OP is the initial
  59 operator (one of \"+|-=\"), TABLE is an alist of tags and
  60 corresponding keys, possibly with grouping information.
  61 TODO-TABLE is a similar table with TODO keywords, should these
  62 have keys assigned to them.  If the keys are nil, a-z are
  63 automatically assigned.  Returns the new query string, or nil to
  64 not change the current one."
  65   (let* ((fulltable (append table todo-table))
  66          (maxlen (apply 'max (mapcar
  67                               (lambda (x)
  68                                 (if (stringp (car x)) (string-width (car x)) 0))
  69                               fulltable)))
  70          (fwidth (+ maxlen 3 1 3))
  71          (ncol (/ (- (window-width) 4) fwidth))
  72          (expert (eq org-agenda-query-selection-single-key 'expert))
  73          (exit-after-next org-agenda-query-selection-single-key)
  74          (done-keywords org-done-keywords)
  75          tbl char cnt e groups ingroup
  76          tg c2 c c1 ntable rtn)
  77     (save-window-excursion
  78       (if expert
  79           (set-buffer (get-buffer-create " *Org tags*"))
  80         (delete-other-windows)
  81         (split-window-vertically)
  82         (org-switch-to-buffer-other-window (get-buffer-create " *Org tags*")))
  83       (erase-buffer)
  84       (org-set-local 'org-done-keywords done-keywords)
  85       (insert "Query:    " current "\n")
  86       (org-agenda-query-op-line op)
  87       (insert "\n\n")
  88       (org-fast-tag-show-exit exit-after-next)
  89       (setq tbl fulltable char ?a cnt 0)
  90       (while (setq e (pop tbl))
  91         (cond
  92          ((equal e '(:startgroup))
  93           (push '() groups) (setq ingroup t)
  94           (when (not (= cnt 0))
  95             (setq cnt 0)
  96             (insert "\n"))
  97           (insert "{ "))
  98          ((equal e '(:endgroup))
  99           (setq ingroup nil cnt 0)
 100           (insert "}\n"))
 101          (t
 102           (setq tg (car e) c2 nil)
 103           (if (cdr e)
 104               (setq c (cdr e))
 105             ;; automatically assign a character.
 106             (setq c1 (string-to-char
 107                       (downcase (substring
 108                                  tg (if (= (string-to-char tg) ?@) 1 0)))))
 109             (if (or (rassoc c1 ntable) (rassoc c1 table))
 110                 (while (or (rassoc char ntable) (rassoc char table))
 111                   (setq char (1+ char)))
 112               (setq c2 c1))
 113             (setq c (or c2 char)))
 114           (if ingroup (push tg (car groups)))
 115           (setq tg (org-add-props tg nil 'face
 116                                   (cond
 117                                    ((not (assoc tg table))
 118                                     (org-get-todo-face tg))
 119                                    (t nil))))
 120           (if (and (= cnt 0) (not ingroup)) (insert "  "))
 121           (insert "[" c "] " tg (make-string
 122                                  (- fwidth 4 (length tg)) ?\ ))
 123           (push (cons tg c) ntable)
 124           (when (= (setq cnt (1+ cnt)) ncol)
 125             (insert "\n")
 126             (if ingroup (insert "  "))
 127             (setq cnt 0)))))
 128       (setq ntable (nreverse ntable))
 129       (insert "\n")
 130       (goto-char (point-min))
 131       (if (and (not expert) (fboundp 'fit-window-to-buffer))
 132           (fit-window-to-buffer))
 133       (setq rtn
 134             (catch 'exit
 135               (while t
 136                 (message "[a-z..]:Toggle [SPC]:clear [RET]:accept [TAB]:free%s%s"
 137                          (if groups " [!] no groups" " [!]groups")
 138                          (if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi")))
 139                 (setq c (let ((inhibit-quit t)) (read-char-exclusive)))
 140                 (cond
 141                  ((= c ?\r) (throw 'exit t))
 142                  ((= c ?!)
 143                   (setq groups (not groups))
 144                   (goto-char (point-min))
 145                   (while (re-search-forward "[{}]" nil t) (replace-match " ")))
 146                  ((= c ?\C-c)
 147                   (if (not expert)
 148                       (org-fast-tag-show-exit
 149                        (setq exit-after-next (not exit-after-next)))
 150                     (setq expert nil)
 151                     (delete-other-windows)
 152                     (split-window-vertically)
 153                     (org-switch-to-buffer-other-window " *Org tags*")
 154                     (and (fboundp 'fit-window-to-buffer)
 155                          (fit-window-to-buffer))))
 156                  ((or (= c ?\C-g)
 157                       (and (= c ?q) (not (rassoc c ntable))))
 158                   (setq quit-flag t))
 159                  ((= c ?\ )
 160                   (setq current "")
 161                   (if exit-after-next (setq exit-after-next 'now)))
 162                  ((= c ?\[)             ; clear left
 163                   (org-agenda-query-decompose current)
 164                   (setq current (concat "/" (match-string 2 current)))
 165                   (if exit-after-next (setq exit-after-next 'now)))
 166                  ((= c ?\])             ; clear right
 167                   (org-agenda-query-decompose current)
 168                   (setq current (match-string 1 current))
 169                   (if exit-after-next (setq exit-after-next 'now)))
 170                  ((= c ?\t)
 171                   (condition-case nil
 172                       (setq current (read-string "Query: " current))
 173                     (quit))
 174                   (if exit-after-next (setq exit-after-next 'now)))
 175                  ;; operators
 176                  ((or (= c ?/) (= c ?+)) (setq op "+"))
 177                  ((or (= c ?\;) (= c ?|)) (setq op "|"))
 178                  ((or (= c ?\\) (= c ?-)) (setq op "-"))
 179                  ((= c ?=) (setq op "="))
 180                  ;; todos
 181                  ((setq e (rassoc c todo-table) tg (car e))
 182                   (setq current (org-agenda-query-manip
 183                                  current op groups 'todo tg))
 184                   (if exit-after-next (setq exit-after-next 'now)))
 185                  ;; tags
 186                  ((setq e (rassoc c ntable) tg (car e))
 187                   (setq current (org-agenda-query-manip
 188                                  current op groups 'tag tg))
 189                   (if exit-after-next (setq exit-after-next 'now))))
 190                 (if (eq exit-after-next 'now) (throw 'exit t))
 191                 (goto-char (point-min))
 192                 (beginning-of-line 1)
 193                 (delete-region (point) (point-at-eol))
 194                 (insert "Query:    " current)
 195                 (beginning-of-line 2)
 196                 (delete-region (point) (point-at-eol))
 197                 (org-agenda-query-op-line op)
 198                 (goto-char (point-min)))))
 199       (if rtn current nil))))
 200
 201 (defun org-agenda-query-op-line (op)
 202   (insert "Operator: "
 203           (org-agenda-query-op-entry (equal op "+") "/+" "and")
 204           (org-agenda-query-op-entry (equal op "|") ";|" "or")
 205           (org-agenda-query-op-entry (equal op "-") "\\-" "not")
 206           (org-agenda-query-op-entry (equal op "=") "=" "clear")))
 207
 208 (defun org-agenda-query-op-entry (matchp chars str)
 209   (if matchp
 210       (org-add-props (format "[%s %s]  " chars (upcase str))
 211           nil 'face 'org-todo)
 212     (format "[%s]%s   " chars str)))
 213
 214 (defun org-agenda-query-decompose (current)
 215   (string-match "\\([^/]*\\)/?\\(.*\\)" current))
 216
 217 (defun org-agenda-query-clear (current prefix tag)
 218   (if (string-match (concat prefix "\\b" (regexp-quote tag) "\\b") current)
 219       (replace-match "" t t current)
 220     current))
 221
 222 (defun org-agenda-query-manip (current op groups kind tag)
 223   "Apply an operator to a query string and a tag.
 224 CURRENT is the current query string, OP is the operator, GROUPS is a
 225 list of lists of tags that are mutually exclusive.  KIND is 'tag for a
 226 regular tag, or 'todo for a TODO keyword, and TAG is the tag or
 227 keyword string."
 228   ;; If this tag is already in query string, remove it.
 229   (setq current (org-agenda-query-clear current "[-\\+&|]?" tag))
 230   (if (equal op "=") current
 231     ;; When using AND, also remove mutually exclusive tags.
 232     (if (equal op "+")
 233         (loop for g in groups do
 234               (if (member tag g)
 235                   (mapc (lambda (x)
 236                           (setq current
 237                                 (org-agenda-query-clear current "\\+" x)))
 238                         g))))
 239     ;; Decompose current query into q1 (tags) and q2 (TODOs).
 240     (org-agenda-query-decompose current)
 241     (let* ((q1 (match-string 1 current))
 242            (q2 (match-string 2 current)))
 243       (cond
 244        ((eq kind 'tag)
 245         (concat q1 op tag "/" q2))
 246        ;; It's a TODO; when using AND, drop all other TODOs.
 247        ((equal op "+")
 248         (concat q1 "/+" tag))
 249        (t
 250         (concat q1 "/" q2 op tag))))))
 251
 252 (defun org-agenda-query-global-todo-keys (&optional files)
 253   "Return alist of all TODO keywords and their fast keys, in all FILES."
 254   (let (alist)
 255     (unless (and files (car files))
 256       (setq files (org-agenda-files)))
 257     (save-excursion
 258       (loop for f in files do
 259             (set-buffer (find-file-noselect f))
 260             (loop for k in org-todo-key-alist do
 261                   (setq alist (org-agenda-query-merge-todo-key
 262                                alist k)))))
 263     alist))
 264
 265 (defun org-agenda-query-merge-todo-key (alist entry)
 266   (let (e)
 267     (cond
 268      ;; if this is not a keyword (:startgroup, etc), ignore it
 269      ((not (stringp (car entry))))
 270      ;; if keyword already exists, replace char if it's null
 271      ((setq e (assoc (car entry) alist))
 272       (when (null (cdr e)) (setcdr e (cdr entry))))
 273      ;; if char already exists, prepend keyword but drop char
 274      ((rassoc (cdr entry) alist)
 275       (message "TRACE POSITION 2")
 276       (setq alist (cons (cons (car entry) nil) alist)))
 277      ;; else, prepend COPY of entry
 278      (t
 279       (setq alist (cons (cons (car entry) (cdr entry)) alist)))))
 280   alist)
 281
 282 (defun org-agenda-query-generic-cmd (op)
 283   "Activate query manipulation with OP as initial operator."
 284   (let ((q (org-agenda-query-selection org-agenda-query-string op
 285                                        org-tag-alist
 286                                        (org-agenda-query-global-todo-keys))))
 287     (when q
 288       (setq org-agenda-query-string q)
 289       (org-agenda-redo))))
 290
 291 (defun org-agenda-query-clear-cmd ()
 292   "Activate query manipulation, to clear a tag from the string."
 293   (interactive)
 294   (org-agenda-query-generic-cmd "="))
 295
 296 (defun org-agenda-query-and-cmd ()
 297   "Activate query manipulation, initially using the AND (+) operator."
 298   (interactive)
 299   (org-agenda-query-generic-cmd "+"))
 300
 301 (defun org-agenda-query-or-cmd ()
 302   "Activate query manipulation, initially using the OR (|) operator."
 303   (interactive)
 304   (org-agenda-query-generic-cmd "|"))
 305
 306 (defun org-agenda-query-not-cmd ()
 307   "Activate query manipulation, initially using the NOT (-) operator."
 308   (interactive)
 309   (org-agenda-query-generic-cmd "-"))
 310
 311 (provide 'org-interactive-query)