REF move super agenda predictate functions to org-x

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"
+        `((:name "Morning routine" :pred org-x-agenda-is-morning-routine-p :order 0)
-                 :pred ,(nd/org-x-mk-super-agenda-pred
+          (:name "Evening routine" :pred org-x-agenda-is-evening-routine-p :order 3)
-                         (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 "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
+          (:name "Stale Appointments" :pred org-x-agenda-is-stale-headline-p)
-                 ,(nd/org-x-mk-super-agenda-pred
+          (:name "Future Appointments"
-                   (org-x-is-stale-heading-p)))
+                 :pred (lambda (a) (not (org-x-agenda-is-todoitem-p a))))
-          (:name "Future Appointments" :pred
+          (:name "Tasks" :pred org-x-agenda-is-task-p)
-                 ,(nd/org-x-mk-super-agenda-pred
+          (:name "Toplevel Projects" :pred org-x-agenda-is-toplevel-project-p)
-                   (and (not (org-x-is-todoitem-p)))))
+          (:name "Projects" :pred org-x-agenda-is-project-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))))
           (: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
+        `((:name "Discontinuous Projects" :pred org-x-agenda-error-is-discontinous-p)
-                 ,(nd/org-x-mk-super-agenda-pred
+          ;; TODO this is redundant, only thing this checks is project headers
-                   (and (org-x-is-todoitem-p)
+          (:name "Done Unclosed" :pred org-x-agenda-error-is-done-unclosed-p)
-                        (org-x-has-discontinuous-parent))))
+          (:name "Undone Closed" :pred org-x-agenda-error-is-undone-closed-p)
-          ;; TODO this is redundant, only thing this checks is
+          (:name "Missing Creation Timestamp"
-          ;; project headers
+                 :pred org-x-agenda-error-is-missing-creation-timestamp-p)
-          (:name "Done Unclosed" :pred
+          (:name "Missing Archive Target (iterators)"
-                 ,(nd/org-x-mk-super-agenda-pred
+                 :pred org-x-agenda-error-is-missing-archive-target-p)
-                   (let ((keyword (org-x-is-todoitem-p)))
+          (:name "Future Creation Timestamp"
-                     (and keyword
+                 :pred org-x-agenda-error-has-missing-creation-timestamp-p)
-                          (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)))))
           (: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
+        `((:name "Atomic Tasks" :pred org-x-agenda-is-atomic-task-p)
-                 ,(nd/org-x-mk-super-agenda-pred
+          (:name "Toplevel Projects" :pred org-x-agenda-is-toplevel-project-p)
-                   (org-x-is-atomic-task-p)))
+          (:name "Projects" :pred org-x-agenda-is-project-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 "Appointments" :anything)))))))))
 #+END_SRC
 ** gtd next generation

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 ()
+(defmacro org-x-return-keyword-when (keyword when-form)
-  "Return todo keyword if heading has todoitem children."
+  "Return keyword under headline if WHEN-FORM is t.
-  (-when-let (kw (org-x-is-todoitem-p))
+If KEYWORD is non-nil, don't look up the keyword but instead
-    (when (org-x-headline-has-task-children)
+return KEYWORD if WHEN-FORM is t."
-      kw)))
+  (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 ()
+(defmacro org-x-is-project-p (&optional keyword)
-  "Return todo keyword if heading has no todoitem children."
+  "Return todo keyword if heading has todoitem children.
-  (-when-let (kw (org-x-is-todoitem-p))
-    (unless (org-x-headline-has-task-children)
-      kw)))
 
-(defun org-x-is-project-task-p ()
+If KEYWORD is provided, skip the keyword lookup part of this
-  "Return todo keyword if heading has todoitem parents."
+function and assume the current headline has KEYWORD. This is
-  (-when-let (kw (org-x-is-task-p))
+useful when the keyword is already known from a previous test."
-    (when (org-x-headline-has-task-parent)
+  `(org-x-return-keyword-when ,keyword
-      kw)))
+     (org-x-headline-has-task-children)))
 
-(defun org-x-is-atomic-task-p ()
+(defmacro org-x-is-task-p (&optional keyword)
-  "Return todo keyword if heading has no todoitem parents or children."
+  "Return todo keyword if heading has no todoitem children.
-  (-when-let (kw (org-x-is-task-p))
-    (unless (org-x-headline-has-task-parent)
-      kw)))
 
-(defun org-x-task-status ()
+If KEYWORD is provided, skip the keyword lookup part of this
-  "Return the status of the headline under point."
+function and assume the current headline has KEYWORD. This is
-  (-when-let (kw (org-x-is-task-p))
+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
+  (org-with-wide-buffer
-    (widen)
+    (-when-let (heading-tags (org-get-tags))
-    (let ((heading-tags (org-get-tags)))
+      (when (and (or (not pos-tags-list)
-      (if (and (or (not pos-tags-list)
+                     (-intersection pos-tags-list heading-tags))
-                   (cl-intersection pos-tags-list heading-tags :test 'equal))
+                 (not (-intersection neg-tags-list heading-tags)))
-               (not (cl-intersection neg-tags-list heading-tags :test 'equal)))
+        (org-x-skip-heading)))))
-          (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
+  (org-with-wide-buffer
-    (widen)
+    (let ((keyword (org-get-todo-state)))
-    (let ((keyword (org-x-is-todoitem-p)))
       ;; 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)
+       ((and (equal keyword org-x-kw-canc) (org-x-is-task-p keyword))
-             (org-x-is-task-p))
         (org-x-skip-heading))
        ;; skip habits
        ((org-x-is-habit-heading-p)
         (org-x-skip-heading))))))
   
 (defun org-x-project-skip-function ()
-  (save-excursion
+  (org-with-wide-buffer
-    (widen)
     (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
+  (org-with-wide-buffer
-    (widen)
+    (let ((keyword (org-get-todo-state)))
-    (let ((keyword (org-x-is-todoitem-p)))
       (cond
        ;; skip done/canc projects
-       ((and (member keyword org-done-keywords)
+       ((and (member keyword org-done-keywords) (org-x-is-project-p keyword))
-             (org-x-is-project-p))
         (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 (or keyword (org-x-is-timestamped-heading-p)))
-             (not (org-x-is-timestamped-heading-p)))
         (org-x-skip-heading))))))
 
 (defun org-x-periodical-skip-function ()
-  (save-excursion
+  (org-with-wide-buffer
-    (widen)
     (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
+  (org-with-wide-buffer
-    (widen)
     (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 ()
+(defun org-x-error-skip-function ()
-  (save-excursion
+  (org-with-wide-buffer
-    (widen)
     (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
+  (org-with-wide-buffer
-  (save-excursion
-    (widen)
     (let ((keyword (org-get-todo-state)))
       (cond
        ;; skip all non-archivable projects
-       ((and keyword
+       ((and (org-x-is-project-p keyword)
-             ;; TODO gets the keyword again
-             (org-x-is-project-p)
              (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
+       ((and (org-x-is-task-p keyword)
-             ;; TODO gets the keyword again
-             (org-x-is-task-p)
              (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