ENH compute buffer status immediately after parsing file
This commit is contained in:
parent
df069a37b9
commit
f868d995ea
|
|
@ -1294,19 +1294,11 @@ used for optimization."
|
||||||
(when (and (< (point) prop-beg) (looking-at org-planning-line-re))
|
(when (and (< (point) prop-beg) (looking-at org-planning-line-re))
|
||||||
(org-element-planning-parser prop-beg))))
|
(org-element-planning-parser prop-beg))))
|
||||||
|
|
||||||
(defun org-x-dag-get-buffer-nodes (file kws target-props)
|
(defun org-x-dag-get-buffer-nodes (file-meta kws target-props)
|
||||||
"Return a list of nodes from FILE.
|
|
||||||
|
|
||||||
A node will only be returned if the headline to which it points
|
|
||||||
has a valid (meaning in KWS) keyword and either its parent has a
|
|
||||||
valid keyword or none of its parents have valid keywords.
|
|
||||||
TARGET-PROPS is a list of properties to parse from each
|
|
||||||
headline."
|
|
||||||
(let ((more t)
|
(let ((more t)
|
||||||
(line-re (org-x-dag-line-regexp kws))
|
(line-re (org-x-dag-line-regexp kws))
|
||||||
cur-path this-point this-key this-level this-todo has-todo this-parent
|
cur-path this-point this-key this-level this-todo has-todo this-parent
|
||||||
this-tags this-meta all-tags this-file-links this-links acc acc-meta
|
this-tags this-meta all-tags this-file-links this-links this-parent-key acc)
|
||||||
acc-links this-parent-key)
|
|
||||||
;; TODO add org-mode sanity check
|
;; TODO add org-mode sanity check
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
;; If not on a headline, check for a property drawer with links in it
|
;; If not on a headline, check for a property drawer with links in it
|
||||||
|
|
@ -1335,56 +1327,523 @@ headline."
|
||||||
(!cdr cur-path))
|
(!cdr cur-path))
|
||||||
(setq this-parent (car cur-path)
|
(setq this-parent (car cur-path)
|
||||||
this-parent-key (nth 1 this-parent))
|
this-parent-key (nth 1 this-parent))
|
||||||
;; Add the current headline to accumulator if it has a keyword, but only
|
;; Add the current headline to accumulator if it is a node, but only if
|
||||||
;; if its parent has a keyword or none of its parents have keywords
|
;; its parent is a node or none of its parents are nodes
|
||||||
(when (and this-todo
|
(when (and this-todo
|
||||||
(or this-parent-key (--none-p (nth 1 it) cur-path))
|
(or this-parent-key (--none-p (nth 1 it) cur-path))
|
||||||
(setq
|
(setq
|
||||||
this-prop-bounds (org-x-dag-property-block next-pos)
|
this-prop-bounds (org-x-dag-property-block next-pos)
|
||||||
this-key (org-x-dag-get-local-property this-prop-bounds "ID")))
|
this-key (org-x-dag-get-local-property this-prop-bounds "ID")))
|
||||||
;; If parent is not a todo and we want tag inheritance, store all
|
;; If parent is not a node and we want tag inheritance, store all
|
||||||
;; tags above this headline (including file tags)
|
;; tags above this headline (including file tags)
|
||||||
(setq all-tags (if (and (not this-parent-key) org-use-tag-inheritance)
|
(setq this-links (or (-> (nth 3 this-prop-bounds)
|
||||||
(->> cur-path
|
(org-x-dag-get-parent-links next-pos))
|
||||||
(--mapcat (nth 2 it))
|
|
||||||
(append this-tags org-file-tags))
|
|
||||||
this-tags)
|
|
||||||
this-planning (org-x-dag-parse-this-planning (car this-prop-bounds))
|
|
||||||
this-links (or (org-x-dag-get-parent-links (nth 3 this-prop-bounds) next-pos)
|
|
||||||
(unless this-parent-key
|
(unless this-parent-key
|
||||||
(-some->> (--first (nth 3 it) cur-path)
|
(-some->> (--first (nth 3 it) cur-path)
|
||||||
(nth 3)
|
(nth 3)
|
||||||
(append this-file-links))))
|
(append this-file-links))))
|
||||||
this-props (org-x-dag-get-local-properties this-prop-bounds target-props)
|
this-node
|
||||||
this-meta (org-x-dag-build-meta file
|
(list :id this-key
|
||||||
this-point
|
:parents this-links
|
||||||
this-level
|
:node-meta
|
||||||
this-todo
|
(list :point this-point
|
||||||
this-title
|
:level this-level
|
||||||
all-tags
|
:todo this-todo
|
||||||
this-planning
|
:title this-title
|
||||||
this-props
|
:tags (if (and (not this-parent-key) org-use-tag-inheritance)
|
||||||
this-parent-key))
|
(->> cur-path
|
||||||
(when this-links
|
(--mapcat (nth 2 it))
|
||||||
(!cons (cons this-key this-links) acc-links))
|
(append this-tags org-file-tags))
|
||||||
(!cons (cons this-key this-meta) acc-meta)
|
this-tags)
|
||||||
(!cons (cons this-key `(,(nth 1 this-parent) ,@this-links)) acc))
|
:planning (->> (car this-prop-bounds)
|
||||||
|
(org-x-dag-parse-this-planning))
|
||||||
|
:props (-> this-prop-bounds
|
||||||
|
(org-x-dag-get-local-properties target-props)))))
|
||||||
|
(!cons this-node acc))
|
||||||
;; Add current headline to stack
|
;; Add current headline to stack
|
||||||
|
;; TODO this isn't necessary for non-node children of nodes
|
||||||
(!cons (list this-level this-key this-tags this-links) cur-path)
|
(!cons (list this-level this-key this-tags this-links) cur-path)
|
||||||
;; Since we know the next headline's position already, skip ahead to
|
;; Since we know the next headline's position already, skip ahead to
|
||||||
;; save some work
|
;; save some work
|
||||||
(goto-char next-pos))
|
(goto-char next-pos))
|
||||||
(list (nreverse acc) (nreverse acc-meta) acc-links)))
|
(nreverse acc)))
|
||||||
|
|
||||||
(defun org-x-dag-get-file-nodes (file)
|
(defun org-x-dag-buffer-nodes-to-tree (nodes)
|
||||||
"Return all nodes in FILE in one pass."
|
(cl-labels
|
||||||
(org-x-with-file file
|
((get-level
|
||||||
(org-x-dag-get-buffer-nodes file
|
(node)
|
||||||
org-todo-keywords-1
|
(plist-get (plist-get node :node-meta) :level))
|
||||||
(list org-x-prop-parent-type
|
(mk-tree
|
||||||
org-x-prop-time-shift
|
(parent nodes)
|
||||||
"ARCHIVE"
|
(-let* (((p . cs) parent)
|
||||||
org-x-prop-created))))
|
(pi (get-level p))
|
||||||
|
stop n i res)
|
||||||
|
(while (and (not stop) nodes)
|
||||||
|
(setq n (car nodes)
|
||||||
|
i (get-level n))
|
||||||
|
(unless (setq stop (<= i pi))
|
||||||
|
(setq res (mk-tree `(,n) (cdr nodes))
|
||||||
|
nodes (cdr res))
|
||||||
|
(!cons (car res) cs)))
|
||||||
|
`((,p ,@cs) . ,nodes))))
|
||||||
|
(let (acc res)
|
||||||
|
(while nodes
|
||||||
|
(setq res (mk-tree `(,(car nodes)) (cdr nodes))
|
||||||
|
nodes (cdr res))
|
||||||
|
(!cons (car res) acc))
|
||||||
|
acc)))
|
||||||
|
|
||||||
|
;; type BS a = Either String a
|
||||||
|
(defmacro org-x-dag-bs (key data)
|
||||||
|
(pcase key
|
||||||
|
((or :error :valid) `(list ,key ,data))
|
||||||
|
(e (error "Invalid status key: %s" key))))
|
||||||
|
|
||||||
|
(defmacro org-x-dag-bs>>= (bs form)
|
||||||
|
(declare (indent 1))
|
||||||
|
`(pcase ,bs
|
||||||
|
(`(:error ,_) ,bs)
|
||||||
|
(`(:valid ,it) ,form)
|
||||||
|
(e (error "Learn to use monads, dummy; this isn't one: %s" e))))
|
||||||
|
|
||||||
|
(defmacro org-x-dag-bs-fmap (bs form)
|
||||||
|
(declare (indent 1))
|
||||||
|
`(pcase ,bs
|
||||||
|
(`(:error ,_) ',bs)
|
||||||
|
(`(:valid ,it) `(:valid ,form))
|
||||||
|
(e (error "Learn to use functors, dummy; this isn't one: %s" e))))
|
||||||
|
|
||||||
|
(defun org-x-dag-bs-error-p (bs)
|
||||||
|
(eq (car bs) :error))
|
||||||
|
|
||||||
|
;; [Status a] -> b -> (a -> a -> Status Bool) -> (a -> Bool) -> (a -> Status b)
|
||||||
|
;; -> Status b
|
||||||
|
(defmacro org-x-dag-fold-child-bss (bss default rank-form stop-form trans-form)
|
||||||
|
(declare (indent 2))
|
||||||
|
(let ((err (org-x-dag-bs :error "Child error")))
|
||||||
|
`(-if-let ((x . xs) ,bss)
|
||||||
|
(if (org-x-dag-bs-error-p x) ',err
|
||||||
|
(let ((acc x) r)
|
||||||
|
(while xs
|
||||||
|
(setq x (car xs))
|
||||||
|
(if (org-x-dag-bs-error-p x)
|
||||||
|
(setq acc ',err
|
||||||
|
xs nil)
|
||||||
|
(setq it x
|
||||||
|
r ,rank-form)
|
||||||
|
(unless r
|
||||||
|
(error "You forgot the difference between Maybe and Either"))
|
||||||
|
(if (org-x-dag-bs-error-p r)
|
||||||
|
(setq acc r
|
||||||
|
xs nil)
|
||||||
|
(when r
|
||||||
|
(setq acc x))
|
||||||
|
(if ,stop-form
|
||||||
|
(setq acc (org-x-dag-bs :valid acc)
|
||||||
|
xs nil)
|
||||||
|
(!cdr xs)))))
|
||||||
|
(org-x-dag-bs>>= acc ,trans-form)))
|
||||||
|
(org-x-dag-bs :valid ,default))))
|
||||||
|
|
||||||
|
(defmacro org-x-dag-bs-action-with-closed (node child-bss type-name
|
||||||
|
canc-bs-form done-form open-form)
|
||||||
|
(declare (indent 3))
|
||||||
|
(let ((o (make-symbol "--todo"))
|
||||||
|
(p (make-symbol "--planning")))
|
||||||
|
`(-let (((&plist :node-meta (&plist :todo ,o :planning ,p)) ,node))
|
||||||
|
(-if-let (it-closed (-some->> ,p
|
||||||
|
(org-ml-get-property :closed)
|
||||||
|
(org-ml-timestamp-get-start-time)
|
||||||
|
(org-ml-time-to-unixtime)))
|
||||||
|
(cond
|
||||||
|
((equal ,o org-x-kw-canc)
|
||||||
|
(org-x-dag-bs :valid ,canc-bs-form))
|
||||||
|
((equal ,o org-x-kw-done)
|
||||||
|
,done-form)
|
||||||
|
(t
|
||||||
|
(->> (format "Closed %s must be marked CANC/DONE" ,type-name)
|
||||||
|
(org-x-dag-bs :error))))
|
||||||
|
(cond
|
||||||
|
((member ,o org-x-done-keywords)
|
||||||
|
(->> (format "DONE/CANC %s must be closed" ,type-name)
|
||||||
|
(org-x-dag-bs :error)))
|
||||||
|
(t
|
||||||
|
,open-form))))))
|
||||||
|
|
||||||
|
(defun org-x-dag-action-project-bs-inner (node child-bss)
|
||||||
|
(cl-flet
|
||||||
|
((new-proj
|
||||||
|
(status)
|
||||||
|
(org-x-dag-bs :valid `(:sp-proj ,@status))))
|
||||||
|
;; rankings
|
||||||
|
;; *-active > proj-wait > proj-held > (proj-stuck == iter-empty) > *-complete
|
||||||
|
(-let (((&plist :node-meta (&plist :todo)) node))
|
||||||
|
(org-x-dag-bs-action-with-closed node child-bss "projects"
|
||||||
|
`(:sp-proj :proj-complete `(it-closed t))
|
||||||
|
|
||||||
|
;; done form
|
||||||
|
(org-x-dag-fold-child-bss child-bss `(:sp-task :task-complete (,it-closed nil))
|
||||||
|
;; TODO this could be slightly more efficient if the error type is
|
||||||
|
;; returned in this form and not the last
|
||||||
|
(->> (pcase `(,acc ,it)
|
||||||
|
(`((:sp-proj :proj-complete ,_) (:sp-proj :proj-complete ,_)) nil)
|
||||||
|
(`((:sp-iter :iter-complete ,_) (:sp-iter :iter-complete ,_)) nil)
|
||||||
|
(`((:sp-task :task-complete ,_) (:sp-task :task-complete ,_)) nil)
|
||||||
|
(`((:sp-proj :proj-complete ,_) ,_) t)
|
||||||
|
(`((:sp-iter :iter-complete ,_) ,_) t)
|
||||||
|
(`((:sp-task :task-complete ,_) ,_) t)
|
||||||
|
(`(,_ (:sp-proj :proj-complete ,_)) nil)
|
||||||
|
(`(,_ (:sp-iter :iter-complete ,_)) nil)
|
||||||
|
(`(,_ (:sp-task :task-complete ,_)) nil))
|
||||||
|
(org-x-dag-bs :valid))
|
||||||
|
(pcase acc
|
||||||
|
(`(:sp-proj :proj-complete ,_) nil)
|
||||||
|
(`(:sp-iter :iter-complete ,_) nil)
|
||||||
|
(`(:sp-task :task-complete ,_) nil)
|
||||||
|
(_ t))
|
||||||
|
(pcase it
|
||||||
|
((or `(:sp-proj :proj-complete ,_)
|
||||||
|
`(:sp-iter :iter-complete ,_)
|
||||||
|
`(:sp-task :task-complete ,_))
|
||||||
|
(org-x-dag-bs :valid `(:sp-proj :proj-complete (,it-closed nil))))
|
||||||
|
(_ (org-x-dag-bs :error "Completed projects cannot have active children"))))
|
||||||
|
|
||||||
|
;; undone form
|
||||||
|
(-let* (((&plist :node-meta (&plist :planning p)) node)
|
||||||
|
(sched (-some->> p (org-ml-get-property :scheduled)))
|
||||||
|
(dead (-some->> p (org-ml-get-property :deadline)))
|
||||||
|
(task-default `(:sp-task :task-active (,todo ,sched ,dead))))
|
||||||
|
(cond
|
||||||
|
((equal todo org-x-kw-hold)
|
||||||
|
(new-proj :proj-held))
|
||||||
|
((and sched child-bss)
|
||||||
|
(org-x-dag-bs :error "Projects cannot be scheduled"))
|
||||||
|
((equal todo org-x-kw-todo)
|
||||||
|
(org-x-dag-fold-child-bss child-bss task-default
|
||||||
|
(->> (pcase `(,acc ,it)
|
||||||
|
(`((:sp-proj :proj-active) ,_) nil)
|
||||||
|
(`((:sp-iter :iter-active ,_) ,_) nil)
|
||||||
|
(`((:sp-task :task-active, _) ,_) nil)
|
||||||
|
(`(,_ (:sp-proj :proj-active)) t)
|
||||||
|
(`(,_ (:sp-iter :iter-active ,_)) t)
|
||||||
|
(`(,_ (:sp-task :task-active ,_)) t)
|
||||||
|
|
||||||
|
(`((:sp-proj :proj-wait) ,_) nil)
|
||||||
|
(`(,_ (:sp-proj :proj-wait)) t)
|
||||||
|
|
||||||
|
(`((:sp-proj :proj-held) ,_) nil)
|
||||||
|
(`(,_ (:sp-proj :proj-held)) t)
|
||||||
|
|
||||||
|
(`((:sp-proj :proj-stuck) ,_) nil)
|
||||||
|
(`((:sp-iter :iter-empty) ,_) nil)
|
||||||
|
(`(,_ (:sp-proj :proj-stuck)) t)
|
||||||
|
(`(,_ (:sp-iter :iter-empty)) t)
|
||||||
|
|
||||||
|
;; any pair that makes it this far is completed in both, which means
|
||||||
|
;; neither takes precedence, which means choose the left one
|
||||||
|
(`(,_ ,_) nil))
|
||||||
|
(org-x-dag-bs :valid))
|
||||||
|
|
||||||
|
;; early stop
|
||||||
|
(pcase acc
|
||||||
|
(`(:sp-proj :proj-active) t)
|
||||||
|
(`(:sp-iter :iter-active ,_) t)
|
||||||
|
(`(:sp-task :task-active ,_) t)
|
||||||
|
(_ nil))
|
||||||
|
|
||||||
|
;; child -> parent translation
|
||||||
|
(pcase it
|
||||||
|
((or `(:sp-proj :proj-complete ,_)
|
||||||
|
`(:sp-task :task-complete ,_)
|
||||||
|
`(:sp-iter :iter-complete ,_))
|
||||||
|
(org-x-dag-bs :error "Active projects must have at least one active child"))
|
||||||
|
(`(:sp-proj . ,s) (new-proj s))
|
||||||
|
(`(:sp-iter :iter-active ,_) (new-proj :proj-active))
|
||||||
|
(`(:sp-iter :iter-empty) (new-proj :proj-stuck))
|
||||||
|
(`(:sp-task :task-active (,todo ,sched ,_))
|
||||||
|
(cond
|
||||||
|
((equal todo org-x-kw-todo) (->> (if sched :proj-active :proj-stuck)
|
||||||
|
(new-proj)))
|
||||||
|
((equal todo org-x-kw-next) (new-proj :proj-active))
|
||||||
|
((equal todo org-x-kw-wait) (new-proj :proj-wait))
|
||||||
|
((equal todo org-x-kw-hold) (new-proj :proj-hold))
|
||||||
|
(t (->> (format "Undefined keyword: %s" todo)
|
||||||
|
(org-x-dag-bs :error))))))))
|
||||||
|
(child-bss
|
||||||
|
(->> (format "Projects cannot have keyword '%s'" todo)
|
||||||
|
(org-x-dag-bs :error)))
|
||||||
|
(t
|
||||||
|
task-default)))))))
|
||||||
|
|
||||||
|
(defun org-x-dag-action-subiter-rank (si-a si-b)
|
||||||
|
(pcase `(,si-a ,si-b)
|
||||||
|
(`((:si-active (,ts-a ,dead-a)) (:si-active (,ts-b ,dead-b)))
|
||||||
|
(let ((dt-a (org-ml-timestamp-get-start-time ts-a))
|
||||||
|
(dt-b (org-ml-timestamp-get-start-time ts-b)))
|
||||||
|
(cond
|
||||||
|
((not (eq dead-a dead-b))
|
||||||
|
(->> "All sub-iter timestamps must be scheduled or deadlined"
|
||||||
|
(org-x-dag-bs :error)))
|
||||||
|
((xor (org-ml-time-is-long dt-a) (org-ml-time-is-long dt-b))
|
||||||
|
(->> "All sub-iter timestamps must be long or short"
|
||||||
|
(org-x-dag-bs :error)))
|
||||||
|
(t
|
||||||
|
;; ASSUME this won't fail since the datetimes are assumed to be the
|
||||||
|
;; same length as per rules above
|
||||||
|
(org-x-dag-bs :valid (org-x-dag-datetime< dt-a dt-b))))))
|
||||||
|
(`((:si-active ,_) ,_) (org-x-dag-bs :valid nil))
|
||||||
|
(`(,_ (:si-active ,_)) (org-x-dag-bs :valid t))))
|
||||||
|
|
||||||
|
(defun org-x-dag-action-subiter-bs-inner (node child-bss)
|
||||||
|
(-let (((&plist :node-meta (&plist :todo)) node))
|
||||||
|
(org-x-dag-bs-action-with-closed node child-bss "sub-iterators"
|
||||||
|
`(:si-complete (,it-closed t))
|
||||||
|
|
||||||
|
;; done form
|
||||||
|
(org-x-dag-fold-child-bss child-bss `(:si-complete (,it-closed nil))
|
||||||
|
(->> (pcase `(,acc ,it)
|
||||||
|
(`((:si-complete ,_) (:si-complete ,_)) nil)
|
||||||
|
(`((:si-complete ,_) ,_) t)
|
||||||
|
(`(,_ (:si-complete ,_)) nil))
|
||||||
|
(org-x-dag-bs :valid))
|
||||||
|
(pcase acc
|
||||||
|
(`(:si-complete ,_) nil)
|
||||||
|
(_ t))
|
||||||
|
(pcase it
|
||||||
|
(`(:si-complete ,_)
|
||||||
|
(org-x-dag-bs :valid `(:si-complete ,(it-closed nil))))
|
||||||
|
(_ (org-x-dag-bs :error "Completed sub-iterators cannot have active children"))))
|
||||||
|
|
||||||
|
;; undone form
|
||||||
|
(-let* (((&plist :node-meta (&plist :planning)) node)
|
||||||
|
(sched (org-ml-get-property :scheduled planning))
|
||||||
|
(dead (org-ml-get-property :dead planning)))
|
||||||
|
(cond
|
||||||
|
((and sched child-bss)
|
||||||
|
(org-x-dag-bs :error "Sub-iterators with children cannot be scheduled"))
|
||||||
|
((and dead child-bss)
|
||||||
|
(org-x-dag-bs :error "Sub-iterators with children cannot be deadlined"))
|
||||||
|
((not (xor sched dead))
|
||||||
|
(org-x-dag-bs :error "Sub-iterators must either be deadlined or scheduled"))
|
||||||
|
;; todo test for iterator property here
|
||||||
|
((equal todo org-x-kw-todo)
|
||||||
|
(org-x-dag-fold-child-bss child-bss (->> `(,(or sched dead) ,(and dead t))
|
||||||
|
(list :si-active))
|
||||||
|
(org-x-dag-action-subiter-rank acc it)
|
||||||
|
(pcase acc
|
||||||
|
(`(:si-active ,_) t)
|
||||||
|
(_ nil))
|
||||||
|
(pcase it
|
||||||
|
(`(:si-complete ,_)
|
||||||
|
(->> "Active iterators must have at least one active child"
|
||||||
|
(org-x-dag-bs :error)))
|
||||||
|
(`(:si-active ,ts-data)
|
||||||
|
(org-x-dag-bs :valid `(:si-active ,ts-data))))))
|
||||||
|
(t
|
||||||
|
(->> (format "Sub-iterators cannot have keyword '%s'" todo)
|
||||||
|
(org-x-dag-bs :error))))))))
|
||||||
|
|
||||||
|
(defun org-x-dag-action-iter-bs-inner (node child-bss)
|
||||||
|
(-let (((&plist :node-meta (&plist :todo)) node))
|
||||||
|
(org-x-dag-bs-action-with-closed node child-bss "iterators"
|
||||||
|
`(:iter-complete ,it-closed)
|
||||||
|
|
||||||
|
;; done form
|
||||||
|
(org-x-dag-fold-child-bss child-bss `(:iter-complete ,it-closed)
|
||||||
|
(->> (pcase `(,acc ,it)
|
||||||
|
(`((:si-complete ,_) (:si-complete ,_)) nil)
|
||||||
|
(`((:si-complete ,_) ,_) t)
|
||||||
|
(`(,_ (:si-complete ,_)) nil))
|
||||||
|
(org-x-dag-bs :valid))
|
||||||
|
(pcase acc
|
||||||
|
(`(:si-complete ,_) nil)
|
||||||
|
(_ t))
|
||||||
|
(pcase it
|
||||||
|
(`(:si-complete ,_)
|
||||||
|
(org-x-dag-bs :valid `(:iter-complete ,(it-closed nil))))
|
||||||
|
(_ (org-x-dag-bs :error "Completed iterators cannot have active children"))))
|
||||||
|
|
||||||
|
;; undone form
|
||||||
|
(-let* (((&plist :planning) node)
|
||||||
|
(sched (org-ml-get-property :scheduled planning)))
|
||||||
|
(cond
|
||||||
|
((and sched child-bss)
|
||||||
|
(org-x-dag-bs :error "Iterators cannot be scheduled"))
|
||||||
|
((equal todo org-x-kw-todo)
|
||||||
|
(org-x-dag-fold-child-bss child-bss '(:iter-empty)
|
||||||
|
(org-x-dag-action-subiter-rank acc it)
|
||||||
|
(pcase acc
|
||||||
|
(`(:si-active ,_) t)
|
||||||
|
(_ nil))
|
||||||
|
(pcase it
|
||||||
|
(`(:si-complete ,_)
|
||||||
|
(->> "Active iterators must have at least one active child"
|
||||||
|
(org-x-dag-bs :error)))
|
||||||
|
(`(:si-active ,ts-data)
|
||||||
|
(org-x-dag-bs :valid `(:iter-active ,ts-data))))))
|
||||||
|
(t
|
||||||
|
(->> (format "Iterators cannot have keyword '%s'" todo)
|
||||||
|
(org-x-dag-bs :error))))))))
|
||||||
|
|
||||||
|
(defun org-x-dag-with-children (tree child-fun node-fun concat-fun)
|
||||||
|
(declare (indent 3))
|
||||||
|
;; TODO this is super inefficient, make a plist mapper function
|
||||||
|
(-let* (((node . children) tree)
|
||||||
|
((&plist :id n :parents ps :node-meta m) node)
|
||||||
|
((shallow rest) (->> (-map child-fun children)
|
||||||
|
(apply #'-zip-lists)))
|
||||||
|
(shallow*
|
||||||
|
(--map (-let (((&plist :id ci :parents cps :node-meta cm) it))
|
||||||
|
(list :id ci :parents (cons n cps) :node-meta cm))
|
||||||
|
shallow)))
|
||||||
|
(list (list :id n
|
||||||
|
:parents ps
|
||||||
|
:node-meta (->> (--map (plist-get it :node-meta) shallow)
|
||||||
|
(funcall node-fun node)))
|
||||||
|
(funcall concat-fun shallow* rest))))
|
||||||
|
|
||||||
|
;; Tree a -> (Tree a -> (b, [d])) -> (a -> [b] -> c) -> (c, [d])
|
||||||
|
(defun org-x-dag-with-children-1 (tree child-fun node-fun)
|
||||||
|
(org-x-dag-with-children tree child-fun node-fun
|
||||||
|
(lambda (shallow deep)
|
||||||
|
(append shallow (-flatten-n 1 it)))))
|
||||||
|
|
||||||
|
;; Tree a -> (Tree a -> (b, ([d], [e]))) -> (a -> [b] -> c) -> (c, ([d], [e]))
|
||||||
|
(defun org-x-dag-with-children-2 (tree child-fun node-fun)
|
||||||
|
(org-x-dag-with-children tree child-fun node-fun
|
||||||
|
(lambda (shallow deep)
|
||||||
|
(--reduce-from (-let (((a b) acc)
|
||||||
|
((as bs) it))
|
||||||
|
`((,@as ,@a) (,@bs ,@b)))
|
||||||
|
`(,shallow nil)
|
||||||
|
deep))))
|
||||||
|
|
||||||
|
(defun org-x-dag-action-subiter-bs (tree)
|
||||||
|
(org-x-dag-with-children-1
|
||||||
|
tree
|
||||||
|
#'org-x-dag-action-subiter-bs
|
||||||
|
#'org-x-dag-action-subiter-bs-inner))
|
||||||
|
|
||||||
|
(defun org-x-dag-action-iter-bs (tree)
|
||||||
|
(org-x-dag-with-children-1
|
||||||
|
tree
|
||||||
|
#'org-x-dag-action-subiter-bs
|
||||||
|
(lambda (node child-bss)
|
||||||
|
(org-x-dag-bs-fmap (org-x-dag-action-iter-bs-inner node-child-bss)
|
||||||
|
`(:sp-proj it)))))
|
||||||
|
|
||||||
|
(defun org-x-dag-action-project-bs (tree)
|
||||||
|
(-let* (((node . children) tree)
|
||||||
|
((&plist :props) node)
|
||||||
|
(pt (alist-get org-x-prop-parent-type props nil nil #'equal)))
|
||||||
|
(if (equal pt org-x-prop-parent-type-iterator)
|
||||||
|
(-let (((iter subiters) (org-x-dag-action-iter-bs tree)))
|
||||||
|
`(,iter (nil ,subiters)))
|
||||||
|
(org-x-dag-with-children-2
|
||||||
|
tree
|
||||||
|
#'org-x-dag-action-project-bs
|
||||||
|
#'org-x-dag-action-project-bs-inner))))
|
||||||
|
|
||||||
|
;; TODO need to somehow keep the metadata in with the returned type
|
||||||
|
(defun org-x-dag-action-bs (node-tree)
|
||||||
|
;; TODO these types might not line up properly
|
||||||
|
(-let (((p (ps is)) (org-x-dag-action-project-bs node-tree)))
|
||||||
|
`(,p ,@ps ,@is)))
|
||||||
|
|
||||||
|
;; (defun org-x-dag-get-buffer-nodes (file kws target-props)
|
||||||
|
;; "Return a list of nodes from FILE.
|
||||||
|
|
||||||
|
;; A node will only be returned if the headline to which it points
|
||||||
|
;; has a valid (meaning in KWS) keyword and either its parent has a
|
||||||
|
;; valid keyword or none of its parents have valid keywords.
|
||||||
|
;; TARGET-PROPS is a list of properties to parse from each
|
||||||
|
;; headline."
|
||||||
|
;; (let ((more t)
|
||||||
|
;; (line-re (org-x-dag-line-regexp kws))
|
||||||
|
;; cur-path this-point this-key this-level this-todo has-todo this-parent
|
||||||
|
;; this-tags this-meta all-tags this-file-links this-links acc acc-meta
|
||||||
|
;; acc-links this-parent-key)
|
||||||
|
;; ;; TODO add org-mode sanity check
|
||||||
|
;; (goto-char (point-min))
|
||||||
|
;; ;; If not on a headline, check for a property drawer with links in it
|
||||||
|
;; (unless (= ?* (following-char))
|
||||||
|
;; (setq this-file-links (org-x-dag-get-parent-links)))
|
||||||
|
;; ;; loop through all headlines
|
||||||
|
;; (while (re-search-forward line-re nil t)
|
||||||
|
;; ;; Keep track of how 'deep' we are in a given org-tree using a stack. The
|
||||||
|
;; ;; stack will have members like (LEVEL KEY TAGS) where LEVEL is the level
|
||||||
|
;; ;; of the headline and KEY is the node key if it has a keyword, and TAGS
|
||||||
|
;; ;; is a list of tags for the headlines. Only add a node to the accumulator
|
||||||
|
;; ;; if it has a keyword and an ID property, and only include its parent
|
||||||
|
;; ;; headline if the parent also has a keyword.
|
||||||
|
;; (setq this-point (car (match-data))
|
||||||
|
;; this-level (length (match-string 1))
|
||||||
|
;; this-todo (match-string 2)
|
||||||
|
;; this-title (-if-let (s (match-string 3)) (s-trim s) "")
|
||||||
|
;; this-tags (-some-> (match-string-no-properties 4)
|
||||||
|
;; (split-string ":" t))
|
||||||
|
;; next-pos (or (org-x-dag-next-headline) (point-max))
|
||||||
|
;; this-key nil
|
||||||
|
;; this-links nil)
|
||||||
|
;; ;; Adjust the stack so that the top headline is the parent of the
|
||||||
|
;; ;; current headline
|
||||||
|
;; (while (and cur-path (<= this-level (nth 0 (car cur-path))))
|
||||||
|
;; (!cdr cur-path))
|
||||||
|
;; (setq this-parent (car cur-path)
|
||||||
|
;; this-parent-key (nth 1 this-parent))
|
||||||
|
;; ;; Add the current headline to accumulator if it has a keyword, but only
|
||||||
|
;; ;; if its parent has a keyword or none of its parents have keywords
|
||||||
|
;; (when (and this-todo
|
||||||
|
;; (or this-parent-key (--none-p (nth 1 it) cur-path))
|
||||||
|
;; (setq
|
||||||
|
;; this-prop-bounds (org-x-dag-property-block next-pos)
|
||||||
|
;; this-key (org-x-dag-get-local-property this-prop-bounds "ID")))
|
||||||
|
;; ;; If parent is not a todo and we want tag inheritance, store all
|
||||||
|
;; ;; tags above this headline (including file tags)
|
||||||
|
;; (setq all-tags (if (and (not this-parent-key) org-use-tag-inheritance)
|
||||||
|
;; (->> cur-path
|
||||||
|
;; (--mapcat (nth 2 it))
|
||||||
|
;; (append this-tags org-file-tags))
|
||||||
|
;; this-tags)
|
||||||
|
;; this-planning (org-x-dag-parse-this-planning (car this-prop-bounds))
|
||||||
|
;; this-links (or (org-x-dag-get-parent-links (nth 3 this-prop-bounds) next-pos)
|
||||||
|
;; (unless this-parent-key
|
||||||
|
;; (-some->> (--first (nth 3 it) cur-path)
|
||||||
|
;; (nth 3)
|
||||||
|
;; (append this-file-links))))
|
||||||
|
;; this-props (org-x-dag-get-local-properties this-prop-bounds target-props)
|
||||||
|
;; this-meta (org-x-dag-build-meta file
|
||||||
|
;; this-point
|
||||||
|
;; this-level
|
||||||
|
;; this-todo
|
||||||
|
;; this-title
|
||||||
|
;; all-tags
|
||||||
|
;; this-planning
|
||||||
|
;; this-props
|
||||||
|
;; this-parent-key))
|
||||||
|
;; (when this-links
|
||||||
|
;; (!cons (cons this-key this-links) acc-links))
|
||||||
|
;; (!cons (cons this-key this-meta) acc-meta)
|
||||||
|
;; (!cons (cons this-key `(,(nth 1 this-parent) ,@this-links)) acc))
|
||||||
|
;; ;; Add current headline to stack
|
||||||
|
;; (!cons (list this-level this-key this-tags this-links) cur-path)
|
||||||
|
;; ;; Since we know the next headline's position already, skip ahead to
|
||||||
|
;; ;; save some work
|
||||||
|
;; (goto-char next-pos))
|
||||||
|
;; (list (nreverse acc) (nreverse acc-meta) acc-links)))
|
||||||
|
|
||||||
|
(defun org-x-dag-get-file-nodes (file group)
|
||||||
|
(let ((meta (list :file file
|
||||||
|
:group group
|
||||||
|
:category (f-base file))))
|
||||||
|
;; TODO use group to determine which properties we need
|
||||||
|
(org-x-with-file file
|
||||||
|
(org-x-dag-get-buffer-nodes meta
|
||||||
|
org-todo-keywords-1
|
||||||
|
(list org-x-prop-parent-type
|
||||||
|
org-x-prop-time-shift
|
||||||
|
"ARCHIVE"
|
||||||
|
org-x-prop-created)))))
|
||||||
|
|
||||||
;;; DAG SYNCHRONIZATION/CONSTRUCTION
|
;;; DAG SYNCHRONIZATION/CONSTRUCTION
|
||||||
|
|
||||||
|
|
@ -1427,18 +1886,30 @@ removed from, added to, or edited within the DAG respectively."
|
||||||
(t 'to-update)))))))
|
(t 'to-update)))))))
|
||||||
(list file-state to-remove to-insert to-update no-change))))
|
(list file-state to-remove to-insert to-update no-change))))
|
||||||
|
|
||||||
(defun org-x-dag-read-files (files)
|
(defun org-x-dag-flatten-file-state (file-state)
|
||||||
|
(-let* (((&plist :goal-files g :plan-files p :action-files a) file-state))
|
||||||
|
(->> (append g p)
|
||||||
|
(-partition-all 2)
|
||||||
|
(--map (cons (nth 1 it) (nth 0 it)))
|
||||||
|
(append (--map (cons it :action) a)))))
|
||||||
|
|
||||||
|
(defun org-x-dag-read-files (files file-state)
|
||||||
(cl-flet
|
(cl-flet
|
||||||
((append-results
|
((append-results
|
||||||
(acc file)
|
(acc file-pair)
|
||||||
(-let* (((acc-ids acc-meta acc-filemaps acc-links) acc)
|
(-let* (((file . group) file-pair)
|
||||||
((ids metas links) (org-x-dag-get-file-nodes file))
|
((acc-ids acc-meta acc-filemaps acc-links) acc)
|
||||||
|
((ids metas links) (org-x-dag-get-file-nodes file group))
|
||||||
(filemap (cons file (-map #'car ids))))
|
(filemap (cons file (-map #'car ids))))
|
||||||
`((,@ids ,@acc-ids)
|
`((,@ids ,@acc-ids)
|
||||||
(,@metas ,@acc-meta)
|
(,@metas ,@acc-meta)
|
||||||
(,filemap ,@acc-filemaps)
|
(,filemap ,@acc-filemaps)
|
||||||
(,@links ,@acc-links)))))
|
(,@links ,@acc-links)))))
|
||||||
(-reduce-from #'append-results nil files)))
|
;; TODO wtf is this error prone garbage? (the use of filter implies failure
|
||||||
|
;; in a list that should have a bijective mapping to the file list)
|
||||||
|
(->> (org-x-dag-flatten-file-state file-state)
|
||||||
|
(--filter (member (car it) files))
|
||||||
|
(-reduce-from #'append-results nil))))
|
||||||
|
|
||||||
;; TODO what about all the nodes that don't need to be updated?
|
;; TODO what about all the nodes that don't need to be updated?
|
||||||
(defun org-x-dag-update-ht (to-remove to-insert ht)
|
(defun org-x-dag-update-ht (to-remove to-insert ht)
|
||||||
|
|
@ -2115,7 +2586,7 @@ plist holding the files to be used in the DAG."
|
||||||
(files2ins (append to-update to-insert))
|
(files2ins (append to-update to-insert))
|
||||||
(ids2rem (org-x-dag-files->ids files2rem))
|
(ids2rem (org-x-dag-files->ids files2rem))
|
||||||
((ids2ins meta2ins fms2ins links2ins)
|
((ids2ins meta2ins fms2ins links2ins)
|
||||||
(org-x-dag-read-files files2ins)))
|
(org-x-dag-read-files files2ins file-state)))
|
||||||
(org-x-dag-update-ht ids2rem meta2ins id->meta)
|
(org-x-dag-update-ht ids2rem meta2ins id->meta)
|
||||||
(org-x-dag-update-ht files2rem fms2ins file->ids)
|
(org-x-dag-update-ht files2rem fms2ins file->ids)
|
||||||
(org-x-dag-update-dag ids2ins ids2rem)
|
(org-x-dag-update-dag ids2ins ids2rem)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue