ndwarshuis
/
emacs-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH optimize org-x-headline-has-children

This commit is contained in:
Nathan Dwarshuis 2021-04-09 01:15:41 -04:00
parent 8907ab75f6
commit c7111e24b6
1 changed files with 119 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

222
local/lib/org-x/org-x.el
View File

@ -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,105 +357,99 @@ 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))
(breaker-status (-last-item allowed-statuscodes)) (trans-tbl (->> statuscode-tree
(previous-point)) (--map (-let (((a . bs) it)) (--map (cons it a) bs)))
(save-excursion (-flatten-n 1)))
(setq previous-point (point)) (breaker-status (-last-item allowed-statuscodes))
(outline-next-heading) (initial-status (car allowed-statuscodes)))
;; loop through subproject tasks until breaker-status found `(let ((project-status ,initial-status)
(while (and (not (eq project-status breaker-status)) (previous-point nil)
(> (point) previous-point)) (new-status nil)
(let ((keyword (org-x-is-todoitem-p))) (it-kw nil))
(if keyword (save-excursion
(let ((new-status (setq previous-point (point))
;; if project then descend recursively (outline-next-heading)
(if (org-x-headline-has-children 'org-x-is-todoitem-p) ;; loop through subproject tasks until breaker-status found
(let ((n (funcall callback-fun))) (while (and (not (eq project-status ,breaker-status))
;; if project returns an allowed status (> (point) previous-point))
;; then use that (setq it-kw (org-get-todo-state))
(or (and (member n allowed-statuscodes) n) (when it-kw
;; otherwise look up the value in the (if (org-x-headline-has-children #'org-x-is-todoitem-p)
;; translation table and return error (progn
;; if not found ;; If project returns an allowed status then use that.
(nth (or (alist-get n trans-tbl) ;; Otherwise look up the value in the translation table and
(error (concat "status not found: " n))) ;; return error if not found.
allowed-statuscodes))) (setq new-status (,callback-fun))
;; if tasks then use get-task-status to obtain status (unless (member new-status ',allowed-statuscodes)
(nth (funcall get-task-status keyword) (setq new-status (alist-get new-status ',trans-tbl))))
allowed-statuscodes)))) ;; if tasks then use get-task-status to obtain status
(if (org-x-compare-statuscodes > new-status project-status allowed-statuscodes) (setq new-status (nth ,get-task-status ',allowed-statuscodes)))
(setq project-status new-status))))) (when (org-x-compare-statuscodes > new-status project-status ',allowed-statuscodes)
(setq previous-point (point)) (setq project-status new-status)))
(org-forward-heading-same-level 1 t))) (setq previous-point (point))
project-status)) (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)."
(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 ;;
;; ;; it does not make sense for projects to be scheduled
(cond (if (org-x-is-scheduled-heading-p) :scheduled-project
;; it does not make sense for projects to be scheduled (-when-let (keyword (org-get-todo-state))
((org-x-is-scheduled-heading-p) :scheduled-project) (cond
;; held projects do not care what is underneath them
;; only need to test if they are inert
((equal keyword "HOLD") (if (org-x-is-inert-p) :inert :held))
;; held projects do not care what is underneath them ;; projects with invalid todostates are nonsense
;; only need to test if they are inert ((member keyword org-x-project-invalid-todostates)
((equal keyword "HOLD") (if (org-x-is-inert-p) :inert :held)) :invalid-todostate)
;; projects with invalid todostates are nonsense ;; canceled projects can either be archivable or complete
((member keyword org-x-project-invalid-todostates) ;; any errors or undone tasks are irrelevant
:invalid-todostate) ((equal keyword "CANC") (if (org-x-is-archivable-heading-p) :archivable
:complete))
;; canceled projects can either be archivable or complete ;;
;; any errors or undone tasks are irrelevant ;; these require descending into the project subtasks
((equal keyword "CANC") (if (org-x-is-archivable-heading-p) :archivable ;;
:complete))
;; ;; done projects are like canceled projects but can also be incomplete
;; these require descending into the project subtasks ((equal keyword "DONE")
;; (org-x-descend-into-project
((:archivable)
;; done projects are like canceled projects but can also be incomplete (:complete)
((equal keyword "DONE") (:done-incomplete :stuck :inert :held :wait :active
(org-x-descend-into-project :scheduled-project :invalid-todostate
'(:archivable :complete :done-incomplete) :undone-complete))
'((:stuck . 2) (if (member it-kw org-done-keywords)
(:inert . 2)
(:held . 2)
(:wait . 2)
(:active . 2)
(: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