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

218
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-tag-node (tags id) (defun org-x-dag-format-item (id extra tags dotime)
(-let* ((tags* (org-x-dag-prepare-tags tags)) (let* ((tags* (org-x-dag-prepare-tags tags))
(category (org-x-dag-id->category id)) (category (org-x-dag-id->category id))
(level (org-x-dag-id->formatted-level id))
(todo-state (org-x-dag-id->todo 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)) (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)) (head (-> (format "%s %s" todo-state (org-x-dag-id->title id))
(org-add-props nil 'effort effort))) (org-add-props nil 'effort effort)))
(level (org-x-dag-id->formatted-level id)) ;; (time-str (-some->> time (apply #'format "%02i:%02i ")))
(marker (org-agenda-new-marker (org-x-dag-id->marker id))) ;; (item (org-agenda-format-item extra head level category tags* time-str))
((ts . ts-type) (org-x-dag-id->agenda-timestamp id))
;; NOTE this depends on the buffer position only when using ;; NOTE this depends on the buffer position only when using
;; breadcrumbs (which I never do) ;; breadcrumbs (which I never do)
(item (org-agenda-format-item "" head level category tags*)) (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)
(-let* ((marker (org-agenda-new-marker (org-x-dag-id->marker id)))
((ts . ts-type) (org-x-dag-id->agenda-timestamp id))
(item (org-x-dag-format-item id "" tags nil))
(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-deadline-node (sel-date pos datetime tags id) (defun org-x-dag-format-scheduled-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)) ;; hopefully this is right...if it is this seems silly
(futurep (< 0 diff)) (-let (((today past) org-agenda-scheduled-leaders))
(extra (-let* (((now future past) org-agenda-deadline-leaders))
(cond (cond
(futurep (format future diff)) ((= 0 diff) today)
(pastp (format past diff)) ((< 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)
(org-x-dag-format-timestamp-node sel-date pos datetime tags id
(lambda (diff)
(-let* (((now future past) org-agenda-deadline-leaders))
(cond
((< 0 diff) (format future diff))
((< diff 0) (format past diff))
(t now)))) (t now))))
;; TODO the stock deadline formatter uses the warning time to ;; TODO the stock deadline formatter uses the warning time to determine this
;; determine this based on percentage; I'm lazy and don't feel like ;; based on percentage; I'm lazy and don't feel like doing that (now) but I
;; doing that (now) but I might in the future ;; might in the future
(face (cond (lambda (diff)
(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)))
((date type) (if futurep `(,sel-date "upcoming-deadline") (lambda (diff this-date)
`(,this-date "deadline"))) (if (< 0 diff) `(,sel-date "upcoming-deadline")
(props (org-x-dag-planning-props id face pos date this-date type))) `(,this-date "deadline")))))
(-> (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)
(`(:sp-task :task-active ,s)
(-let (((&plist :sched :dead) s))
(append (append
(when dead (-when-let (dead (org-x-dag-id->planning-timestamp :deadline id))
(format-deadlines todayp sel-date it dead)) (format-deadlines todayp sel-date id dead))
(when sched (-when-let (sched (org-x-dag-id->planning-timestamp :scheduled id))
(format-scheduleds todayp sel-date it sched)))))))) (format-scheduleds todayp sel-date id sched)))))
(daily (org-x-dag-with-ids (org-x-dag->dlp-ids) (let ((todayp (= (org-x-dag-date-to-absolute sel-date) (org-today))))
(org-x-dag-with-ids files
(pcase (either-from-right (org-x-dag-id->bs it) nil) (pcase (either-from-right (org-x-dag-id->bs it) nil)
(`(:daily :active (:sched ,sched)) (`(:daily :active (:sched ,sched))
(format-scheduleds todayp sel-date it sched)))))) (-when-let (datetime (org-ml-timestamp-get-start-time sched))
(append action daily)))) (when (org-x-dag-datetime= sel-date (-take 3 datetime))
(format-scheduleds todayp sel-date it sched))))
(`(: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
@ -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)