ENH move iterator/periodical functions to org-x
This commit is contained in:
parent
c7111e24b6
commit
fdde5fefc8
130
etc/conf.org
130
etc/conf.org
|
|
@ -3013,132 +3013,6 @@ These are functions and variables exclusively for agenda block manipulation with
|
|||
|
||||
(defconst org-clone-peri-statuscodes '(:uninit :empt :actv :unscheduled))
|
||||
#+END_SRC
|
||||
***** task helper functions
|
||||
These are the building blocks for skip functions.
|
||||
****** repeater testing
|
||||
:PROPERTIES:
|
||||
:ID: 44657755-b47e-4b2a-85c4-5f82d830618a
|
||||
:END:
|
||||
Iterators and periodicals are tested similarly to projects in that they have statuscodes.
|
||||
#+BEGIN_SRC emacs-lisp
|
||||
(defun org-clone-get-iterator-project-status (kw)
|
||||
(cond
|
||||
((or (org-x-is-scheduled-heading-p)
|
||||
(member kw org-x-project-invalid-todostates)) :project-error)
|
||||
|
||||
;; canceled tasks add nothing
|
||||
((equal kw "CANC") :empt)
|
||||
|
||||
;;
|
||||
;; these require descending into the project subtasks
|
||||
;;
|
||||
|
||||
;; done projects either add nothing (empty) or are not actually
|
||||
;; done (project error)
|
||||
((equal kw "DONE")
|
||||
(org-x-descend-into-project
|
||||
'(:empt :project-error)
|
||||
'((:unscheduled . 1)
|
||||
(:actv . 1))
|
||||
(lambda (k)
|
||||
(if (member k org-done-keywords) 0 1))
|
||||
#'org-clone-get-iterator-project-status))
|
||||
|
||||
;; project with TODO states could be basically any status
|
||||
((equal kw "TODO")
|
||||
(org-x-descend-into-project
|
||||
'(:unscheduled :empt :actv)
|
||||
'(:project-error . 0)
|
||||
(lambda (k)
|
||||
(let ((ts (org-x-is-scheduled-heading-p)))
|
||||
(cond
|
||||
((not ts) 0)
|
||||
((> org-clone-iter-future-time (- ts (float-time))) 1)
|
||||
(t 2))))
|
||||
#'org-clone-get-iterator-project-status))
|
||||
|
||||
(t (error (concat "invalid keyword detected: " kw)))))
|
||||
|
||||
(defun org-clone-get-iterator-status ()
|
||||
"Get the status of an iterator where allowed statuscodes are in list
|
||||
`nd/get-iter-statuscodes.' where latter codes in the list trump
|
||||
earlier ones."
|
||||
(let ((cur-status (first org-clone-iter-statuscodes))
|
||||
(breaker-status (-last-item org-clone-iter-statuscodes))
|
||||
(subtree-end (save-excursion (org-end-of-subtree t)))
|
||||
(prev-point (point)))
|
||||
(save-excursion
|
||||
(outline-next-heading)
|
||||
(while (and (not (eq cur-status breaker-status))
|
||||
(< prev-point (point) subtree-end))
|
||||
(let ((kw (org-x-is-todoitem-p))
|
||||
(new-status))
|
||||
(when kw
|
||||
;; test if project of atomic task
|
||||
;; assume that there are no todoitems above this headline
|
||||
;; to make checking easier
|
||||
(setq
|
||||
new-status
|
||||
(if (org-x-headline-has-children 'org-x-is-todoitem-p)
|
||||
(org-clone-get-iterator-project-status kw)
|
||||
(let ((ts (or (org-x-is-scheduled-heading-p)
|
||||
(org-x-is-deadlined-heading-p))))
|
||||
(cond
|
||||
((member kw org-done-keywords) :empt)
|
||||
((not ts) :unscheduled)
|
||||
((< org-clone-iter-future-time (- ts (float-time))) :actv)
|
||||
(t :empt)))))
|
||||
(when (org-x-compare-statuscodes > new-status cur-status org-clone-iter-statuscodes)
|
||||
(setq cur-status new-status))))
|
||||
(setq prev-point (point))
|
||||
(org-forward-heading-same-level 1 t)))
|
||||
cur-status))
|
||||
|
||||
(defun org-clone-get-periodical-status ()
|
||||
"Get the status of a periodical where allowed statuscodes are in list
|
||||
`nd/get-peri-statuscodes.' where latter codes in the list trump
|
||||
earlier ones."
|
||||
(letrec
|
||||
((max-ts
|
||||
(lambda ()
|
||||
(-some-->
|
||||
(org-ml-parse-this-headline)
|
||||
(org-element-map it 'timestamp #'identity)
|
||||
(--filter
|
||||
(memq (org-element-property :type it) '(active active-range))
|
||||
it)
|
||||
(--map
|
||||
(--> it
|
||||
(org-timestamp-split-range it t)
|
||||
(org-element-property :raw-value it)
|
||||
(org-2ft it))
|
||||
it)
|
||||
(-max it))))
|
||||
(compare
|
||||
(lambda (s1 s2)
|
||||
(if (org-x-compare-statuscodes > s1 s2 org-clone-peri-statuscodes) s1 s2)))
|
||||
(new-status
|
||||
(lambda (ts)
|
||||
(-->
|
||||
ts
|
||||
(cond
|
||||
((not it) :unscheduled)
|
||||
((< org-clone-peri-future-time (- it (float-time))) :actv)
|
||||
(t :empt))
|
||||
(funcall compare it cur-status))))
|
||||
(cur-status (first org-clone-peri-statuscodes))
|
||||
(breaker-status (-last-item org-clone-peri-statuscodes))
|
||||
(subtree-end (save-excursion (org-end-of-subtree t)))
|
||||
(prev-point (point)))
|
||||
(save-excursion
|
||||
(outline-next-heading)
|
||||
(while (and (not (eq cur-status breaker-status))
|
||||
(< prev-point (point) subtree-end))
|
||||
(setq cur-status (->> (funcall max-ts) (funcall new-status)))
|
||||
(setq prev-point (point))
|
||||
(org-forward-heading-same-level 1 t)))
|
||||
cur-status))
|
||||
#+END_SRC
|
||||
**** super agenda
|
||||
:PROPERTIES:
|
||||
:ID: 6bd2a7c9-2104-4b18-9f56-c1581ed86d82
|
||||
|
|
@ -3398,7 +3272,7 @@ original org entry before executing BODY."
|
|||
(org-super-agenda-groups
|
||||
`((:auto-map
|
||||
,(nd/org-x-mk-super-agenda-pred
|
||||
(cl-case (org-clone-get-periodical-status)
|
||||
(cl-case (org-x-get-periodical-status)
|
||||
(:uninit "0. Uninitialized")
|
||||
(:unscheduled "0. Unscheduled")
|
||||
(:empt "1. Empty")
|
||||
|
|
@ -3421,7 +3295,7 @@ original org entry before executing BODY."
|
|||
(org-super-agenda-groups
|
||||
`((:auto-map
|
||||
,(nd/org-x-mk-super-agenda-pred
|
||||
(cl-case (org-clone-get-iterator-status)
|
||||
(cl-case (org-x-get-iterator-status)
|
||||
(:uninit "0. Uninitialized")
|
||||
(:project-error "0. Project Error")
|
||||
(:unscheduled "0. Unscheduled")
|
||||
|
|
|
|||
|
|
@ -269,40 +269,40 @@ compared to REF-TIME. Returns nil if no timestamp is found."
|
|||
|
||||
;; relational testing
|
||||
|
||||
;; ;; TODO this function seems slow
|
||||
;; (defun org-x-headline-has-children (heading-test)
|
||||
;; "Return t if heading has a child for whom HEADING-TEST is t."
|
||||
;; (let ((subtree-end (save-excursion (org-end-of-subtree t)))
|
||||
;; has-children previous-point)
|
||||
;; (save-excursion
|
||||
;; (setq previous-point (point))
|
||||
;; (outline-next-heading)
|
||||
;; (while (and (not has-children)
|
||||
;; (< previous-point (point) subtree-end))
|
||||
;; (when (funcall heading-test)
|
||||
;; (setq has-children t))
|
||||
;; (setq previous-point (point))
|
||||
;; (org-forward-heading-same-level 1 t)))
|
||||
;; has-children))
|
||||
|
||||
(defun org-x-headline-has-children (test-fun)
|
||||
"Return t if heading has a child for whom TEST-FUN is t."
|
||||
;; assume that point is at the beginning of a headline
|
||||
(let* ((level (1+ (org-current-level)))
|
||||
(has-children nil)
|
||||
(cur-level level))
|
||||
;; skip over the current headline
|
||||
(re-search-forward org-outline-regexp-bol nil t)
|
||||
;; TODO this function seems slow
|
||||
(defun org-x-headline-has-children (heading-test)
|
||||
"Return t if heading has a child for whom HEADING-TEST is t."
|
||||
(let ((subtree-end (save-excursion (org-end-of-subtree t)))
|
||||
has-children previous-point)
|
||||
(save-excursion
|
||||
(while (and (<= level cur-level)
|
||||
(re-search-forward org-outline-regexp-bol nil t))
|
||||
;; it's actually more efficient to scan every headline and check its
|
||||
;; level rather than using a regexp to match the target depth
|
||||
(setq cur-level (- (match-end 0) (match-beginning 0) 1))
|
||||
(when (and (= cur-level level) (funcall test-fun))
|
||||
(setq has-children t))))
|
||||
(setq previous-point (point))
|
||||
(outline-next-heading)
|
||||
(while (and (not has-children)
|
||||
(< previous-point (point) subtree-end))
|
||||
(when (funcall heading-test)
|
||||
(setq has-children t))
|
||||
(setq previous-point (point))
|
||||
(org-forward-heading-same-level 1 t)))
|
||||
has-children))
|
||||
|
||||
;; (defun org-x-headline-has-children (test-fun)
|
||||
;; "Return t if heading has a child for whom TEST-FUN is t."
|
||||
;; ;; assume that point is at the beginning of a headline
|
||||
;; (let* ((level (1+ (org-current-level)))
|
||||
;; (has-children nil)
|
||||
;; (cur-level level))
|
||||
;; ;; skip over the current headline
|
||||
;; (re-search-forward org-outline-regexp-bol nil t)
|
||||
;; (save-excursion
|
||||
;; (while (and (<= level cur-level)
|
||||
;; (re-search-forward org-outline-regexp-bol nil t))
|
||||
;; ;; it's actually more efficient to scan every headline and check its
|
||||
;; ;; level rather than using a regexp to match the target depth
|
||||
;; (setq cur-level (- (match-end 0) (match-beginning 0) 1))
|
||||
;; (when (and (= cur-level level) (funcall test-fun))
|
||||
;; (setq has-children t))))
|
||||
;; has-children))
|
||||
|
||||
(defun org-x-headline-has-parent (heading-test)
|
||||
"Return t if heading has parent for whom HEADING-TEST is t."
|
||||
(save-excursion (and (org-up-heading-safe) (funcall heading-test))))
|
||||
|
|
@ -451,6 +451,122 @@ should be this function again)."
|
|||
|
||||
(t (error (concat "invalid keyword detected: " keyword)))))))
|
||||
|
||||
(defun org-x--clone-get-iterator-project-status (kw)
|
||||
(cond
|
||||
((or (org-x-is-scheduled-heading-p)
|
||||
(member kw org-x-project-invalid-todostates)) :project-error)
|
||||
|
||||
;; canceled tasks add nothing
|
||||
((equal kw "CANC") :empt)
|
||||
|
||||
;;
|
||||
;; these require descending into the project subtasks
|
||||
;;
|
||||
|
||||
;; done projects either add nothing (empty) or are not actually
|
||||
;; done (project error)
|
||||
((equal kw "DONE")
|
||||
(org-x-descend-into-project
|
||||
((:empt)
|
||||
(:project-error :unscheduled :actv))
|
||||
(if (member it-kw org-done-keywords) 0 1)
|
||||
#'org-x--clone-get-iterator-project-status))
|
||||
|
||||
;; project with TODO states could be basically any status
|
||||
((equal kw "TODO")
|
||||
(org-x-descend-into-project
|
||||
((:unscheduled :project-error)
|
||||
(:empt)
|
||||
(:actv))
|
||||
(let ((ts (org-x-is-scheduled-heading-p)))
|
||||
(cond
|
||||
((not ts) 0)
|
||||
((> org-clone-iter-future-time (- ts (float-time))) 1)
|
||||
(t 2)))
|
||||
org-x--clone-get-iterator-project-status))
|
||||
|
||||
(t (error (concat "invalid keyword detected: " kw)))))
|
||||
|
||||
(defun org-x-get-iterator-status ()
|
||||
"Get the status of an iterator.
|
||||
Allowed statuscodes are in list `nd/get-iter-statuscodes.' where
|
||||
latter codes in the list trump earlier ones."
|
||||
(let ((cur-status (first org-clone-iter-statuscodes))
|
||||
(breaker-status (-last-item org-clone-iter-statuscodes))
|
||||
(subtree-end (save-excursion (org-end-of-subtree t)))
|
||||
(prev-point (point)))
|
||||
(save-excursion
|
||||
(outline-next-heading)
|
||||
(while (and (not (eq cur-status breaker-status))
|
||||
(< prev-point (point) subtree-end))
|
||||
(let ((kw (org-x-is-todoitem-p))
|
||||
(new-status))
|
||||
(when kw
|
||||
;; test if project of atomic task
|
||||
;; assume that there are no todoitems above this headline
|
||||
;; to make checking easier
|
||||
(setq
|
||||
new-status
|
||||
(if (org-x-headline-has-children 'org-x-is-todoitem-p)
|
||||
(org-x--clone-get-iterator-project-status kw)
|
||||
(let ((ts (or (org-x-is-scheduled-heading-p)
|
||||
(org-x-is-deadlined-heading-p))))
|
||||
(cond
|
||||
((member kw org-done-keywords) :empt)
|
||||
((not ts) :unscheduled)
|
||||
((< org-clone-iter-future-time (- ts (float-time))) :actv)
|
||||
(t :empt)))))
|
||||
(when (org-x-compare-statuscodes > new-status cur-status org-clone-iter-statuscodes)
|
||||
(setq cur-status new-status))))
|
||||
(setq prev-point (point))
|
||||
(org-forward-heading-same-level 1 t)))
|
||||
cur-status))
|
||||
|
||||
(defun org-x-get-periodical-status ()
|
||||
"Get the status of a periodical.
|
||||
Allowed statuscodes are in list `nd/get-peri-statuscodes.' where
|
||||
latter codes in the list trump earlier ones."
|
||||
(letrec
|
||||
((max-ts
|
||||
(lambda ()
|
||||
(-some-->
|
||||
(org-ml-parse-this-headline)
|
||||
(org-element-map it 'timestamp #'identity)
|
||||
(--filter
|
||||
(memq (org-element-property :type it) '(active active-range))
|
||||
it)
|
||||
(--map
|
||||
(--> it
|
||||
(org-timestamp-split-range it t)
|
||||
(org-element-property :raw-value it)
|
||||
(org-2ft it))
|
||||
it)
|
||||
(-max it))))
|
||||
(compare
|
||||
(lambda (s1 s2)
|
||||
(if (org-x-compare-statuscodes > s1 s2 org-clone-peri-statuscodes) s1 s2)))
|
||||
(new-status
|
||||
(lambda (ts)
|
||||
(-->
|
||||
ts
|
||||
(cond
|
||||
((not it) :unscheduled)
|
||||
((< org-clone-peri-future-time (- it (float-time))) :actv)
|
||||
(t :empt))
|
||||
(funcall compare it cur-status))))
|
||||
(cur-status (first org-clone-peri-statuscodes))
|
||||
(breaker-status (-last-item org-clone-peri-statuscodes))
|
||||
(subtree-end (save-excursion (org-end-of-subtree t)))
|
||||
(prev-point (point)))
|
||||
(save-excursion
|
||||
(outline-next-heading)
|
||||
(while (and (not (eq cur-status breaker-status))
|
||||
(< prev-point (point) subtree-end))
|
||||
(setq cur-status (->> (funcall max-ts) (funcall new-status)))
|
||||
(setq prev-point (point))
|
||||
(org-forward-heading-same-level 1 t)))
|
||||
cur-status))
|
||||
|
||||
;; skip functions
|
||||
|
||||
(defun org-x-skip-heading ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue