From 26081cad6db6ec0b5d1f6d67755bd2938aebf4dd Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Wed, 21 Apr 2021 00:29:24 -0400 Subject: [PATCH] REF move super agenda predictate functions to org-x --- etc/conf.org | 105 ++++-------------- local/lib/org-x/org-x.el | 225 +++++++++++++++++++++++++++------------ 2 files changed, 178 insertions(+), 152 deletions(-) diff --git a/etc/conf.org b/etc/conf.org index 3e5f0db..42b33cb 100644 --- a/etc/conf.org +++ b/etc/conf.org @@ -2558,11 +2558,6 @@ By default I want block agendas to sort based on the todo keyword (with NEXT bei :END: These agenda commands are the center of the gtd workflow. #+BEGIN_SRC emacs-lisp -;; (defmacro org-x-mk-skip-function (&rest body) -;; "Return a skip function with BODY. -;; The only thing this function does is `save-excursion' and `widen'." -;; `(lambda () (save-excursion (widen) ,@body))) - (defmacro nd/org-x-mk-super-agenda-pred (&rest body) "Return a predicate function with BODY. This is meant to be used in `org-super-agenda-groups'. For each item, @@ -2615,16 +2610,8 @@ original org entry before executing BODY." (org-agenda-sorting-strategy '(time-up deadline-up scheduled-up category-keep)) (org-agenda-include-diary t) (org-super-agenda-groups - `((:name "Morning routine" - :pred ,(nd/org-x-mk-super-agenda-pred - (org-x-headline-has-property org-x-prop-routine - org-x-prop-routine-morning)) - :order 0) - (:name "Evening routine" - :pred ,(nd/org-x-mk-super-agenda-pred - (org-x-headline-has-property org-x-prop-routine - org-x-prop-routine-evening)) - :order 3) + `((:name "Morning routine" :pred org-x-agenda-is-morning-routine-p :order 0) + (:name "Evening routine" :pred org-x-agenda-is-evening-routine-p :order 3) (:name "Calendar" :order 1 :time-grid t) (:name "Habits" :order 6 :habit t) (:name "Deadlined" :order 4 :deadline t) @@ -2711,30 +2698,19 @@ original org entry before executing BODY." (org-super-agenda-groups `((:name "Past Deadlines" :deadline past) (:name "Future Deadlines" :deadline future) - (:name "Stale Appointments" :pred - ,(nd/org-x-mk-super-agenda-pred - (org-x-is-stale-heading-p))) - (:name "Future Appointments" :pred - ,(nd/org-x-mk-super-agenda-pred - (and (not (org-x-is-todoitem-p))))) - (:name "Tasks" :pred - ,(nd/org-x-mk-super-agenda-pred - (org-x-is-task-p))) - (:name "Toplevel Projects" :pred - ,(nd/org-x-mk-super-agenda-pred - (and (not (org-x-headline-has-parent #'org-x-is-todoitem-p)) - (org-x-is-project-p)))) - (:name "Projects" :pred - ,(nd/org-x-mk-super-agenda-pred - (and (org-x-headline-has-parent #'org-x-is-todoitem-p) - (org-x-is-project-p)))) + (:name "Stale Appointments" :pred org-x-agenda-is-stale-headline-p) + (:name "Future Appointments" + :pred (lambda (a) (not (org-x-agenda-is-todoitem-p a)))) + (:name "Tasks" :pred org-x-agenda-is-task-p) + (:name "Toplevel Projects" :pred org-x-agenda-is-toplevel-project-p) + (:name "Projects" :pred org-x-agenda-is-project-p) (:discard (:anything t)))))))) ("P" "Periodical View" ((tags ,(nd/org-x-mk-match-string - org-x-tag-no-agenda - org-x-tag-refile) - ((org-agenda-overriding-header "Iterator Status") + ((org-agenda-overriding-header "Periodical Status") (org-agenda-skip-function #'org-x-periodical-skip-function) (org-agenda-sorting-strategy '(category-keep)) (org-super-agenda-groups @@ -2780,45 +2756,18 @@ original org entry before executing BODY." - org-x-tag-refile - org-x-tag-incubated) ((org-agenda-overriding-header "Critical Errors") - (org-agenda-skip-function #'org-x-critical-error-skip-function) + (org-agenda-skip-function #'org-x-error-skip-function) (org-super-agenda-groups - `((:name "Discontinuous Projects" :pred - ,(nd/org-x-mk-super-agenda-pred - (and (org-x-is-todoitem-p) - (org-x-has-discontinuous-parent)))) - ;; TODO this is redundant, only thing this checks is - ;; project headers - (:name "Done Unclosed" :pred - ,(nd/org-x-mk-super-agenda-pred - (let ((keyword (org-x-is-todoitem-p))) - (and keyword - (member keyword org-done-keywords) - (not (org-x-is-closed-heading-p)))))) - (:name "Undone Closed" :pred - ,(nd/org-x-mk-super-agenda-pred - (let ((keyword (org-x-is-todoitem-p))) - (and keyword - (not (member keyword org-done-keywords)) - (org-x-is-closed-heading-p))))) - (:name "Missing Creation Timestamp" :pred - ,(nd/org-x-mk-super-agenda-pred - ;; TODO extend this to non-todoitems - (-when-let (kw (org-x-is-task-p)) - (and - (not (member kw org-done-keywords)) - (not (org-x-is-created-heading-p)))))) - (:name "Missing Archive Target (iterators)" :pred - ,(nd/org-x-mk-super-agenda-pred - (and (org-x-headline-has-property - org-x-prop-parent-type org-x-prop-parent-type-iterator) - (org-x-headline-has-property "ARCHIVE" nil)))) - (:name "Future Creation Timestamp" :pred - ,(nd/org-x-mk-super-agenda-pred - ;; TODO extend this to non-todoitems - (-when-let (kw (org-x-is-task-p)) - (and - (not (member kw org-done-keywords)) - (org-x-is-created-in-future))))) + `((:name "Discontinuous Projects" :pred org-x-agenda-error-is-discontinous-p) + ;; TODO this is redundant, only thing this checks is project headers + (:name "Done Unclosed" :pred org-x-agenda-error-is-done-unclosed-p) + (:name "Undone Closed" :pred org-x-agenda-error-is-undone-closed-p) + (:name "Missing Creation Timestamp" + :pred org-x-agenda-error-is-missing-creation-timestamp-p) + (:name "Missing Archive Target (iterators)" + :pred org-x-agenda-error-is-missing-archive-target-p) + (:name "Future Creation Timestamp" + :pred org-x-agenda-error-has-missing-creation-timestamp-p) (:discard (:anything t)))))))) ("A" @@ -2829,17 +2778,9 @@ original org entry before executing BODY." (org-agenda-skip-function #'org-x-skip-function-archivable) (org-agenda-sorting-strategy '(category-keep)) (org-super-agenda-groups - `((:name "Atomic Tasks" :pred - ,(nd/org-x-mk-super-agenda-pred - (org-x-is-atomic-task-p))) - (:name "Toplevel Projects" :pred - ,(nd/org-x-mk-super-agenda-pred - (and (not (org-x-headline-has-parent #'org-x-is-todoitem-p)) - (org-x-is-project-p)))) - (:name "Projects" :pred - ,(nd/org-x-mk-super-agenda-pred - (and (org-x-headline-has-parent #'org-x-is-todoitem-p) - (org-x-is-project-p)))) + `((:name "Atomic Tasks" :pred org-x-agenda-is-atomic-task-p) + (:name "Toplevel Projects" :pred org-x-agenda-is-toplevel-project-p) + (:name "Projects" :pred org-x-agenda-is-project-p) (:name "Appointments" :anything))))))))) #+END_SRC ** gtd next generation diff --git a/local/lib/org-x/org-x.el b/local/lib/org-x/org-x.el index 7e6780f..b016d6a 100644 --- a/local/lib/org-x/org-x.el +++ b/local/lib/org-x/org-x.el @@ -398,33 +398,59 @@ no timestamp is found." "Return todo keyword of current headline's if it exists." (org-x-headline-has-parent #'org-x-is-todoitem-p)) -(defun org-x-is-project-p () - "Return todo keyword if heading has todoitem children." - (-when-let (kw (org-x-is-todoitem-p)) - (when (org-x-headline-has-task-children) - kw))) +(defmacro org-x-return-keyword-when (keyword when-form) + "Return keyword under headline if WHEN-FORM is t. +If KEYWORD is non-nil, don't look up the keyword but instead +return KEYWORD if WHEN-FORM is t." + (declare (indent 1)) + (let ((kw-form (if keyword keyword '(org-x-is-todoitem-p)))) + `(-when-let (kw ,kw-form) + (when ,when-form + kw)))) -(defun org-x-is-task-p () - "Return todo keyword if heading has no todoitem children." - (-when-let (kw (org-x-is-todoitem-p)) - (unless (org-x-headline-has-task-children) - kw))) +(defmacro org-x-is-project-p (&optional keyword) + "Return todo keyword if heading has todoitem children. -(defun org-x-is-project-task-p () - "Return todo keyword if heading has todoitem parents." - (-when-let (kw (org-x-is-task-p)) - (when (org-x-headline-has-task-parent) - kw))) +If KEYWORD is provided, skip the keyword lookup part of this +function and assume the current headline has KEYWORD. This is +useful when the keyword is already known from a previous test." + `(org-x-return-keyword-when ,keyword + (org-x-headline-has-task-children))) -(defun org-x-is-atomic-task-p () - "Return todo keyword if heading has no todoitem parents or children." - (-when-let (kw (org-x-is-task-p)) - (unless (org-x-headline-has-task-parent) - kw))) +(defmacro org-x-is-task-p (&optional keyword) + "Return todo keyword if heading has no todoitem children. -(defun org-x-task-status () - "Return the status of the headline under point." - (-when-let (kw (org-x-is-task-p)) +If KEYWORD is provided, skip the keyword lookup part of this +function and assume the current headline has KEYWORD. This is +useful when the keyword is already known from a previous test." + `(org-x-return-keyword-when ,keyword + (not (org-x-headline-has-task-children)))) + +(defmacro org-x-is-project-task-p (&optional keyword) + "Return todo keyword if heading has todoitem parents. + +If KEYWORD is provided, skip the keyword lookup part of this +function and assume the current headline has KEYWORD. This is +useful when the keyword is already known from a previous test." + `(org-x-return-keyword-when (org-x-is-task-p ,keyword) + (org-x-headline-has-task-parent))) + +(defmacro org-x-is-atomic-task-p (&optional keyword) + "Return todo keyword if heading has no todoitem parents or children. + +If KEYWORD is provided, skip the keyword lookup part of this +function and assume the current headline has KEYWORD. This is +useful when the keyword is already known from a previous test." + `(org-x-return-keyword-when (org-x-is-task-p ,keyword) + (not (org-x-headline-has-task-parent)))) + +(defun org-x-task-status (&optional keyword) + "Return the status of the headline under point. + +If KEYWORD is provided, skip the keyword lookup part of this +function and assume the current headline has KEYWORD. This is +useful when the keyword is already known from a previous test." + (-when-let (kw (or keyword (org-x-is-task-p))) (cond ((org-x-is-archivable-heading-p) :archivable) @@ -438,7 +464,8 @@ no timestamp is found." :undone-closed) ((member kw org-x-done-keywords) :complete) - (t :active)))) + (t + :active)))) ;; property testing @@ -795,13 +822,12 @@ function will simply return the point of the next headline." (defun org-x-skip-headings-with-tags (pos-tags-list &optional neg-tags-list) "Skip headings that have tags in POS-TAGS-LIST and not in NEG-TAGS-LIST." - (save-restriction - (widen) - (let ((heading-tags (org-get-tags))) - (if (and (or (not pos-tags-list) - (cl-intersection pos-tags-list heading-tags :test 'equal)) - (not (cl-intersection neg-tags-list heading-tags :test 'equal))) - (org-x-skip-heading))))) + (org-with-wide-buffer + (-when-let (heading-tags (org-get-tags)) + (when (and (or (not pos-tags-list) + (-intersection pos-tags-list heading-tags)) + (not (-intersection neg-tags-list heading-tags))) + (org-x-skip-heading))))) ;;; INTERACTIVE FUNCTIONS @@ -1307,43 +1333,35 @@ If ARG is non-nil use long timestamp format." ;; skip functions (all of them) -(defmacro org-x-mk-skip-function (&rest body) - "Return a skip function with BODY. -The only thing this function does is `save-excursion' and `widen'." - `(lambda () (save-excursion (widen) ,@body))) - (defun org-x-calendar-skip-function () (org-x-skip-headings-with-tags (list org-x-tag-no-agenda org-x-tag-maybe org-x-tag-refile))) (defun org-x-task-skip-function () - (save-excursion - (widen) - (let ((keyword (org-x-is-todoitem-p))) + (org-with-wide-buffer + (let ((keyword (org-get-todo-state))) ;; currently we assume that periodicals have no TODOs (cond ;; skip over held/canc projects ((and (member keyword org-x-project-skip-todostates) - (org-x-is-project-p)) + (org-x-is-project-p keyword)) (org-x-skip-subtree)) ;; skip iterators ((org-x-is-iterator-heading-p) (org-x-skip-heading)) ;; skip project headings - ((org-x-is-project-p) + ((org-x-is-project-p keyword) (org-x-skip-heading)) ;; skip canceled tasks - ((and (equal keyword org-x-kw-canc) - (org-x-is-task-p)) + ((and (equal keyword org-x-kw-canc) (org-x-is-task-p keyword)) (org-x-skip-heading)) ;; skip habits ((org-x-is-habit-heading-p) (org-x-skip-heading)))))) (defun org-x-project-skip-function () - (save-excursion - (widen) + (org-with-wide-buffer (cond ((or (org-x-is-iterator-heading-p) (org-x-is-periodical-heading-p)) (org-x-skip-subtree)) @@ -1351,46 +1369,44 @@ The only thing this function does is `save-excursion' and `widen'." (org-x-skip-heading))))) (defun org-x-incubator-skip-function () - (save-excursion - (widen) - (let ((keyword (org-x-is-todoitem-p))) + (org-with-wide-buffer + (let ((keyword (org-get-todo-state))) (cond ;; skip done/canc projects - ((and (member keyword org-done-keywords) - (org-x-is-project-p)) + ((and (member keyword org-done-keywords) (org-x-is-project-p keyword)) (org-x-skip-subtree)) ;; skip project tasks - ((and keyword (org-x-is-project-task-p)) + ((org-x-is-project-task-p keyword) (org-x-skip-heading)) ;; skip done/canc tasks ((member keyword org-done-keywords) (org-x-skip-heading)) ;; skip non-tasks if they don't have a timestamp - ((and (not keyword) - (not (org-x-is-timestamped-heading-p))) + ((not (or keyword (org-x-is-timestamped-heading-p))) (org-x-skip-heading)))))) (defun org-x-periodical-skip-function () - (save-excursion - (widen) + (org-with-wide-buffer (cond ((not (org-x-is-periodical-heading-p)) (org-x-skip-heading)) ((org-x-headline-has-parent #'org-x-is-periodical-heading-p) + ;; TODO this can be made faster by skipping to the next headline one + ;; level up (org-x-skip-heading))))) (defun org-x-iterator-skip-function () - (save-excursion - (widen) + (org-with-wide-buffer (cond ((not (org-x-is-iterator-heading-p)) (org-x-skip-heading)) ((org-x-headline-has-parent #'org-x-is-iterator-heading-p) + ;; TODO this can be made faster by skipping to the next headline one + ;; level up (org-x-skip-heading))))) -(defun org-x-critical-error-skip-function () - (save-excursion - (widen) +(defun org-x-error-skip-function () + (org-with-wide-buffer (cond ((org-x-is-habit-heading-p) (org-x-skip-heading)) @@ -1398,32 +1414,101 @@ The only thing this function does is `save-excursion' and `widen'." (org-x-skip-subtree))))) (defun org-x-skip-function-archivable () - ;; (org-x-mk-skip-function - (save-excursion - (widen) + (org-with-wide-buffer (let ((keyword (org-get-todo-state))) (cond ;; skip all non-archivable projects - ((and keyword - ;; TODO gets the keyword again - (org-x-is-project-p) + ((and (org-x-is-project-p keyword) (not (eq :archivable (org-x-get-project-status)))) (org-x-skip-subtree)) ;; skip all incubator tasks ((org-x-headline-has-tag-p org-x-tag-incubated) (org-x-skip-heading)) ;; skip all project tasks - ((and keyword (org-x-is-project-task-p)) + ((and (org-x-is-project-task-p keyword)) (org-x-skip-heading)) ;; skip all tasks not marked done or archivable - ((and keyword - ;; TODO gets the keyword again - (org-x-is-task-p) + ((and (org-x-is-task-p keyword) (not (eq :archivable (org-x-task-status)))) (org-x-skip-heading)) ;; skip all non-todoitems that are not stale ((and (not keyword) (not (org-x-is-stale-heading-p))) (org-x-skip-heading)))))) +;; super agenda predicate functions + +(defmacro org-x-with-raw-headline (agenda-line &rest body) + (declare (indent 1)) + `(-when-let (marker (get-text-property 1 'org-marker ,agenda-line)) + (with-current-buffer (marker-buffer marker) + (goto-char marker) + ,@body))) + +(defun org-x-agenda-is-morning-routine-p (agenda-line) + (org-x-with-raw-headline agenda-line + (org-x-headline-has-property org-x-prop-routine org-x-prop-routine-morning))) + +(defun org-x-agenda-is-evening-routine-p (agenda-line) + (org-x-with-raw-headline agenda-line + (org-x-headline-has-property org-x-prop-routine org-x-prop-routine-evening))) + +(defun org-x-agenda-is-todoitem-p (agenda-line) + (org-x-with-raw-headline agenda-line + (org-x-is-todoitem-p))) + +(defun org-x-agenda-is-stale-headline-p (agenda-line) + (org-x-with-raw-headline agenda-line + (org-x-is-stale-heading-p))) + +(defun org-x-agenda-is-task-p (agenda-line) + (org-x-with-raw-headline agenda-line + (org-x-is-task-p))) + +(defun org-x-agenda-is-atomic-task-p (agenda-line) + (org-x-with-raw-headline agenda-line + (org-x-is-atomic-task-p))) + +(defun org-x-agenda-is-toplevel-project-p (agenda-line) + (org-x-with-raw-headline agenda-line + (and (not (org-x-headline-has-task-parent)) (org-x-is-project-p)))) + +(defun org-x-agenda-is-project-p (agenda-line) + (org-x-with-raw-headline agenda-line + (org-x-is-project-p))) + +(defun org-x-agenda-error-is-discontinous-p (agenda-line) + (org-x-with-raw-headline agenda-line + (and (org-x-is-todoitem-p) (org-x-has-discontinuous-parent)))) + +(defun org-x-agenda-error-is-done-unclosed-p (agenda-line) + (org-x-with-raw-headline agenda-line + (let ((keyword (org-get-todo-state))) + (and (member keyword org-x-done-keywords) + (not (org-x-is-closed-heading-p)))))) + +(defun org-x-agenda-error-is-undone-closed-p (agenda-line) + (org-x-with-raw-headline agenda-line + (-when-let (keyword (org-get-todo-state)) + (and (not (member keyword org-x-done-keywords)) + (org-x-is-closed-heading-p))))) + +(defun org-x-agenda-error-is-missing-creation-timestamp-p (agenda-line) + (org-x-with-raw-headline agenda-line + (-when-let (kw (org-x-is-task-p)) + (not (or (member kw org-x-done-keywords) + (org-x-is-created-heading-p)))))) + +(defun org-x-agenda-error-is-missing-archive-target-p (agenda-line) + (org-x-with-raw-headline agenda-line + (and (org-x-headline-has-property org-x-prop-parent-type + org-x-prop-parent-type-iterator) + (org-x-headline-has-property "ARCHIVE" nil)))) + +(defun org-x-agenda-error-has-missing-creation-timestamp-p (agenda-line) + (org-x-with-raw-headline agenda-line + (-when-let (kw (org-x-is-task-p)) + (and (not (member kw org-x-done-keywords)) + (org-x-is-created-in-future))))) + (provide 'org-x) ;;; org-x.el ends here