Merge branch 'maint'
[org-mode.git] / contrib / lisp / org-interactive-query.el
blob644132c81e17038700df13c1233dc521379ae06a
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.
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.
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.
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/>.
24 ;;; Commentary:
27 ;; This library implements interactive modification of a tags/todo query
28 ;; in the org-agenda. It adds 4 keys to the agenda
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 ;; ;
35 (require 'org)
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)
42 ;;; Agenda interactive query manipulation
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)))
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"))
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))))
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")))
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)))
214 (defun org-agenda-query-decompose (current)
215 (string-match "\\([^/]*\\)/?\\(.*\\)" current))
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))
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))
250 (concat q1 "/" q2 op tag))))))
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))
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
279 (setq alist (cons (cons (car entry) (cdr entry)) alist)))))
280 alist)
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))))
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 "="))
296 (defun org-agenda-query-and-cmd ()
297 "Activate query manipulation, initially using the AND (+) operator."
298 (interactive)
299 (org-agenda-query-generic-cmd "+"))
301 (defun org-agenda-query-or-cmd ()
302 "Activate query manipulation, initially using the OR (|) operator."
303 (interactive)
304 (org-agenda-query-generic-cmd "|"))
306 (defun org-agenda-query-not-cmd ()
307 "Activate query manipulation, initially using the NOT (-) operator."
308 (interactive)
309 (org-agenda-query-generic-cmd "-"))
311 (provide 'org-interactive-query)