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

FIX a bunch of project errors

This commit is contained in:
Nathan Dwarshuis 2022-04-02 23:18:02 -04:00
parent 8cc48bb484
commit 92b8639327
1 changed files with 65 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
local/lib/org-x/org-x-dag.el
View File

@ -1454,28 +1454,29 @@ used for optimization."
(defmacro org-x-dag-bs-fold-children (bss default rank-form stop-form trans-form) (defmacro org-x-dag-bs-fold-children (bss default rank-form stop-form trans-form)
(declare (indent 2)) (declare (indent 2))
(let ((err (org-x-dag-bs :error "Child error"))) (let ((err (org-x-dag-bs :error "Child error")))
`(-if-let ((x . xs) ,bss) `(if ,bss
;; (if (org-x-dag-bs-error-p x) (progn (print x) ',err) (-let (((x . xs) ,bss))
(if (org-x-dag-bs-error-p x) ',err ;; (if (org-x-dag-bs-error-p x) (progn (print x) ',err)
(let ((acc (cadr x)) r final) (if (org-x-dag-bs-error-p x) ',err
(while (and (not final) xs) (let ((acc (cadr x)) r final)
(setq x (car xs)) (while (and (not final) xs)
(if (org-x-dag-bs-error-p x) (setq x (car xs))
(setq final ',err) (if (org-x-dag-bs-error-p x)
(setq it (cadr x) (setq final ',err)
r ,rank-form) (setq it (cadr x)
(unless r r ,rank-form)
(error "You forgot the difference between Maybe and Either")) (unless r
(if (org-x-dag-bs-error-p r) (error "You forgot the difference between Maybe and Either"))
(setq final r) (if (org-x-dag-bs-error-p r)
(when (cadr r) (setq final r)
(setq acc (cadr x))) (when (cadr r)
(if ,stop-form (setq acc (cadr x)))
(setq final (org-x-dag-bs :valid acc)) (if ,stop-form
(!cdr xs))))) (setq final (org-x-dag-bs :valid acc))
(when (not final) (!cdr xs)))))
(setq final (org-x-dag-bs :valid acc))) (when (not final)
(org-x-dag-bs>>= final ,trans-form))) (setq final (org-x-dag-bs :valid acc)))
(org-x-dag-bs>>= final ,trans-form))))
(org-x-dag-bs :valid ,default)))) (org-x-dag-bs :valid ,default))))
(defun org-x-dag-bs-error-kw (type-name kw) (defun org-x-dag-bs-error-kw (type-name kw)
@ -1516,7 +1517,11 @@ used for optimization."
(cl-flet (cl-flet
((new-proj ((new-proj
(status) (status)
(org-x-dag-bs :valid `(:sp-proj ,@status)))) (org-x-dag-bs :valid `(:sp-proj ,@status)))
(is-next
(task-data)
(-let (((&plist :todo :sched) task-data))
(or sched (equal todo org-x-kw-next)))))
;; rankings ;; rankings
;; *-active > proj-wait > proj-held > (proj-stuck == iter-empty) > *-complete ;; *-active > proj-wait > proj-held > (proj-stuck == iter-empty) > *-complete
(org-x-dag-bs-action-with-closed node-data "projects" (org-x-dag-bs-action-with-closed node-data "projects"
@ -1558,22 +1563,38 @@ used for optimization."
:dead dead) :dead dead)
(list :sp-task :task-active)))) (list :sp-task :task-active))))
(cond (cond
((equal it-todo org-x-kw-hold) ((and child-bss (equal it-todo org-x-kw-hold))
(new-proj '(:proj-held))) (new-proj '(:proj-held)))
((and sched child-bss) ((and child-bss sched)
(org-x-dag-bs :error "Projects cannot be scheduled")) (org-x-dag-bs :error "Projects cannot be scheduled"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(org-x-dag-bs-fold-children child-bss task-default (org-x-dag-bs-fold-children child-bss task-default
(->> (pcase `(,acc ,it) (->> (pcase `(,acc ,it)
(`((:sp-task :task-active ,a) (:sp-task :task-active ,b)) (`((:sp-task :task-active ,a) (:sp-task :task-active ,b))
(and (not (plist-get a :sched)) (plist-get b :sched))) (and (not (is-next a)) (is-next b)))
(`(,(or `(:sp-proj :proj-active)
`(:sp-proj :proj-wait)
`(:sp-proj :proj-held)
`(:sp-proj :proj-stuck)
`(:sp-iter :iter-active)
`(:sp-iter :iter-empty))
(:sp-task :task-active ,d))
(is-next d))
(`((:sp-task :task-active ,d)
,(or `(:sp-proj :proj-active)
`(:sp-proj :proj-wait)
`(:sp-proj :proj-held)
`(:sp-proj :proj-stuck)
`(:sp-iter :iter-active)
`(:sp-iter :iter-empty)))
(not (is-next d)))
(`((:sp-proj :proj-active) ,_) nil)
(`((:sp-iter :iter-active ,_) ,_) nil) (`((:sp-iter :iter-active ,_) ,_) nil)
(`((:sp-task :task-active ,d) ,_) (not (plist-get d :sched))) (`((:sp-proj :proj-active) ,_) nil)
(`(,_ (:sp-proj :proj-active)) t) (`(,_ (:sp-proj :proj-active)) t)
(`(,_ (:sp-iter :iter-active ,_)) t) (`(,_ (:sp-iter :iter-active ,_)) t)
(`(,_ (:sp-task :task-active ,d)) (plist-get d :sched))
(`((:sp-proj :proj-wait) ,_) nil) (`((:sp-proj :proj-wait) ,_) nil)
(`(,_ (:sp-proj :proj-wait)) t) (`(,_ (:sp-proj :proj-wait)) t)
@ -1583,8 +1604,10 @@ used for optimization."
(`((:sp-proj :proj-stuck) ,_) nil) (`((:sp-proj :proj-stuck) ,_) nil)
(`((:sp-iter :iter-empty) ,_) nil) (`((:sp-iter :iter-empty) ,_) nil)
(`((:sp-task :task-active ,_) ,_) nil)
(`(,_ (:sp-proj :proj-stuck)) t) (`(,_ (:sp-proj :proj-stuck)) t)
(`(,_ (:sp-iter :iter-empty)) t) (`(,_ (:sp-iter :iter-empty)) t)
(`(,_ (:sp-task :task-active ,_)) t)
;; any pair that makes it this far is completed in both, which means ;; any pair that makes it this far is completed in both, which means
;; neither takes precedence, which means choose the left one ;; neither takes precedence, which means choose the left one
@ -1595,7 +1618,7 @@ used for optimization."
(pcase acc (pcase acc
(`(:sp-proj :proj-active) t) (`(:sp-proj :proj-active) t)
(`(:sp-iter :iter-active ,_) t) (`(:sp-iter :iter-active ,_) t)
(`(:sp-task :task-active ,d) (plist-get d :sched)) (`(:sp-task :task-active ,d) (is-next d))
(_ nil)) (_ nil))
;; child -> parent translation ;; child -> parent translation
@ -3158,6 +3181,7 @@ except it ignores inactive timestamps."
(id status-data) (id status-data)
;; NOTE in the future there might be more than just the car to this ;; NOTE in the future there might be more than just the car to this
(let ((status (car status-data))) (let ((status (car status-data)))
(print status)
(-when-let (priority (cl-case status (-when-let (priority (cl-case status
(:proj-active 4) (:proj-active 4)
(:proj-wait 3) (:proj-wait 3)
@ -3477,21 +3501,17 @@ except it ignores inactive timestamps."
(defun org-x-dag-scan-errors () (defun org-x-dag-scan-errors ()
(cl-flet (cl-flet
((format-id ((format-id
(category id) (id msg)
(-when-let (error-type (-> (org-x-dag-format-tag-node nil id)
(if (org-x-dag-id->is-iterator-p id) (org-add-props nil
(unless (org-x-dag-id->node-property "ARCHIVE" id) 'x-error msg))))
:missing-archive) (with-temp-buffer
(-if-let (created (org-x-dag-id->node-property org-x-prop-created)) (org-mode)
(when (<= (float-time) (org-2ft created)) (->> (org-x-dag->action-files)
:future-created) (org-x-dag-files->ids)
:missing-created))) (--map (pcase (org-x-dag-id->bs it)
(-> (org-x-dag-format-tag-node category nil id) (`(:error ,msg) (format-id it msg))))
(org-add-props nil (-non-nil)))))
'x-error error-type)))))
(org-x-dag-with-files (org-x-dag->files)
(not (org-x-dag-id->is-done-p it))
(list (format-id it-category it)))))
(defun org-x-dag-scan-agenda (sel-date) (defun org-x-dag-scan-agenda (sel-date)
(cl-flet* (cl-flet*