ENH optimize org-x-headline-has-children
This commit is contained in:
parent
8907ab75f6
commit
c7111e24b6
|
@ -98,8 +98,7 @@ entire subtrees to save time and ignore tasks")
|
||||||
(defun org-x-get-date-property (timestamp-property)
|
(defun org-x-get-date-property (timestamp-property)
|
||||||
"Get TIMESTAMP-PROPERTY on current heading and convert to a number.
|
"Get TIMESTAMP-PROPERTY on current heading and convert to a number.
|
||||||
If it does not have a date, it will return nil."
|
If it does not have a date, it will return nil."
|
||||||
(let ((ts (org-entry-get nil timestamp-property)))
|
(-some-> (org-entry-get nil timestamp-property) (org-2ft)))
|
||||||
(when ts (org-2ft ts))))
|
|
||||||
|
|
||||||
;; TODO I don't like this function...it perplexes me
|
;; TODO I don't like this function...it perplexes me
|
||||||
(defun org-x-heading-compare-timestamp (timestamp-fun &optional ref-time future)
|
(defun org-x-heading-compare-timestamp (timestamp-fun &optional ref-time future)
|
||||||
|
@ -270,19 +269,38 @@ compared to REF-TIME. Returns nil if no timestamp is found."
|
||||||
|
|
||||||
;; relational testing
|
;; relational testing
|
||||||
|
|
||||||
(defun org-x-headline-has-children (heading-test)
|
;; ;; TODO this function seems slow
|
||||||
"Return t if heading has a child for whom HEADING-TEST is t."
|
;; (defun org-x-headline-has-children (heading-test)
|
||||||
(let ((subtree-end (save-excursion (org-end-of-subtree t)))
|
;; "Return t if heading has a child for whom HEADING-TEST is t."
|
||||||
has-children previous-point)
|
;; (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)
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(setq previous-point (point))
|
(while (and (<= level cur-level)
|
||||||
(outline-next-heading)
|
(re-search-forward org-outline-regexp-bol nil t))
|
||||||
(while (and (not has-children)
|
;; it's actually more efficient to scan every headline and check its
|
||||||
(< previous-point (point) subtree-end))
|
;; level rather than using a regexp to match the target depth
|
||||||
(when (funcall heading-test)
|
(setq cur-level (- (match-end 0) (match-beginning 0) 1))
|
||||||
(setq has-children t))
|
(when (and (= cur-level level) (funcall test-fun))
|
||||||
(setq previous-point (point))
|
(setq has-children t))))
|
||||||
(org-forward-heading-same-level 1 t)))
|
|
||||||
has-children))
|
has-children))
|
||||||
|
|
||||||
(defun org-x-headline-has-parent (heading-test)
|
(defun org-x-headline-has-parent (heading-test)
|
||||||
|
@ -317,9 +335,7 @@ compared to REF-TIME. Returns nil if no timestamp is found."
|
||||||
`(,op (cl-position ,sc1 ,sc-list) (cl-position ,sc2 ,sc-list)))
|
`(,op (cl-position ,sc1 ,sc-list) (cl-position ,sc2 ,sc-list)))
|
||||||
|
|
||||||
;; TODO there is likely a better way to handle this
|
;; TODO there is likely a better way to handle this
|
||||||
(defun org-x-descend-into-project (allowed-statuscodes trans-tbl
|
(defmacro org-x-descend-into-project (statuscode-tree get-task-status callback-fun)
|
||||||
get-task-status
|
|
||||||
callback-fun)
|
|
||||||
"Loop through (sub)project and return overall statuscode.
|
"Loop through (sub)project and return overall statuscode.
|
||||||
|
|
||||||
The returned statuscode is chosen from list ALLOWED-STATUSCODES where
|
The returned statuscode is chosen from list ALLOWED-STATUSCODES where
|
||||||
|
@ -341,50 +357,50 @@ should be this function again)."
|
||||||
;; define "breaker-status" as the last of the allowed-statuscodes
|
;; define "breaker-status" as the last of the allowed-statuscodes
|
||||||
;; when this is encountered the loop is broken because we are done
|
;; when this is encountered the loop is broken because we are done
|
||||||
;; (the last entry trumps all others)
|
;; (the last entry trumps all others)
|
||||||
(let ((project-status (cl-first allowed-statuscodes))
|
(let* ((allowed-statuscodes (-map #'car statuscode-tree))
|
||||||
|
(trans-tbl (->> statuscode-tree
|
||||||
|
(--map (-let (((a . bs) it)) (--map (cons it a) bs)))
|
||||||
|
(-flatten-n 1)))
|
||||||
(breaker-status (-last-item allowed-statuscodes))
|
(breaker-status (-last-item allowed-statuscodes))
|
||||||
(previous-point))
|
(initial-status (car allowed-statuscodes)))
|
||||||
|
`(let ((project-status ,initial-status)
|
||||||
|
(previous-point nil)
|
||||||
|
(new-status nil)
|
||||||
|
(it-kw nil))
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(setq previous-point (point))
|
(setq previous-point (point))
|
||||||
(outline-next-heading)
|
(outline-next-heading)
|
||||||
;; loop through subproject tasks until breaker-status found
|
;; loop through subproject tasks until breaker-status found
|
||||||
(while (and (not (eq project-status breaker-status))
|
(while (and (not (eq project-status ,breaker-status))
|
||||||
(> (point) previous-point))
|
(> (point) previous-point))
|
||||||
(let ((keyword (org-x-is-todoitem-p)))
|
(setq it-kw (org-get-todo-state))
|
||||||
(if keyword
|
(when it-kw
|
||||||
(let ((new-status
|
(if (org-x-headline-has-children #'org-x-is-todoitem-p)
|
||||||
;; if project then descend recursively
|
(progn
|
||||||
(if (org-x-headline-has-children 'org-x-is-todoitem-p)
|
;; If project returns an allowed status then use that.
|
||||||
(let ((n (funcall callback-fun)))
|
;; Otherwise look up the value in the translation table and
|
||||||
;; if project returns an allowed status
|
;; return error if not found.
|
||||||
;; then use that
|
(setq new-status (,callback-fun))
|
||||||
(or (and (member n allowed-statuscodes) n)
|
(unless (member new-status ',allowed-statuscodes)
|
||||||
;; otherwise look up the value in the
|
(setq new-status (alist-get new-status ',trans-tbl))))
|
||||||
;; translation table and return error
|
|
||||||
;; if not found
|
|
||||||
(nth (or (alist-get n trans-tbl)
|
|
||||||
(error (concat "status not found: " n)))
|
|
||||||
allowed-statuscodes)))
|
|
||||||
;; if tasks then use get-task-status to obtain status
|
;; if tasks then use get-task-status to obtain status
|
||||||
(nth (funcall get-task-status keyword)
|
(setq new-status (nth ,get-task-status ',allowed-statuscodes)))
|
||||||
allowed-statuscodes))))
|
(when (org-x-compare-statuscodes > new-status project-status ',allowed-statuscodes)
|
||||||
(if (org-x-compare-statuscodes > new-status project-status allowed-statuscodes)
|
(setq project-status new-status)))
|
||||||
(setq project-status new-status)))))
|
|
||||||
(setq previous-point (point))
|
(setq previous-point (point))
|
||||||
(org-forward-heading-same-level 1 t)))
|
(org-forward-heading-same-level 1 t)))
|
||||||
project-status))
|
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)."
|
||||||
(let ((keyword (org-x-is-todoitem-p)))
|
|
||||||
;;
|
;;
|
||||||
;; these first three are easy because they only require
|
;; these first three are easy because they only require
|
||||||
;; testing the project headline and nothing underneath
|
;; testing the project headline and nothing underneath
|
||||||
;;
|
;;
|
||||||
(cond
|
|
||||||
;; it does not make sense for projects to be scheduled
|
;; it does not make sense for projects to be scheduled
|
||||||
((org-x-is-scheduled-heading-p) :scheduled-project)
|
(if (org-x-is-scheduled-heading-p) :scheduled-project
|
||||||
|
(-when-let (keyword (org-get-todo-state))
|
||||||
|
(cond
|
||||||
;; held projects do not care what is underneath them
|
;; held projects do not care what is underneath them
|
||||||
;; only need to test if they are inert
|
;; only need to test if they are inert
|
||||||
((equal keyword "HOLD") (if (org-x-is-inert-p) :inert :held))
|
((equal keyword "HOLD") (if (org-x-is-inert-p) :inert :held))
|
||||||
|
@ -405,41 +421,35 @@ should be this function again)."
|
||||||
;; done projects are like canceled projects but can also be incomplete
|
;; done projects are like canceled projects but can also be incomplete
|
||||||
((equal keyword "DONE")
|
((equal keyword "DONE")
|
||||||
(org-x-descend-into-project
|
(org-x-descend-into-project
|
||||||
'(:archivable :complete :done-incomplete)
|
((:archivable)
|
||||||
'((:stuck . 2)
|
(:complete)
|
||||||
(:inert . 2)
|
(:done-incomplete :stuck :inert :held :wait :active
|
||||||
(:held . 2)
|
:scheduled-project :invalid-todostate
|
||||||
(:wait . 2)
|
:undone-complete))
|
||||||
(:active . 2)
|
(if (member it-kw org-done-keywords)
|
||||||
(:scheduled-project . 2)
|
|
||||||
(:invalid-todostate . 2)
|
|
||||||
(:undone-complete . 2))
|
|
||||||
(lambda (k)
|
|
||||||
(if (member k org-done-keywords)
|
|
||||||
(if (org-x-is-archivable-heading-p) 0 1)
|
(if (org-x-is-archivable-heading-p) 0 1)
|
||||||
2))
|
2)
|
||||||
#'org-x-get-project-status))
|
org-x-get-project-status))
|
||||||
|
|
||||||
;; project with TODO states could be basically any status
|
;; project with TODO states could be basically any status
|
||||||
((equal keyword "TODO")
|
((equal keyword "TODO")
|
||||||
(org-x-descend-into-project
|
(org-x-descend-into-project
|
||||||
'(:undone-complete :stuck :held :wait :inert :active)
|
((:undone-complete :complete :archivable)
|
||||||
'((:complete . 0)
|
(:stuck :scheduled-project :invalid-todostate :done-incomplete)
|
||||||
(:archivable . 0)
|
(:held)
|
||||||
(:scheduled-project . 1)
|
(:wait)
|
||||||
(:invalid-todostate . 1)
|
(:inert)
|
||||||
(:done-incomplete . 1))
|
(:active))
|
||||||
(lambda (k)
|
(cond
|
||||||
(cond ((and (not (member k org-done-keywords))
|
((and (not (member it-kw org-done-keywords)) (org-x-is-inert-p)) 4)
|
||||||
(org-x-is-inert-p)) 4)
|
((equal it-kw "TODO") (if (org-x-is-scheduled-heading-p) 5 1))
|
||||||
((equal k "TODO") (if (org-x-is-scheduled-heading-p) 5 1))
|
((equal it-kw "HOLD") 2)
|
||||||
((equal k "HOLD") 2)
|
((equal it-kw "WAIT") 3)
|
||||||
((equal k "WAIT") 3)
|
((equal it-kw "NEXT") 5)
|
||||||
((equal k "NEXT") 5)
|
(t 0))
|
||||||
(t 0)))
|
org-x-get-project-status))
|
||||||
#'org-x-get-project-status))
|
|
||||||
|
|
||||||
(t (error (concat "invalid keyword detected: " keyword))))))
|
(t (error (concat "invalid keyword detected: " keyword)))))))
|
||||||
|
|
||||||
;; skip functions
|
;; skip functions
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue