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

FIX daily agenda parsing bugs

This commit is contained in:
Nathan Dwarshuis 2022-02-06 20:42:21 -05:00
parent 2a1aafbeaa
commit b7c057026e
1 changed files with 38 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -475,7 +475,7 @@ encountered will be returned."
(defun org-x-dag-time-shift (datetime shift unit) (defun org-x-dag-time-shift (datetime shift unit)
(cl-flet* (cl-flet*
((enc-dec-long ((enc-dec-long
(y m d M H) (y m d H M)
(-let (((_ M* H* d* m* y* _ _ _) (-let (((_ M* H* d* m* y* _ _ _)
(->> (list 0 M H d m y nil nil (current-time-zone)) (->> (list 0 M H d m y nil nil (current-time-zone))
(encode-time) (encode-time)
@ -625,18 +625,23 @@ FUTURE-LIMIT in a list."
'priority priority)))) '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 (cl-flet
;; face ((to-abs
'face (if (org-x-dag-id->is-done-p id) 'org-agenda-done face) (date)
'undone-face face (->> (org-x-dag-date-to-gregorian date)
'done-face 'org-agenda-done (calendar-absolute-from-gregorian))))
;; marker (list
'org-hd-marker (org-agenda-new-marker) ;; face
'org-marker (org-agenda-new-marker pos) 'face (if (org-x-dag-id->is-done-p id) 'org-agenda-done face)
;; headline stuff 'undone-face face
'date (org-x-dag-date-to-gregorian date) 'done-face 'org-agenda-done
'ts-date (org-x-dag-date-to-gregorian ts-date) ;; marker
'type type)) 'org-hd-marker (org-agenda-new-marker)
'org-marker (org-agenda-new-marker pos)
;; headline stuff
'date (to-abs date)
'ts-date (to-abs ts-date)
'type type)))
(defun org-x-dag-format-scheduled-node (sel-date pos datetime category tags id) (defun org-x-dag-format-scheduled-node (sel-date pos datetime category tags id)
(-let* (((this-date this-time) (org-x-dag-time-partition datetime)) (-let* (((this-date this-time) (org-x-dag-time-partition datetime))
@ -1131,32 +1136,36 @@ FUTURE-LIMIT in a list."
(defun org-x-dag-scan-agenda (sel-date) (defun org-x-dag-scan-agenda (sel-date)
(cl-flet* (cl-flet*
((format-timestamps ((format-timestamps
(sel-date cat id pts get-datetimes-fun format-datetime-fun) (todayp 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 ((tags (org-x-dag-id->tags t org-file-tags id))) (let ((tags (org-x-dag-id->tags t org-file-tags id)))
(unless (member org-x-tag-incubated tags) (unless (member org-x-tag-incubated tags)
(-let (((&plist :pos) pts) (-let (((&plist :pos) pts)
(donep (org-x-dag-id->is-done-p id))) (donep (org-x-dag-id->is-done-p id)))
(->> datetimes (--> datetimes
(--remove (and donep (not (org-x-dag-date= (-take 3 it) sel-date)))) (--remove (and donep (not (org-x-dag-date= (-take 3 it) sel-date))) it)
(--map (funcall format-datetime-fun sel-date pos it cat tags id)))))))) (if (not todayp) (--remove (org-x-dag-date< (-take 3 it) sel-date) it) it)
(--map (funcall format-datetime-fun sel-date pos it cat tags id) it)))))))
(format-id (format-id
(cat id) (todayp 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 (append
(when dead (when dead
(format-timestamps sel-date cat id dead (format-timestamps todayp sel-date cat id dead
#'org-x-dag-get-deadlines-at #'org-x-dag-get-deadlines-at
#'org-x-dag-format-deadline-node)) #'org-x-dag-format-deadline-node))
(when sched (when sched
(format-timestamps sel-date cat id sched (format-timestamps todayp sel-date cat id sched
#'org-x-dag-get-scheduled-at #'org-x-dag-get-scheduled-at
#'org-x-dag-format-scheduled-node)))))))) #'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
(format-id it-category it)))) (let ((todayp (->> (org-x-dag-date-to-gregorian sel-date)
(calendar-absolute-from-gregorian)
(= (org-today)))))
(format-id todayp it-category it)))))
;;; AGENDA VIEWS ;;; AGENDA VIEWS
@ -1199,27 +1208,26 @@ FUTURE-LIMIT in a list."
(setq buffer-read-only t))))) (setq buffer-read-only t)))))
;; make the signature exactly like `org-agenda-list' ...for now ;; make the signature exactly like `org-agenda-list' ...for now
(defun org-x-dag-show-daily-nodes (&optional arg start-day span with-hour) (defun org-x-dag-show-daily-nodes (&optional _ start-day _ _)
(org-x-dag-sync) (org-x-dag-sync)
;; TODO not sure if this is actually necessary (-let ((completion-ignore-case t)
(when org-agenda-overriding-arguments ;; TODO not sure if this if thing is actually necessary
(-setq (arg start-day span) org-agenda-overriding-arguments)) ((arg start-day span with-hour) (or org-agenda-overriding-arguments
(let* ((org-tags-match-list-sublevels org-tags-match-list-sublevels) (list nil start-day 'day nil))))
(completion-ignore-case t))
(catch 'exit (catch 'exit
(org-agenda-prepare "DAG-DAILY") (org-agenda-prepare "DAG-DAILY")
(org-compile-prefix-format 'agenda) (org-compile-prefix-format 'agenda)
(org-set-sorting-strategy 'agenda) (org-set-sorting-strategy 'agenda)
(-let* ((today (org-today)) (-let* ((today (org-today))
(sd (or start-day today)) (sd (or start-day today))
(org-agenda-redo-command `(org-x-dag-show-daily-nodes (org-agenda-redo-command
',arg ,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-scan-agenda `(,y ,m ,d)))) (rtnall (org-x-dag-scan-agenda `(,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)
(setq-local org-agenda-current-span 'day) (setq-local org-agenda-current-span span)
(org-agenda--insert-overriding-header (org-agenda--insert-overriding-header
(with-temp-buffer (with-temp-buffer
(insert (format "Agenda for %d-%02d-%02d: \n" y m d)) (insert (format "Agenda for %d-%02d-%02d: \n" y m d))