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

ADD dagified agenda view

This commit is contained in:
Nathan Dwarshuis 2022-02-05 17:34:18 -05:00
parent 78946d1968
commit 1a3a178f90
1 changed files with 100 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -413,21 +413,21 @@ encountered will be returned."
((convert-value ((convert-value
(islongp value unit) (islongp value unit)
(pcase unit (pcase unit
('year (* 12 value)) ('year (* 12 value))
('month value) ('month value)
(_ (if islongp (_ (if islongp
;; TODO make these messages not suck ;; TODO make these messages not suck
(pcase unit (pcase unit
('week (* 7 value)) ('week (* 7 1440 value))
('day value) ('day (* 1440 value))
((or 'hour 'minute) (message "WARNING: ...")) ('hour (* 60 value))
(_ (error))) ('minute value)
(pcase unit (_ (error)))
('week (* 7 1440 value)) (pcase unit
('day (* 1440 value)) ('week (* 7 value))
('hour (* 60 value)) ('day value)
('minute value) ((or 'hour 'minute) (message "WARNING: ..."))
(_ (error))))))) (_ (error)))))))
(convert-unit (convert-unit
(unit) (unit)
(if (memq unit '(year month)) 'month 'submonth))) (if (memq unit '(year month)) 'month 'submonth)))
@ -494,7 +494,8 @@ encountered will be returned."
('month (enc-dec-long y (+ m shift) d H M)) ('month (enc-dec-long y (+ m shift) d H M))
('submonth (enc-dec-long y m d H (+ M shift)))))))) ('submonth (enc-dec-long y m d H (+ M shift))))))))
(defun org-x-dag-repeater-get-next (cur time shift shifttype reptype) (defun org-x-dag-repeater-get-next (sel-datetime datetime shift shifttype reptype)
"Return the next timestamp repeater of DATETIME."
(pcase reptype (pcase reptype
('catch-up ('catch-up
;; Next time is a multiple of repeater in the future relative to the base ;; Next time is a multiple of repeater in the future relative to the base
@ -502,31 +503,36 @@ encountered will be returned."
;; (DST, leap year, different days in each month, etc). Think of this like ;; (DST, leap year, different days in each month, etc). Think of this like
;; a path function from p-chem; shifting 3 months once might be different ;; a path function from p-chem; shifting 3 months once might be different
;; than shifting by 1 month three times. ;; than shifting by 1 month three times.
(let ((next time)) (let ((next datetime)
(while (org-x-dag-date< next cur) (pastp t))
(setq next (org-x-dag-time-shift next shift shifttype))) (while pastp
(setq next (org-x-dag-time-shift next shift shifttype)
pastp (org-x-dag-date< next sel-datetime)))
next)) next))
('restart ('restart
;; Next time is one repeater interval after now ;; Next time is one repeater interval after now
;; ;;
;; TODO cur needs to match the length of time ;; ASSUME cur needs to match the length of time
(org-x-dag-time-shift cur shift shifttype)) (org-x-dag-time-shift sel-datetime shift shifttype))
('cumulate ('cumulate
;; Next time is one repeater interval after the base timestamp ;; Next time is one repeater interval after the base timestamp
(org-x-dag-time-shift time shift shifttype)))) (org-x-dag-time-shift datetime shift shifttype))))
(defun org-x-dag-unfold-timestamp (cur time rep future-limit) (defun org-x-dag-unfold-timestamp (cur datetime rep future-limit)
"Return all timestamps associated with DATETIME.
If REP is nil, return a singleton list just containing DATETIME.
If REP is non-nil, return DATETIME and all repeaters up until
FUTURE-LIMIT in a list."
;; ASSUME pts and future-limit are both long or short timestamps ;; ASSUME pts and future-limit are both long or short timestamps
(pcase rep (unless (org-x-dag-date< future-limit datetime)
(`nil (pcase rep
(unless (org-x-dag-date< future-limit time) (`nil `(,datetime))
(list time))) (`(,value ,unit ,reptype)
(`(,value ,unit ,reptype) (->> (org-x-dag-repeater-get-next cur datetime value unit reptype)
(->> (org-x-dag-repeater-get-next cur time value unit reptype) (--unfold (unless (org-x-dag-date< future-limit it)
(--unfold (let ((next (org-x-dag-time-shift it value unit))) (cons it (org-x-dag-time-shift it value unit))))
(unless (org-x-dag-date< future-limit next) (cons datetime))))))
(cons next next))))
(cons time)))))
(defun org-x-dag-date-add-time (date) (defun org-x-dag-date-add-time (date)
(-let (((_ M H) (decode-time (current-time)))) (-let (((_ M H) (decode-time (current-time))))
@ -1127,29 +1133,30 @@ encountered will be returned."
((format-timestamps ((format-timestamps
(sel-date cat id pts get-datetimes-fun format-datetime-fun) (sel-date cat id pts get-datetimes-fun format-datetime-fun)
(-when-let (datetimes (funcall get-datetimes-fun sel-date pts)) (-when-let (datetimes (funcall get-datetimes-fun sel-date pts))
(-let (((&plist :pos) pts) (let ((tags (org-x-dag-id->tags t org-file-tags id)))
(tags (org-x-dag-id->tags t org-file-tags id)) (unless (member org-x-tag-incubated tags)
(donep (org-x-dag-id->is-done-p id))) (-let (((&plist :pos) pts)
(->> datetimes (donep (org-x-dag-id->is-done-p id)))
(--remove (and donep (not (org-x-dag-date= (-take 3 it) sel-date)))) (->> datetimes
(--map (funcall format-datetime-fun sel-date pos it cat tags id)))))) (--remove (and donep (not (org-x-dag-date= (-take 3 it) sel-date))))
(--map (funcall format-datetime-fun sel-date pos it cat tags id))))))))
(format-id (format-id
(cat id) (cat id)
(org-x-dag-with-key id (org-x-dag-with-key id
(-when-let (res (org-x-dag-headline-get-planning)) (-when-let (res (org-x-dag-headline-get-planning))
(-let (((dead sched) res)) (-let (((dead sched) res))
(append (when dead (append
(format-timestamps sel-date cat id dead (when dead
#'org-x-dag-get-deadlines-at (format-timestamps sel-date cat id dead
#'org-x-dag-format-deadline-node)) #'org-x-dag-get-deadlines-at
(when sched #'org-x-dag-format-deadline-node))
(format-timestamps sel-date cat id sched (when sched
#'org-x-dag-get-scheduled-at (format-timestamps sel-date cat id sched
#'org-x-dag-format-scheduled-node)))))))) #'org-x-dag-get-scheduled-at
#'org-x-dag-format-scheduled-node))))))))
(org-x-dag-with-files (org-x-get-action-files) (org-x-dag-with-files (org-x-get-action-files)
nil nil
(org-x-dag-with-key it (format-id it-category it))))
(format-id it-category it)))))
;;; AGENDA VIEWS ;;; AGENDA VIEWS
@ -1191,5 +1198,49 @@ encountered will be returned."
(org-agenda-finalize) (org-agenda-finalize)
(setq buffer-read-only t))))) (setq buffer-read-only t)))))
;; make the signature exactly like `org-agenda-list' ...for now
(defun org-x-dag-show-daily-nodes (&optional arg start-day span with-hour)
(org-x-dag-sync)
;; TODO not sure if this is actually necessary
(when org-agenda-overriding-arguments
(-setq (arg start-day span) org-agenda-overriding-arguments))
(let* ((org-tags-match-list-sublevels org-tags-match-list-sublevels)
(completion-ignore-case t))
(catch 'exit
(org-agenda-prepare "DAG-DAILY")
(org-compile-prefix-format 'agenda)
(org-set-sorting-strategy 'agenda)
(-let* ((today (org-today))
(sd (or start-day today))
(org-agenda-redo-command `(org-x-dag-show-daily-nodes
',arg ,start-day ',span ,with-hour))
((m d y) (calendar-gregorian-from-absolute sd))
(rtnall (org-x-dag-scan-agenda `(,y ,m ,d))))
(setq-local org-starting-day sd)
(setq-local org-arg-loc arg)
;; TODO just day (for now)
(setq-local org-agenda-current-span 'day)
(org-agenda--insert-overriding-header
(with-temp-buffer
(insert (format "Agenda for %d-%02d-%02d: \n" y m d))
(add-text-properties (point-min) (1- (point))
(list 'face 'org-agenda-structure))
(buffer-string)))
(org-agenda-mark-header-line (point-min))
;; TODO handle time grid here somehow
(-some--> (org-agenda-add-time-grid-maybe rtnall 1 (= sd today))
(org-agenda-finalize-entries it 'agenda)
(insert it "\n"))
(goto-char (point-min))
(or org-agenda-multi (org-agenda-fit-window-to-buffer))
(add-text-properties
(point-min) (point-max)
`(org-agenda-type agenda
org-last-args (,arg ,start-day ,span)
org-redo-cmd ,org-agenda-redo-command
org-series-cmd ,org-cmd))
(org-agenda-finalize)
(setq buffer-read-only t)))))
(provide 'org-x-dag) (provide 'org-x-dag)
;;; org-x-dag.el ends here ;;; org-x-dag.el ends here