diff --git a/conf.org b/conf.org index de6d977..fe7e974 100644 --- a/conf.org +++ b/conf.org @@ -138,13 +138,6 @@ OS is one of those in `system-type'." #+END_SRC ** functions #+BEGIN_SRC emacs-lisp -(defun nd/filter-list-prefix (prefix str-list) - "Return a subset of STR-LIST whose first characters are PREFIX." - (seq-filter (lambda (i) - (and (stringp i) - (string-prefix-p prefix i))) - str-list)) - (defun nd/move-key (keymap-from keymap-to key) "Move KEY from KEYMAP-FROM keymap to KEYMAP-TO keymap." (define-key keymap-to key (lookup-key keymap-from key)) @@ -242,7 +235,6 @@ If FRONT is t, do to the front of current values instead of the back." (let* ((cur (plist-get plist prop)) (new (if front (append (list value) cur) (append cur (list value))))) (plist-put plist prop new))) - #+END_SRC ** interactive #+BEGIN_SRC emacs-lisp @@ -937,6 +929,12 @@ Save all org buffers 1 minute before the hour. (run-at-time "00:59" 3600 #'nd/org-save-all-org-buffers) #+END_SRC +*** libraries +Org extras +#+BEGIN_SRC emacs-lisp +(add-to-list 'load-path "~/.emacs.d/dvl/org-x/") +(require 'org-x) +#+END_SRC ** buffer interface *** line wrap I often write long, lengthy prose in org buffers, so use =visual-line-mode= to make lines wrap in automatic and sane manner. @@ -1019,188 +1017,6 @@ Since I use org mode as my config file, makes sense to have a table of contents (interactive) (helm-org-rifle-directories (list org-brain-path))) #+END_SRC -** extra commands -*** org buffer -Some useful additional commands for org buffers. -#+BEGIN_SRC emacs-lisp -(defun org-x-mark-subtree-keyword (new-keyword &optional exclude no-log) - "Mark all tasks in a subtree with NEW-KEYWORD unless original -keyword is in the optional argument EXCLUDE." - (let ((subtree-end (save-excursion (org-end-of-subtree t))) - (org-todo-log-states (unless no-log org-todo-log-states))) - (if (not (listp exclude)) - (error "exlude must be a list if provided")) - (save-excursion - (while (< (point) subtree-end) - (let ((keyword (org-x-is-todoitem-p))) - (if (and keyword (not (member keyword exclude))) - (org-todo new-keyword))) - (outline-next-heading))))) - -(defun org-x-mark-subtree-done () - "Mark all tasks in subtree as DONE unless they are already CANC." - (interactive) - (org-x-mark-subtree-keyword "DONE" '("CANC"))) - -(defun org-x-clone-subtree-with-time-shift (n &optional shift) - "Like `org-clone-subtree-with-time-shift' except it resets checkboxes -and reverts all todo keywords to TODO." - (interactive "nNumber of clones to produce: ") - - (let ((shift (or (org-entry-get nil "TIME_SHIFT" 'selective) - (read-from-minibuffer - "Date shift per clone (e.g. +1w, empty to copy unchanged): ")))) - (condition-case err - (save-excursion - ;; clone once and reset - (org-clone-subtree-with-time-shift 1 shift) - (org-forward-heading-same-level 1 t) - (org-reset-checkbox-state-subtree) - (org-x-mark-subtree-keyword "TODO" nil t) - (call-interactively 'org-x-log-delete) - (org-cycle) - ;; clone reset tree again if we need more than one clone - (if (> n 1) - (let ((additional-trees (- n 1))) - (org-clone-subtree-with-time-shift additional-trees shift) - (dotimes (i additional-trees) - (org-forward-heading-same-level 1 t) - (org-cycle))))) - (error (message "%s" (error-message-string err)))))) - -(defun org-x-clone-subtree-with-time-shift-toplevel (n) - "Go to the last item underneath an iterator and clone using -`org-x-agenda-clone-subtree-with-time-shift'. Assumes point starts on -the top level headline and only looks at the second level of -headlines to clone." - (interactive "nNumber of clones to produce: ") - ;; do nothing if there is nothing to clone - (unless (eq :uninit - (or (and (org-x-is-iterator-heading-p) - (org-clone-get-iterator-status)) - (and (org-x-is-periodical-heading-p) - (org-clone-get-periodical-status)))) - ;; goto last item in the second level - (save-excursion - (let ((current-point (point))) - (outline-next-heading) - (while (< current-point (point)) - (setq current-point (point)) - (org-forward-heading-same-level 1 t))) - (org-x-clone-subtree-with-time-shift n)))) - -(defun org-x-log-delete () - "Delete logbook drawer of subtree." - (interactive) - (save-excursion - (goto-char (org-log-beginning)) - (when (save-excursion - (save-match-data - (beginning-of-line 0) - (search-forward-regexp org-drawer-regexp) - (goto-char (match-beginning 1)) - (looking-at "LOGBOOK"))) - (org-mark-element) - (delete-region (region-beginning) (region-end)) - (org-remove-empty-drawer-at (point))))) - -(defun org-x-delete-subtree () - "Delete the entire subtree under the current heading without sending to kill ring." - (interactive) - (org-back-to-heading t) - (delete-region (point) (+ 1 (save-excursion (org-end-of-subtree))))) - -(defun org-x-clock-range (&optional arg) - "Add a completed clock entry to the current heading. -Does not touch the running clock. When called with one C-u prefix -argument, ask for a range in minutes in place of the second date." - (interactive "P") - (let* ((t1 (-> (org-read-date t t) float-time)) - (diff (if (equal arg '(4)) - (-some-> (read-string "Length in minutes: ") - (cl-parse-integer :junk-allowed t) - (* 60)) - (-> (org-read-date t t nil nil t1) - float-time - round - (- t1))))) - (cond - ((not diff) (message "Invalid range given!")) - ((< diff 0) (message "Second timestamp earlier than first!")) - (t - (let* ((h (-> diff (/ 3600) floor)) - (m (-> diff (- (* h 3600)) (/ 60) floor)) - (new-clock - (concat - org-clock-string " " - (format-time-string (org-time-stamp-format t t) t1) - "--" - (format-time-string (org-time-stamp-format t t) (+ t1 diff)) - " => " - (format "%2d:%02d" h m)))) - (save-excursion - (org-clock-find-position nil) - (insert-before-markers "\n") - (backward-char 1) - (org-indent-line) - (insert new-clock))))))) -#+END_SRC -*** org agenda -These are executed directly from agenda views and affect their source org buffers. The trick is that all of them must somehow go back to the heading to which they allude, execute, then update the agenda view with whatever changes have been made. -#+BEGIN_SRC emacs-lisp -(defmacro org-x-agenda-cmd-wrapper (get-head &rest body) - "Wraps commands in BODY in necessary code to allow commands to be -called from the agenda buffer. Particularly, this wrapper will -navigate to the original header, execute BODY, then update the agenda -buffer." - '(org-agenda-check-no-diary) - `(let* ((hdmarker (or (org-get-at-bol 'org-hd-marker) - (org-agenda-error))) - (buffer (marker-buffer hdmarker)) - (pos (marker-position hdmarker)) - (inhibit-read-only t) - newhead) - (org-with-remote-undo buffer - (with-current-buffer buffer - (widen) - (goto-char pos) - (org-show-context 'agenda) - ,@body - (when ,get-head (setq newhead (org-get-heading)))) - (if ,get-head - (org-agenda-change-all-lines newhead hdmarker) - (org-agenda-redo)) - (beginning-of-line 1)))) - -(defun org-x-agenda-toggle-checkbox () - "Toggle checkboxes in org agenda view using `org-toggle-checkbox'." - (interactive) - (org-x-agenda-cmd-wrapper - t - (call-interactively #'org-toggle-checkbox))) - -(defun org-x-agenda-clone-subtree-with-time-shift () - "Apply `org-x-clone-subtree-with-time-shift' to an agenda entry. -It will clone the last entry in the selected subtree." - (interactive) - (org-x-agenda-cmd-wrapper - nil - (call-interactively #'org-x-clone-subtree-with-time-shift-toplevel))) - -(defun org-x-agenda-delete-subtree () - "Apply `org-x-delete-subtree' to an agenda entry." - (interactive) - (org-x-agenda-cmd-wrapper - nil - (call-interactively #'org-x-delete-subtree))) - -(defun org-x-agenda-clock-range () - "Apply `org-x-clock-range' to an agenda entry" - (interactive) - (org-x-agenda-cmd-wrapper - nil - (call-interactively #'org-x-clock-range))) -#+END_SRC ** calfw This is a nifty calendar...sometimes way faster than the agenda buffer for looking at long term things. #+BEGIN_SRC emacs-lisp @@ -1518,7 +1334,7 @@ Each group also has its own color, defined by its prefix symbol. "Adds list of cons cells to org-tag-faces with foreground set to fg-name. Start and end specify the positions in org-tag-alist which define the tags to which the faces are applied" - (dolist (tag (nd/filter-list-prefix prefix (mapcar #'car org-tag-alist))) + (dolist (tag (org-x-filter-list-prefix prefix (mapcar #'car org-tag-alist))) (push `(,tag . (:foreground ,fg-name)) org-tag-faces))) (setq org-tag-faces '()) @@ -2164,7 +1980,7 @@ This controls what each line on the block agenda looks like. This is reformated ***** modeline Hide the various modules that may be present #+BEGIN_SRC emacs-lisp -(defun org-x-agenda-trim-modeline (orig-fn &rest args) +(defun nd/org-agenda-trim-modeline (orig-fn &rest args) "Advice to remove extra information from agenda modeline name." (let ((org-agenda-include-diary nil) (org-agenda-include-deadlines nil) @@ -2172,7 +1988,7 @@ Hide the various modules that may be present (org-habit-show-habits nil)) (apply orig-fn args))) -(advice-add #'org-agenda-set-mode-name :around #'org-x-agenda-trim-modeline) +(advice-add #'org-agenda-set-mode-name :around #'nd/org-agenda-trim-modeline) #+END_SRC ***** misc These are just some options to enable/disable some aesthetic things. @@ -2189,88 +2005,6 @@ Based on my screen size and usage patterns, this seems to be a good value to ena #+BEGIN_SRC emacs-lisp (setq org-habit-graph-column 50) #+END_SRC -**** interactive filters -Rather than define infinite views for different tasks (I already have plenty of views) I use filtering to sort through the noise. Some of the built-in filters don't cut it, so I made a few of my own. -***** custom filtering functions -Some custom filters that are applied to the agenda view. Note that some of these use alternative filter types that are implemented via advising functions (see below). -#+BEGIN_SRC emacs-lisp -(defun org-x-agenda-filter-non-context () - "Filter all tasks with context tags." - (interactive) - (let* ((tags-list (mapcar #'car org-tag-alist)) - (context-tags (append - (nd/filter-list-prefix "@" tags-list) - (nd/filter-list-prefix "#" tags-list)))) - (setq org-agenda-tag-filter - (mapcar (lambda (tag) (concat "-" tag)) context-tags)) - (org-agenda-filter-apply org-agenda-tag-filter 'tag))) - -(defun org-x-agenda-filter-non-peripheral () - "Filter all tasks that don't have peripheral tags." - (interactive) - (let* ((peripheral-tags '("PERIPHERAL"))) - (setq org-agenda-tag-filter - (mapcar (lambda (tag) (concat "-" tag)) peripheral-tags)) - (org-agenda-filter-apply org-agenda-tag-filter 'tag))) - -(defun org-x-agenda-filter-non-effort () - "Filter agenda by non-effort tasks." - (interactive) - (setq org-agenda-hasprop-filter '("-Effort")) - (org-agenda-filter-apply org-agenda-hasprop-filter 'hasprop)) - -(defun org-x-agenda-filter-delegate () - "Filter agenda by tasks with an external delegate." - (interactive) - (setq org-agenda-hasprop-filter '("+DELEGATE")) - (org-agenda-filter-apply org-agenda-hasprop-filter 'hasprop)) -#+END_SRC -***** filter advice -In order to implement the =hasprop= filter, the functions =org-agenda-filter-make-matcher= and =org-agenda-filter-remove-all= need to be advised in order to add the functionality for the =hasprop= filter type. - -As it is, this allows any filter using =hasprop= to be applied and removed using the standard =org-agenda-filter-apply= function with the =org-agenda-hasprop-filter= variable (obviously these can all be extended to different filter types). Note this does not give a shiny indicator at the bottom of spaceline like the built-in filter does...oh well. -#+BEGIN_SRC emacs-lisp -;; initialize new filters -(defvar org-agenda-hasprop-filter nil) - -(defun org-x-agenda-filter-make-matcher-prop - (filter type &rest args) - "Return matching matcher form for FILTER and TYPE where TYPE is not -in the regular `org-agenda-filter-make-matcher' function. This is -intended to be uses as :before-until advice and will return nil if -the type is not valid (which is currently 'prop')" - (let (f f1) - ;; has property - (cond - ((eq type 'hasprop) - (dolist (x filter) - (push (org-x-agenda-filter-make-matcher-hasprop-exp x) f)))) - (if f (cons 'and (nreverse f))))) - -(defun org-x-agenda-filter-make-matcher-hasprop-exp (h) - "Returns form to test the presence or absence of properties H. -H is a string like +prop or -prop" - (let (op) - (let* ((op (string-to-char h)) - (h (substring h 1)) - (f `(save-excursion - (let ((m (org-get-at-bol 'org-hd-marker))) - (with-current-buffer - (marker-buffer m) - (goto-char m) - (org-entry-get nil ,h)))))) - (if (eq op ?-) (list 'not f) f)))) - -(defun org-x-agenda-filter-show-all-hasprop nil - (org-agenda-remove-filter 'hasprop)) - -(advice-add #'org-agenda-filter-make-matcher :before-until - #'org-x-agenda-filter-make-matcher-prop) - -(advice-add #'org-agenda-filter-remove-all :before - (lambda () (when org-agenda-hasprop-filter - (org-x-agenda-filter-show-all-hasprop)))) -#+END_SRC **** bulk actions These add to the existing bulk actions in the agenda view. #+BEGIN_SRC emacs-lisp @@ -2295,12 +2029,6 @@ These are functions and variables exclusively for agenda block manipulation with (defconst org-clone-iter-future-time (* 7 24 60 60) "Iterators must have at least one task greater into the future to be active.") -(defconst org-x-archive-delay 30 - "The number of days to wait before tasks are considered archivable.") - -(defconst org-x-inert-delay-days 90 - "The number of days to wait before tasks are considered inert.") - ;; TODO ;unscheduled should trump all (defconst org-clone-iter-statuscodes '(:uninit :empt :actv :project-error :unscheduled) "Iterators can have these statuscodes.") @@ -2309,388 +2037,9 @@ These are functions and variables exclusively for agenda block manipulation with "Periodicals must have at least one heading greater into the future to be fresh.") (defconst org-clone-peri-statuscodes '(:uninit :empt :actv :unscheduled)) - -(defconst org-x-project-invalid-todostates - '("WAIT" "NEXT") - "Projects cannot have these todostates.") - -(defconst org-x-agenda-todo-sort-order - '("NEXT" "WAIT" "HOLD" "TODO") - "Defines the order in which todo keywords should be sorted.") - -(defconst org-x-project-skip-todostates - '("HOLD" "CANC") - "These keywords override all contents within their subtrees. -Currently used to tell skip functions when they can hop over -entire subtrees to save time and ignore tasks") -#+END_SRC -***** variables -#+BEGIN_SRC emacs-lisp -(defvar org-x-agenda-limit-project-toplevel t - "If true, filter projects by all levels or top level only.") - -(defvar org-x-agenda-hide-incubator-tags t - "If true, don't show incubator headings.") #+END_SRC ***** task helper functions These are the building blocks for skip functions. -****** org-element -#+BEGIN_SRC emacs-lisp -(defun org-x-element-parse-headline (&optional granularity subtree) - "Like `org-element-parse-buffer' but on only one headline. Assumes -that point is currently on the starting line of the headline in -question. if SUBTREE is t, return all the subheadings under this -heading." - ;; (line-beginning-position) - (let ((start (point)) - (end (if subtree - (save-excursion (org-end-of-subtree)) - (save-excursion (outline-next-heading) (point))))) - (-> (org-element--parse-elements - start end 'first-section nil granularity nil nil) - car))) - -(defun org-x-element-first-lb-entry (headline) - "Get the first logbook entry of the headline under point." - (letrec - ((get-ts - (lambda (obj) - (if (eq 'clock (org-element-type obj)) - (--> obj - (org-element-property :value it) - ;; assume this will return the latest even if - ;; not a range - (org-timestamp-split-range it t)) - (->> - obj - org-element-contents - car - org-element-contents - car - ;; this assumes that the log timestamps are always - ;; at the end of the first line - (--take-while (not (eq 'line-break (org-element-type it)))) - (--last (eq 'timestamp (org-element-type it)))))))) - (-some--> - headline - (org-element-contents it) - (car it) - (org-element-contents it) - (--first - (equal org-log-into-drawer (org-element-property :drawer-name it)) - it) - (org-element-contents it) - (car it) - (funcall get-ts it) - (org-element-property :raw-value it)))) -#+END_SRC -****** timestamps -#+BEGIN_SRC emacs-lisp -(defun org-x-get-date-property (timestamp-property) - "Get TIMESTAMP-PROPERTY on current heading and convert to a number. -If it does not have a date, it will return nil." - (let ((ts (org-entry-get nil timestamp-property))) - (when ts (org-2ft ts)))) - -(defun org-x-heading-compare-timestamp (timestamp-fun - &optional ref-time future) - "Returns the timestamp (from TIMESTAMP-FUM on the current heading) -if timestamp is futher back in time compared to a REF-TIME (default to -0 which is now, where negative is past and positive is future). If the -FUTURE flag is t, returns timestamp if it is in the future compared -to REF-TIME. Returns nil if no timestamp is found." - (let* ((timestamp (funcall timestamp-fun)) - (ref-time (or ref-time 0))) - (if (and timestamp - (if future - (> (- timestamp (float-time)) ref-time) - (<= (- timestamp (float-time)) ref-time))) - timestamp))) - -(defun org-x-is-created-heading-p () - "Return heading's CREATED property timestamp or nil." - (org-x-get-date-property "CREATED")) - -(defun org-x-is-timestamped-heading-p () - "Get active timestamp of current heading." - (org-x-get-date-property "TIMESTAMP")) - -(defun org-x-is-scheduled-heading-p () - "Get scheduled timestamp of current heading." - (org-x-get-date-property "SCHEDULED")) - -(defun org-x-is-deadlined-heading-p () - "Get deadline timestamp of current heading." - (org-x-get-date-property "DEADLINE")) - -(defun org-x-is-closed-heading-p () - "Get closed timestamp of current heading." - (org-x-get-date-property "CLOSED")) - -(defun org-x-is-stale-heading-p (&optional ts-prop) - "Return timestamp for TS-PROP (TIMESTAMP by default) if current heading is stale." - (org-x-heading-compare-timestamp - (lambda () (let ((ts (org-entry-get nil (or ts-prop "TIMESTAMP")))) - (when (and ts (not (find ?+ ts))) (org-2ft ts)))))) - -(defun org-x-is-fresh-heading-p () - "Return timestamp if current heading is fresh." - (org-x-heading-compare-timestamp 'org-x-is-timestamped-heading-p nil t)) - -(defun org-x-is-archivable-heading-p () - "Return timestamp if current heading is archivable." - (org-x-heading-compare-timestamp - 'org-x-is-closed-heading-p - (- (* 60 60 24 org-x-archive-delay)))) - -(defun org-x-is-inert-p () - "Return most recent timestamp if headline is inert." - (let* ((recent-ft (-some->> (org-x-element-parse-headline) - org-x-element-first-lb-entry - org-2ft))) - (-some--> (or recent-ft (org-x-get-date-property "CREATED")) - (- (float-time) it) - (when (> it (* 86400 org-x-inert-delay-days)) it)))) -#+END_SRC -****** task level testing -#+BEGIN_SRC emacs-lisp -(defun org-x-is-todoitem-p () - "Return todo keyword if heading has one." - (let ((keyword (nth 2 (org-heading-components)))) - (if (member keyword org-todo-keywords-1) - keyword))) - -(defun org-x-is-project-p () - "Return todo keyword if heading has todoitem children." - (and (org-x-headline-has-children 'org-x-is-todoitem-p) (org-x-is-todoitem-p))) - -(defun org-x-is-task-p () - "Return todo keyword if heading has no todoitem children." - (and (not (org-x-headline-has-children 'org-x-is-todoitem-p)) (org-x-is-todoitem-p))) - -(defun org-x-is-project-task-p () - "Return todo keyword if heading has todoitem parents." - (and (org-x-headline-has-parent 'org-x-is-todoitem-p) (org-x-is-task-p))) - -(defun org-x-is-atomic-task-p () - "Return todo keyword if heading has no todoitem parents or children." - (and (not (org-x-headline-has-parent 'org-x-is-todoitem-p)) (org-x-is-task-p))) - -(defun org-x-task-status () - "Return the status of the headline under point." - (let ((kw (org-x-is-task-p))) - (when kw - (cond - ((org-x-is-archivable-heading-p) - :arch) - ((org-x-is-inert-p) - :inrt) - ((and (member kw org-done-keywords) (not (org-x-is-closed-heading-p))) - :done-unclosed) - ((and (not (member kw org-done-keywords)) (org-x-is-closed-heading-p)) - :closed-undone) - ((member kw org-done-keywords) - :comp) - (t :actv))))) -#+END_SRC -****** property testing -#+BEGIN_SRC emacs-lisp -(defun org-x-is-periodical-heading-p () - "Return t if heading is a periodical." - (equal "periodical" (org-entry-get nil "PARENT_TYPE" t))) - -(defun org-x-is-iterator-heading-p () - "Return t if heading is an iterator." - (equal "iterator" (org-entry-get nil "PARENT_TYPE" t))) - -(defun org-x-headline-has-effort-p () - "Return t if heading has an effort." - (org-entry-get nil "Effort")) - -(defun org-x-headline-has-context-p () - "Return t if heading has a context." - (let ((tags (org-get-tags-at))) - (or (> (length (nd/filter-list-prefix "#" tags)) 0) - (> (length (nd/filter-list-prefix "@" tags)) 0)))) - -(defun org-x-headline-has-tag-p (tag) - "Return t if heading has tag TAG." - (member tag (org-get-tags-at))) -#+END_SRC -****** relational testing -Returns t if heading has certain relationship to other headings -#+BEGIN_SRC emacs-lisp -(defun org-x-headline-has-children (heading-test) - "Return t if heading has a child for whom HEADING-TEST is t." - (let ((subtree-end (save-excursion (org-end-of-subtree t))) - has-children previous-point) - (save-excursion - (setq previous-point (point)) - (outline-next-heading) - (while (and (not has-children) - (< previous-point (point) subtree-end)) - (when (funcall heading-test) - (setq has-children t)) - (setq previous-point (point)) - (org-forward-heading-same-level 1 t))) - has-children)) - -(defun org-x-headline-has-parent (heading-test) - "Return t if heading has parent for whom HEADING-TEST is t." - (save-excursion (and (org-up-heading-safe) (funcall heading-test)))) - -(defun org-x-has-discontinuous-parent () - "Return t if heading has a non-todoitem parent which in turn has a todoitem parent." - (let ((has-todoitem-parent) - (has-non-todoitem-parent)) - (save-excursion - (while (and (org-up-heading-safe) - (not has-todoitem-parent)) - (if (org-x-is-todoitem-p) - (setq has-todoitem-parent t) - (setq has-non-todoitem-parent t)))) - (and has-todoitem-parent has-non-todoitem-parent))) -#+END_SRC -****** project level testing -Projects are tested according to their statuscodes, which in turn are a function of the todo keywords and timestamps of their individual subtasks. -#+BEGIN_SRC emacs-lisp -(defmacro org-x-compare-statuscodes (op sc1 sc2 sc-list) - "Compare position of statuscodes SC1 and SC2 in SC-LIST using operator OP." - `(,op (position ,sc1 ,sc-list) (position ,sc2 ,sc-list))) - -(defun org-x-descend-into-project - (allowed-statuscodes trans-tbl get-task-status callback-fun) - "Loop through (sub)project and return overall statuscode. - -The returned statuscode is chosen from list ALLOWED-STATUSCODES where -later entries in the list trump earlier ones. - -When a subproject is encountered, this function will obtain the -statuscode of that project and use TRANS-TBL to translate the -subproject statuscode to one in ALLOWED-STATUSCODES (if not found an -error will be raised). TRANS-TBL is given as an alist of two-member -cons cells where the first member is the subproject statuscode and the - second is the index in ALLOWED-STATUSCODES to which the subproject -statuscode will be translated. - -When a task is encountered, function GET-TASK-STATUS will be applied to -obtain a statuscode-equivalent of the status of the tasks." - ;; define "breaker-status" as the last of the allowed-statuscodes - ;; when this is encountered the loop is broken because we are done - ;; (the last entry trumps all others) - (let ((project-status (first allowed-statuscodes)) - (breaker-status (-last-item allowed-statuscodes)) - (previous-point)) - (save-excursion - (setq previous-point (point)) - (outline-next-heading) - ;; loop through subproject tasks until breaker-status found - (while (and (not (eq project-status breaker-status)) - (> (point) previous-point)) - (let ((keyword (org-x-is-todoitem-p))) - (if keyword - (let ((new-status - ;; if project then descend recursively - (if (org-x-headline-has-children 'org-x-is-todoitem-p) - (let ((n (funcall callback-fun))) - ;; if project returns an allowed status - ;; then use that - (or (and (member n allowed-statuscodes) n) - ;; otherwise look up the value in the - ;; translation table and return error - ;; if not found - (nth (or (alist-get n trans-tbl) - (error (concat "status not found: " n))) - allowed-statuscodes))) - ;; if tasks then use get-task-status to obtain status - (nth (funcall get-task-status keyword) - allowed-statuscodes)))) - (if (org-x-compare-statuscodes > new-status project-status allowed-statuscodes) - (setq project-status new-status))))) - (setq previous-point (point)) - (org-forward-heading-same-level 1 t))) - project-status)) - -(defun org-x-get-project-status () - "Return project heading statuscode (assumes it is indeed a project)." - (let ((keyword (org-x-is-todoitem-p))) - ;; - ;; these first three are easy because they only require - ;; testing the project headline and nothing underneath - ;; - (cond - ;; it does not make sense for projects to be scheduled - ((org-x-is-scheduled-heading-p) :scheduled-project) - - ;; held projects do not care what is underneath them - ;; only need to test if they are inert - ((equal keyword "HOLD") (if (org-x-is-inert-p) :inrt :held)) - - ;; projects with invalid todostates are nonsense - ((member keyword org-x-project-invalid-todostates) - :invalid-todostate) - - ;; - ;; these require descending into the project subtasks - ;; - - ;; canceled projects can either be archivable or complete - ;; any errors or undone tasks are irrelevant - ((equal keyword "CANC") - (org-x-descend-into-project - '(:arch :comp) - '((:stck . 1) - (:inrt . 1) - (:held . 1) - (:wait . 1) - (:actv . 1) - (:sched-project . 1) - (:invalid-todostate . 1) - (:undone-complete . 1) - (:done-incomplete . 1)) - (lambda (k) - (if (and (member k org-done-keywords) - (org-x-is-archivable-heading-p)) 0 1)) - #'org-x-get-project-status)) - - ;; done projects are like canceled projects but can also be incomplete - ((equal keyword "DONE") - (org-x-descend-into-project - '(:arch :comp :done-incomplete) - '((:stck . 2) - (:inrt . 2) - (:held . 2) - (:wait . 2) - (:actv . 2) - (:scheduled-project . 2) - (:invalid-todostate . 2) - (:undone-complete . 2)) - (lambda (k) - (if (member k org-done-keywords) - (if (org-x-is-archivable-heading-p) 0 1) - 2)) - #'org-x-get-project-status)) - - ;; project with TODO states could be basically any status - ((equal keyword "TODO") - (org-x-descend-into-project - '(:undone-complete :stck :held :wait :actv :inrt) - '((:comp . 0) - (:arch . 0) - (:scheduled-project . 1) - (:invalid-todostate . 1) - (:done-incomplete . 1)) - (lambda (k) - (cond ((org-x-is-inert-p) 5) - ((equal k "TODO") (if (org-x-is-scheduled-heading-p) 4 1)) - ((equal k "HOLD") 2) - ((equal k "WAIT") 3) - ((equal k "NEXT") 4) - (t 0))) - #'org-x-get-project-status)) - - (t (error (concat "invalid keyword detected: " keyword)))))) -#+END_SRC ****** repeater testing Iterators and periodicals are tested similarly to projects in that they have statuscodes. #+BEGIN_SRC emacs-lisp @@ -2814,104 +2163,6 @@ earlier ones." #+END_SRC ***** skip functions These are the primary means used to sort through tasks and build agenda block views -****** helper skip functions and macros -Subunits for skip functions. Not meant to be used or called from the custom commands api -#+BEGIN_SRC emacs-lisp -(defun org-x-skip-heading () - "Skip forward to next heading." - (save-excursion (or (outline-next-heading) (point-max)))) - -(defun org-x-skip-subtree () - "Skip forward to next subtree." - (save-excursion (or (org-end-of-subtree t) (point-max)))) - - -(defmacro org-x-skip-heading-without (heading-fun test-fun) - "Skip headings accoring to certain characteristics. - -HEADING-FUN is a function that tests the heading and returns the -todoitem keyword on success. TEST-FUN is a function that further tests -the identity of the heading and may or may not use the keyword output -supplied by the HEADING-FUN. This function will not skip if -HEADING-FUN and TEST-FUN return true" - `(save-restriction - (widen) - (let ((keyword (,heading-fun))) - ;; (message keyword) - (if (not (and keyword ,test-fun)) - (org-x-skip-heading))))) -#+END_SRC -****** headings -Skip functions for headings which may or may not be todo-items. -#+BEGIN_SRC emacs-lisp -(defun org-x-skip-headings-with-tags (pos-tags-list &optional neg-tags-list) - "Skip headings that have tags in POS-TAGS-LIST and not in NEG-TAGS-LIST." - (save-restriction - (widen) - (let ((heading-tags (org-get-tags-at))) - (if (and (or (not pos-tags-list) - (intersection pos-tags-list heading-tags :test 'equal)) - (not (intersection neg-tags-list heading-tags :test 'equal))) - (org-x-skip-heading))))) - -(defun org-x-skip-non-stale-headings () - "Skip headings that do not have stale timestamps and are not part of projects." - (save-restriction - (widen) - (let ((keyword (org-x-is-todoitem-p))) - (if (not - (and (org-x-is-stale-heading-p) - (not (member keyword org-done-keywords)) - (not (org-x-headline-has-children 'org-x-is-todoitem-p)) - (not (org-x-headline-has-parent 'org-x-is-todoitem-p)))) - (org-x-skip-heading))))) -#+END_SRC -****** tasks -A few functions apply to both atomic tasks and project tasks the same. -#+BEGIN_SRC emacs-lisp -(defun org-x-skip-non-tasks () - "Skip headlines that are not tasks." - (save-restriction - (widen) - (let ((keyword (org-x-is-todoitem-p))) - (if keyword - (when (org-x-headline-has-children 'org-x-is-todoitem-p) - (if (member keyword org-x-project-skip-todostates) - (org-x-skip-subtree) - (org-x-skip-heading))) - (org-x-skip-heading))))) - -(defun org-x-skip-non-created-tasks () - "Skip tasks that do not have CREATED timestamp properties." - (save-excursion - (widen) - (if (not (and (org-x-is-task-p) - (not (org-x-is-created-heading-p)))) - (org-x-skip-heading)))) -#+END_SRC -****** atomic tasks -By definition these have no parents, so I don't need to worry about skipping over projects. Any todo state is valid and we only sort by done/canc -#+BEGIN_SRC emacs-lisp -(defun org-x-skip-non-atomic-tasks () - "Skip headings that are not atomic tasks." - (save-excursion - (widen) - (if (not (org-x-is-atomic-task-p)) - (org-x-skip-heading)))) - -(defun org-x-skip-non-closed-atomic-tasks () - "Skip headings that are not complete (but not archivable) atomic tasks." - (org-x-skip-heading-without - org-x-is-atomic-task-p - (and (member keyword org-done-keywords) - (not (org-x-is-archivable-heading-p))))) - -(defun org-x-skip-non-archivable-atomic-tasks () - "Skip headings that are not archivable atomic tasks." - (org-x-skip-heading-without - org-x-is-atomic-task-p - (org-x-is-archivable-heading-p))) -#+END_SRC ****** repeaters These are headings marked with PARENT_TYPE property that have timestamped headings as children. They are to be refilled when all children are stale. Note that I only care about the parent headings as the children should always show up in the agenda simply because they have timestamps. Parents can be either fresh (at least one child in the future) or stale (all children in the past). #+BEGIN_SRC emacs-lisp @@ -2948,255 +2199,6 @@ These are headings marked with PARENT_TYPE property that have timestamped headin ;; (not (org-x-headline-has-children 'org-x-is-periodical-heading-p)))) ;; (org-x-skip-heading)))) #+END_SRC -****** project tasks -Note that I don't care about the timestamp in these cases because I don't archive these; I archive their parent projects. The keywords I care about are NEXT, WAIT, and HOLD because these are definitive project tasks that require/inhibit futher action. (TODO = stuck which I take care of at the project level, and DONE/CANC = archivable which is dealt with similarly) - -For performance, I need to assess if the parent project is skippable, in which case I jump to the next subtree. -#+BEGIN_SRC emacs-lisp -(defun org-x-skip-non-project-tasks () - "Skip headings that are not project tasks." - (save-restriction - (widen) - (let ((keyword (org-x-is-todoitem-p))) - (if keyword - (if (org-x-headline-has-children 'org-x-is-todoitem-p) - (if (member keyword org-x-project-skip-todostates) - (org-x-skip-subtree) - (org-x-skip-heading)) - (if (not (org-x-headline-has-parent 'org-x-is-todoitem-p)) - (org-x-skip-heading))) - (org-x-skip-heading))))) -#+END_SRC -****** heading-level errors -Some headings are invalid under certain conditions; these are tested here. -#+BEGIN_SRC emacs-lisp -(defun org-x-skip-non-discontinuous-project-tasks () - "Skip headings that are not discontinuous within projects." - (org-x-skip-heading-without - org-x-is-todoitem-p - (org-x-has-discontinuous-parent))) - -(defun org-x-skip-non-done-unclosed-todoitems () - "Skip headings that are not completed without a closed timestamp." - (org-x-skip-heading-without - org-x-is-todoitem-p - (and (member keyword org-done-keywords) - (not (org-x-is-closed-heading-p))))) - -(defun org-x-skip-non-undone-closed-todoitems () - "Skip headings that are not incomplete with a closed timestamp." - (org-x-skip-heading-without - org-x-is-todoitem-p - (and (not (member keyword org-done-keywords)) - (org-x-is-closed-heading-p)))) -#+END_SRC -****** projects -Projects are handled quite simply. They have statuscodes for which I test, and this can all be handled by one function. Note that this is used for "normal" projects as well as repeaters. -#+BEGIN_SRC emacs-lisp -(defun org-x-skip-non-projects (&optional ignore-toplevel) - "Skip headings that are not projects (toplevel-only if IGNORE-TOPLEVEL is t)." - (save-restriction - (widen) - (let ((keyword (org-x-is-project-p))) - (if keyword - (if (and org-x-agenda-limit-project-toplevel - (not ignore-toplevel) - (org-x-headline-has-parent 'org-x-is-todoitem-p)) - (org-x-skip-subtree)) - (org-x-skip-heading))))) -#+END_SRC -***** sorting and filtering -These are used to filter and sort within block agendas (note this is different from the other filtering functions above as these are non-interactive). -#+BEGIN_SRC emacs-lisp -(defun org-x-agenda-filter-prop (a-line filter prop-fun - &optional prop-key) - "Filter for `org-agenda-before-sorting-filter-function' where -A-LINE is a line from the agenda view, FILTER is an ordered list -of property values to be filtered/sorted, and PROP-FUN is a function -that determines a property value based on the org content of the -original buffer. If PROP-KEY is supplied, assign the return value of -PROP-FUN to PROP-KEY in A-LINE's text properties. Returns either nil -if return value of PROP-FUN not in FILTER or A-LINE (modified or not)." - (let* ((m (get-text-property 1 'org-marker a-line)) - (s (with-current-buffer (marker-buffer m) - (goto-char m) - (funcall prop-fun)))) - (when (find s filter) - (if (not prop-key) a-line - (org-add-props a-line nil prop-key s))))) - -(defun org-x-agenda-regexp-replace-props (props) - (letrec - ((replace-prop - (lambda (p) - (let ((prop-val (->> (thing-at-point 'line) - (get-text-property 1 (cdr p)) - symbol-name)) - (re (format "$%s$" (car p)))) - (when prop-val - (save-excursion - (when (search-forward re (line-end-position) t 1) - (replace-match prop-val)))))))) - (save-excursion - (goto-char (point-min)) - (while (< (point) (point-max)) - (--each props (funcall replace-prop it)) - (forward-line))))) - -(add-hook - 'org-agenda-finalize-hook - (lambda () - (org-x-agenda-regexp-replace-props '(("y" . atomic) - ("xxxx" . statuscode))))) - -(defun org-x-agenda-sort-prop (prop order a b) - "Sort a block agenda view by text property PROP given a list ORDER -of said text properties in the desired order and lines A and B as -inputs. To be used with `org-agenda-cmp-user-defined'." - (let* ((ta (get-text-property 1 prop a)) - (tb (get-text-property 1 prop b)) - (pa (position ta order :test (if (stringp ta) #'equal))) - (pb (position tb order :test (if (stringp tb) #'equal)))) - (cond ((or (null pa) (null pb)) nil) - ((< pa pb) +1) - ((> pa pb) -1)))) - -(defun org-x-agenda-sort-multi (a b &rest funs) - "Sort lines A and B from block agenda view given functions FUNS. -Functions in FUNS must take either A or B as their arguments and -should return a positive integer indicating their rank. The FUNS -list is traversed in order, where the front is the outermost sorting -order." - (let* ((fun (car funs)) - (pa (funcall fun a)) - (pb (funcall fun b))) - (cond - ((< pa pb) +1) - ((> pa pb) -1) - (t (-some->> funs cdr (apply #'org-x-agenda-sort-multi a b)))))) - -(defun org-x-agenda-sort-task-todo (line) - (or - (-some-> (get-text-property 1 'todo-state line) - (position org-x-agenda-todo-sort-order :test #'equal)) - (length org-x-agenda-todo-sort-order))) - -(defun org-x-agenda-sort-status (line order) - (or - (-some-> (get-text-property 1 'statuscode line) (position order)) - (length order))) - -(defun org-x-agenda-sort-task-atomic (line) - (if (eq '-!- (get-text-property 1 'atomic line)) 1 0)) -#+END_SRC -***** block view building macros -Some useful shorthands to create block agenda views -#+BEGIN_SRC emacs-lisp -(defun org-x-agenda-base-heading-cmd (match header skip-fun) - "Make a tags agenda view that matches tags in string MATCH with -header given as string HEADER and with skip function SKIP-FUN." - `(tags - ,match - ((org-agenda-overriding-header ,header) - (org-agenda-skip-function ,skip-fun) - (org-agenda-sorting-strategy '(category-keep))))) - -(defun org-x-agenda-base-task-cmd (match header skip-fun &optional sort) - "Make a tags-todo agenda view that matches tags in string MATCH with -header given as string HEADER and with skip function SKIP-FUN. Also -takes a sorting structure SORT which is passed to -`org-agenda-sorting-strategy'" - (or sort (setq sort ''(category-keep))) - `(tags-todo - ,match - ((org-agenda-overriding-header ,header) - (org-agenda-skip-function ,skip-fun) - (org-agenda-todo-ignore-with-date t) - (org-agenda-sorting-strategy ,sort)))) - -(defun org-x-agenda-base-task-cmd* (match header skip-fun kw-list status-fun - &optional status-px) - (let ((prefix (if status-px - ''((tags . " %-12:c $xxxx$: $y$ %-5:e ")) - ''((tags . " %-12:c %-5:e"))))) - `(tags-todo - ,match - ((org-agenda-overriding-header ,header) - (org-agenda-skip-function ,skip-fun) - (org-agenda-todo-ignore-with-date t) - (org-agenda-before-sorting-filter-function - (lambda (l) - (-some-> - l - (org-x-agenda-filter-prop ,kw-list ,status-fun 'statuscode) - (org-x-agenda-filter-prop - '(-*- -!-) (lambda () (if (org-x-is-atomic-task-p) '-!- '-*-)) 'atomic)))) - (org-agenda-cmp-user-defined - (lambda (a b) - (org-x-agenda-sort-multi - a b - (lambda (l) (org-x-agenda-sort-status l ,kw-list)) - #'org-x-agenda-sort-task-atomic - #'org-x-agenda-sort-task-todo))) - (org-agenda-prefix-format ,prefix) - (org-agenda-sorting-strategy '(user-defined-down category-keep)))))) - -(defun org-x-agenda-base-project-cmd (match header skip-fun kw-list status-fun - &optional todo status-px) - "Make a tags-todo agenda view that matches tags in string MATCH with -header given as string HEADER and with skip function SKIP-FUN. KW-LIST -is a list of keywords to be used in filtering and sorting (the order -in the list defines the sort order). STATUS-FUN is a function used to -get the statuscode of the current line in the agenda. Optional arg -TODO determines if this is a tags-todo (t) or tags (nil) block, and -STATUS-PX as t enables the statuscode to be formatted into the prefix -string." - (let ((prefix (if status-px - ''((tags . " %-12:c $xxxx$: ")) - ''((tags . " %-12:c "))))) - `(,(if 'tags-todo 'tags) - ,match - ((org-agenda-overriding-header ,header) - (org-agenda-skip-function ,skip-fun) - (org-agenda-before-sorting-filter-function - (lambda (l) (org-x-agenda-filter-prop l ,kw-list ,status-fun 'statuscode))) - (org-agenda-cmp-user-defined - (lambda (a b) (org-x-agenda-sort-prop 'statuscode ,kw-list a b))) - (org-agenda-prefix-format ,prefix) - (org-agenda-sorting-strategy '(user-defined-down category-keep)))))) -#+END_SRC -***** interactive functions -This is basically a filter but since it is implemented through skip functions it makes more sense to include it here. It allows distinguishing between toplevel projects and projects that are subprojects of the toplevel project (I usually only care about the former). -#+BEGIN_SRC emacs-lisp -(defun org-x-toggle-project-toplevel-display () - "Toggle all project headings and toplevel only headings in project blocks." - (interactive) - (setq org-x-agenda-limit-project-toplevel (not org-x-agenda-limit-project-toplevel)) - (when (equal major-mode 'org-agenda-mode) - (org-agenda-redo)) - (message "Showing %s project view in agenda" - (if org-x-agenda-limit-project-toplevel "toplevel" "complete"))) -#+END_SRC -***** advising -Some org functions don't do exactly what I want. Re-educate them here -****** org-tags-view done keywords -The =org-tags-view= can filter tags for only headings with TODO keywords (with type tags-todo), but this automatically excludes keywords in =org-done-keywords=. Therefore, if I want to include these in any custom agenda blocks, I need to use type tags instead and skip the unwanted TODO keywords with a skip function. This is far slower as it applies the skip function to EVERY heading. - -Fix that here by nullifying =org--matcher-tags-todo-only= which controls how the matcher is created for tags and tags-todo. Now I can select done keywords using a match string like "+tag/DONE|CANC" (also much clearer in my opinion). - -While this is usually more efficient, it may be counterproductive in cases where skip functions can be used to ignore huge sections of an org file (which is rarely for me; most only skip ahead to the next heading). -#+BEGIN_SRC emacs-lisp -(defun org-x-tags-view-advice (orig-fn &optional todo-only match) - "Advice to include done states in `org-tags-view' for tags-todo agenda types." - (nd/with-advice - ((#'org-make-tags-matcher - :around (lambda (f m) - (let ((org--matcher-tags-todo-only nil)) - (funcall f m))))) - (funcall orig-fn todo-only match))) - -(advice-add #'org-tags-view :around #'org-x-tags-view-advice) -#+END_SRC **** block agenda views ***** default sorting This gives more flexibility in ignoring items with timestamps @@ -3353,32 +2355,6 @@ In these cases, it is nice to know what happened during each cycle, so force not #+BEGIN_SRC emacs-lisp (setq org-log-repeat 'note) #+END_SRC -**** creation time -=org-mode= has no good way out of the box to add creation time to todo entries or headings. This is nice to have as I can use them to see which tasks are bein ignored or neglected. - -And yes, there is =org-expiry=, but it does more than I need and I don't feel like installing the extra contrib libraries. - -This function adds the =CREATED= property. Note that I only really care about TODO entries, as anything else is either not worth tracking or an appointment which already have timestamps. -#+BEGIN_SRC emacs-lisp -(defun nd/org-set-creation-time (&optional always &rest args) - "Set the creation time property of the current heading. -Applies only to todo entries unless ALWAYS is t." - ;; (when (or always (org-x-is-todoitem-p)) - (let* ((ts (format-time-string (cdr org-time-stamp-formats))) - (ts-ia (concat "[" (substring ts 1 -1) "]"))) - (funcall-interactively 'org-set-property "CREATED" ts-ia))) -#+END_SRC - -Advise the =org-insert-todo-entry= function. Advice here is necessary as there is only a hook for =org-insert-heading= and it fires before the TODO info is added. -#+BEGIN_SRC emacs-lisp -(advice-add 'org-insert-heading :after #'nd/org-set-creation-time) -(advice-add 'org-insert-todo-heading :after #'nd/org-set-creation-time) -#+END_SRC - -Add hook for =org-capture=. -#+BEGIN_SRC emacs-lisp -(add-hook 'org-capture-before-finalize-hook #'nd/org-set-creation-time) -#+END_SRC *** sqlite backend Org mode is great and all, but in many cases, text files just won't cut it. Hardcore data analysis is one of them, so make functions to shove org files (specifically archive files) into a sqlite database **** load path