mirror of
https://github.com/SqrtMinusOne/dotfiles.git
synced 2025-12-10 19:23:03 +03:00
emacs: experiments with sequential headers in org-mode
This commit is contained in:
parent
d0488e62ce
commit
525b4fcb54
2 changed files with 240 additions and 5 deletions
115
.emacs.d/init.el
115
.emacs.d/init.el
|
|
@ -3787,7 +3787,21 @@ With ARG, repeats or can move backward if negative."
|
|||
:commands (org-clock-agg)
|
||||
:init
|
||||
(with-eval-after-load 'org
|
||||
(my-leader-def "ol" #'org-clock-agg)))
|
||||
(my-leader-def "ol" #'org-clock-agg))
|
||||
:config
|
||||
(push
|
||||
(cons "Agenda+Archive"
|
||||
(append
|
||||
(org-agenda-files)
|
||||
(thread-last "/projects/archive"
|
||||
(concat org-directory)
|
||||
(directory-files)
|
||||
(mapcar (lambda (f)
|
||||
(concat
|
||||
org-directory "/projects/archive/" f)))
|
||||
(seq-filter (lambda (f)
|
||||
(not (file-directory-p f)))))))
|
||||
org-clock-agg-files-preset))
|
||||
|
||||
(with-eval-after-load 'org
|
||||
(setq org-clock-persist 'clock)
|
||||
|
|
@ -4006,7 +4020,15 @@ TYPE may be `ts', `ts-active', `ts-inactive', `clocked', or
|
|||
(not (property "MEETING"))
|
||||
(ts :from -7))
|
||||
:super-groups '((:auto-outline-path-file t))))
|
||||
(cons "Review: Meeting" #'my/org-ql-meeting-tasks)))
|
||||
(cons "Review: Meeting" #'my/org-ql-meeting-tasks)
|
||||
(cons "Fix: tasks without TASK_KIND"
|
||||
(lambda ()
|
||||
(interactive)
|
||||
(org-ql-search (current-buffer)
|
||||
'(and (olp "Tasks")
|
||||
(not (property "TASK_KIND"))
|
||||
(clocked))
|
||||
:super-groups '((:auto-outline-path-file t)))))))
|
||||
|
||||
(defun my/org-ql-view--format-element-override (element)
|
||||
"Format ELEMENT for `org-ql-view'.
|
||||
|
|
@ -4323,6 +4345,95 @@ KEYS is a list of cons cells like (<label> . <time>)."
|
|||
(buffer-string)))))
|
||||
(goto-char beg)))
|
||||
|
||||
(defun my/org--headings-in-outline ()
|
||||
(org-ql-query
|
||||
:select (lambda () (propertize
|
||||
(substring-no-properties (org-get-heading t t t))
|
||||
'marker (copy-marker (point))))
|
||||
:from (append
|
||||
(list (buffer-file-name))
|
||||
(let ((archive
|
||||
(concat (file-name-directory (buffer-file-name))
|
||||
"archive/"
|
||||
(file-name-nondirectory (buffer-file-name)))))
|
||||
(when (file-exists-p archive)
|
||||
(list archive))))
|
||||
:where `(and (outline-path ,@(org-get-outline-path))
|
||||
(level ,(org-current-level)))))
|
||||
|
||||
(defun my/org--heading-strip (heading)
|
||||
(thread-last
|
||||
heading
|
||||
(substring-no-properties)
|
||||
(replace-regexp-in-string (rx (| "(" "[") (+ alnum) (| "]" ")")) "")
|
||||
(replace-regexp-in-string (rx " " (+ (or digit "."))) " ")
|
||||
(replace-regexp-in-string (rx (+ " ")) " ")
|
||||
(string-trim)))
|
||||
|
||||
(defun my/org--headings-group-seq (headings)
|
||||
(thread-last
|
||||
headings
|
||||
(seq-group-by #'my/org--heading-strip)
|
||||
(seq-sort-by #'car #'string-lessp)
|
||||
(mapcar (lambda (group)
|
||||
(cons (car group)
|
||||
(seq-sort-by
|
||||
(lambda (heading)
|
||||
(save-match-data
|
||||
(or
|
||||
(and (string-match (rx (group (+ digit)))
|
||||
heading)
|
||||
(string-to-number (match-string 1 heading)))
|
||||
-1)))
|
||||
#'<
|
||||
(cdr group)))))))
|
||||
|
||||
(defun my/org-headings-seq ()
|
||||
(interactive)
|
||||
(let* ((headings (my/org--headings-in-outline))
|
||||
(headings-seq (my/org--headings-group-seq headings))
|
||||
(buffer (generate-new-buffer "*Sequential Headings in Outline*")))
|
||||
(with-current-buffer buffer
|
||||
(outline-mode)
|
||||
(setq-local widget-push-button-prefix "")
|
||||
(setq-local widget-push-button-suffix "")
|
||||
(dolist (group headings-seq)
|
||||
(insert (format "* %s\n" (car group)))
|
||||
(dolist (heading (cdr group))
|
||||
(widget-create 'push-button
|
||||
:marker (get-text-property 0 'marker heading)
|
||||
:notify (lambda (widget &rest ignore)
|
||||
(let ((marker (widget-get widget :marker)))
|
||||
(pop-to-buffer (marker-buffer marker))
|
||||
(goto-char marker)))
|
||||
(concat "** " (substring-no-properties heading)))
|
||||
(insert "\n")))
|
||||
(widget-setup)
|
||||
(setq buffer-read-only t)
|
||||
(goto-char (point-min)))
|
||||
(pop-to-buffer buffer)))
|
||||
|
||||
(defun my/org-heading-seq-insert ()
|
||||
(interactive)
|
||||
(let* ((headings (my/org--headings-in-outline))
|
||||
(headings-seq (my/org--headings-group-seq headings))
|
||||
(heading (completing-read "Headings: " headings-seq))
|
||||
(last-number
|
||||
(thread-last headings-seq
|
||||
(assoc heading)
|
||||
(cdr)
|
||||
(mapcar (lambda (x)
|
||||
(save-match-data
|
||||
(or
|
||||
(when (string-match (rx (group (+ digit)))
|
||||
x)
|
||||
(string-to-number (match-string 1 x)))
|
||||
1))))
|
||||
(seq-max)
|
||||
(1+))))
|
||||
(org-insert-heading '(4))
|
||||
(insert (format "FUTURE %s %s" heading last-number))))
|
||||
|
||||
(defun my/org-archive--get-file ()
|
||||
"Get an archive version of the file."
|
||||
(let ((archive-file
|
||||
|
|
|
|||
130
Emacs.org
130
Emacs.org
|
|
@ -5291,7 +5291,21 @@ It's been somewhat complicated to integrate into my workflow, but I think it's b
|
|||
:commands (org-clock-agg)
|
||||
:init
|
||||
(with-eval-after-load 'org
|
||||
(my-leader-def "ol" #'org-clock-agg)))
|
||||
(my-leader-def "ol" #'org-clock-agg))
|
||||
:config
|
||||
(push
|
||||
(cons "Agenda+Archive"
|
||||
(append
|
||||
(org-agenda-files)
|
||||
(thread-last "/projects/archive"
|
||||
(concat org-directory)
|
||||
(directory-files)
|
||||
(mapcar (lambda (f)
|
||||
(concat
|
||||
org-directory "/projects/archive/" f)))
|
||||
(seq-filter (lambda (f)
|
||||
(not (file-directory-p f)))))))
|
||||
org-clock-agg-files-preset))
|
||||
#+end_src
|
||||
|
||||
The following enables org-clock persistence between Emacs sessions.
|
||||
|
|
@ -5566,7 +5580,15 @@ Putting all the above in =org-ql-views=.
|
|||
(not (property "MEETING"))
|
||||
(ts :from -7))
|
||||
:super-groups '((:auto-outline-path-file t))))
|
||||
(cons "Review: Meeting" #'my/org-ql-meeting-tasks)))
|
||||
(cons "Review: Meeting" #'my/org-ql-meeting-tasks)
|
||||
(cons "Fix: tasks without TASK_KIND"
|
||||
(lambda ()
|
||||
(interactive)
|
||||
(org-ql-search (current-buffer)
|
||||
'(and (olp "Tasks")
|
||||
(not (property "TASK_KIND"))
|
||||
(clocked))
|
||||
:super-groups '((:auto-outline-path-file t)))))))
|
||||
#+end_src
|
||||
|
||||
***** Custom format element
|
||||
|
|
@ -5855,7 +5877,7 @@ I don't have any idea why, but evaluating =(my/org-alert-mode)= just after =org=
|
|||
(add-hook 'emacs-startup-hook #'my/org-alert-mode)))
|
||||
#+end_src
|
||||
|
||||
**** Copying records
|
||||
**** Seqeuential headers
|
||||
I like to add numbers to repeating events, like meetings. E.g.
|
||||
|
||||
#+begin_example
|
||||
|
|
@ -5866,6 +5888,7 @@ SCHEDULED: <2022-11-14 16:00>
|
|||
...
|
||||
#+end_example
|
||||
|
||||
***** Copying records
|
||||
Naturally, I want a way to copy such records. Org Mode already has a function called =org-clone-subtree-with-time-shift=, that does everything I want except for updating the numbers.
|
||||
|
||||
Unfortunately, I see no way to advise the original function, so here's my version that makes use of =evil-numbers=:
|
||||
|
|
@ -5956,6 +5979,107 @@ Unfortunately, I see no way to advise the original function, so here's my versio
|
|||
#+end_src
|
||||
|
||||
My addition to that is the form with =evil-numbers/inc-at-pt=.
|
||||
***** Keeping consistency among sequential records
|
||||
I also like to keep such headers consistent. Here are a few tools to help with that.
|
||||
|
||||
First, I need to find and group and such headers. =org-ql= can help with that:
|
||||
#+begin_src emacs-lisp
|
||||
(defun my/org--headings-in-outline ()
|
||||
(org-ql-query
|
||||
:select (lambda () (propertize
|
||||
(substring-no-properties (org-get-heading t t t))
|
||||
'marker (copy-marker (point))))
|
||||
:from (append
|
||||
(list (buffer-file-name))
|
||||
(let ((archive
|
||||
(concat (file-name-directory (buffer-file-name))
|
||||
"archive/"
|
||||
(file-name-nondirectory (buffer-file-name)))))
|
||||
(when (file-exists-p archive)
|
||||
(list archive))))
|
||||
:where `(and (outline-path ,@(org-get-outline-path))
|
||||
(level ,(org-current-level)))))
|
||||
|
||||
(defun my/org--heading-strip (heading)
|
||||
(thread-last
|
||||
heading
|
||||
(substring-no-properties)
|
||||
(replace-regexp-in-string (rx (| "(" "[") (+ alnum) (| "]" ")")) "")
|
||||
(replace-regexp-in-string (rx " " (+ (or digit "."))) " ")
|
||||
(replace-regexp-in-string (rx (+ " ")) " ")
|
||||
(string-trim)))
|
||||
|
||||
(defun my/org--headings-group-seq (headings)
|
||||
(thread-last
|
||||
headings
|
||||
(seq-group-by #'my/org--heading-strip)
|
||||
(seq-sort-by #'car #'string-lessp)
|
||||
(mapcar (lambda (group)
|
||||
(cons (car group)
|
||||
(seq-sort-by
|
||||
(lambda (heading)
|
||||
(save-match-data
|
||||
(or
|
||||
(and (string-match (rx (group (+ digit)))
|
||||
heading)
|
||||
(string-to-number (match-string 1 heading)))
|
||||
-1)))
|
||||
#'<
|
||||
(cdr group)))))))
|
||||
#+end_src
|
||||
|
||||
Then, display all such headings a buffer:
|
||||
#+begin_src emacs-lisp
|
||||
(defun my/org-headings-seq ()
|
||||
(interactive)
|
||||
(let* ((headings (my/org--headings-in-outline))
|
||||
(headings-seq (my/org--headings-group-seq headings))
|
||||
(buffer (generate-new-buffer "*Sequential Headings in Outline*")))
|
||||
(with-current-buffer buffer
|
||||
(outline-mode)
|
||||
(setq-local widget-push-button-prefix "")
|
||||
(setq-local widget-push-button-suffix "")
|
||||
(dolist (group headings-seq)
|
||||
(insert (format "* %s\n" (car group)))
|
||||
(dolist (heading (cdr group))
|
||||
(widget-create 'push-button
|
||||
:marker (get-text-property 0 'marker heading)
|
||||
:notify (lambda (widget &rest ignore)
|
||||
(let ((marker (widget-get widget :marker)))
|
||||
(pop-to-buffer (marker-buffer marker))
|
||||
(goto-char marker)))
|
||||
(concat "** " (substring-no-properties heading)))
|
||||
(insert "\n")))
|
||||
(widget-setup)
|
||||
(setq buffer-read-only t)
|
||||
(goto-char (point-min)))
|
||||
(pop-to-buffer buffer)))
|
||||
#+end_src
|
||||
|
||||
And insert a similar heading:
|
||||
#+begin_src emacs-lisp
|
||||
(defun my/org-heading-seq-insert ()
|
||||
(interactive)
|
||||
(let* ((headings (my/org--headings-in-outline))
|
||||
(headings-seq (my/org--headings-group-seq headings))
|
||||
(heading (completing-read "Headings: " headings-seq))
|
||||
(last-number
|
||||
(thread-last headings-seq
|
||||
(assoc heading)
|
||||
(cdr)
|
||||
(mapcar (lambda (x)
|
||||
(save-match-data
|
||||
(or
|
||||
(when (string-match (rx (group (+ digit)))
|
||||
x)
|
||||
(string-to-number (match-string 1 x)))
|
||||
1))))
|
||||
(seq-max)
|
||||
(1+))))
|
||||
(org-insert-heading '(4))
|
||||
(insert (format "FUTURE %s %s" heading last-number))))
|
||||
#+end_src
|
||||
|
||||
**** Archiving records
|
||||
- *CREDIT*: thanks [[https://emacs.ch/@grinn][Amy]] for pointing me to the right functionality of =org-refile=.
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue