From 1a3a178f90c9863d97aa6cdfb68ce902d88a9789 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 5 Feb 2022 17:34:18 -0500 Subject: [PATCH] ADD dagified agenda view --- local/lib/org-x/org-x-dag.el | 149 +++++++++++++++++++++++------------ 1 file changed, 100 insertions(+), 49 deletions(-) diff --git a/local/lib/org-x/org-x-dag.el b/local/lib/org-x/org-x-dag.el index 9ccfc4f..e6eb4b7 100644 --- a/local/lib/org-x/org-x-dag.el +++ b/local/lib/org-x/org-x-dag.el @@ -413,21 +413,21 @@ encountered will be returned." ((convert-value (islongp value unit) (pcase unit - ('year (* 12 value)) - ('month value) - (_ (if islongp - ;; TODO make these messages not suck - (pcase unit - ('week (* 7 value)) - ('day value) - ((or 'hour 'minute) (message "WARNING: ...")) - (_ (error))) - (pcase unit - ('week (* 7 1440 value)) - ('day (* 1440 value)) - ('hour (* 60 value)) - ('minute value) - (_ (error))))))) + ('year (* 12 value)) + ('month value) + (_ (if islongp + ;; TODO make these messages not suck + (pcase unit + ('week (* 7 1440 value)) + ('day (* 1440 value)) + ('hour (* 60 value)) + ('minute value) + (_ (error))) + (pcase unit + ('week (* 7 value)) + ('day value) + ((or 'hour 'minute) (message "WARNING: ...")) + (_ (error))))))) (convert-unit (unit) (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)) ('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 ('catch-up ;; 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 ;; a path function from p-chem; shifting 3 months once might be different ;; than shifting by 1 month three times. - (let ((next time)) - (while (org-x-dag-date< next cur) - (setq next (org-x-dag-time-shift next shift shifttype))) + (let ((next datetime) + (pastp t)) + (while pastp + (setq next (org-x-dag-time-shift next shift shifttype) + pastp (org-x-dag-date< next sel-datetime))) next)) ('restart ;; Next time is one repeater interval after now ;; - ;; TODO cur needs to match the length of time - (org-x-dag-time-shift cur shift shifttype)) + ;; ASSUME cur needs to match the length of time + (org-x-dag-time-shift sel-datetime shift shifttype)) ('cumulate ;; 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 - (pcase rep - (`nil - (unless (org-x-dag-date< future-limit time) - (list time))) - (`(,value ,unit ,reptype) - (->> (org-x-dag-repeater-get-next cur time value unit reptype) - (--unfold (let ((next (org-x-dag-time-shift it value unit))) - (unless (org-x-dag-date< future-limit next) - (cons next next)))) - (cons time))))) + (unless (org-x-dag-date< future-limit datetime) + (pcase rep + (`nil `(,datetime)) + (`(,value ,unit ,reptype) + (->> (org-x-dag-repeater-get-next cur datetime value unit reptype) + (--unfold (unless (org-x-dag-date< future-limit it) + (cons it (org-x-dag-time-shift it value unit)))) + (cons datetime)))))) (defun org-x-dag-date-add-time (date) (-let (((_ M H) (decode-time (current-time)))) @@ -1127,29 +1133,30 @@ encountered will be returned." ((format-timestamps (sel-date cat id pts get-datetimes-fun format-datetime-fun) (-when-let (datetimes (funcall get-datetimes-fun sel-date pts)) - (-let (((&plist :pos) pts) - (tags (org-x-dag-id->tags t org-file-tags id)) - (donep (org-x-dag-id->is-done-p id))) - (->> datetimes - (--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)))))) + (let ((tags (org-x-dag-id->tags t org-file-tags id))) + (unless (member org-x-tag-incubated tags) + (-let (((&plist :pos) pts) + (donep (org-x-dag-id->is-done-p id))) + (->> datetimes + (--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 (cat id) (org-x-dag-with-key id (-when-let (res (org-x-dag-headline-get-planning)) (-let (((dead sched) res)) - (append (when dead - (format-timestamps sel-date cat id dead - #'org-x-dag-get-deadlines-at - #'org-x-dag-format-deadline-node)) - (when sched - (format-timestamps sel-date cat id sched - #'org-x-dag-get-scheduled-at - #'org-x-dag-format-scheduled-node)))))))) + (append + (when dead + (format-timestamps sel-date cat id dead + #'org-x-dag-get-deadlines-at + #'org-x-dag-format-deadline-node)) + (when sched + (format-timestamps sel-date cat id sched + #'org-x-dag-get-scheduled-at + #'org-x-dag-format-scheduled-node)))))))) (org-x-dag-with-files (org-x-get-action-files) nil - (org-x-dag-with-key it - (format-id it-category it))))) + (format-id it-category it)))) ;;; AGENDA VIEWS @@ -1191,5 +1198,49 @@ encountered will be returned." (org-agenda-finalize) (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) ;;; org-x-dag.el ends here