org-interactive-query.el 11 KB

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