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

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

@ -417,16 +417,16 @@ encountered will be returned."
('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)))
(pcase unit
('week (* 7 value))
('day value)
((or 'hour 'minute) (message "WARNING: ..."))
(_ (error)))))))
(convert-unit
(unit)
@ -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
(unless (org-x-dag-date< future-limit datetime)
(pcase rep
(`nil
(unless (org-x-dag-date< future-limit time)
(list time)))
(`nil `(,datetime))
(`(,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)))))
(->> (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,18 +1133,20 @@ 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 ((tags (org-x-dag-id->tags t org-file-tags id)))
(unless (member org-x-tag-incubated tags)
(-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))))))
(--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
(append
(when dead
(format-timestamps sel-date cat id dead
#'org-x-dag-get-deadlines-at
#'org-x-dag-format-deadline-node))
@ -1148,8 +1156,7 @@ encountered will be returned."
#'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