1285 lines
61 KiB
EmacsLisp
1285 lines
61 KiB
EmacsLisp
|
;;; org-super-agenda.el --- Supercharge your agenda -*- lexical-binding: t; -*-
|
||
|
|
|
||
|
|
;; Author: Adam Porter <adam@alphapapa.net>
|
||
|
|
;; Url: http://github.com/alphapapa/org-super-agenda
|
||
|
|
;; Version: 1.3-pre
|
||
|
|
;; Package-Requires: ((emacs "26.1") (s "1.10.0") (dash "2.13") (org "9.0") (ht "2.2") (ts "0.2"))
|
||
|
|
;; Keywords: hypermedia, outlines, Org, agenda
|
||
|
|
|
||
|
|
;;; Commentary:
|
||
|
|
|
||
|
|
;; This package lets you "supercharge" your Org daily/weekly agenda.
|
||
|
|
;; The idea is to group items into sections, rather than having them
|
||
|
|
;; all in one big list.
|
||
|
|
|
||
|
|
;; Now you can sort-of do this already with custom agenda commands,
|
||
|
|
;; but when you do that, you lose the daily/weekly aspect of the
|
||
|
|
;; agenda: items are no longer shown based on deadline/scheduled
|
||
|
|
;; timestamps, but are shown no-matter-what.
|
||
|
|
|
||
|
|
;; So this package filters the results from
|
||
|
|
;; `org-agenda-finalize-entries', which runs just before items are
|
||
|
|
;; inserted into agenda views. It runs them through a set of filters
|
||
|
|
;; that separate them into groups. Then the groups are inserted into
|
||
|
|
;; the agenda buffer, and any remaining items are inserted at the end.
|
||
|
|
;; Empty groups are not displayed.
|
||
|
|
|
||
|
|
;; The end result is your standard daily/weekly agenda, but arranged
|
||
|
|
;; into groups defined by you. You might put items with certain tags
|
||
|
|
;; in one group, habits in another group, items with certain todo
|
||
|
|
;; keywords in another, and items with certain priorities in another.
|
||
|
|
;; The possibilities are only limited by the grouping functions.
|
||
|
|
|
||
|
|
;; The primary use of this package is for the daily/weekly agenda,
|
||
|
|
;; made by the `org-agenda-list' command, but it also works for other
|
||
|
|
;; agenda views, like `org-tags-view', `org-todo-list',
|
||
|
|
;; `org-search-view', etc.
|
||
|
|
|
||
|
|
;; Here's an example which you can test by evaluating the `let' form:
|
||
|
|
|
||
|
|
;; (let ((org-super-agenda-groups
|
||
|
|
;; '(;; Each group has an implicit boolean OR operator between its selectors.
|
||
|
|
;; (:name "Today" ; Optionally specify section name
|
||
|
|
;; :time-grid t ; Items that appear on the time grid
|
||
|
|
;; :todo "TODAY") ; Items that have this TODO keyword
|
||
|
|
;; (:name "Important"
|
||
|
|
;; ;; Single arguments given alone
|
||
|
|
;; :tag "bills"
|
||
|
|
;; :priority "A")
|
||
|
|
;; ;; Set order of multiple groups at once
|
||
|
|
;; (:order-multi (2 (:name "Shopping in town"
|
||
|
|
;; ;; Boolean AND group matches items that match all subgroups
|
||
|
|
;; :and (:tag "shopping" :tag "@town"))
|
||
|
|
;; (:name "Food-related"
|
||
|
|
;; ;; Multiple args given in list with implicit OR
|
||
|
|
;; :tag ("food" "dinner"))
|
||
|
|
;; (:name "Personal"
|
||
|
|
;; :habit t
|
||
|
|
;; :tag "personal")
|
||
|
|
;; (:name "Space-related (non-moon-or-planet-related)"
|
||
|
|
;; ;; Regexps match case-insensitively on the entire entry
|
||
|
|
;; :and (:regexp ("space" "NASA")
|
||
|
|
;; ;; Boolean NOT also has implicit OR between selectors
|
||
|
|
;; :not (:regexp "moon" :tag "planet")))))
|
||
|
|
;; ;; Groups supply their own section names when none are given
|
||
|
|
;; (:todo "WAITING" :order 8) ; Set order of this section
|
||
|
|
;; (:todo ("SOMEDAY" "TO-READ" "CHECK" "TO-WATCH" "WATCHING")
|
||
|
|
;; ;; Show this group at the end of the agenda (since it has the
|
||
|
|
;; ;; highest number). If you specified this group last, items
|
||
|
|
;; ;; with these todo keywords that e.g. have priority A would be
|
||
|
|
;; ;; displayed in that group instead, because items are grouped
|
||
|
|
;; ;; out in the order the groups are listed.
|
||
|
|
;; :order 9)
|
||
|
|
;; (:priority<= "B"
|
||
|
|
;; ;; Show this section after "Today" and "Important", because
|
||
|
|
;; ;; their order is unspecified, defaulting to 0. Sections
|
||
|
|
;; ;; are displayed lowest-number-first.
|
||
|
|
;; :order 1)
|
||
|
|
;; ;; After the last group, the agenda will display items that didn't
|
||
|
|
;; ;; match any of these groups, with the default order position of 99
|
||
|
|
;; )))
|
||
|
|
;; (org-agenda nil "a"))
|
||
|
|
|
||
|
|
;; You can adjust the `org-super-agenda-groups' to create as many different
|
||
|
|
;; groups as you like.
|
||
|
|
|
||
|
|
;;; License:
|
||
|
|
|
||
|
|
;; This program is free software; you can redistribute it and/or modify
|
||
|
|
;; it under the terms of the GNU General Public License as published by
|
||
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
||
|
|
;; (at your option) any later version.
|
||
|
|
|
||
|
|
;; This program is distributed in the hope that it will be useful,
|
||
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
;; GNU General Public License for more details.
|
||
|
|
|
||
|
|
;; You should have received a copy of the GNU General Public License
|
||
|
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
|
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
;;;; Requirements
|
||
|
|
|
||
|
|
(require 'subr-x)
|
||
|
|
(require 'org)
|
||
|
|
(require 'org-agenda)
|
||
|
|
(require 'org-element)
|
||
|
|
(require 'org-habit)
|
||
|
|
(require 'cl-lib)
|
||
|
|
(require 'dash)
|
||
|
|
(require 's)
|
||
|
|
(require 'ht)
|
||
|
|
(require 'seq)
|
||
|
|
(require 'ts)
|
||
|
|
|
||
|
|
;; I think this is the right way to do this...
|
||
|
|
(eval-when-compile
|
||
|
|
(require 'org-macs))
|
||
|
|
|
||
|
|
;;;; Variables
|
||
|
|
|
||
|
|
(defconst org-super-agenda-special-selectors
|
||
|
|
'(:name :order :face :transformer)
|
||
|
|
;; This needs to be manually updated if any are added.
|
||
|
|
"Special, non-grouping selectors.")
|
||
|
|
|
||
|
|
(defvar org-super-agenda-group-types nil
|
||
|
|
"List of agenda grouping keywords and associated functions.
|
||
|
|
Populated automatically by `org-super-agenda--defgroup'.")
|
||
|
|
|
||
|
|
(defvar org-super-agenda-auto-selector-keywords nil
|
||
|
|
"Keywords used as auto-grouping selectors.
|
||
|
|
Populated automatically by `org-super-agenda--def-auto-group'.")
|
||
|
|
|
||
|
|
(defvar org-super-agenda-group-transformers nil
|
||
|
|
"List of agenda group transformers.")
|
||
|
|
|
||
|
|
(defvar org-super-agenda-header-map (copy-keymap org-agenda-mode-map)
|
||
|
|
"Keymap applied to agenda group headers.
|
||
|
|
This is initialized to a copy of `org-agenda-mode-map'; changes
|
||
|
|
made to that map after this variable is defined will not be
|
||
|
|
included. This map is useful for binding commands which apply
|
||
|
|
only with point on the group headers (e.g. use `origami' to fold
|
||
|
|
group headings by binding a key to `origami-toggle-node' in this
|
||
|
|
map).")
|
||
|
|
|
||
|
|
;; Silence byte-compiler.
|
||
|
|
(defvar org-element--timestamp-regexp)
|
||
|
|
|
||
|
|
(defvar org-super-agenda-allow-unsafe-groups t
|
||
|
|
"When nil, groups that could be unsafe do not function.
|
||
|
|
This includes, e.g. `:pred' and `:auto-map', which call arbitrary
|
||
|
|
functions. This variable is intended to be bound around calls to
|
||
|
|
grouping functions by code that might read values from untrusted
|
||
|
|
origin (e.g. Org QL's link-handling code).")
|
||
|
|
|
||
|
|
;;;; Customization
|
||
|
|
|
||
|
|
(defgroup org-super-agenda nil
|
||
|
|
"Settings for `org-super-agenda'."
|
||
|
|
:group 'org
|
||
|
|
:link '(url-link "http://github.com/alphapapa/org-super-agenda"))
|
||
|
|
|
||
|
|
(defcustom org-super-agenda-groups nil
|
||
|
|
"List of groups to apply to agenda views.
|
||
|
|
See readme for information."
|
||
|
|
:type 'list)
|
||
|
|
|
||
|
|
(defcustom org-super-agenda-group-property-name "agenda-group"
|
||
|
|
"Name of the Org property used by the :auto-group selector."
|
||
|
|
:type 'string)
|
||
|
|
|
||
|
|
(defcustom org-super-agenda-properties-inherit t
|
||
|
|
"Use property inheritance when checking properties with :auto-group selector.
|
||
|
|
With this enabled, you can set the \"agenda-group\" property for
|
||
|
|
an entire subtree, and every entry below it will inherit the
|
||
|
|
agenda group. It seems most natural for it to be enabled, so the
|
||
|
|
default is. But in case of performance problems, it can be
|
||
|
|
disabled. This sets the INHERIT argument to `org-entry-get'."
|
||
|
|
:type 'boolean)
|
||
|
|
|
||
|
|
(defcustom org-super-agenda-unmatched-name "Other items"
|
||
|
|
"Default name for agenda section containing items unmatched by any filter."
|
||
|
|
:type 'string)
|
||
|
|
|
||
|
|
(defcustom org-super-agenda-unmatched-order 99
|
||
|
|
"Default order setting for agenda section containing items unmatched by any filter."
|
||
|
|
:type 'integer)
|
||
|
|
|
||
|
|
(defcustom org-super-agenda-header-separator "\n"
|
||
|
|
"Separator inserted before group headers.
|
||
|
|
If a string, a newline is added. If a character, it is repeated
|
||
|
|
to fill window width, and a newline is added."
|
||
|
|
:type '(choice character string))
|
||
|
|
|
||
|
|
(defcustom org-super-agenda-header-prefix " "
|
||
|
|
"String prepended to group headers."
|
||
|
|
:type 'string)
|
||
|
|
|
||
|
|
(defcustom org-super-agenda-final-group-separator ""
|
||
|
|
"Separator inserted after final agenda group.
|
||
|
|
If a character, it is repeated to fill window width, and a
|
||
|
|
newline is added."
|
||
|
|
:type '(choice character string))
|
||
|
|
|
||
|
|
(defcustom org-super-agenda-date-format "%e %B %Y"
|
||
|
|
"Format string for date headers.
|
||
|
|
See `format-time-string'."
|
||
|
|
:type 'string)
|
||
|
|
|
||
|
|
(defcustom org-super-agenda-header-properties
|
||
|
|
'(face org-super-agenda-header
|
||
|
|
org-agenda-structural-header t)
|
||
|
|
"Text properties added to group headers."
|
||
|
|
:type 'plist)
|
||
|
|
|
||
|
|
(defcustom org-super-agenda-hide-empty-groups nil
|
||
|
|
"Hide empty groups.
|
||
|
|
Note that `org-super-agenda-mode' must be toggled for this option
|
||
|
|
to take effect."
|
||
|
|
:type 'boolean)
|
||
|
|
|
||
|
|
(defcustom org-super-agenda-keep-order nil
|
||
|
|
"Keep items' original sort order.
|
||
|
|
When multiple selectors are used, items' sort order may be
|
||
|
|
changed by the grouping process. This option re-sorts items
|
||
|
|
after grouping. The cost of this may range from negligible to
|
||
|
|
considerable, depending on the number of items."
|
||
|
|
:type 'boolean)
|
||
|
|
|
||
|
|
;;;; Faces
|
||
|
|
|
||
|
|
(defface org-super-agenda-header '((t (:inherit org-agenda-structure)))
|
||
|
|
"Face used in agenda for `org-super-agenda' group name header.")
|
||
|
|
|
||
|
|
;;;; Macros
|
||
|
|
|
||
|
|
(defmacro org-super-agenda--when-with-marker-buffer (form &rest body)
|
||
|
|
"When FORM is a marker, run BODY in the marker's buffer, with point starting at it."
|
||
|
|
(declare (indent defun) (debug (form body)))
|
||
|
|
(org-with-gensyms (marker)
|
||
|
|
`(let ((,marker ,form))
|
||
|
|
(when (markerp ,marker)
|
||
|
|
(with-current-buffer (marker-buffer ,marker)
|
||
|
|
(save-excursion
|
||
|
|
(goto-char ,marker)
|
||
|
|
,@body))))))
|
||
|
|
|
||
|
|
(cl-defmacro org-super-agenda--map-children (&key form any)
|
||
|
|
"Return FORM mapped across child entries of entry at point, if it has any.
|
||
|
|
If ANY is non-nil, return as soon as FORM returns non-nil."
|
||
|
|
(declare (indent defun)
|
||
|
|
(debug (":form" form [&optional ":any" sexp])))
|
||
|
|
(org-with-gensyms (tree-start all-results)
|
||
|
|
`(save-excursion
|
||
|
|
(save-restriction
|
||
|
|
(let ((,tree-start (point))
|
||
|
|
,all-results)
|
||
|
|
(when (save-excursion
|
||
|
|
(org-goto-first-child))
|
||
|
|
(org-narrow-to-subtree)
|
||
|
|
(cond (,any (cl-loop while (outline-next-heading)
|
||
|
|
thereis ,form))
|
||
|
|
(t (cl-loop while (outline-next-heading)
|
||
|
|
collect ,form)))))))))
|
||
|
|
|
||
|
|
;;;; Support functions
|
||
|
|
|
||
|
|
(defun org-super-agenda--org-timestamp-element< (a b)
|
||
|
|
"Return non-nil if A's date element is earlier than B's.
|
||
|
|
A and B are Org timestamp elements."
|
||
|
|
;; Copied from `org-ql'.
|
||
|
|
(cl-macrolet ((ts (ts)
|
||
|
|
`(when ,ts
|
||
|
|
(org-timestamp-format ,ts "%s"))))
|
||
|
|
(let* ((a-ts (ts a))
|
||
|
|
(b-ts (ts b)))
|
||
|
|
(cond ((and a-ts b-ts)
|
||
|
|
(string< a-ts b-ts))
|
||
|
|
(a-ts t)
|
||
|
|
(b-ts nil)))))
|
||
|
|
|
||
|
|
(defsubst org-super-agenda--get-marker (s)
|
||
|
|
"Return `org-marker' text properties of string S."
|
||
|
|
(org-find-text-property-in-string 'org-marker s))
|
||
|
|
|
||
|
|
(defsubst org-super-agenda--get-category (s)
|
||
|
|
"Return category of agenda item string S."
|
||
|
|
(org-find-text-property-in-string 'org-category s))
|
||
|
|
|
||
|
|
(defsubst org-super-agenda--get-tags (s)
|
||
|
|
"Return list of tags in agenda item string S."
|
||
|
|
(org-find-text-property-in-string 'tags s))
|
||
|
|
|
||
|
|
(defun org-super-agenda--make-agenda-header (name)
|
||
|
|
"Return agenda header named NAME.
|
||
|
|
If NAME is nil or `none', return empty string. Otherwise, return
|
||
|
|
string NAME prepended with `org-super-agenda-header-separator',
|
||
|
|
which see. NAME has the face `org-super-agenda-header' appended,
|
||
|
|
and the text properties `keymap' and `local-map' set to the value
|
||
|
|
of `org-super-agenda-header-map', which see."
|
||
|
|
(pcase name
|
||
|
|
((or `nil 'none) "")
|
||
|
|
(_ (let* ((properties (text-properties-at 0 name))
|
||
|
|
(header (concat org-super-agenda-header-prefix name))
|
||
|
|
(separator
|
||
|
|
(cl-etypecase org-super-agenda-header-separator
|
||
|
|
(character (concat (make-string (window-width) org-super-agenda-header-separator)
|
||
|
|
"\n"))
|
||
|
|
(string org-super-agenda-header-separator))))
|
||
|
|
(set-text-properties 0 (length header) properties header)
|
||
|
|
(add-face-text-property 0 (length header) 'org-super-agenda-header t header)
|
||
|
|
(org-add-props header org-super-agenda-header-properties
|
||
|
|
'keymap org-super-agenda-header-map
|
||
|
|
;; NOTE: According to the manual, only `keymap' should be necessary, but in my
|
||
|
|
;; testing, it only takes effect in Agenda buffers when `local-map' is set, so
|
||
|
|
;; we'll use both.
|
||
|
|
'local-map org-super-agenda-header-map)
|
||
|
|
;; Don't apply faces and properties to the separator part of the string.
|
||
|
|
(concat separator header)))))
|
||
|
|
|
||
|
|
(defsubst org-super-agenda--get-priority-cookie (s)
|
||
|
|
"Return priority character for string S.
|
||
|
|
Matches `org-priority-regexp'."
|
||
|
|
(when (string-match org-priority-regexp s)
|
||
|
|
(match-string-no-properties 2 s)))
|
||
|
|
|
||
|
|
(defun org-super-agenda--get-item-entry (item)
|
||
|
|
"Get entry for ITEM.
|
||
|
|
ITEM should be a string with the `org-marker' property set to a
|
||
|
|
marker."
|
||
|
|
(org-super-agenda--when-with-marker-buffer (org-super-agenda--get-marker item)
|
||
|
|
(buffer-substring (org-entry-beginning-position)
|
||
|
|
(org-entry-end-position))))
|
||
|
|
|
||
|
|
;;;; Minor mode
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(define-minor-mode org-super-agenda-mode
|
||
|
|
"Global minor mode to group items in Org agenda views according to `org-super-agenda-groups'.
|
||
|
|
With prefix argument ARG, turn on if positive, otherwise off."
|
||
|
|
:global t
|
||
|
|
(let ((advice-function-filter-return (if org-super-agenda-mode
|
||
|
|
(lambda (to fn)
|
||
|
|
;; Enable mode
|
||
|
|
(advice-add to :filter-return fn))
|
||
|
|
(lambda (from fn)
|
||
|
|
;; Disable mode
|
||
|
|
(advice-remove from fn))))
|
||
|
|
(advice-function-after (if org-super-agenda-mode
|
||
|
|
(lambda (to fn)
|
||
|
|
;; Enable mode
|
||
|
|
(advice-add to :after fn))
|
||
|
|
(lambda (from fn)
|
||
|
|
;; Disable mode
|
||
|
|
(advice-remove from fn))))
|
||
|
|
(hook-function (if org-super-agenda-mode #'add-hook #'remove-hook)))
|
||
|
|
(funcall advice-function-filter-return #'org-agenda-finalize-entries
|
||
|
|
#'org-super-agenda--filter-finalize-entries)
|
||
|
|
(when org-super-agenda-hide-empty-groups
|
||
|
|
(funcall advice-function-after #'org-agenda-filter-apply
|
||
|
|
#'org-super-agenda--hide-or-show-groups)
|
||
|
|
(funcall hook-function 'org-agenda-finalize-hook
|
||
|
|
'org-super-agenda--hide-or-show-groups))
|
||
|
|
|
||
|
|
;; Add variable to list of variables (see issue #22).
|
||
|
|
(if org-super-agenda-mode
|
||
|
|
(add-to-list 'org-agenda-local-vars 'org-super-agenda-groups)
|
||
|
|
(setq org-agenda-local-vars (remove 'org-super-agenda-groups org-agenda-local-vars)))
|
||
|
|
;; Display message
|
||
|
|
(message (if org-super-agenda-mode
|
||
|
|
"org-super-agenda-mode enabled."
|
||
|
|
"org-super-agenda-mode disabled."))))
|
||
|
|
|
||
|
|
;;;; Group selectors
|
||
|
|
|
||
|
|
;; TODO: Write TODOs for places to use this custom error.
|
||
|
|
(define-error 'org-super-agenda-invalid-selector "Invalid org-super-agenda selector" 'user-error)
|
||
|
|
|
||
|
|
(cl-defmacro org-super-agenda--defgroup (name docstring &key section-name test let*)
|
||
|
|
"Define an agenda-item group function.
|
||
|
|
NAME is a symbol that will be appended to `org-super-agenda--group-' to
|
||
|
|
construct the name of the group function. A symbol like `:name'
|
||
|
|
will be added to the `org-super-agenda-group-types' list, associated
|
||
|
|
with the function, which is used by the dispatcher.
|
||
|
|
|
||
|
|
DOCSTRING is a string used for the function's docstring.
|
||
|
|
|
||
|
|
:SECTION-NAME is a string or a lisp form that is run once, with
|
||
|
|
the variable `items' available.
|
||
|
|
|
||
|
|
:TEST is a lisp form that is run for each item, with the variable
|
||
|
|
`item' available. Items passing this test are filtered into a
|
||
|
|
separate list.
|
||
|
|
|
||
|
|
:LET* is a `let*' binding form that is bound around the function
|
||
|
|
body after the ARGS are made a list.
|
||
|
|
|
||
|
|
Finally a list of three items is returned, with the value
|
||
|
|
returned by :SECTION-NAME as the first item, a list of items not
|
||
|
|
matching the :TEST as the second, and a list of items matching as
|
||
|
|
the third."
|
||
|
|
(declare (indent defun)
|
||
|
|
(debug (&define symbolp stringp
|
||
|
|
&rest [&or [":section-name" [&or stringp def-form]]
|
||
|
|
[":test" def-form]
|
||
|
|
[":let*" (&rest &or symbolp (gate symbolp &optional def-form))]])))
|
||
|
|
(let ((group-type (intern (concat ":" (symbol-name name))))
|
||
|
|
(function-name (intern (concat "org-super-agenda--group-" (symbol-name name)))))
|
||
|
|
;; Associate the group type with this function so the dispatcher can find it
|
||
|
|
`(progn
|
||
|
|
(setq org-super-agenda-group-types (plist-put org-super-agenda-group-types ,group-type ',function-name))
|
||
|
|
(defun ,function-name (items args)
|
||
|
|
,docstring
|
||
|
|
(unless (listp args)
|
||
|
|
(setq args (list args)))
|
||
|
|
(let* ,let*
|
||
|
|
(cl-loop with section-name = ,section-name
|
||
|
|
for item in items
|
||
|
|
if ,test
|
||
|
|
collect item into matching
|
||
|
|
else collect item into non-matching
|
||
|
|
finally return (list section-name non-matching matching)))))))
|
||
|
|
|
||
|
|
;;;;; Date/time-related
|
||
|
|
|
||
|
|
;; TODO: I guess these should be in a date-matcher macro
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup date
|
||
|
|
"Group items that have a date associated.
|
||
|
|
Argument can be `t' to match items with any date, `nil' to match
|
||
|
|
items without a date, or `today' to match items with today's
|
||
|
|
date. The `ts-date' text-property is matched against. "
|
||
|
|
:section-name "Dated items" ; Note: this does not mean the item has a "SCHEDULED:" line
|
||
|
|
:let* ((today (org-today)))
|
||
|
|
:test (pcase (car args)
|
||
|
|
('t ;; Test for any date
|
||
|
|
(org-find-text-property-in-string 'ts-date item))
|
||
|
|
('nil ;; Test for not having a date
|
||
|
|
(not (org-find-text-property-in-string 'ts-date item)))
|
||
|
|
('today ;; Items that have a time sometime today
|
||
|
|
;; TODO: Maybe I can use the ts-date property in some other places, might be faster
|
||
|
|
(when-let ((day (org-find-text-property-in-string 'ts-date item)))
|
||
|
|
(= day today)))
|
||
|
|
(_ ;; Oops
|
||
|
|
(user-error "Argument to `:date' must be `t', `nil', or `today'"))))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup time-grid
|
||
|
|
"Group items that appear on a time grid.
|
||
|
|
This matches the `dotime' text-property, which, if NOT set to
|
||
|
|
`time' (I know, this gets confusing), means it WILL appear in the
|
||
|
|
agenda time-grid. "
|
||
|
|
:section-name "Timed items" ; Note: this does not mean the item has a "SCHEDULED:" line
|
||
|
|
:test (or (--when-let (org-find-text-property-in-string 'time item)
|
||
|
|
;; This property is a string; if empty, it doesn't match
|
||
|
|
(not (string-empty-p it)))
|
||
|
|
;; This property is nil if it doesn't match
|
||
|
|
(org-find-text-property-in-string 'time-of-day item)
|
||
|
|
(--when-let (org-find-text-property-in-string 'dotime item)
|
||
|
|
;; For this to match, the 'dotime property must be set, and
|
||
|
|
;; it must not be equal to 'time. If it is not set, or if
|
||
|
|
;; it is set and is equal to 'time, the item is not part of
|
||
|
|
;; the time-grid. Yes, this is confusing. :)
|
||
|
|
(not (eql it 'time)))))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup deadline
|
||
|
|
"Group items that have a deadline.
|
||
|
|
Argument can be `t' (to match items with any deadline), `nil' (to
|
||
|
|
match items that have no deadline), `past` (to match items with a
|
||
|
|
deadline in the past), `today' (to match items whose deadline is
|
||
|
|
today), or `future' (to match items with a deadline in the
|
||
|
|
future). Argument may also be given like `before DATE' or `after
|
||
|
|
DATE', where DATE is a date string that
|
||
|
|
`org-time-string-to-absolute' can process."
|
||
|
|
:section-name (pcase (car args)
|
||
|
|
('t "Deadline items")
|
||
|
|
('nil "Items without deadlines")
|
||
|
|
('past "Past due")
|
||
|
|
('today "Due today")
|
||
|
|
('future "Due soon")
|
||
|
|
('before (concat "Due before " (cadr args)))
|
||
|
|
('on (concat "Due on " (cadr args)))
|
||
|
|
('after (concat "Due after " (cadr args))))
|
||
|
|
:let* ((today (pcase (car args) ; Perhaps premature optimization
|
||
|
|
((or 'past 'today 'future 'before 'on 'after)
|
||
|
|
(org-today))))
|
||
|
|
(target-date (pcase (car args)
|
||
|
|
((or 'before 'on 'after)
|
||
|
|
(org-time-string-to-absolute (cadr args))))))
|
||
|
|
:test (org-super-agenda--when-with-marker-buffer (org-super-agenda--get-marker item)
|
||
|
|
(let ((entry-time (org-entry-get (point) "DEADLINE")))
|
||
|
|
(pcase (car args)
|
||
|
|
('t entry-time) ; Has any deadline info
|
||
|
|
('nil (not entry-time)) ; Has no deadline info
|
||
|
|
(comparison
|
||
|
|
(when entry-time
|
||
|
|
(let ((entry-time (org-time-string-to-absolute entry-time))
|
||
|
|
(compare-date (pcase comparison
|
||
|
|
((or 'past 'today 'future) today)
|
||
|
|
((or 'before 'on 'after) target-date))))
|
||
|
|
(org-super-agenda--compare-dates comparison entry-time compare-date))))))))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup scheduled
|
||
|
|
"Group items that are scheduled.
|
||
|
|
Argument can be `t' (to match items scheduled for any date),
|
||
|
|
`nil' (to match items that are not schedule), `past` (to match
|
||
|
|
items scheduled for the past), `today' (to match items scheduled
|
||
|
|
for today), or `future' (to match items scheduled for the
|
||
|
|
future). Argument may also be given like `before DATE' or `after
|
||
|
|
DATE', where DATE is a date string that
|
||
|
|
`org-time-string-to-absolute' can process."
|
||
|
|
:section-name (pcase (car args)
|
||
|
|
('t "Scheduled items")
|
||
|
|
('nil "Unscheduled items ")
|
||
|
|
('past "Past scheduled")
|
||
|
|
('today "Scheduled today")
|
||
|
|
('future "Scheduled soon")
|
||
|
|
('before (concat "Scheduled before " (cadr args)))
|
||
|
|
('on (concat "Scheduled on " (cadr args)))
|
||
|
|
('after (concat "Scheduled after " (cadr args))))
|
||
|
|
:let* ((today (pcase (car args) ; Perhaps premature optimization
|
||
|
|
((or 'past 'today 'future 'before 'on 'after)
|
||
|
|
(org-today))))
|
||
|
|
(target-date (pcase (car args)
|
||
|
|
((or 'before 'on 'after)
|
||
|
|
(org-time-string-to-absolute (cadr args))))))
|
||
|
|
:test (org-super-agenda--when-with-marker-buffer (org-super-agenda--get-marker item)
|
||
|
|
(let ((entry-time (org-entry-get (point) "SCHEDULED")))
|
||
|
|
(pcase (car args)
|
||
|
|
('t entry-time) ; Has any scheduled info
|
||
|
|
('nil (not entry-time)) ; Has no scheduled info
|
||
|
|
(comparison
|
||
|
|
(when entry-time
|
||
|
|
(let ((entry-time (org-time-string-to-absolute entry-time))
|
||
|
|
(compare-date (pcase comparison
|
||
|
|
((or 'past 'today 'future) today)
|
||
|
|
((or 'before 'on 'after) target-date))))
|
||
|
|
(org-super-agenda--compare-dates comparison entry-time compare-date))))))))
|
||
|
|
|
||
|
|
(defun org-super-agenda--compare-dates (comparison date-a date-b)
|
||
|
|
"Compare DATE-A and DATE-B according to COMPARISON.
|
||
|
|
COMPARISON should be a symbol, one of: `past' or `before',
|
||
|
|
`today' or `on', `future' or `after'."
|
||
|
|
(pcase comparison
|
||
|
|
((or 'past 'before) (< date-a date-b))
|
||
|
|
((or 'today 'on) (= date-a date-b))
|
||
|
|
((or 'future 'after) (> date-a date-b))))
|
||
|
|
|
||
|
|
;;;;; Effort
|
||
|
|
|
||
|
|
(cl-defmacro org-super-agenda--defeffort-group (name docstring &key comparator)
|
||
|
|
(declare (indent defun))
|
||
|
|
`(org-super-agenda--defgroup ,(intern (concat "effort" (symbol-name name)))
|
||
|
|
,(concat docstring "\nArgument is a time-duration string, like \"5\" or \"0:05\" for 5 minutes.")
|
||
|
|
:section-name (concat "Effort " ,(symbol-name name) " "
|
||
|
|
(s-join " or " args) " items")
|
||
|
|
:let* ((effort-minutes (org-duration-string-to-minutes (car args))))
|
||
|
|
:test (when-let ((item-effort (org-find-text-property-in-string 'effort item)))
|
||
|
|
(,comparator (org-duration-string-to-minutes item-effort) effort-minutes))))
|
||
|
|
|
||
|
|
(org-super-agenda--defeffort-group <
|
||
|
|
"Group items that are less than (or equal to) the given effort."
|
||
|
|
:comparator <=)
|
||
|
|
|
||
|
|
(org-super-agenda--defeffort-group >
|
||
|
|
"Group items that are higher than (or equal to) the given effort."
|
||
|
|
:comparator >=)
|
||
|
|
|
||
|
|
;;;;; Misc
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup anything
|
||
|
|
"Select any item, no matter what.
|
||
|
|
This is a catch-all, probably most useful with the `:discard'
|
||
|
|
selector."
|
||
|
|
:test t)
|
||
|
|
|
||
|
|
;; TODO: Rename this to something like :descendants and make a new
|
||
|
|
;; one-level-deep-only :children matcher that will be much faster
|
||
|
|
(org-super-agenda--defgroup children
|
||
|
|
"Select any item that has child entries.
|
||
|
|
Argument may be `t' to match if it has any children, `nil' to
|
||
|
|
match if it has no children, `todo' to match if it has children
|
||
|
|
with any to-do keywords, or a string to match if it has specific
|
||
|
|
to-do keywords."
|
||
|
|
:section-name (pcase (car args)
|
||
|
|
('todo "Items with child to-dos")
|
||
|
|
((pred stringp) (concat "Items with children " (car args)))
|
||
|
|
('t "Items with children")
|
||
|
|
('nil "Items without children"))
|
||
|
|
:let* ((case-fold-search t))
|
||
|
|
:test (org-super-agenda--when-with-marker-buffer (org-super-agenda--get-marker item)
|
||
|
|
(pcase (car args)
|
||
|
|
('todo ;; Match if entry has child to-dos
|
||
|
|
(org-super-agenda--map-children
|
||
|
|
:form (org-entry-is-todo-p)
|
||
|
|
:any t))
|
||
|
|
((pred stringp) ;; Match child to-do keywords
|
||
|
|
(org-super-agenda--map-children
|
||
|
|
:form (cl-member (org-get-todo-state) args :test #'string=)
|
||
|
|
:any t))
|
||
|
|
('t ;; Match if it has any children
|
||
|
|
(org-goto-first-child))
|
||
|
|
('nil ;; Match if it has no children
|
||
|
|
(not (org-goto-first-child))))))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup habit
|
||
|
|
"Group habit items.
|
||
|
|
Habit items have a \"STYLE: habit\" Org property."
|
||
|
|
:section-name "Habits"
|
||
|
|
:test (org-is-habit-p (org-super-agenda--get-marker item)))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup file-path
|
||
|
|
"Group items by file path.
|
||
|
|
Argument can be `t' to match items from files at any
|
||
|
|
path (i.e. all items from file-backed buffers), `nil' to match
|
||
|
|
items from non-file-backed buffers, or one or a list of regexp
|
||
|
|
strings to match against file paths."
|
||
|
|
:section-name (concat "File path: " (s-join " OR " args))
|
||
|
|
:test (-when-let* ((marker (or (get-text-property 0 'org-marker item)
|
||
|
|
(get-text-property 0 'org-hd-marker item)))
|
||
|
|
(file-path (->> marker marker-buffer buffer-file-name)))
|
||
|
|
(pcase args
|
||
|
|
('t t)
|
||
|
|
('nil nil)
|
||
|
|
((pred stringp) (s-matches? args file-path))
|
||
|
|
(_ (cl-loop for path in args
|
||
|
|
thereis (s-matches? path file-path))))))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup log
|
||
|
|
"Group Agenda Log Mode items.
|
||
|
|
Argument may be `close' or `closed' to select items closed today;
|
||
|
|
`clock' or `clocked' to select items clocked today; `changed' or
|
||
|
|
`state' to select items whose to-do state was changed today; `t'
|
||
|
|
to select any logged item, or `nil' to select any non-logged
|
||
|
|
item. (See also variable `org-agenda-log-mode-items'.) Note
|
||
|
|
that these items may also be matched by the :time-grid selector,
|
||
|
|
so if you want these displayed in their own group, you may need
|
||
|
|
to select them in a group before a group containing the
|
||
|
|
:time-grid selector."
|
||
|
|
:section-name (pcase (car args)
|
||
|
|
((or 'close 'closed) "Log: Closed")
|
||
|
|
((or 'clock 'clocked) "Log: Clocked")
|
||
|
|
((or 'changed 'state) "Log: State changed")
|
||
|
|
('t "Logged")
|
||
|
|
('nil "Not logged"))
|
||
|
|
;; I don't know why the property's value is a string instead of a
|
||
|
|
;; symbol, because `org-agenda-log-mode-items' is a list of symbols.
|
||
|
|
|
||
|
|
;; TODO: Rather than hard-coding these strings and symbols, it would be good to get them smartly
|
||
|
|
;; from `org-agenda-log-mode-items', but I don't want to give up accepting both e.g. `close' and
|
||
|
|
;; `closed', because it's easily confusing and error-prone without that flexibility.
|
||
|
|
:test (let ((value (org-find-text-property-in-string 'type item)))
|
||
|
|
(pcase (car args)
|
||
|
|
((or 'close 'closed) (string= value "closed"))
|
||
|
|
((or 'clock 'clocked) (string= value "clock"))
|
||
|
|
((or 'changed 'state) (string= value "state"))
|
||
|
|
('t (cl-member value '("closed" "clock" "state") :test #'string=))
|
||
|
|
('nil (not (cl-member value '("closed" "clock" "state") :test #'string=))))))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup heading-regexp
|
||
|
|
"Group items whose headings match any of the given regular expressions.
|
||
|
|
Argument may be a string or list of strings, each of which should
|
||
|
|
be a regular expression. You'll probably want to override the
|
||
|
|
section name for this group."
|
||
|
|
:section-name (concat "Headings matching regexps: "
|
||
|
|
(s-join " OR "
|
||
|
|
(--map (s-wrap it "\"")
|
||
|
|
args)))
|
||
|
|
:let* ((case-fold-search t))
|
||
|
|
:test (org-super-agenda--when-with-marker-buffer (org-super-agenda--get-marker item)
|
||
|
|
(let ((heading (org-get-heading 'no-tags 'no-todo)))
|
||
|
|
(cl-loop for regexp in args
|
||
|
|
thereis (string-match-p regexp heading)))))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup pred
|
||
|
|
"Group items that match a predicate.
|
||
|
|
Argument can be one or a list of functions, to match items that
|
||
|
|
return non-nil for any function.
|
||
|
|
|
||
|
|
Each predicate is called with a single argument: the agenda item
|
||
|
|
being tested, as a string. Agenda-related attributes will have
|
||
|
|
been applied to the string as text-properties. Use
|
||
|
|
`describe-text-properties' in an agenda buffer to see what's
|
||
|
|
available."
|
||
|
|
:section-name (progn
|
||
|
|
(unless org-super-agenda-allow-unsafe-groups
|
||
|
|
;; Check here so the test is run once, not for every item.
|
||
|
|
(error "Unsafe groups disallowed (:pred): %s" args))
|
||
|
|
(concat "Predicate: "
|
||
|
|
(cl-labels ((to-string (arg)
|
||
|
|
(pcase-exhaustive arg
|
||
|
|
;; FIXME: What if the lambda's byte-compiled?
|
||
|
|
(`(lambda . ,_) "Lambda")
|
||
|
|
((pred functionp) (symbol-name arg))
|
||
|
|
((pred listp) (s-join " OR " (-map #'to-string arg))))))
|
||
|
|
(to-string args))))
|
||
|
|
:test (pcase args
|
||
|
|
((pred functionp) (funcall args item))
|
||
|
|
(_ (cl-loop for fn in args
|
||
|
|
thereis (funcall fn item)))))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup property
|
||
|
|
"Group items with a property, optionally matching a value.
|
||
|
|
Argument may be a property name string, or a list of property
|
||
|
|
name string and either value string or predicate with which to
|
||
|
|
test the value."
|
||
|
|
:section-name (concat "Property: " (car args)
|
||
|
|
(pcase (cadr args)
|
||
|
|
(`nil nil)
|
||
|
|
((pred stringp) (concat ": " (cadr args)))
|
||
|
|
((and (pred functionp) (pred symbolp))
|
||
|
|
(concat " matches predicate " (symbol-name (cadr args))))
|
||
|
|
((pred functionp) (concat " matches lambda predicate"))))
|
||
|
|
:test (when-let* ((found-value
|
||
|
|
(org-entry-get (org-super-agenda--get-marker item)
|
||
|
|
(car-safe args)
|
||
|
|
org-super-agenda-properties-inherit)))
|
||
|
|
(pcase args
|
||
|
|
((or (and property (pred stringp))
|
||
|
|
`(,(and property (pred stringp)) . nil))
|
||
|
|
;; Only property, no value given.
|
||
|
|
t)
|
||
|
|
(`(,property ,(and value (pred stringp)))
|
||
|
|
(string= value found-value))
|
||
|
|
(`(,property ,(and predicate (pred functionp)))
|
||
|
|
(funcall predicate found-value))
|
||
|
|
(_ ;; Oops
|
||
|
|
(signal 'org-super-agenda-invalid-selector (list (cons :property args)))))))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup regexp
|
||
|
|
"Group items that match any of the given regular expressions.
|
||
|
|
Argument may be a string or list of strings, each of which should
|
||
|
|
be a regular expression. You'll probably want to override the
|
||
|
|
section name for this group."
|
||
|
|
:section-name (concat "Items matching regexps: "
|
||
|
|
(s-join " OR "
|
||
|
|
(--map (s-wrap it "\"")
|
||
|
|
args)))
|
||
|
|
:let* ((case-fold-search t))
|
||
|
|
:test (when-let ((entry (org-super-agenda--get-item-entry item)))
|
||
|
|
(cl-loop for regexp in args
|
||
|
|
thereis (string-match-p regexp entry))))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup tag
|
||
|
|
"Group items that match any of the given tags.
|
||
|
|
Argument may be a string or list of strings."
|
||
|
|
:section-name (concat "Tags: " (s-join " OR " args))
|
||
|
|
:test (seq-intersection (org-super-agenda--get-tags item) args 'cl-equalp))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup category
|
||
|
|
"Group items that match any of the given categories.
|
||
|
|
Argument may be a string or list of strings."
|
||
|
|
:section-name (concat "Items categorized as: " (s-join " OR " args))
|
||
|
|
:test (cl-member (org-super-agenda--get-category item)
|
||
|
|
args :test #'string=))
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup todo
|
||
|
|
"Group items that match any of the given TODO keywords.
|
||
|
|
Argument may be a string or list of strings, or `t' to match any
|
||
|
|
keyword, or `nil' to match only non-todo items."
|
||
|
|
:section-name (pcase (car args)
|
||
|
|
((pred stringp) ;; To-do keyword given
|
||
|
|
(concat (s-join " and " (--map (propertize it 'face (org-get-todo-face it))
|
||
|
|
args))
|
||
|
|
" items"))
|
||
|
|
('t ;; Test for any to-do keyword
|
||
|
|
"Any TODO keyword")
|
||
|
|
('nil ;; Test for not having a to-do keyword
|
||
|
|
"Non-todo items")
|
||
|
|
(_ ;; Oops
|
||
|
|
(user-error "Argument to `:todo' must be a string, list of strings, t, or nil")))
|
||
|
|
:test (pcase (car args)
|
||
|
|
((pred stringp) ;; To-do keyword given
|
||
|
|
(cl-member (org-find-text-property-in-string 'todo-state item) args :test 'string=))
|
||
|
|
('t ;; Test for any to-do keyword
|
||
|
|
(org-find-text-property-in-string 'todo-state item))
|
||
|
|
('nil ;; Test for not having a to-do keyword
|
||
|
|
(not (org-find-text-property-in-string 'todo-state item)))
|
||
|
|
(_ ;; Oops
|
||
|
|
(user-error "Argument to `:todo' must be a string, list of strings, t, or nil"))))
|
||
|
|
|
||
|
|
;;;;; Priority
|
||
|
|
|
||
|
|
(org-super-agenda--defgroup priority
|
||
|
|
"Group items that match any of the given priorities.
|
||
|
|
Argument may be a string or list of strings, which should be,
|
||
|
|
e.g. \"A\" or (\"B\" \"C\")."
|
||
|
|
:section-name (concat "Priority " (s-join " and " args) " items")
|
||
|
|
:test (cl-member (org-super-agenda--get-priority-cookie item) args :test 'string=))
|
||
|
|
|
||
|
|
(cl-defmacro org-super-agenda--defpriority-group (name docstring &key comparator)
|
||
|
|
(declare (indent defun))
|
||
|
|
`(org-super-agenda--defgroup ,(intern (concat "priority" (symbol-name name)))
|
||
|
|
,(concat docstring "\nArgument is a string; it may also be a list of
|
||
|
|
strings, in which case only the first will be used.
|
||
|
|
The string should be the priority cookie letter, e.g. \"A\".")
|
||
|
|
:section-name (concat "Priority " ,(symbol-name name) " "
|
||
|
|
(s-join " or " args) " items")
|
||
|
|
:let* ((priority-number (string-to-char (car args))))
|
||
|
|
:test (let ((item-priority (org-super-agenda--get-priority-cookie item)))
|
||
|
|
(when item-priority
|
||
|
|
;; Higher priority means lower number
|
||
|
|
(,comparator (string-to-char item-priority) priority-number)))))
|
||
|
|
|
||
|
|
(org-super-agenda--defpriority-group >
|
||
|
|
"Group items that are higher than the given priority."
|
||
|
|
:comparator <)
|
||
|
|
|
||
|
|
(org-super-agenda--defpriority-group >=
|
||
|
|
"Group items that are greater than or equal to the given priority."
|
||
|
|
:comparator <=)
|
||
|
|
|
||
|
|
(org-super-agenda--defpriority-group <
|
||
|
|
"Group items that are lower than the given priority."
|
||
|
|
:comparator >)
|
||
|
|
|
||
|
|
(org-super-agenda--defpriority-group <=
|
||
|
|
"Group items that are lower than or equal to the given priority."
|
||
|
|
:comparator >=)
|
||
|
|
|
||
|
|
;;;; Grouping functions
|
||
|
|
|
||
|
|
;; TODO: cl-loop is great, but when it gets this big, it's rather ugly, and it
|
||
|
|
;; probably scares some people away. This should probably be refactored.
|
||
|
|
(defun org-super-agenda--group-items (all-items)
|
||
|
|
"Divide ALL-ITEMS into groups based on `org-super-agenda-groups'."
|
||
|
|
(if (bound-and-true-p org-super-agenda-groups)
|
||
|
|
;; Transform groups
|
||
|
|
(let ((org-super-agenda-groups (org-super-agenda--transform-groups org-super-agenda-groups)))
|
||
|
|
;; Collect and insert groups
|
||
|
|
(cl-loop with section-name
|
||
|
|
for filter in org-super-agenda-groups
|
||
|
|
for custom-section-name = (plist-get filter :name)
|
||
|
|
for order = (or (plist-get filter :order) 0) ; Lowest number first, 0 by default
|
||
|
|
for (auto-section-name non-matching matching) = (org-super-agenda--group-dispatch all-items filter)
|
||
|
|
|
||
|
|
do (when org-super-agenda-keep-order
|
||
|
|
(setf matching (sort matching #'org-entries-lessp)))
|
||
|
|
|
||
|
|
;; Transformer
|
||
|
|
for transformer = (plist-get filter :transformer)
|
||
|
|
when transformer
|
||
|
|
do (setq matching (-map (pcase transformer
|
||
|
|
(`(function ,transformer) transformer)
|
||
|
|
((pred symbolp) transformer)
|
||
|
|
(_ `(lambda (it) ,transformer)))
|
||
|
|
matching))
|
||
|
|
|
||
|
|
;; Face
|
||
|
|
for face = (plist-get filter :face)
|
||
|
|
when face
|
||
|
|
do (let ((append (plist-get face :append)))
|
||
|
|
(when append (cl-remf face :append))
|
||
|
|
(--each matching
|
||
|
|
(add-face-text-property 0 (length it) face append it)))
|
||
|
|
|
||
|
|
;; Auto category/group
|
||
|
|
if (cl-member auto-section-name org-super-agenda-auto-selector-keywords)
|
||
|
|
do (setq section-name (or custom-section-name "Auto category/group"))
|
||
|
|
and append (cl-loop for group in matching
|
||
|
|
collect (list :name (plist-get group :name)
|
||
|
|
:items (plist-get group :items)
|
||
|
|
:order order))
|
||
|
|
into sections
|
||
|
|
and do (setq all-items non-matching)
|
||
|
|
|
||
|
|
;; Manual groups
|
||
|
|
else
|
||
|
|
do (setq section-name (or custom-section-name auto-section-name))
|
||
|
|
and collect (list :name section-name :items matching :order order) into sections
|
||
|
|
and do (setq all-items non-matching)
|
||
|
|
|
||
|
|
;; Sort sections by :order then :name
|
||
|
|
finally do (setq non-matching (list :name org-super-agenda-unmatched-name
|
||
|
|
:items non-matching
|
||
|
|
:order org-super-agenda-unmatched-order))
|
||
|
|
finally do (setq sections (--sort (let ((o-it (plist-get it :order))
|
||
|
|
(o-other (plist-get other :order)))
|
||
|
|
(cond ((and
|
||
|
|
;; FIXME: This is now quite ugly. I'm not sure that all of these tests
|
||
|
|
;; are necessary, but at the moment it works, so I'm leaving it alone.
|
||
|
|
(equal o-it o-other)
|
||
|
|
(not (equal o-it 0))
|
||
|
|
(stringp (plist-get it :name))
|
||
|
|
(stringp (plist-get other :name)))
|
||
|
|
;; Sort by string only for items with a set order
|
||
|
|
(string< (plist-get it :name)
|
||
|
|
(plist-get other :name)))
|
||
|
|
((and (numberp o-it)
|
||
|
|
(numberp o-other))
|
||
|
|
(< o-it o-other))
|
||
|
|
(t nil)))
|
||
|
|
(push non-matching sections)))
|
||
|
|
;; Insert sections
|
||
|
|
finally return (cl-loop for (_ name _ items) in sections
|
||
|
|
when items
|
||
|
|
collect (org-super-agenda--make-agenda-header name)
|
||
|
|
and append items)))
|
||
|
|
;; No super-filters; return list unmodified
|
||
|
|
all-items))
|
||
|
|
|
||
|
|
;;;;; Auto-grouping
|
||
|
|
|
||
|
|
(cl-defmacro org-super-agenda--def-auto-group (name docstring-ending
|
||
|
|
&key keyword key-form
|
||
|
|
(header-form 'key) (key-sort-fn #'string<))
|
||
|
|
"Define an auto-grouping function.
|
||
|
|
|
||
|
|
The function will be named `org-super-agenda--auto-group-NAME'.
|
||
|
|
|
||
|
|
The docstring will be, \"Divide ALL-ITEMS into groups based on DOCSTRING_ENDING.\".
|
||
|
|
|
||
|
|
The selector keyword will be `:auto-NAME'.
|
||
|
|
|
||
|
|
Items will be grouped by the value of KEY-FORM evaluated for each
|
||
|
|
item, with the variable `item' bound to the string from the
|
||
|
|
agenda buffer.
|
||
|
|
|
||
|
|
Group headers will be sorted by KEY-SORT-FN; usually the default
|
||
|
|
will suffice.
|
||
|
|
|
||
|
|
The groups' headers will be the value of HEADER-FORM, evaluated
|
||
|
|
for each group after items are grouped, with the variable `key'
|
||
|
|
bound to the group's key. The form defaults to `key'.
|
||
|
|
|
||
|
|
In the body of the function, the variable `all-items' will be
|
||
|
|
bound to all agenda items being grouped, and `args' to the rest
|
||
|
|
of the arguments to the function."
|
||
|
|
(declare (indent defun))
|
||
|
|
(cl-labels ((form-contains (form symbol)
|
||
|
|
(cl-typecase form
|
||
|
|
(atom (eq form symbol))
|
||
|
|
(list (or (form-contains (car form) symbol)
|
||
|
|
(form-contains (cdr form) symbol))))))
|
||
|
|
(let* ((fn-name (intern (format "org-super-agenda--auto-group-%s" name)))
|
||
|
|
(docstring (format "Divide ALL-ITEMS into groups based on %s." docstring-ending))
|
||
|
|
(keyword (or keyword (intern (format ":auto-%s" name))))
|
||
|
|
(fn-args (if (or (form-contains key-form 'args)
|
||
|
|
(form-contains header-form 'args))
|
||
|
|
'(all-items &rest args)
|
||
|
|
'(all-items &rest _args))))
|
||
|
|
`(progn
|
||
|
|
(defun ,fn-name ,fn-args
|
||
|
|
,docstring
|
||
|
|
(cl-loop with groups = (ht-create)
|
||
|
|
for item in all-items
|
||
|
|
for key = ,key-form
|
||
|
|
if key
|
||
|
|
do (ht-set! groups key (cons item (ht-get groups key)))
|
||
|
|
else collect item into non-matching
|
||
|
|
finally return (list ,keyword
|
||
|
|
non-matching
|
||
|
|
(cl-loop for key in (sort (ht-keys groups) #',key-sort-fn)
|
||
|
|
for name = ,header-form
|
||
|
|
collect (list :name name
|
||
|
|
:items (nreverse (ht-get groups key)))))))
|
||
|
|
(setq org-super-agenda-group-types (plist-put org-super-agenda-group-types
|
||
|
|
,keyword #',fn-name))
|
||
|
|
(add-to-list 'org-super-agenda-auto-selector-keywords ,keyword)))))
|
||
|
|
|
||
|
|
;; TODO: auto-year and auto-month groups. Maybe also auto-quarter,
|
||
|
|
;; auto-week, etc. Maybe also auto-next-7-days, something like that.
|
||
|
|
|
||
|
|
(org-super-agenda--def-auto-group planning
|
||
|
|
"their earliest deadline or scheduled date (formatted according to `org-super-agenda-date-format', which see)"
|
||
|
|
:keyword :auto-planning
|
||
|
|
;; This is convoluted, mainly because dates and times in Emacs are kind of
|
||
|
|
;; insane. Good luck parsing a simple "%e %B %Y"-formatted time back to a
|
||
|
|
;; time value that can be compared. It's virtually impossible, at least
|
||
|
|
;; without a lot of work (hence my ts.el package, but it's not yet mature
|
||
|
|
;; enough to use here). So we store the Org timestamp element in the text
|
||
|
|
;; properties of the formatted time.
|
||
|
|
;; TODO: Use `ts' for this.
|
||
|
|
:key-form (cl-flet ((get-date-type (type)
|
||
|
|
(when-let* ((date-string (org-entry-get (point) type)))
|
||
|
|
(with-temp-buffer
|
||
|
|
;; FIXME: Hack: since we're using (org-element-property
|
||
|
|
;; :type date-element) below, we need this date parsed
|
||
|
|
;; into an org-element element.
|
||
|
|
(insert date-string)
|
||
|
|
(goto-char 0)
|
||
|
|
(org-element-timestamp-parser)))))
|
||
|
|
(org-super-agenda--when-with-marker-buffer (org-super-agenda--get-marker item)
|
||
|
|
;; MAYBE: Also check CLOSED date.
|
||
|
|
(let ((earliest-ts (car (sort (list (get-date-type "SCHEDULED")
|
||
|
|
(get-date-type "DEADLINE"))
|
||
|
|
#'org-super-agenda--org-timestamp-element<))))
|
||
|
|
(pcase earliest-ts
|
||
|
|
('nil nil)
|
||
|
|
(_ (propertize (org-timestamp-format earliest-ts org-super-agenda-date-format)
|
||
|
|
'org-super-agenda-ts earliest-ts))))))
|
||
|
|
:key-sort-fn (lambda (a b)
|
||
|
|
(org-super-agenda--org-timestamp-element<
|
||
|
|
(get-text-property 0 'org-super-agenda-ts a)
|
||
|
|
(get-text-property 0 'org-super-agenda-ts b))))
|
||
|
|
|
||
|
|
(org-super-agenda--def-auto-group tags
|
||
|
|
"their tags"
|
||
|
|
:keyword :auto-tags
|
||
|
|
:key-form (--when-let (org-super-agenda--get-tags item)
|
||
|
|
(->> it (-sort #'string<) (s-join ", ")
|
||
|
|
(concat "Tags: ")))
|
||
|
|
:key-sort-fn string<)
|
||
|
|
|
||
|
|
(org-super-agenda--def-auto-group ts
|
||
|
|
"the date of their latest timestamp anywhere in the entry (formatted according to `org-super-agenda-date-format', which see)"
|
||
|
|
:keyword :auto-ts
|
||
|
|
:key-form (org-super-agenda--when-with-marker-buffer (org-super-agenda--get-marker item)
|
||
|
|
(ignore args)
|
||
|
|
(let* ((limit (org-entry-end-position))
|
||
|
|
(latest-ts (->> (cl-loop for next-ts =
|
||
|
|
(when (re-search-forward org-element--timestamp-regexp limit t)
|
||
|
|
(ts-parse-org (match-string 1)))
|
||
|
|
while next-ts
|
||
|
|
collect next-ts)
|
||
|
|
(-sort #'ts>)
|
||
|
|
car)))
|
||
|
|
(when latest-ts
|
||
|
|
(propertize (ts-format org-super-agenda-date-format latest-ts)
|
||
|
|
'org-super-agenda-ts latest-ts))))
|
||
|
|
:key-sort-fn (lambda (a b)
|
||
|
|
(funcall (if (member 'reverse args)
|
||
|
|
#'ts> #'ts<)
|
||
|
|
(get-text-property 0 'org-super-agenda-ts a)
|
||
|
|
(get-text-property 0 'org-super-agenda-ts b))))
|
||
|
|
|
||
|
|
(org-super-agenda--def-auto-group items "their AGENDA-GROUP property"
|
||
|
|
:keyword :auto-group
|
||
|
|
:key-form (org-entry-get (org-super-agenda--get-marker item)
|
||
|
|
org-super-agenda-group-property-name
|
||
|
|
org-super-agenda-properties-inherit)
|
||
|
|
:header-form (concat "Group: " key))
|
||
|
|
|
||
|
|
(org-super-agenda--def-auto-group category "their org-category property"
|
||
|
|
:key-form (org-super-agenda--when-with-marker-buffer (org-super-agenda--get-marker item)
|
||
|
|
(org-get-category))
|
||
|
|
:header-form (concat "Category: " key))
|
||
|
|
|
||
|
|
(org-super-agenda--def-auto-group map "the value returned by calling function ARGS with each item. The function should return a string to be used as the grouping key and as the header for its group"
|
||
|
|
:key-form (progn
|
||
|
|
(unless org-super-agenda-allow-unsafe-groups
|
||
|
|
;; This check gets run for every item because the `def-auto-group' macro
|
||
|
|
;; doesn't have a form that is eval'ed once. NOTE: If there are no
|
||
|
|
;; results, the key-form never gets evaluated, so the check doesn't either.
|
||
|
|
;; TODO: Add a form to the macro so this test can be run once.
|
||
|
|
(error "Unsafe groups disallowed (:auto-map): %s" args))
|
||
|
|
(org-super-agenda--when-with-marker-buffer (org-super-agenda--get-marker item)
|
||
|
|
(funcall (car args) item))))
|
||
|
|
|
||
|
|
(org-super-agenda--def-auto-group priority "their priority"
|
||
|
|
:key-form (org-super-agenda--get-priority-cookie item)
|
||
|
|
:header-form (format "Priority: %s" key))
|
||
|
|
|
||
|
|
(org-super-agenda--def-auto-group property "the given property"
|
||
|
|
:key-form (org-entry-get (org-super-agenda--get-marker item)
|
||
|
|
(car args)
|
||
|
|
org-super-agenda-properties-inherit)
|
||
|
|
:header-form (format "%s: %s" (car args) key))
|
||
|
|
|
||
|
|
(org-super-agenda--def-auto-group todo "their to-do keyword"
|
||
|
|
:keyword :auto-todo
|
||
|
|
;; NOTE: I'm not sure why sometimes items have the `todo-state' property set and other
|
||
|
|
;; times `todo-keyword', but that seems to be the case, so we need to handle both.
|
||
|
|
:key-form (when-let* ((keyword (or (org-find-text-property-in-string 'todo-state item)
|
||
|
|
(org-find-text-property-in-string 'todo-keyword item))))
|
||
|
|
(propertize keyword 'face (org-get-todo-face keyword)))
|
||
|
|
:header-form (concat "To-do: " key))
|
||
|
|
|
||
|
|
(org-super-agenda--def-auto-group dir-name "their parent heading"
|
||
|
|
:key-form (-when-let* ((marker (org-super-agenda--get-marker item))
|
||
|
|
(file-path (->> marker marker-buffer buffer-file-name))
|
||
|
|
(directory-name (->> file-path file-name-directory directory-file-name file-name-nondirectory)))
|
||
|
|
(concat "Directory: " directory-name)))
|
||
|
|
|
||
|
|
(org-super-agenda--def-auto-group outline-path "their outline paths"
|
||
|
|
:key-form (org-super-agenda--when-with-marker-buffer (org-super-agenda--get-marker item)
|
||
|
|
(s-join "/" (org-get-outline-path))))
|
||
|
|
|
||
|
|
(org-super-agenda--def-auto-group parent "their parent heading"
|
||
|
|
:key-form (org-super-agenda--when-with-marker-buffer (org-super-agenda--get-marker item)
|
||
|
|
(when (org-up-heading-safe)
|
||
|
|
(org-get-heading 'notags 'notodo))))
|
||
|
|
|
||
|
|
;;;;; Dispatchers
|
||
|
|
|
||
|
|
(defun org-super-agenda--get-selector-fn (selector)
|
||
|
|
"Return function for SELECTOR, or nil if special selector.
|
||
|
|
Raise error if invalid selector."
|
||
|
|
(cond
|
||
|
|
((cl-member selector org-super-agenda-special-selectors)
|
||
|
|
;; Special selector, so no associated function; return nil
|
||
|
|
nil)
|
||
|
|
;; Valid selector: return function
|
||
|
|
((plist-get org-super-agenda-group-types selector))
|
||
|
|
((eq selector :habit)
|
||
|
|
;; :habit selector used but `org-habit' not loaded
|
||
|
|
(user-error "Please `require' the `org-habit' library to use the :habit selector"))
|
||
|
|
;; Invalid selector: raise error
|
||
|
|
((user-error "Invalid org-super-agenda-groups selector: %s" selector))))
|
||
|
|
|
||
|
|
(defun org-super-agenda--group-dispatch (items group)
|
||
|
|
"Group ITEMS with the appropriate grouping functions for GROUP.
|
||
|
|
Grouping functions are listed in `org-super-agenda-group-types', which
|
||
|
|
see."
|
||
|
|
(cl-loop for (selector args) on group by 'cddr ; plist access
|
||
|
|
for fn = (org-super-agenda--get-selector-fn selector)
|
||
|
|
;; This double "when fn" is an ugly hack, but it lets us
|
||
|
|
;; use the destructuring-bind; otherwise we'd have to put
|
||
|
|
;; all the collection logic in a progn, or do the
|
||
|
|
;; destructuring ourselves, which would be uglier.
|
||
|
|
when fn
|
||
|
|
for (auto-section-name non-matching matching) = (funcall fn items args)
|
||
|
|
when fn
|
||
|
|
;; This is the implicit OR
|
||
|
|
append matching into all-matches
|
||
|
|
and collect auto-section-name into names
|
||
|
|
and do (setq items non-matching)
|
||
|
|
for name = (if (stringp (car names))
|
||
|
|
(s-join " and " (-non-nil names))
|
||
|
|
;; Probably an :auto-group
|
||
|
|
(car names))
|
||
|
|
finally return (list name items all-matches)))
|
||
|
|
|
||
|
|
;; TODO: This works, but it seems inelegant to basically copy the
|
||
|
|
;; group-dispatch function. A more pure-functional approach might be
|
||
|
|
;; more DRY, but that would preclude using the loop macro, and might
|
||
|
|
;; be slower. Decisions, decisions...
|
||
|
|
|
||
|
|
(defun org-super-agenda--group-dispatch-and (items group)
|
||
|
|
"Group ITEMS that match all selectors in GROUP."
|
||
|
|
;; Used for the `:and' selector.
|
||
|
|
(cl-loop with final-non-matches with final-matches
|
||
|
|
with all-items = items ; Save for later
|
||
|
|
for (selector args) on group by 'cddr ; plist access
|
||
|
|
for fn = (org-super-agenda--get-selector-fn selector)
|
||
|
|
;; This double "when fn" is an ugly hack, but it lets us
|
||
|
|
;; use the destructuring-bind; otherwise we'd have to put
|
||
|
|
;; all the collection logic in a progn, or do the
|
||
|
|
;; destructuring ourselves, which would be uglier.
|
||
|
|
when fn
|
||
|
|
for (auto-section-name _ matching) = (funcall fn items args)
|
||
|
|
when fn
|
||
|
|
collect matching into all-matches
|
||
|
|
and collect auto-section-name into names
|
||
|
|
|
||
|
|
;; Now for the AND
|
||
|
|
finally do (setq final-matches (cl-reduce 'seq-intersection all-matches))
|
||
|
|
finally do (setq final-non-matches (seq-difference all-items final-matches))
|
||
|
|
finally return (list (s-join " AND " (-non-nil names))
|
||
|
|
final-non-matches
|
||
|
|
final-matches)))
|
||
|
|
(setq org-super-agenda-group-types (plist-put org-super-agenda-group-types
|
||
|
|
:and 'org-super-agenda--group-dispatch-and))
|
||
|
|
|
||
|
|
(defun org-super-agenda--group-dispatch-not (items group)
|
||
|
|
"Group ITEMS that match no selectors in GROUP."
|
||
|
|
;; Used for the `:not' selector.
|
||
|
|
;; I think all I need to do is re-dispatch and reverse the results
|
||
|
|
(-let (((name non-matching matching) (org-super-agenda--group-dispatch items group)))
|
||
|
|
(list name matching non-matching)))
|
||
|
|
(setq org-super-agenda-group-types (plist-put org-super-agenda-group-types
|
||
|
|
:not 'org-super-agenda--group-dispatch-not))
|
||
|
|
|
||
|
|
(cl-defun org-super-agenda--group-dispatch-take (items (n &rest group))
|
||
|
|
"Take N ITEMS that match selectors in GROUP.
|
||
|
|
If N is positive, take the first N items, otherwise take the last N items.
|
||
|
|
Note: the ordering of entries is not guaranteed to be preserved, so this may
|
||
|
|
not always show the expected results."
|
||
|
|
(-let* (((name non-matching matching) (org-super-agenda--group-dispatch items group))
|
||
|
|
(take-fn (if (cl-minusp n) #'-take-last #'-take))
|
||
|
|
(placement (if (cl-minusp n) "Last" "First"))
|
||
|
|
(name (format "%s %d %s" placement (abs n) name)))
|
||
|
|
(list name non-matching (funcall take-fn (abs n) matching))))
|
||
|
|
(setq org-super-agenda-group-types (plist-put org-super-agenda-group-types
|
||
|
|
:take 'org-super-agenda--group-dispatch-take))
|
||
|
|
|
||
|
|
(defun org-super-agenda--group-dispatch-discard (items group)
|
||
|
|
"Discard ITEMS that match GROUP.
|
||
|
|
Any groups processed after this will not see these items."
|
||
|
|
(cl-loop for (selector args) on group by 'cddr ; plist access
|
||
|
|
for fn = (org-super-agenda--get-selector-fn selector)
|
||
|
|
;; This double "when fn" is an ugly hack, but it lets us
|
||
|
|
;; use the destructuring-bind; otherwise we'd have to put
|
||
|
|
;; all the collection logic in a progn, or do the
|
||
|
|
;; destructuring ourselves, which would be uglier.
|
||
|
|
when fn
|
||
|
|
for (auto-section-name non-matching matching) = (funcall fn items args)
|
||
|
|
when fn
|
||
|
|
;; This is the implicit OR
|
||
|
|
append matching into all-matches
|
||
|
|
and collect auto-section-name into names
|
||
|
|
and do (setq items non-matching)
|
||
|
|
finally return (list (s-join " and " (-non-nil names))
|
||
|
|
items
|
||
|
|
nil)))
|
||
|
|
(setq org-super-agenda-group-types (plist-put org-super-agenda-group-types
|
||
|
|
:discard 'org-super-agenda--group-dispatch-discard))
|
||
|
|
|
||
|
|
;;;;; Transformers
|
||
|
|
|
||
|
|
(defun org-super-agenda--transform-groups (groups)
|
||
|
|
"Transform GROUPS according to `org-super-agenda-group-transformers'."
|
||
|
|
(cl-loop for group in groups
|
||
|
|
for fn = (plist-get org-super-agenda-group-transformers (car group))
|
||
|
|
if fn
|
||
|
|
do (setq group (funcall fn (cadr group)))
|
||
|
|
and append group
|
||
|
|
else collect group))
|
||
|
|
|
||
|
|
(defun org-super-agenda--transform-group-order (groups)
|
||
|
|
"Return GROUPS with their order set.
|
||
|
|
GROUPS is a list of groups, but the first element of the list is
|
||
|
|
actually the ORDER for the groups."
|
||
|
|
(cl-loop with order = (pop groups)
|
||
|
|
for group in groups
|
||
|
|
collect (plist-put group :order order)))
|
||
|
|
(setq org-super-agenda-group-transformers (plist-put org-super-agenda-group-transformers
|
||
|
|
:order-multi 'org-super-agenda--transform-group-order))
|
||
|
|
|
||
|
|
;;;; Filters
|
||
|
|
|
||
|
|
(defun org-super-agenda--filter-finalize-entries (string)
|
||
|
|
"Filter STRING through `org-super-agenda--group-items'.
|
||
|
|
STRING should be that returned by `org-agenda-finalize-entries'"
|
||
|
|
(--> string
|
||
|
|
(split-string it "\n" 'omit-nulls)
|
||
|
|
org-super-agenda--group-items
|
||
|
|
(-remove #'s-blank-str? it)
|
||
|
|
(s-join "\n" it)
|
||
|
|
(concat it (cl-etypecase org-super-agenda-final-group-separator
|
||
|
|
(character (concat "\n" (make-string (window-width) org-super-agenda-final-group-separator)))
|
||
|
|
(string org-super-agenda-final-group-separator)))))
|
||
|
|
|
||
|
|
(defun org-super-agenda--hide-or-show-groups (&rest _)
|
||
|
|
"Hide/Show any empty/non-empty groups.
|
||
|
|
Should be done after `org-agenda-finalize' or
|
||
|
|
`org-agenda-filter-apply' is called."
|
||
|
|
(cl-labels ((header-p () (org-get-at-bol 'org-super-agenda-header))
|
||
|
|
(grid-p () (not (cl-intersection
|
||
|
|
'(org-agenda-structural-header org-agenda-date-header org-super-agenda-header type)
|
||
|
|
(text-properties-at (point-at-bol)))))
|
||
|
|
(group-item-visible-p () (and (org-get-at-bol 'type) (not (org-get-at-bol 'invisible))))
|
||
|
|
(next-header
|
||
|
|
() (let ((hide-p t) header grid-end)
|
||
|
|
(while (not (or (bobp) header))
|
||
|
|
(cond ((header-p)
|
||
|
|
(setq header (list (1- (or (previous-single-property-change
|
||
|
|
(point-at-eol) 'org-super-agenda-header)
|
||
|
|
(1+ (point-min))))
|
||
|
|
(or grid-end (point-at-eol))
|
||
|
|
hide-p)))
|
||
|
|
((group-item-visible-p)
|
||
|
|
(setq hide-p nil))
|
||
|
|
((and (grid-p) (not grid-end))
|
||
|
|
(setq grid-end (point-at-eol))))
|
||
|
|
(beginning-of-line 0))
|
||
|
|
header))
|
||
|
|
(hide-or-show-header
|
||
|
|
(header) (when header
|
||
|
|
(cl-loop
|
||
|
|
with (start end hide-p) = header
|
||
|
|
with props = '(invisible org-filtered org-filter-type org-super-agenda-filtered)
|
||
|
|
initially do (goto-char end)
|
||
|
|
while (and start (> (point) start))
|
||
|
|
do (when (or (grid-p) (header-p))
|
||
|
|
(let ((beg (1- (point-at-bol)))
|
||
|
|
(end (point-at-eol)))
|
||
|
|
(if hide-p
|
||
|
|
(add-text-properties beg end props)
|
||
|
|
(remove-text-properties beg end props))))
|
||
|
|
(beginning-of-line 0)))))
|
||
|
|
(let ((inhibit-read-only t))
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-max))
|
||
|
|
(beginning-of-line 0)
|
||
|
|
(while (not (bobp))
|
||
|
|
(hide-or-show-header (next-header)))))))
|
||
|
|
|
||
|
|
;;;; Footer
|
||
|
|
|
||
|
|
(provide 'org-super-agenda)
|
||
|
|
|
||
|
|
;;; org-super-agenda.el ends here
|