ENH put status filter directly in dag functions
This commit is contained in:
parent
6b8129883f
commit
7160c31424
|
|
@ -47,11 +47,6 @@ representing the headlines's ID property or a cons cell
|
||||||
like (FILE POS) representing the staring position in file/buffer
|
like (FILE POS) representing the staring position in file/buffer
|
||||||
of the headline (aka a \"pseudo-marker\").")
|
of the headline (aka a \"pseudo-marker\").")
|
||||||
|
|
||||||
;; TODO might be better if I make one giant variable to hold these things, the
|
|
||||||
;; dag, and whatever else I decide should be cached to death
|
|
||||||
(defvar org-x-dag-node-tags-table nil)
|
|
||||||
(defvar org-x-dag-file-tags-table nil)
|
|
||||||
|
|
||||||
(defvar org-x-dag-sync-state nil
|
(defvar org-x-dag-sync-state nil
|
||||||
"An alist representing the sync state of the DAG.
|
"An alist representing the sync state of the DAG.
|
||||||
|
|
||||||
|
|
@ -83,6 +78,9 @@ that file as it currently sits on disk.")
|
||||||
|
|
||||||
(defun org-x-dag-get-files ()
|
(defun org-x-dag-get-files ()
|
||||||
"Return a list of all files to be used in the DAG."
|
"Return a list of all files to be used in the DAG."
|
||||||
|
;; (list "/mnt/data/Org/projects/router.org"
|
||||||
|
;; "/mnt/data/Org/projects/omnimacs.org"
|
||||||
|
;; ))
|
||||||
`(,(org-x-get-lifetime-goal-file)
|
`(,(org-x-get-lifetime-goal-file)
|
||||||
,(org-x-get-endpoint-goal-file)
|
,(org-x-get-endpoint-goal-file)
|
||||||
,@(org-x-get-action-files)))
|
,@(org-x-get-action-files)))
|
||||||
|
|
@ -118,18 +116,17 @@ The returned value will be a list like (TO-REMOVE TO-INSERT
|
||||||
TO-UPDATE) which will contain the file paths the should be
|
TO-UPDATE) which will contain the file paths the should be
|
||||||
removed from, added to, or edited within the DAG respectively."
|
removed from, added to, or edited within the DAG respectively."
|
||||||
(cl-flet
|
(cl-flet
|
||||||
((states-to-files
|
((lookup-md5
|
||||||
(states)
|
(path)
|
||||||
(-map #'car states)))
|
(alist-get path org-x-dag-sync-state nil nil #'equal)))
|
||||||
(-let* (((exist noexist)
|
(-let* ((existing-files (org-x-dag-get-files))
|
||||||
(--separate (f-exists-p (car it)) org-x-dag-sync-state))
|
(state-files (-map #'car org-x-dag-sync-state))
|
||||||
(to-remove (states-to-files noexist))
|
(to-remove (-difference state-files existing-files))
|
||||||
(to-insert (->> (states-to-files exist)
|
(to-insert (-difference existing-files state-files))
|
||||||
(-difference (org-x-dag-get-files))))
|
(to-update
|
||||||
(to-update (->> exist
|
(->> (-intersection existing-files state-files)
|
||||||
(--filter (-let (((file . md5) it))
|
(--filter (org-x-dag-file-is-dirty it (lookup-md5 it))))))
|
||||||
(org-x-dag-file-is-dirty file md5)))
|
;; (print (list to-remove to-insert to-update))
|
||||||
(states-to-files))))
|
|
||||||
(list to-remove to-insert to-update))))
|
(list to-remove to-insert to-update))))
|
||||||
|
|
||||||
;; TODO this assumes the `org-id-locations' is synced
|
;; TODO this assumes the `org-id-locations' is synced
|
||||||
|
|
@ -235,38 +232,20 @@ valid keyword or none of its parents have valid keywords."
|
||||||
;; (error "Invalid key: %s" key)))))
|
;; (error "Invalid key: %s" key)))))
|
||||||
|
|
||||||
(defun org-x-dag-get-nodes-in-files (dag files)
|
(defun org-x-dag-get-nodes-in-files (dag files)
|
||||||
(dag-get-nodes-and-edges-where org-x-dag
|
(let ((x (->> (dag-get-nodes-and-edges-where org-x-dag
|
||||||
(org-x-dag-files-contains-key-p it files)))
|
(org-x-dag-files-contains-key-p it files))
|
||||||
|
(-map #'car)))
|
||||||
(defun org-x-dag-build-tag-tables (nodes &optional node-tags file-tags)
|
(y (dag-get-floating-nodes-where org-x-dag
|
||||||
"Create hash tables for the tags from NODES.
|
(org-x-dag-files-contains-key-p it files))))
|
||||||
|
;; (print (list x y))
|
||||||
Two tables will be returned, one for the local tags of each node,
|
;; (print x)
|
||||||
and one for the file tags for each file represented by NODES."
|
;; (print (list (length x) (length y) (length (-intersection x y))))
|
||||||
(let ((node-tags (or node-tags (ht-create #'equal)))
|
(append x y)))
|
||||||
(file-tags (or file-tags (ht-create #'equal))))
|
|
||||||
(-> (-group-by #'org-x-dag-key-get-file nodes)
|
|
||||||
(--each (-let (((path . nodes) it))
|
|
||||||
(org-x-with-file path
|
|
||||||
(ht-set file-tags path org-file-tags)
|
|
||||||
(--each nodes
|
|
||||||
(goto-char (org-x-dag-key-get-point it))
|
|
||||||
(ht-set node-tags it (org-get-tags nil t)))))))
|
|
||||||
(list node-tags file-tags)))
|
|
||||||
|
|
||||||
(defun org-x-dag-tags-table-remove (nodes node-tags file-tags)
|
|
||||||
(--each nodes
|
|
||||||
(ht-remove node-tags it)
|
|
||||||
(ht-remove file-tags it))
|
|
||||||
(list node-tags file-tags))
|
|
||||||
|
|
||||||
(defun org-x-dag-tags-table-update (to-remove to-insert)
|
|
||||||
(-setq (org-x-dag-node-tags-table org-x-dag-file-tags-table)
|
|
||||||
(->> (org-x-dag-tags-table-remove to-remove
|
|
||||||
org-x-dag-node-tags-table
|
|
||||||
org-x-dag-file-tags-table)
|
|
||||||
(apply #'org-x-dag-build-tag-tables to-insert))))
|
|
||||||
|
|
||||||
|
;; TODO there is a HUGE DIFFERENCE between a 'key' (the things in the hash table
|
||||||
|
;; the look things up) and a 'node' (which is a cons cell, the car of which is a
|
||||||
|
;; 'key' and the cdr of which is a 'relation'). These names suck, but the point
|
||||||
|
;; is we need to distinguish between them otherwise really strange things happen
|
||||||
(defun org-x-dag-update (to-remove to-insert to-update)
|
(defun org-x-dag-update (to-remove to-insert to-update)
|
||||||
"Update the DAG given files to add and remove.
|
"Update the DAG given files to add and remove.
|
||||||
|
|
||||||
|
|
@ -276,14 +255,12 @@ from, add to, and update with the DAG."
|
||||||
(nodes-to-insert (-mapcat #'org-x-dag-get-file-nodes files-to-insert)))
|
(nodes-to-insert (-mapcat #'org-x-dag-get-file-nodes files-to-insert)))
|
||||||
(if org-x-dag
|
(if org-x-dag
|
||||||
(let* ((files-to-remove (append to-update to-remove))
|
(let* ((files-to-remove (append to-update to-remove))
|
||||||
(nodes-to-remove (org-x-dag-get-nodes-in-files
|
(keys-to-remove (->> (org-x-dag-get-nodes-in-files
|
||||||
org-x-dag files-to-remove)))
|
org-x-dag files-to-remove))))
|
||||||
(setq org-x-dag (dag-edit-nodes nodes-to-remove
|
(when (or keys-to-remove nodes-to-insert)
|
||||||
nodes-to-insert
|
(setq org-x-dag (dag-edit-nodes keys-to-remove
|
||||||
org-x-dag))
|
nodes-to-insert
|
||||||
(org-x-dag-tags-table-update (-map #'car nodes-to-remove)
|
org-x-dag))))
|
||||||
(-map #'car nodes-to-insert)))
|
|
||||||
(org-x-dag-tags-table-update nil (-map #'car nodes-to-insert))
|
|
||||||
(setq org-x-dag (dag-alist-to-dag nodes-to-insert)))))
|
(setq org-x-dag (dag-alist-to-dag nodes-to-insert)))))
|
||||||
|
|
||||||
(defun org-x-dag-sync (&optional force)
|
(defun org-x-dag-sync (&optional force)
|
||||||
|
|
@ -455,27 +432,23 @@ encountered will be returned."
|
||||||
'org-complex-heading-regexp org-complex-heading-regexp
|
'org-complex-heading-regexp org-complex-heading-regexp
|
||||||
'mouse-face 'default))
|
'mouse-face 'default))
|
||||||
|
|
||||||
;; TODO this doesn't even use the tags cache...hmmm
|
(defun org-x-dag-format-tag-node (category tags key)
|
||||||
(defun org-x-dag-format-tag-node (tags key)
|
;; ASSUME I don't use subtree-level categories
|
||||||
(-let* ((category (org-get-category))
|
(-let* (;; (category (org-get-category))
|
||||||
(head (org-get-heading))
|
(head (org-get-heading))
|
||||||
(level (-> (plist-get key :level)
|
(level (-> (plist-get key :level)
|
||||||
(make-string ?s)))
|
(make-string ?s)))
|
||||||
;; (tags (-> (plist-get key :tags)
|
|
||||||
;; (append parent-tags)
|
|
||||||
;; (org-x-dag-collapse-tags)))
|
|
||||||
;; no idea what this does...
|
;; no idea what this does...
|
||||||
(help-echo (format "mouse-2 or RET jump to Org file %S"
|
(help-echo (format "mouse-2 or RET jump to Org file %S"
|
||||||
(abbreviate-file-name
|
(abbreviate-file-name
|
||||||
(or (buffer-file-name (buffer-base-buffer))
|
(or (buffer-file-name (buffer-base-buffer))
|
||||||
(buffer-name (buffer-base-buffer))))))
|
(buffer-name (buffer-base-buffer))))))
|
||||||
(marker (org-agenda-new-marker))
|
(marker (org-agenda-new-marker))
|
||||||
(priority (org-get-priority head))
|
|
||||||
(todo-state (plist-get key :todo))
|
|
||||||
;; no idea what this function actually does
|
;; no idea what this function actually does
|
||||||
((ts . ts-type) (org-agenda-entry-get-agenda-timestamp (point))))
|
((ts . ts-type) (org-agenda-entry-get-agenda-timestamp (point)))
|
||||||
(-> (org-agenda-format-item "" head level category tags)
|
(item (org-agenda-format-item "" head level category tags))
|
||||||
(org-x-dag-add-default-props)
|
(priority (org-get-priority item)))
|
||||||
|
(-> (org-x-dag-add-default-props item)
|
||||||
(org-add-props nil
|
(org-add-props nil
|
||||||
;; face
|
;; face
|
||||||
'face 'default
|
'face 'default
|
||||||
|
|
@ -485,7 +458,7 @@ encountered will be returned."
|
||||||
'org-hd-marker marker
|
'org-hd-marker marker
|
||||||
'org-marker marker
|
'org-marker marker
|
||||||
;; headline stuff
|
;; headline stuff
|
||||||
'todo-state todo-state
|
'todo-state (plist-get key :todo)
|
||||||
'priority priority
|
'priority priority
|
||||||
'ts-date ts
|
'ts-date ts
|
||||||
;; misc
|
;; misc
|
||||||
|
|
@ -497,29 +470,96 @@ encountered will be returned."
|
||||||
(->> (org-entry-get (org-x-dag-key-get-point key) org-x-prop-parent-type)
|
(->> (org-entry-get (org-x-dag-key-get-point key) org-x-prop-parent-type)
|
||||||
(equal org-x-prop-parent-type-iterator))))
|
(equal org-x-prop-parent-type-iterator))))
|
||||||
|
|
||||||
(defun org-x-dag-scan-tasks ()
|
;; (defmacro org-x-dag-do-file-nodes (path keys form)
|
||||||
(let* ((dag org-x-dag))
|
;; (declare (indent 2))
|
||||||
(->> (org-x-dag-get-project-task-nodes #'org-x-dag-key-is-iterator dag)
|
;; `(let ((acc))
|
||||||
(append (org-x-dag-get-standalone-task-nodes dag))
|
;; (org-x-with-file ,path
|
||||||
;; TODO don't hardcode this
|
;; ;; ;; TODO tbh this could just be the file basename since that's all
|
||||||
(--remove (org-x-with-file (org-x-dag-key-get-file it)
|
;; ;; ;; I ever use
|
||||||
(or (org-entry-get (org-x-dag-key-get-point it) "SCHEDULED")
|
;; ;; (let ((it-category (org-get-category)))
|
||||||
(org-entry-get (org-x-dag-key-get-point it) "DEADLINE"))))
|
;; (--each keys
|
||||||
(--group-by (org-x-dag-key-get-file it))
|
;; (goto-char (org-x-dag-key-get-point it))
|
||||||
(--mapcat
|
;; ,form))
|
||||||
(-let (((path . keys) it))
|
;; (nreverse acc)))
|
||||||
(org-x-with-file path
|
|
||||||
(--map
|
|
||||||
(let ((tags (->> (org-x-dag-get-inherited-tags org-file-tags dag it)
|
|
||||||
(append (plist-get it :tags))
|
|
||||||
(org-x-dag-collapse-tags))))
|
|
||||||
;; filter out incubators
|
|
||||||
(unless (member org-x-tag-incubated tags)
|
|
||||||
(goto-char (org-x-dag-key-get-point it))
|
|
||||||
(org-x-dag-format-tag-node tags it)))
|
|
||||||
keys))))
|
|
||||||
(-non-nil))))
|
|
||||||
|
|
||||||
|
(defun org-x-headline-has-timestamp (re want-time)
|
||||||
|
(let ((end (save-excursion (outline-next-heading))))
|
||||||
|
(-when-let (p (save-excursion (re-search-forward re end t)))
|
||||||
|
(if want-time (org-2ft (match-string 1)) p))))
|
||||||
|
|
||||||
|
(defun org-x-headline-is-deadlined (want-time)
|
||||||
|
(org-x-headline-has-timestamp org-deadline-time-regexp want-time))
|
||||||
|
|
||||||
|
(defun org-x-headline-is-scheduled (want-time)
|
||||||
|
(org-x-headline-has-timestamp org-scheduled-time-regexp want-time))
|
||||||
|
|
||||||
|
(defun org-x-headline-is-closed (want-time)
|
||||||
|
(org-x-headline-has-timestamp org-closed-time-regexp want-time))
|
||||||
|
|
||||||
|
(defconst org-x-headline-task-status-priorities
|
||||||
|
'((:archivable . -1)
|
||||||
|
(:complete . -1)
|
||||||
|
(:expired . 0)
|
||||||
|
(:done-unclosed . 0)
|
||||||
|
(:undone-closed . 0)
|
||||||
|
(:active . 1)
|
||||||
|
(:inert . 2)))
|
||||||
|
|
||||||
|
(defun org-x-headline-get-task-status-0 (kw)
|
||||||
|
(if (member kw org-x-done-keywords)
|
||||||
|
(-if-let (c (org-x-headline-is-closed t))
|
||||||
|
(if (< (- (float-time) c) (* 60 60 24 org-x-archive-delay))
|
||||||
|
:archivable
|
||||||
|
:complete)
|
||||||
|
:done-unclosed)
|
||||||
|
(cond
|
||||||
|
((org-x-headline-is-expired-p) :expired)
|
||||||
|
((org-x-headline-is-inert-p) :inert)
|
||||||
|
((org-x-headline-is-closed nil) :undone-closed)
|
||||||
|
(t :active))))
|
||||||
|
|
||||||
|
;; TODO making this an imperative-style loop doesn't speed it up 'that-much'
|
||||||
|
(defun org-x-dag-scan-tasks ()
|
||||||
|
(let* ((dag org-x-dag)
|
||||||
|
(sats (->> (org-x-dag-get-standalone-task-nodes dag)
|
||||||
|
(--map (cons it :is-standalone))))
|
||||||
|
(pts (->> (org-x-dag-get-project-task-nodes #'org-x-dag-key-is-iterator dag)
|
||||||
|
(--map (list it))))
|
||||||
|
(grouped (->> (append sats pts)
|
||||||
|
(--group-by (org-x-dag-key-get-file (car it)))))
|
||||||
|
acc path key-cells category key tags is-standalone)
|
||||||
|
(--each grouped
|
||||||
|
;; (-let (((path . key-cells) it))
|
||||||
|
(-setq (path . key-cells) it)
|
||||||
|
;; TODO this won't add the file to `org-agenda-new-buffers'
|
||||||
|
(org-x-with-file path
|
||||||
|
;; TODO tbh this could just be the file basename since that's all
|
||||||
|
;; I ever use
|
||||||
|
(setq category (org-get-category))
|
||||||
|
;; (let ((category (org-get-category)))
|
||||||
|
(--each key-cells
|
||||||
|
(-setq (key . is-standalone) it)
|
||||||
|
(setq tags (->> (org-x-dag-get-inherited-tags org-file-tags dag key)
|
||||||
|
(append (plist-get key :tags))
|
||||||
|
(org-x-dag-collapse-tags)))
|
||||||
|
;; (-let* (((key . is-standalone) it)
|
||||||
|
;; (tags (->> (org-x-dag-get-inherited-tags org-file-tags dag key)
|
||||||
|
;; (append (plist-get key :tags))
|
||||||
|
;; (org-x-dag-collapse-tags))))
|
||||||
|
;; filter out incubators
|
||||||
|
(goto-char (plist-get key :point))
|
||||||
|
(unless (or (member org-x-tag-incubated tags)
|
||||||
|
(org-x-headline-is-scheduled nil)
|
||||||
|
(org-x-headline-is-deadlined nil))
|
||||||
|
(let* ((s (org-x-headline-get-task-status-0 (plist-get key :todo)))
|
||||||
|
(p (alist-get s org-x-headline-task-status-priorities)))
|
||||||
|
(unless (= p -1)
|
||||||
|
(setq acc (-> (org-x-dag-format-tag-node category tags key)
|
||||||
|
(org-add-props nil
|
||||||
|
'x-is-standalone is-standalone
|
||||||
|
'x-status s)
|
||||||
|
(cons acc)))))))))
|
||||||
|
acc))
|
||||||
|
|
||||||
(defun org-x-dag-scan-tags ()
|
(defun org-x-dag-scan-tags ()
|
||||||
(let* ((dag org-x-dag)
|
(let* ((dag org-x-dag)
|
||||||
|
|
@ -578,6 +618,7 @@ encountered will be returned."
|
||||||
(org-tags-view '(4) "TODO"))))
|
(org-tags-view '(4) "TODO"))))
|
||||||
|
|
||||||
(defun org-x-dag-show-nodes (get-nodes)
|
(defun org-x-dag-show-nodes (get-nodes)
|
||||||
|
(org-x-dag-sync)
|
||||||
(let* ((org-tags-match-list-sublevels org-tags-match-list-sublevels)
|
(let* ((org-tags-match-list-sublevels org-tags-match-list-sublevels)
|
||||||
(completion-ignore-case t)
|
(completion-ignore-case t)
|
||||||
rtnall files file pos matcher
|
rtnall files file pos matcher
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue