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

FIX a bunch of errors related to the timeblock view

This commit is contained in:
Nathan Dwarshuis 2022-04-13 22:13:17 -04:00
parent 8d01ebc94c
commit fbe36911da
1 changed files with 145 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1024,7 +1024,7 @@ used for optimization."
#'org-x-dag-bs-epg-inner)) #'org-x-dag-bs-epg-inner))
(defun org-x-dag-bs-prefix (key nodes) (defun org-x-dag-bs-prefix (key nodes)
(--map (org-x-dag-node-fmap it (either<$> it `(,key ,it))) nodes)) (--map (org-x-dag-node-fmap it (either<$> it `(,key ,@it))) nodes))
(defun org-x-dag-bs-epg (tree) (defun org-x-dag-bs-epg (tree)
(-let (((n ns) (org-x-dag-bs-epg-outer tree))) (-let (((n ns) (org-x-dag-bs-epg-outer tree)))
@ -1311,19 +1311,20 @@ used for optimization."
(agoals (get-committed ht-a a))) (agoals (get-committed ht-a a)))
;; TODO this check doesn't matter for survival goals since ;; TODO this check doesn't matter for survival goals since
;; those won't be on the quarterly plan ;; those won't be on the quarterly plan
(-if-let (gs (-intersection qgoals agoals)) ;; (-if-let (gs (-intersection qgoals agoals))
(progn (progn
(->> (list :scheduled w (->> (list :scheduled w
:committed (-uniq gs) ;; :committed (-uniq gs)
:committed (-uniq (append qgoals agoals))
:active a) :active a)
(either :right) (either :right)
(ht-set this-h id)) (ht-set this-h id))
;; TODO add the goals to their goal links? (this might be ;; TODO add the goals to their goal links? (this might be
;; useful later when displaying) ;; useful later when displaying)
(org-x-dag-ht-add-links id ht-w :planned w) (org-x-dag-ht-add-links id ht-w :planned w)
(org-x-dag-ht-add-links id ht-a :planned a)) (org-x-dag-ht-add-links id ht-a :planned a))))))
(->> (either :left "Non overlapping goals") ;; (->> (either :left "Non overlapping goals")
(ht-set this-h id))))))) ;; (ht-set this-h id)))))))
ns))) ns)))
(defun org-x-dag-get-children (adjlist id) (defun org-x-dag-get-children (adjlist id)
@ -2110,24 +2111,32 @@ FUTURE-LIMIT in a list."
(b (or (get-file-buffer f) (find-file-noselect f)))) (b (or (get-file-buffer f) (find-file-noselect f))))
(set-marker (make-marker) p b))) (set-marker (make-marker) p b)))
(defun org-x-dag-format-item (id extra tags dotime)
(let* ((tags* (org-x-dag-prepare-tags tags))
(category (org-x-dag-id->category id))
(level (org-x-dag-id->formatted-level id))
(todo-state (org-x-dag-id->todo id))
(effort (org-x-dag-id->hl-meta-prop id :effort))
;; (head (format "%s %s" todo-state (org-x-dag-id->title id)))
(head (-> (format "%s %s" todo-state (org-x-dag-id->title id))
(org-add-props nil 'effort effort)))
;; (time-str (-some->> time (apply #'format "%02i:%02i ")))
;; (item (org-agenda-format-item extra head level category tags* time-str))
;; NOTE this depends on the buffer position only when using
;; breadcrumbs (which I never do)
(item (org-agenda-format-item extra head level category tags* dotime))
;; TODO why am I getting the priority after sending the headline
;; through some crazy formatting function?
(priority (org-get-priority item)))
(-> (org-x-dag-add-default-props item id)
(org-add-props nil
'todo-state todo-state
'priority priority))))
(defun org-x-dag-format-tag-node (tags id) (defun org-x-dag-format-tag-node (tags id)
(-let* ((tags* (org-x-dag-prepare-tags tags)) (-let* ((marker (org-agenda-new-marker (org-x-dag-id->marker id)))
(category (org-x-dag-id->category id))
(todo-state (org-x-dag-id->todo id))
;; (todo-state (--> (org-x-dag-id->todo id)
;; (org-add-props it nil
;; 'face (org-get-todo-face it))))
;; TODO the only reason this format thing is here is to satisfy
;; `org-agenda-format-item' (which I should probably just rewrite)
(effort (org-x-dag-id->hl-meta-prop id :effort))
(head (-> (format "%s %s" todo-state (org-x-dag-id->title id))
(org-add-props nil 'effort effort)))
(level (org-x-dag-id->formatted-level id))
(marker (org-agenda-new-marker (org-x-dag-id->marker id)))
((ts . ts-type) (org-x-dag-id->agenda-timestamp id)) ((ts . ts-type) (org-x-dag-id->agenda-timestamp id))
;; NOTE this depends on the buffer position only when using (item (org-x-dag-format-item id "" tags nil))
;; breadcrumbs (which I never do)
(item (org-agenda-format-item "" head level category tags*))
(priority (org-get-priority item))) (priority (org-get-priority item)))
(-> (org-x-dag-add-default-props item id) (-> (org-x-dag-add-default-props item id)
(org-add-props nil (org-add-props nil
@ -2139,28 +2148,10 @@ FUTURE-LIMIT in a list."
'org-hd-marker marker 'org-hd-marker marker
'org-marker marker 'org-marker marker
;; headline stuff ;; headline stuff
'todo-state todo-state
'priority priority
'ts-date ts 'ts-date ts
;; misc ;; misc
'type (concat "tagsmatch" ts-type))))) 'type (concat "tagsmatch" ts-type)))))
(defun org-x-dag-format-item (id extra tags time)
(let* ((tags* (org-x-dag-prepare-tags tags))
(category (org-x-dag-id->category id))
(level (org-x-dag-id->formatted-level id))
(todo-state (org-x-dag-id->todo id))
(head (format "%s %s" todo-state (org-x-dag-id->title id)))
(time-str (-some->> time (apply #'format "%02i:%02i ")))
(item (org-agenda-format-item extra head level category tags* time-str))
;; TODO why am I getting the priority after sending the headline
;; through some crazy formatting function?
(priority (org-get-priority item)))
(-> (org-x-dag-add-default-props item id)
(org-add-props nil
'todo-state todo-state
'priority priority))))
(defun org-x-dag-planning-props (id face pos date ts-date type) (defun org-x-dag-planning-props (id face pos date ts-date type)
(list (list
;; face ;; face
@ -2175,48 +2166,57 @@ FUTURE-LIMIT in a list."
'ts-date (org-x-dag-date-to-absolute ts-date) 'ts-date (org-x-dag-date-to-absolute ts-date)
'type type)) 'type type))
(defun org-x-dag-format-scheduled-node (sel-date pos datetime tags id) (defun org-x-dag-format-timestamp-node (sel-date pos datetime tags id
extra-fun face-fun dt-fun)
(declare (indent 5))
(-let* (((this-date this-time) (org-x-dag-datetime-split datetime)) (-let* (((this-date this-time) (org-x-dag-datetime-split datetime))
(time-str (-some->> this-time (apply #'format "%02i:%02i ")))
;; negative diff -> past and vice versa
(diff (org-x-dag-date-diff this-date sel-date)) (diff (org-x-dag-date-diff this-date sel-date))
(pastp (< diff 0)) (extra (funcall extra-fun diff))
(todayp (= diff 0)) (face (funcall face-fun diff))
;; hopefully this is right...if it is this seems silly ((date type) (funcall dt-fun diff this-date))
(extra (-let (((today past) org-agenda-scheduled-leaders))
(cond (todayp today)
(pastp (format past (- diff)))
(t "")))) ;; This should never actually be used
(face (cond (pastp 'org-scheduled-previously)
(todayp 'org-scheduled-today)
(t 'org-scheduled)))
((date type) (if pastp `(,this-date "past-scheduled")
`(,sel-date "scheduled")))
(props (org-x-dag-planning-props id face pos date this-date type))) (props (org-x-dag-planning-props id face pos date this-date type)))
;; NOTE: I don't care about habits, no need to consider them (-> (org-x-dag-format-item id extra tags time-str)
(-> (org-x-dag-format-item id extra tags this-time)
(org-add-props props)))) (org-add-props props))))
(defun org-x-dag-format-scheduled-node (sel-date pos datetime tags id)
(org-x-dag-format-timestamp-node sel-date pos datetime tags id
(lambda (diff)
;; hopefully this is right...if it is this seems silly
(-let (((today past) org-agenda-scheduled-leaders))
(cond
((= 0 diff) today)
((< diff 0) (format past (- diff)))
(t ""))))
(lambda (diff)
(cond
((< diff 0) 'org-scheduled-previously)
((= diff 0) 'org-scheduled-today)
(t 'org-scheduled)))
(lambda (diff this-date)
(if (< diff 0) `(,this-date "past-scheduled")
`(,sel-date "scheduled")))))
(defun org-x-dag-format-deadline-node (sel-date pos datetime tags id) (defun org-x-dag-format-deadline-node (sel-date pos datetime tags id)
(-let* (((this-date this-time) (org-x-dag-datetime-split datetime)) (org-x-dag-format-timestamp-node sel-date pos datetime tags id
(diff (org-x-dag-date-diff this-date sel-date)) (lambda (diff)
(pastp (< diff 0)) (-let* (((now future past) org-agenda-deadline-leaders))
(futurep (< 0 diff)) (cond
(extra (-let* (((now future past) org-agenda-deadline-leaders)) ((< 0 diff) (format future diff))
(cond ((< diff 0) (format past diff))
(futurep (format future diff)) (t now))))
(pastp (format past diff)) ;; TODO the stock deadline formatter uses the warning time to determine this
(t now)))) ;; based on percentage; I'm lazy and don't feel like doing that (now) but I
;; TODO the stock deadline formatter uses the warning time to ;; might in the future
;; determine this based on percentage; I'm lazy and don't feel like (lambda (diff)
;; doing that (now) but I might in the future (cond
(face (cond ((< 5 diff) 'org-upcoming-distant-deadline)
((< 5 diff) 'org-upcoming-distant-deadline) ((< 1 diff) 'org-upcoming-deadline)
((< 1 diff) 'org-upcoming-deadline) (t 'org-warning)))
(t 'org-warning))) (lambda (diff this-date)
((date type) (if futurep `(,sel-date "upcoming-deadline") (if (< 0 diff) `(,sel-date "upcoming-deadline")
`(,this-date "deadline"))) `(,this-date "deadline")))))
(props (org-x-dag-planning-props id face pos date this-date type)))
(-> (org-x-dag-format-item id extra tags this-time)
(org-add-props props))))
;;; ID FUNCTIONS ;;; ID FUNCTIONS
@ -2475,7 +2475,7 @@ FUTURE-LIMIT in a list."
;; agenda/calendar ;; agenda/calendar
(defun org-x-dag-itemize-agenda (sel-date) (defun org-x-dag-itemize-agenda (files sel-date)
(cl-flet* (cl-flet*
((format-timestamps ((format-timestamps
(todayp sel-date id ts get-datetimes-fun format-datetime-fun) (todayp sel-date id ts get-datetimes-fun format-datetime-fun)
@ -2499,22 +2499,33 @@ FUTURE-LIMIT in a list."
(todayp sel-date id ts) (todayp sel-date id ts)
(format-timestamps todayp sel-date id ts (format-timestamps todayp sel-date id ts
#'org-x-dag-get-deadlines-at #'org-x-dag-get-deadlines-at
#'org-x-dag-format-deadline-node))) #'org-x-dag-format-deadline-node))
(let* ((todayp (= (org-x-dag-date-to-absolute sel-date) (org-today))) (with-task-ish
(action (org-x-dag-with-action-ids (id todayp)
(pcase (either-from-right (org-x-dag-id->bs it) nil) (append
(`(:sp-task :task-active ,s) (-when-let (dead (org-x-dag-id->planning-timestamp :deadline id))
(-let (((&plist :sched :dead) s)) (format-deadlines todayp sel-date id dead))
(append (-when-let (sched (org-x-dag-id->planning-timestamp :scheduled id))
(when dead (format-scheduleds todayp sel-date id sched)))))
(format-deadlines todayp sel-date it dead)) (let ((todayp (= (org-x-dag-date-to-absolute sel-date) (org-today))))
(when sched (org-x-dag-with-ids files
(format-scheduleds todayp sel-date it sched)))))))) (pcase (either-from-right (org-x-dag-id->bs it) nil)
(daily (org-x-dag-with-ids (org-x-dag->dlp-ids) (`(:daily :active (:sched ,sched))
(pcase (either-from-right (org-x-dag-id->bs it) nil) (-when-let (datetime (org-ml-timestamp-get-start-time sched))
(`(:daily :active (:sched ,sched)) (when (org-x-dag-datetime= sel-date (-take 3 datetime))
(format-scheduleds todayp sel-date it sched)))))) (format-scheduleds todayp sel-date it sched))))
(append action daily)))) (`(:daily :complete ,_)
(-when-let (sched (org-x-dag-id->planning-timestamp :scheduled it))
(when (org-x-dag-datetime= sel-date (-take 3 (org-ml-timestamp-get-start-time sched)))
(format-scheduleds todayp sel-date it sched))))
(`(:sp-task :task-active ,_)
(with-task-ish it todayp))
(`(:sp-task :task-complete ,_)
(with-task-ish it todayp))
(`(:sp-subiter :si-active ,_)
(with-task-ish it todayp))
(`(:sp-subiter :si-complete ,_)
(with-task-ish it todayp)))))))
;;; BUFFER MANIPULATION ;;; BUFFER MANIPULATION
@ -3489,7 +3500,7 @@ FUTURE-LIMIT in a list."
(-let ((completion-ignore-case t) (-let ((completion-ignore-case t)
;; TODO not sure if this if thing is actually necessary ;; TODO not sure if this if thing is actually necessary
((arg start-day span with-hour) (or org-agenda-overriding-arguments ((arg start-day span with-hour) (or org-agenda-overriding-arguments
(list nil start-day 'day nil)))) (list nil start-day 'day nil))))
(catch 'exit (catch 'exit
(org-agenda-prepare "DAG-DAILY") (org-agenda-prepare "DAG-DAILY")
(org-compile-prefix-format 'agenda) (org-compile-prefix-format 'agenda)
@ -3500,7 +3511,7 @@ FUTURE-LIMIT in a list."
(org-agenda-redo-command (org-agenda-redo-command
`(org-x-dag-show-daily-nodes 'nil ,start-day ',span ,with-hour)) `(org-x-dag-show-daily-nodes 'nil ,start-day ',span ,with-hour))
((m d y) (calendar-gregorian-from-absolute sd)) ((m d y) (calendar-gregorian-from-absolute sd))
(rtnall (org-x-dag-itemize-agenda `(,y ,m ,d)))) (rtnall (org-x-dag-itemize-agenda org-agenda-files `(,y ,m ,d))))
(setq-local org-starting-day sd) (setq-local org-starting-day sd)
(setq-local org-arg-loc arg) (setq-local org-arg-loc arg)
;; TODO just day (for now) ;; TODO just day (for now)
@ -3557,6 +3568,22 @@ The title will have the form 'LEVEL1.LEVEL2 STATUS (SUBTITLE)'."
(s-titleize)))) (s-titleize))))
(format "%s.%s %s (%s)" level1 level2 status* subtitle))) (format "%s.%s %s (%s)" level1 level2 status* subtitle)))
(defun org-x-dag-run-series-advice (fun name settings)
(nd/with-advice
((#'org-agenda-list :override #'org-x-dag-show-daily-nodes))
;; TODO why the if?
(-if-let (org-agenda-files (->> (nth 1 settings)
(alist-get 'org-agenda-files)
(car)
(eval)))
(funcall fun name settings)
(funcall fun name settings))))
(defun org-x-dag-set-series-advice (on?)
(let ((f #'org-agenda-run-series)
(a #'org-x-dag-run-series-advice))
(if on? (advice-add f :around a) (advice-remove f a))))
;; agenda views ;; agenda views
(defun org-x-dag-agenda-timeblock () (defun org-x-dag-agenda-timeblock ()
@ -3567,7 +3594,10 @@ In the order of display
2. daily calendar (for thing that begin today at a specific time) 2. daily calendar (for thing that begin today at a specific time)
3. evening tasks (to do immediately before sleeping)" 3. evening tasks (to do immediately before sleeping)"
(interactive) (interactive)
(let ((org-agenda-sorting-strategy '(time-up deadline-up scheduled-up category-keep)) (let ((files (cons (org-x-dag->planning-file :daily)
(org-x-dag->action-files))))
(org-x-dag-agenda-call "Timeblock" nil 'agenda "" files
`((org-agenda-sorting-strategy '(time-up deadline-up scheduled-up category-keep))
(org-super-agenda-groups (org-super-agenda-groups
`(,(nd/org-def-super-agenda-pred "Morning routine" `(,(nd/org-def-super-agenda-pred "Morning routine"
(org-x-headline-has-property org-x-prop-routine (org-x-headline-has-property org-x-prop-routine
@ -3577,9 +3607,25 @@ In the order of display
(org-x-headline-has-property org-x-prop-routine (org-x-headline-has-property org-x-prop-routine
org-x-prop-routine-evening) org-x-prop-routine-evening)
:order 3) :order 3)
(:name "Calendar" :order 1 :time-grid t) (:name "Calendar" :order 1 :time-grid t
(:discard (:anything t))))) :transformer (if (equal (get-text-property 1 'org-category it) "daily")
(org-x-dag-show-daily-nodes))) (propertize it 'face 'org-todo)
it))))))))
;; (:discard (:anything t))))))))
;; (let ((org-agenda-sorting-strategy '(time-up deadline-up scheduled-up category-keep))
;; (org-super-agenda-groups
;; `(,(nd/org-def-super-agenda-pred "Morning routine"
;; (org-x-headline-has-property org-x-prop-routine
;; org-x-prop-routine-morning)
;; :order 0)
;; ,(nd/org-def-super-agenda-pred "Evening routine"
;; (org-x-headline-has-property org-x-prop-routine
;; org-x-prop-routine-evening)
;; :order 3)
;; (:name "Calendar" :order 1 :time-grid t)
;; (:discard (:anything t)))))
;; (org-x-dag-show-daily-nodes)))
;; (defun org-x-dag-agenda-goals () ;; (defun org-x-dag-agenda-goals ()
;; (interactive) ;; (interactive)