contrib/lisp/org-interactive-query.el

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