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

ADD agenda scanner

This commit is contained in:
Nathan Dwarshuis 2022-02-04 18:59:37 -05:00
parent 04c177216c
commit 8fdec11d79
1 changed files with 290 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -173,7 +173,8 @@ has a valid (meaning in KWS) keyword and either its parent has a
valid keyword or none of its parents have valid keywords." valid keyword or none of its parents have valid keywords."
(let ((more t) (let ((more t)
cur-path this-point this-key this-level this-todo has-todo this-parent cur-path this-point this-key this-level this-todo has-todo this-parent
tags this-file-links acc acc-meta this-parent-key) this-tags this-meta all-tags this-file-links this-links acc acc-meta
this-parent-key)
;; TODO add org-mode sanity check ;; TODO add org-mode sanity check
(goto-char (point-min)) (goto-char (point-min))
;; If not on a headline, check for a property drawer with links in it ;; If not on a headline, check for a property drawer with links in it
@ -219,20 +220,22 @@ valid keyword or none of its parents have valid keywords."
;; If parent is not a todo and we want tag inheritance, store all tags ;; If parent is not a todo and we want tag inheritance, store all tags
;; above this headline (sans file-tags which we can get later easily) ;; above this headline (sans file-tags which we can get later easily)
;; (org-entry-get nil org-x-prop-parent-type) ;; (org-entry-get nil org-x-prop-parent-type)
(setq tags (if (and (not this-parent-key) org-use-tag-inheritance) (setq all-tags (if (and (not this-parent-key)
(->> cur-path org-use-tag-inheritance)
(--mapcat (nth 2 it)) (->> cur-path
(append this-tags)) (--mapcat (nth 2 it))
this-tags) (append this-tags))
this-tags)
this-links (or (org-x-dag-get-link-property)
(when (not this-parent-key) this-file-links))
this-meta (org-x-dag-build-meta file this-meta (org-x-dag-build-meta file
this-point this-point
this-level this-level
(substring-no-properties this-todo) (substring-no-properties this-todo)
tags all-tags
this-parent-key)) this-parent-key))
(!cons (cons this-key this-meta) acc-meta) (!cons (cons this-key this-meta) acc-meta)
(!cons (cons this-key (append (list (nth 1 this-parent)) (!cons (cons this-key (append (list (nth 1 this-parent)) this-links))
(org-x-dag-get-link-property)))
acc)) acc))
;; Add current headline to stack ;; Add current headline to stack
(!cons (list this-level this-key this-tags) cur-path))) (!cons (list this-level this-key this-tags) cur-path)))
@ -399,6 +402,162 @@ encountered will be returned."
(-when-let (p (save-excursion (re-search-forward re end t))) (-when-let (p (save-excursion (re-search-forward re end t)))
(list (1- (match-beginning 1)) (match-string 1))))) (list (1- (match-beginning 1)) (match-string 1)))))
(defun org-x-dag-timestamp-to-absolute (ts)
(->> (org-ml-get-properties '(:month-start :day-start :year-start) ts)
(calendar-absolute-from-gregorian)))
;; TODO 'modulus' only applies to the repeater
(defun org-ml-timestamp-extract-modulus (modtype ts)
"Return the modulus of timestamp TS for MODTYPE."
(cl-flet
((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)))))))
(convert-unit
(unit)
(if (memq unit '(year month)) 'month 'submonth)))
(-let* ((props (pcase modtype
('warning '(:warning-value :warning-unit :warning-type))
('repeater '(:repeater-value :repeater-unit :repeater-type))))
(islongp (->> (org-ml-timestamp-get-start-time ts)
(org-ml-time-is-long))))
(-when-let ((value unit type) (org-ml-get-properties props ts))
(let ((v (convert-value islongp value unit))
(u (convert-unit unit)))
`(,v ,u ,type))))))
(defun org-x-dag-partition-timestamp (ts)
(list :datetime (org-ml-timestamp-get-start-time ts)
:pos (org-ml-get-property :begin ts)
:repeater (org-ml-timestamp-extract-modulus 'repeater ts)
:warning (org-ml-timestamp-extract-modulus 'warning ts)))
(defmacro org-x-dag-with-times (datetime0 datetime1 form)
;; ASSUME all digits in this comparison are on the calendar/clock (eg day 32
;; does not 'rollover' to day 1 on the next month)
(declare (indent 2))
`(if (or (and (org-ml-time-is-long ,datetime0)
(org-ml-time-is-long ,datetime1))
(not (or (org-ml-time-is-long ,datetime0)
(org-ml-time-is-long ,datetime1))))
,form
(error "Datetimes are invalid lengths: %S and %S" ,datetime0 ,datetime1)))
;; TODO this function name sucks, call it datetime
(defun org-x-dag-date< (datetime0 datetime1)
(org-x-dag-with-times datetime0 datetime1
(-when-let (next (->> (-zip-with #'cons datetime0 datetime1)
(--drop-while (= (car it) (cdr it)))
(car)))
(< (car next) (cdr next)))))
(defun org-x-dag-date= (datetime0 datetime1)
(org-x-dag-with-times datetime0 datetime1
(->> (-zip-with #'cons datetime0 datetime1)
(--drop-while (= (car it) (cdr it)))
(not))))
(defun org-x-dag-time-shift (datetime shift unit)
(cl-flet*
((enc-dec-long
(y m d M H)
(-let (((_ M* H* d* m* y* _ _ _)
(->> (list 0 M H d m y nil nil (current-time-zone))
(encode-time)
(decode-time))))
(list y* m* d* H* M*)))
(enc-dec-short
(y m d)
(-take 3 (enc-dec-long y m d 0 0))))
(pcase datetime
((or `(,y ,m ,d) `(,y ,m ,d nil nil))
(pcase unit
('month (enc-dec-short y (+ m shift) d))
('submonth (enc-dec-short y m (+ d shift)))))
(`(,y ,m ,d ,H ,M)
(pcase unit
('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)
(pcase reptype
('catch-up
;; Next time is a multiple of repeater in the future relative to the base
;; time; shift one interval at a time since they may not be spaced evenly
;; (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)))
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))
('cumulate
;; Next time is one repeater interval after the base timestamp
(org-x-dag-time-shift time shift shifttype))))
(defun org-x-dag-unfold-timestamp (cur time rep future-limit)
;; 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)))))
(defun org-x-dag-date-add-time (date)
(-let (((_ M H) (decode-time (current-time))))
`(,@date ,H ,M)))
(defun org-x-dag-get-scheduled-at (sel-date pts)
(-let* (((&plist :datetime d :repeater r) pts)
(islongp (org-ml-time-is-long d))
(future-limit (if islongp `(,@sel-date 23 59) sel-date))
(sel-datetime (if islongp (org-x-dag-date-add-time sel-date) sel-date)))
(org-x-dag-unfold-timestamp sel-datetime d r future-limit)))
(defun org-x-dag-get-deadlines-at (sel-date pts)
(-let* (((&plist :datetime d :repeater r :warning w) pts)
(islongp (org-ml-time-is-long d))
((warn-shift warn-shifttype)
(if w w
(let ((f (if islongp 1440 1)))
`(,(* f org-deadline-warning-days) submonth))))
(sel-datetime (if islongp (org-x-dag-date-add-time sel-date) sel-date))
(future-limit (org-x-dag-time-shift sel-datetime warn-shift warn-shifttype)))
(org-x-dag-unfold-timestamp sel-datetime d r future-limit)))
(defun org-x-dag-headline-get-planning ()
(let ((end (save-excursion (outline-next-heading))))
(save-excursion
(when (re-search-forward org-planning-line-re end t)
(-let* ((pl (org-ml-parse-this-element)))
(->> (org-ml-get-properties '(:deadline :scheduled) pl)
(--map (-some-> it (org-x-dag-partition-timestamp)))))))))
(defun org-x-dag-format-tag-node (category tags key) (defun org-x-dag-format-tag-node (category tags key)
;; ASSUME I don't use subtree-level categories ;; ASSUME I don't use subtree-level categories
(-let* (;; (category (org-get-category)) (-let* (;; (category (org-get-category))
@ -426,101 +585,95 @@ encountered will be returned."
;; misc ;; misc
'type (concat "tagsmatch" ts-type))))) 'type (concat "tagsmatch" ts-type)))))
;; (defun org-x-dag-format-timestamp-node (date category tags id) (defun org-x-dag-date-to-gregorian (date)
;; (let* ((help-echo (-let (((y m d) date))
;; (format "mouse-2 or RET jump to Org file %s" `(,m ,d ,y)))
;; (abbreviate-file-name buffer-file-name)))
;; (extra)
;; (head)
;; (level)
;; (tags)
;; (timestamp)
;; ;; idk if this matters, nothing we care about here will be a habit
;; (habitp)
;; (ts-marker)
;; (hd-marker (org-agenda-new-marker))
;; (item (org-agenda-format-item extra head level category tags timestamp
;; org-ts-regexp habitp))
;; ;; 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)
;; (org-add-props nil
;; ;; face
;; 'face 'org-agenda-calendar-event
;; 'done-face 'org-agenda-done
;; ;; marker
;; 'org-hd-marker hd-marker
;; 'org-marker ts-marker
;; ;; headline stuff
;; 'todo-state (org-x-dag-id->todo id)
;; 'priority priority
;; 'date date
;; 'ts-date ts
;; ;; this appears to be either obsolete or such an obscure feature
;; ;; that I would never care about it
;; ;; 'warntime warntime
;; ;; misc
;; 'type "timestamp"
;; 'help-echo help-echo))))
;; TODO it might make sense to make this also parse deadline (defun org-x-dag-time-get-clock-time (time)
(defun org-x-dag-format-scheduled-node (date category tags id) (when (org-ml-time-is-long time) (list (nth 3 time) (nth 4 time))))
(-let* (((pos ts-match) (org-x-dag-headlines-get-regexp org-scheduled-time-regexp))
(current (calendar-absolute-from-gregorian date)) (defun org-x-dag-time-partition (time)
(schedule (org-time-string-to-absolute ts-match)) (if (org-ml-time-is-long time) (-split-at 3 time) `(,(-take 3 time) nil)))
(diff (- current schedule))
(pastschedp (< diff 0)) (defun org-x-dag-date-diff (date0 date1)
(futureschedp (> diff 0)) ""
;; TODO wtf does this actually do? (pcase (list date0 date1)
(repeat (if (<= current today) schedule (`((,y0 ,m0 ,d0) (,y1 ,m1 ,d1))
(org-time-string-to-absolute s current 'future (current-buffer) pos))) (- (calendar-absolute-from-gregorian `(,m0 ,d0 ,y0))
(habitp (and (fboundp 'org-is-habit-p) (org-is-habit-p))) (calendar-absolute-from-gregorian `(,m1 ,d1 ,y1))))
;; hopefully this is right... (_ (error "Invalid date format(s): %S or %S" date0 date1))))
(time (unless (and (not habitp) (/= current schedule) (/= current repeat))
(-if-let (m (s-match " \\([012]?[0-9]:[0-9][0-9]\\)" ts-match)) (defun org-x-dag-format-item (id extra category tags time)
(concat m " ") (let* ((tags* (org-x-dag-prepare-tags tags))
'time))) (head (org-get-heading))
(today (org-today)) (level (org-x-dag-id->formatted-level id))
(todayp (org-agenda-today-p date)) (todo-state (org-x-dag-id->todo id))
(head (org-get-heading)) (time-str (-some->> time (apply #'format "%02i:%02i ")))
(level (org-x-dag-id->formatted-level id)) (item (org-agenda-format-item extra head level category tags* time-str))
(tags* (org-x-dag-prepare-tags tags)) ;; TODO why am I getting the priority after sending the headline
(todo-state (org-x-dag-id->todo id)) ;; through some crazy formatting function?
(donep (member todo-state org-x-done-keywords)) (priority (org-get-priority item)))
(hd-marker (org-agenda-new-marker))
(ts-marker (org-agenda-new-marker pos))
(extra (->> (if pastschedp (format "%sd Ago" diff) "Scheduled")
(format "%s: ")))
(item (org-agenda-format-item extra head level category tags* time
nil habitp))
;; TODO why am I getting the priority after sending the headline
;; through some crazy formatting function?
(priority (org-get-priority item))
(face (cond ((and (not habitp) pastschedp) 'org-scheduled-previously)
((and habitp futureschedp) 'org-agenda-done)
(todayp 'org-scheduled-today)
(t 'org-scheduled))))
(-> (org-x-dag-add-default-props item) (-> (org-x-dag-add-default-props item)
(org-add-props nil (org-add-props nil
;; face 'todo-state todo-state
'face (if donep 'org-agenda-done face) 'priority priority))))
'undone-face face
'done-face 'org-agenda-done (defun org-x-dag-planning-props (id face pos date ts-date type)
;; marker (list
'org-hd-marker hd-marker ;; face
'org-marker ts-marker 'face (if (org-x-dag-id->is-done-p id) 'org-agenda-done face)
;; headline stuff 'undone-face face
'todo-state (org-x-dag-id->todo id) 'done-face 'org-agenda-done
'priority priority ;; marker
'date (if pastschedp schedule date) 'org-hd-marker (org-agenda-new-marker)
'ts-date schedule 'org-marker (org-agenda-new-marker pos)
'org-habit-p habitp ;; headline stuff
;; this appears to be either obsolete or such an obscure feature 'date (org-x-dag-date-to-gregorian date)
;; that I would never care about it 'ts-date (org-x-dag-date-to-gregorian ts-date)
;; 'warntime warntime 'type type))
;; misc
'type (if pastschedp "past-scheduled" "scheduled"))))) (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))
(diff (org-x-dag-date-diff this-date sel-date))
(pastp (< diff 0))
(todayp (= diff 0))
;; hopefully this is right...if it is this seems silly
(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)))
;; NOTE: I don't care about habits, no need to consider them
(-> (org-x-dag-format-item id extra category tags this-time)
(org-add-props props))))
(defun org-x-dag-format-deadline-node (sel-date pos datetime category tags id)
(-let* (((this-date this-time) (org-x-dag-time-partition datetime))
(diff (org-x-dag-date-diff this-date sel-date))
(pastp (< diff 0))
(futurep (< 0 diff))
(extra (-let* (((now future past) org-agenda-deadline-leaders))
(cond
(futurep (format future diff))
(pastp (format past diff))
(t now))))
;; TODO the stock deadline formatter uses the warning time to
;; determine this based on percentage; I'm lazy and don't feel like
;; doing that (now) but I might in the future
(face (cond
((< 5 diff) 'org-upcoming-distant-deadline)
((< 1 diff) 'org-upcoming-deadline)
(t 'org-warning)))
((date type) (if futurep `(,sel-date "upcoming-deadline")
`(,this-date "deadline")))
(props (org-x-dag-planning-props id face pos date this-date type)))
(-> (org-x-dag-format-item id extra category tags this-time)
(org-add-props props))))
;;; HEADLINE PREDICATES ;;; HEADLINE PREDICATES
;; ;;
@ -699,12 +852,15 @@ encountered will be returned."
((:empt) ((:empt)
(:project-error :unscheduled :actv)) (:project-error :unscheduled :actv))
(if (member it-kw org-x-done-keywords) 0 1) (if (member it-kw org-x-done-keywords) 0 1)
;; TODO this has an argument mismatch
#'org-x-dag-headline-get-iterator-project-status)) #'org-x-dag-headline-get-iterator-project-status))
((equal kw org-x-kw-todo) ((equal kw org-x-kw-todo)
(org-x-dag-descend-into-project children nil (org-x-dag-descend-into-project children nil
((:unscheduled :project-error) ((:unscheduled :project-error)
(:empt) (:empt)
(:actv)) (:actv))
;; TODO this triggers a compiler warning because I don't use
;; `it-kw'
(let ((ts (org-x-dag-headline-is-scheduled-p t))) (let ((ts (org-x-dag-headline-is-scheduled-p t)))
(cond (cond
((not ts) 0) ((not ts) 0)
@ -872,7 +1028,7 @@ encountered will be returned."
(org-x-dag-with-key key (org-x-dag-with-key key
(-let (((is-archivable is-project) (-let (((is-archivable is-project)
(-if-let (children (org-x-dag-id->headline-children key)) (-if-let (children (org-x-dag-id->headline-children key))
(-> (org-x-dag-headline-get-project-status org-x-dag key tags children) (-> (org-x-dag-headline-get-project-status key tags children)
(alist-get org-x-project-status-priorities) (alist-get org-x-project-status-priorities)
(eq :archivable) (eq :archivable)
(list t)) (list t))
@ -888,7 +1044,8 @@ encountered will be returned."
(org-x-dag-id->is-toplevel-p it) (org-x-dag-id->is-toplevel-p it)
(org-x-dag-with-key it (org-x-dag-with-key it
(if (org-x-dag-headline-is-iterator-p) (if (org-x-dag-headline-is-iterator-p)
(--map (format-key category it) (org-x-dag-id->headline-children it)) (->> (org-x-dag-id->headline-children it)
(--map (format-key it-category it)))
(list (format-key it-category it))))))) (list (format-key it-category it)))))))
(defun org-x-dag-scan-ltgs () (defun org-x-dag-scan-ltgs ()
@ -965,6 +1122,35 @@ encountered will be returned."
(org-x-dag-with-key it (org-x-dag-with-key it
(list (format-id it-category it)))))) (list (format-id it-category it))))))
(defun org-x-dag-scan-agenda (sel-date)
(cl-flet*
((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))))))
(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))))))))
(org-x-dag-with-files (org-x-get-action-files)
nil
(org-x-dag-with-key it
(format-id it-category it)))))
;;; AGENDA VIEWS ;;; AGENDA VIEWS
;; (defun org-x-dag-show-tasks (_match) ;; (defun org-x-dag-show-tasks (_match)
@ -978,9 +1164,7 @@ encountered will be returned."
(defun org-x-dag-show-nodes (get-nodes) (defun org-x-dag-show-nodes (get-nodes)
(org-x-dag-sync) (org-x-dag-sync)
(let* ((org-tags-match-list-sublevels org-tags-match-list-sublevels) (let* ((org-tags-match-list-sublevels org-tags-match-list-sublevels)
(completion-ignore-case t) (completion-ignore-case t))
rtnall files file pos matcher
buffer)
(catch 'exit (catch 'exit
(org-agenda-prepare (concat "DAG-TAG")) (org-agenda-prepare (concat "DAG-TAG"))
(org-compile-prefix-format 'tags) (org-compile-prefix-format 'tags)