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