ENH make macro to abstract stateful org headline iteration
This commit is contained in:
parent
78e6c73a71
commit
71c9cdceb1
|
@ -452,9 +452,19 @@ compared to REF-TIME. Returns nil if no timestamp is found."
|
||||||
|
|
||||||
;; relational testing
|
;; relational testing
|
||||||
|
|
||||||
(defun org-x-headline-has-children (test-fun)
|
(defun org-x-headline-get-level ()
|
||||||
"Return t if heading has a child for whom TEST-FUN is t.
|
"Return level of the current headline.
|
||||||
Assume that point is at the beginning of a headline."
|
Assumes point is at the start of a headline."
|
||||||
|
(save-excursion
|
||||||
|
(forward-char 1)
|
||||||
|
(while (= ?* (following-char)) (forward-char 1))
|
||||||
|
(current-column)))
|
||||||
|
|
||||||
|
(defmacro org-x-while-child-headlines (while-form &rest body)
|
||||||
|
"Run BODY for each child headline in the subtree under point.
|
||||||
|
Assume point is at the start of a headline. Loop through children
|
||||||
|
until WHILE-FORM evals to nil. Note that this only applies BODY
|
||||||
|
to the children one level down from the current headline."
|
||||||
;; Rather than using regular expressions, it is much faster and simpler to
|
;; Rather than using regular expressions, it is much faster and simpler to
|
||||||
;; walk down each line and count the number of stars to get the level.
|
;; walk down each line and count the number of stars to get the level.
|
||||||
;;
|
;;
|
||||||
|
@ -462,35 +472,59 @@ Assume that point is at the beginning of a headline."
|
||||||
;; 1. Count stars on the current headline (move point forward until first
|
;; 1. Count stars on the current headline (move point forward until first
|
||||||
;; non-star, and use the column number to get level) and add 1 to get
|
;; non-star, and use the column number to get level) and add 1 to get
|
||||||
;; the "target-level" (that is the child level of the current headline)
|
;; the "target-level" (that is the child level of the current headline)
|
||||||
;; 2. Move forward one line until a) `test-fun' returns t b) the current
|
;; 2. Move forward one line until a) `while-form' returns nil b) the current
|
||||||
;; level of the org-tree is less than the target-level or c) the end of
|
;; level of the org-tree is less than the target-level or c) the end of
|
||||||
;; the buffer is reached.
|
;; the buffer is reached.
|
||||||
;; 2.1. If point not on a star, continue looping.
|
;; 2.1. If point not on a star, continue looping.
|
||||||
;; 2.2. Otherwise, get the current level similar to (1) using the column
|
;; 2.2. Otherwise, get the current level similar to (1) using the column
|
||||||
;; number. If the current level is equal to the target level, eval
|
;; number. If the current level is equal to the target level, eval
|
||||||
;; `test-fun', otherwise do nothing since point is too deep in the
|
;; `body', otherwise do nothing since point is too deep in the tree.
|
||||||
;; tree
|
(declare (indent 1))
|
||||||
(save-excursion
|
`(save-excursion
|
||||||
(forward-char 1)
|
(let* ((target-level (1+ (org-x-headline-get-level)))
|
||||||
(while (= ?* (following-char)) (forward-char 1))
|
(cur-level target-level))
|
||||||
(let* ((target-level (1+ (current-column)))
|
(while (and ,while-form
|
||||||
(cur-level (1+ target-level))
|
(<= target-level cur-level)
|
||||||
(has-children nil))
|
(= 0 (forward-line 1)))
|
||||||
(while (and (not has-children)
|
(when (= ?* (following-char))
|
||||||
(<= target-level cur-level)
|
(setq cur-level (org-x-headline-get-level))
|
||||||
(= 0 (forward-line 1)))
|
(when (= cur-level target-level)
|
||||||
(when (= ?* (following-char))
|
,@body))))))
|
||||||
(forward-char 1)
|
|
||||||
(while (= ?* (following-char)) (forward-char 1))
|
(defun org-x-headline-has-children (test-fun)
|
||||||
(setq cur-level (current-column))
|
"Return t if heading has a child for whom TEST-FUN is t.
|
||||||
(when (and (= cur-level target-level) (funcall test-fun))
|
Assume that point is at the beginning of a headline."
|
||||||
(setq has-children t))))
|
(let ((has-children nil))
|
||||||
has-children)))
|
(org-x-while-child-headlines (not has-children)
|
||||||
|
(when (funcall test-fun)
|
||||||
|
(setq has-children t)))
|
||||||
|
has-children))
|
||||||
|
|
||||||
(defun org-x-headline-has-parent (heading-test)
|
(defun org-x-headline-has-parent (heading-test)
|
||||||
"Return t if heading has parent for whom HEADING-TEST is t."
|
"Return t if heading has parent for whom HEADING-TEST is t."
|
||||||
(save-excursion (and (org-up-heading-safe) (funcall heading-test))))
|
(save-excursion (and (org-up-heading-safe) (funcall heading-test))))
|
||||||
|
|
||||||
|
(defun org-x-up-headline ()
|
||||||
|
"Move point up to the next parent headline or `point-min' if none.
|
||||||
|
Return point on success and nil on failure. Assume point is
|
||||||
|
current at the start of a headline."
|
||||||
|
(let ((cur-level (org-x-headline-get-level)))
|
||||||
|
(if (= 1 cur-level)
|
||||||
|
(beginning-of-buffer)
|
||||||
|
(let ((target-level (1- cur-level))
|
||||||
|
(stop nil))
|
||||||
|
(while (and (not stop) (= 0 (forward-line -1)))
|
||||||
|
(when (= ?* (following-char))
|
||||||
|
(when (= (org-x-headline-get-level) target-level)
|
||||||
|
(setq stop t)
|
||||||
|
(beginning-of-line)
|
||||||
|
(point))))))))
|
||||||
|
|
||||||
|
;; (defun org-x-headline-has-parent (heading-test)
|
||||||
|
;; "Return t if heading has parent for whom HEADING-TEST is t."
|
||||||
|
;; (save-excursion
|
||||||
|
;; (and (org-x-up-headline) (funcall heading-test))))
|
||||||
|
|
||||||
(defun org-x-has-discontinuous-parent ()
|
(defun org-x-has-discontinuous-parent ()
|
||||||
"Return t if heading has a non-todoitem parent which in turn has a todoitem parent."
|
"Return t if heading has a non-todoitem parent which in turn has a todoitem parent."
|
||||||
(let ((has-todoitem-parent)
|
(let ((has-todoitem-parent)
|
||||||
|
@ -547,33 +581,27 @@ should be this function again)."
|
||||||
(-flatten-n 1)))
|
(-flatten-n 1)))
|
||||||
(breaker-status (-last-item allowed-statuscodes))
|
(breaker-status (-last-item allowed-statuscodes))
|
||||||
(initial-status (car allowed-statuscodes)))
|
(initial-status (car allowed-statuscodes)))
|
||||||
`(let ((project-status ,initial-status)
|
`(save-excursion
|
||||||
(previous-point nil)
|
(let ((project-status ,initial-status)
|
||||||
(new-status nil)
|
(new-status nil)
|
||||||
(it-kw nil))
|
(it-kw nil))
|
||||||
(save-excursion
|
;; loop through tasks one level down until breaker-status found
|
||||||
(setq previous-point (point))
|
(org-x-while-child-headlines (not (eq project-status ,breaker-status))
|
||||||
(outline-next-heading)
|
(setq it-kw (org-get-todo-state))
|
||||||
;; loop through subproject tasks until breaker-status found
|
(when it-kw
|
||||||
(while (and (not (eq project-status ,breaker-status))
|
(if (org-x-headline-has-children #'org-x-is-todoitem-p)
|
||||||
(> (point) previous-point))
|
(progn
|
||||||
(setq it-kw (org-get-todo-state))
|
;; If project returns an allowed status then use that.
|
||||||
(when it-kw
|
;; Otherwise look up the value in the translation table and
|
||||||
(if (org-x-headline-has-children #'org-x-is-todoitem-p)
|
;; return error if not found.
|
||||||
(progn
|
(setq new-status (,callback-fun))
|
||||||
;; If project returns an allowed status then use that.
|
(unless (member new-status ',allowed-statuscodes)
|
||||||
;; Otherwise look up the value in the translation table and
|
(setq new-status (alist-get new-status ',trans-tbl))))
|
||||||
;; return error if not found.
|
;; if tasks then use get-task-status to obtain status
|
||||||
(setq new-status (,callback-fun))
|
(setq new-status (nth ,get-task-status ',allowed-statuscodes)))
|
||||||
(unless (member new-status ',allowed-statuscodes)
|
(when (org-x-compare-statuscodes > new-status project-status ',allowed-statuscodes)
|
||||||
(setq new-status (alist-get new-status ',trans-tbl))))
|
(setq project-status new-status))))
|
||||||
;; if tasks then use get-task-status to obtain status
|
project-status))))
|
||||||
(setq new-status (nth ,get-task-status ',allowed-statuscodes)))
|
|
||||||
(when (org-x-compare-statuscodes > new-status project-status ',allowed-statuscodes)
|
|
||||||
(setq project-status new-status)))
|
|
||||||
(setq previous-point (point))
|
|
||||||
(org-forward-heading-same-level 1 t)))
|
|
||||||
project-status)))
|
|
||||||
|
|
||||||
(defun org-x-get-project-status ()
|
(defun org-x-get-project-status ()
|
||||||
"Return project heading statuscode (assumes it is indeed a project)."
|
"Return project heading statuscode (assumes it is indeed a project)."
|
||||||
|
|
Loading…
Reference in New Issue