>From 948a38b403125359b59c5f5d520be6d053599b0d Mon Sep 17 00:00:00 2001 From: Bastien Guerry Date: Sun, 6 Nov 2011 19:26:28 +0100 Subject: [PATCH] Implement agenda filtering by category. --- doc/org.texi | 6 +- lisp/org-agenda.el | 234 ++++++++++++++++++++++++++++++++++++++++------------ lisp/org-faces.el | 6 ++ 3 files changed, 189 insertions(+), 57 deletions(-) diff --git a/doc/org.texi b/doc/org.texi index 4a547d0..af189f0 100644 --- a/doc/org.texi +++ b/doc/org.texi @@ -7954,10 +7954,10 @@ the entire agenda view---in a block agenda, you should only set this in the global options section, not in the section of an individual block.} You will be prompted for a tag selection letter; @key{SPC} will mean any tag at -all. Pressing @key{TAB} at that prompt will offer use completion to select a -tag (including any tags that do not have a selection character). The command +all. Pressing @key{TAB} at that prompt will use completion to select a +tag (also including tags that do not have a selection character). The command then hides all entries that do not contain or inherit this tag. When called -with prefix arg, remove the entries that @emph{do} have the tag. A second +with a prefix arguement, remove the entries that @emph{do} have the tag. A second @kbd{/} at the prompt will turn off the filter and unhide any hidden entries. If the first key you press is either @kbd{+} or @kbd{-}, the previous filter will be narrowed by requiring or forbidding the selected additional tag. diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el index bcc2de4..83c42f0 100644 --- a/lisp/org-agenda.el +++ b/lisp/org-agenda.el @@ -286,8 +286,14 @@ you can \"misuse\" it to also add other text to the header. However, (list :tag "Deadline Warning days" (const org-deadline-warning-days) (integer :value 1)) + (list :tag "Category filter preset" + (const org-agenda-category-filter-preset) + (list + (const :format "" quote) + (repeat + (string :tag "+category or -category")))) (list :tag "Tags filter preset" - (const org-agenda-filter-preset) + (const org-agenda-tag-filter-preset) (list (const :format "" quote) (repeat @@ -1949,6 +1955,7 @@ The following commands are available: (org-defkey org-agenda-mode-map "}" 'org-agenda-manipulate-query-subtract-re) (org-defkey org-agenda-mode-map "/" 'org-agenda-filter-by-tag) (org-defkey org-agenda-mode-map "\\" 'org-agenda-filter-by-tag-refine) +(org-defkey org-agenda-mode-map "<" 'org-agenda-filter-by-category) (org-defkey org-agenda-mode-map ";" 'org-timer-set-timer) (define-key org-agenda-mode-map "?" 'org-agenda-show-the-flagging-note) (org-defkey org-agenda-mode-map "\C-c\C-x\C-mg" 'org-mobile-pull) @@ -3043,9 +3050,9 @@ removed from the entry content. Currently only `planning' is allowed here." (defvar org-pre-agenda-window-conf nil) (defvar org-agenda-columns-active nil) (defvar org-agenda-name nil) -(defvar org-agenda-filter nil) -(defvar org-agenda-filter-while-redo nil) -(defvar org-agenda-filter-preset nil +(defvar org-agenda-tag-filter nil) +(defvar org-agenda-tag-filter-while-redo nil) +(defvar org-agenda-tag-filter-preset nil "A preset of the tags filter used for secondary agenda filtering. This must be a list of strings, each string must be a single tag preceded by \"+\" or \"-\". @@ -3055,13 +3062,21 @@ the entire agenda view. In a block agenda, it will not work reliably to define a filter for one of the individual blocks. You need to set it in the global options and expect it to be applied to the entire view.") +(defvar org-agenda-category-filter-preset nil + "A preset of the categeory filter used for secondary agenda filtering. +This must be a list of strings, each string must be a single category +preceded by \"+\" or \"-\". See `org-agenda-tag-filter-preset' for +details.") + (defun org-prepare-agenda (&optional name) (setq org-todo-keywords-for-agenda nil) (setq org-done-keywords-for-agenda nil) (setq org-drawers-for-agenda nil) (unless org-agenda-persistent-filter - (setq org-agenda-filter nil)) - (put 'org-agenda-filter :preset-filter org-agenda-filter-preset) + (setq org-agenda-tag-filter nil + org-agenda-category-filter nil)) + (put 'org-agenda-tag-filter :preset-filter org-agenda-tag-filter-preset) + (put 'org-agenda-category-filter :preset-filter org-agenda-category-filter-preset) (if org-agenda-multi (progn (setq buffer-read-only nil) @@ -3140,8 +3155,10 @@ the global options and expect it to be applied to the entire view.") (org-habit-insert-consistency-graphs)) (run-hooks 'org-finalize-agenda-hook) (setq org-agenda-type (org-get-at-bol 'org-agenda-type)) - (when (or org-agenda-filter (get 'org-agenda-filter :preset-filter)) - (org-agenda-filter-apply org-agenda-filter)) + (when (or org-agenda-tag-filter (get 'org-agenda-tag-filter :preset-filter)) + (org-agenda-filter-apply org-agenda-tag-filter 'tag)) + (when (or org-agenda-category-filter (get 'org-agenda-category-filter :preset-filter)) + (org-agenda-filter-apply org-agenda-category-filter 'category)) ))) (defun org-agenda-mark-clocking-task () @@ -3675,8 +3692,9 @@ given in `org-agenda-start-on-weekday'." (setq p (plist-put p :tend clocktable-end)) (setq p (plist-put p :scope 'agenda)) (when (and (eq org-agenda-clockreport-mode 'with-filter) - (setq filter (or org-agenda-filter-while-redo - (get 'org-agenda-filter :preset-filter)))) + ;; FIXME: allow category filters? + (setq filter (or org-agenda-tag-filter-while-redo + (get 'org-agenda-tag-filter :preset-filter)))) (setq p (plist-put p :tags (mapconcat (lambda (x) (if (string-match "[<>=]" x) "" @@ -6132,29 +6150,94 @@ in the agenda." When this is the global TODO list, a prefix argument will be interpreted." (interactive) (let* ((org-agenda-keep-modes t) - (filter org-agenda-filter) - (preset (get 'org-agenda-filter :preset-filter)) - (org-agenda-filter-while-redo (or filter preset)) + (tag-filter org-agenda-tag-filter) + (tag-preset (get 'org-agenda-tag-filter :preset-filter)) + (cat-filter org-agenda-category-filter) + (cat-preset (get 'org-agenda-category-filter :preset-filter)) + (org-agenda-tag-filter-while-redo (or tag-filter tag-preset)) (cols org-agenda-columns-active) (line (org-current-line)) (window-line (- line (org-current-line (window-start)))) (lprops (get 'org-agenda-redo-command 'org-lprops))) - (put 'org-agenda-filter :preset-filter nil) + (put 'org-agenda-tag-filter :preset-filter nil) + (put 'org-agenda-category-filter :preset-filter nil) (and cols (org-columns-quit)) (message "Rebuilding agenda buffer...") (org-let lprops '(eval org-agenda-redo-command)) (setq org-agenda-undo-list nil org-agenda-pending-undo-list nil) (message "Rebuilding agenda buffer...done") - (put 'org-agenda-filter :preset-filter preset) - (and (or filter preset) (org-agenda-filter-apply filter)) + (put 'org-agenda-tag-filter :preset-filter tag-preset) + (put 'org-agenda-category-filter :preset-filter cat-preset) + (and (or tag-filter tag-preset) (org-agenda-filter-apply tag-filter 'tag)) + (and (or cat-filter cat-preset) (org-agenda-filter-apply cat-filter 'category)) (and cols (org-called-interactively-p 'any) (org-agenda-columns)) (org-goto-line line) (recenter window-line))) - (defvar org-global-tags-completion-table nil) (defvar org-agenda-filter-form nil) +(defvar org-agenda-filtered nil) + +(defun org-agenda-filter-by-category (strip &optional char narrow) + "Keep only those lines in the agenda buffer that have a specific category. +The category is that of the current line." + (interactive "P") + (let ((current org-agenda-category-filter) + catfilter catchars curcat allcats allcatsalist) + ;; First gather all categories represented in this agenda: + (save-excursion + (goto-char 0) + (while (progn (beginning-of-line 2) (not (eobp))) + (when (setq curcat (get-text-property (point) 'org-category)) + (push curcat allcats))) + (setq allcats (delete-dups (reverse allcats)))) + (setq allcatsalist (mapcar (lambda(x) (cons (string-to-char x) x)) allcats) + catchars (mapconcat (lambda (x) (substring x 0 1)) allcats "")) + ;; Read the key: + (unless char + (message "%s by category [%s ], [TAB], [<]:category at point, [+-]:narrow: " + (if narrow "Narrow" "Filter") catchars) + (setq char (read-char))) + ;; Handle narrowing: + (when (member char '(?+ ?-)) + (cond ((equal char ?-) (setq strip t narrow t)) + ((equal char ?+) (setq strip nil narrow t))) + (message + "Narrow by category [%s ], [TAB], [<]:category at point: " catchars) + (setq char (read-char))) + (cond + ;; Use TAB to select a category + ((equal char ?\t) + (let ((completion-ignore-case t)) + (setq catfilter (org-icompleting-read + "Category: " allcats))) + (setq org-agenda-category-filter + (list (concat "+" catfilter))) + (org-agenda-filter-apply org-agenda-category-filter 'category)) + ;; Select categories at point or remove filter + ((equal char ?<) + (if org-agenda-filtered + (progn (org-agenda-filter-show-all) + (when (get 'org-agenda-category-filter :preset-filter) + (org-agenda-filter-apply org-agenda-category-filter 'category)) + (setq org-agenda-filtered nil)) + (setq org-agenda-category-filter + (list (concat "+" (or (org-get-at-bol 'org-category) + (error "No category at point"))))) + (org-agenda-filter-apply org-agenda-category-filter 'category))) + ;; Only select entries with no category (i.e the "General category") + ((or (and (equal char ?\ ) (setq catfilter "General")) + (assoc char allcatsalist)) + (setq org-agenda-category-filter + (cons (concat (if strip "-" "+") + (or catfilter (cdr (assoc char allcatsalist)))) + (if narrow current nil))) + (org-agenda-filter-apply org-agenda-category-filter 'category))) + (org-agenda-redo) + (when org-agenda-category-filter + (message "Agenda filtered by category(s): %s" org-agenda-category-filter)))) + (defun org-agenda-filter-by-tag (strip &optional char narrow) "Keep only those lines in the agenda buffer that have a specific tag. The tag is selected with its fast selection letter, as configured. @@ -6178,7 +6261,7 @@ to switch to narrowing." (effort-op org-agenda-filter-effort-default-operator) (effort-prompt "") (inhibit-read-only t) - (current org-agenda-filter) + (current org-agenda-tag-filter) maybe-refresh a n tag) (unless char (message @@ -6217,21 +6300,28 @@ to switch to narrowing." "Tag: " org-global-tags-completion-table)))) (cond ((equal char ?\r) - (org-agenda-filter-by-tag-show-all) + (org-agenda-filter-show-all) (when org-agenda-auto-exclude-function - (setq org-agenda-filter '()) + (setq org-agenda-tag-filter '()) (dolist (tag (org-agenda-get-represented-tags)) (let ((modifier (funcall org-agenda-auto-exclude-function tag))) (if modifier - (push modifier org-agenda-filter)))) - (if (not (null org-agenda-filter)) - (org-agenda-filter-apply org-agenda-filter))) + (push modifier org-agenda-tag-filter)))) + (if (not (null org-agenda-tag-filter)) + (org-agenda-filter-apply org-agenda-tag-filter 'tag))) (setq maybe-refresh t)) ((equal char ?/) - (org-agenda-filter-by-tag-show-all) - (when (get 'org-agenda-filter :preset-filter) - (org-agenda-filter-apply org-agenda-filter)) - (setq maybe-refresh t)) + (if org-agenda-filtered + (progn (org-agenda-filter-show-all) + (when (get 'org-agenda-tag-filter :preset-filter) + (org-agenda-filter-apply org-agenda-tag-filter 'tag)) + (setq org-agenda-filtered nil + maybe-refresh t)) + (setq org-agenda-tag-filter + (mapcar (lambda (tag) (concat "+" tag)) + (org-get-at-bol 'tags))) + (org-agenda-filter-apply org-agenda-tag-filter 'tag) + (setq maybe-refresh t))) ((or (equal char ?\ ) (setq a (rassoc char alist)) (and (>= char ?0) (<= char ?9) @@ -6242,17 +6332,19 @@ to switch to narrowing." (setq tag "?eff") a (cons tag nil)) (and tag (setq a (cons tag nil)))) - (org-agenda-filter-by-tag-show-all) + (org-agenda-filter-show-all) (setq tag (car a)) - (setq org-agenda-filter + (setq org-agenda-tag-filter (cons (concat (if strip "-" "+") tag) (if narrow current nil))) - (org-agenda-filter-apply org-agenda-filter) + (org-agenda-filter-apply org-agenda-tag-filter 'tag) (setq maybe-refresh t)) (t (error "Invalid tag selection character %c" char))) (when (and maybe-refresh (eq org-agenda-clockreport-mode 'with-filter)) - (org-agenda-redo)))) + (org-agenda-redo)) + (when org-agenda-tag-filter + (message "Agenda filtered by tag(s): %s" org-agenda-tag-filter)))) (defun org-agenda-get-represented-tags () "Get a list of all tags currently represented in the agenda." @@ -6270,20 +6362,31 @@ to switch to narrowing." (interactive "P") (org-agenda-filter-by-tag strip char 'refine)) -(defun org-agenda-filter-make-matcher () - "Create the form that tests a line for the agenda filter." - (let (f f1) - (dolist (x (append (get 'org-agenda-filter :preset-filter) - org-agenda-filter)) +(defun org-agenda-filter-make-matcher (type) + "Create the form that tests a line for agenda filter of TYPE. +TYPE can be either 'tag or 'category." + (let ((filter (if (eq type 'tag) org-agenda-tag-filter + org-agenda-category-filter)) + f f1) + (dolist (x (delete-dups + (append (get (if (eq type 'tag) 'org-agenda-tag-filter + 'org-agenda-category-filter) + :preset-filter) filter))) (if (member x '("-" "+")) - (setq f1 (if (equal x "-") 'tags '(not tags))) + (if (eq type 'tag) + (setq f1 (if (equal x "-") 'tags '(not tags))) + (setq f1 (if (equal x "-") 'cat '(not cat)))) (if (string-match "[<=>?]" x) (setq f1 (org-agenda-filter-effort-form x)) - (setq f1 (list 'member (downcase (substring x 1)) 'tags))) + (if (eq type 'tag) + (setq f1 (list 'member (downcase (substring x 1)) 'tags)) + (setq f1 (list 'equal (substring x 1) 'cat))) (if (equal (string-to-char x) ?-) - (setq f1 (list 'not f1)))) + (setq f1 (list 'not f1))))) (push f1 f)) - (cons 'and (nreverse f)))) + (if (eq type 'tag) + (cons 'and (nreverse f)) + (cons 'or (nreverse f))))) (defun org-agenda-filter-effort-form (e) "Return the form to compare the effort of the current line with what E says. @@ -6307,26 +6410,33 @@ If the line does not have an effort defined, return nil." (funcall op (or eff (if org-sort-agenda-noeffort-is-high 32767 0)) value)))) -(defun org-agenda-filter-apply (filter) +(defvar org-agenda-filter nil) ;; FIXME needed? +(defvar org-agenda-filtered nil) +(defun org-agenda-filter-apply (filter type) "Set FILTER as the new agenda filter and apply it." (let (tags) - (setq org-agenda-filter filter - org-agenda-filter-form (org-agenda-filter-make-matcher)) + (setq org-agenda-filtered t) + (if (eq type 'tag) + (setq org-agenda-tag-filter filter) + (setq org-agenda-category-filter filter)) + (setq org-agenda-filter-form + (org-agenda-filter-make-matcher type)) (org-agenda-set-mode-name) (save-excursion (goto-char (point-min)) (while (not (eobp)) (if (org-get-at-bol 'org-marker) (progn - (setq tags (org-get-at-bol 'tags)) ; used in eval + (setq tags (org-get-at-bol 'tags) ; used in eval + cat (get-text-property (point) 'org-category)) (if (not (eval org-agenda-filter-form)) - (org-agenda-filter-by-tag-hide-line)) + (org-agenda-filter-hide-line)) (beginning-of-line 2)) (beginning-of-line 2)))) (if (get-char-property (point) 'invisible) (org-agenda-previous-line)))) -(defun org-agenda-filter-by-tag-hide-line () +(defun org-agenda-filter-hide-line () (let (ov) (setq ov (make-overlay (max (point-min) (1- (point-at-bol))) (point-at-eol))) @@ -6345,10 +6455,11 @@ If the line does not have an effort defined, return nil." (move-overlay ov (point-at-eol) (overlay-end ov))))))) -(defun org-agenda-filter-by-tag-show-all () +(defun org-agenda-filter-show-all () (mapc 'delete-overlay org-agenda-filter-overlays) (setq org-agenda-filter-overlays nil) - (setq org-agenda-filter nil) + (setq org-agenda-tag-filter nil) + (setq org-agenda-category-filter nil) (setq org-agenda-filter-form nil) (org-agenda-set-mode-name)) @@ -6764,16 +6875,31 @@ When called with a prefix argument, include all archive files as well." ((eq org-agenda-show-log 'clockcheck) " ClkCk") (org-agenda-show-log " Log") (t "")) - ;; show tags used for filtering in a custom face - (if (or org-agenda-filter (get 'org-agenda-filter + ;; show category used for filtering in a custom face + ;; FIXME + (if (or org-agenda-category-filter (get 'org-agenda-category-filter + :preset-filter)) + '(:eval (org-propertize + (concat " <" + (mapconcat + 'identity + (append + (get 'org-agenda-category-filter :preset-filter) + org-agenda-category-filter) + "") + ">") + 'face 'org-agenda-filter-category + 'help-echo "Category used in filtering")) + "") + (if (or org-agenda-tag-filter (get 'org-agenda-tag-filter :preset-filter)) '(:eval (org-propertize (concat " {" (mapconcat 'identity (append - (get 'org-agenda-filter :preset-filter) - org-agenda-filter) + (get 'org-agenda-tag-filter :preset-filter) + org-agenda-tag-filter) "") "}") 'face 'org-agenda-filter-tags @@ -8490,9 +8616,9 @@ details and examples." (org-prepare-agenda-buffers files) (while (setq file (pop files)) (setq entries - (delq nil + (delq nil (append entries - (apply 'org-agenda-get-day-entries + (apply 'org-agenda-get-day-entries file today scope))))) ;; Map thru entries and find if we should filter them out (mapc diff --git a/lisp/org-faces.el b/lisp/org-faces.el index 7b7dfa7..fe3dc8d 100644 --- a/lisp/org-faces.el +++ b/lisp/org-faces.el @@ -678,6 +678,12 @@ month and 365.24 days for a year)." "Face for tag(s) in the mode-line when filtering the agenda." :group 'org-faces) +(defface org-agenda-filter-category + (org-compatible-face 'modeline + nil) + "Face for the category in the mode-line when filtering the agenda." + :group 'org-faces) + (defface org-time-grid ;; originally copied from font-lock-variable-name-face (org-compatible-face nil '((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod")) -- 1.7.7.2