sqrtminusone/dotfiles
1
0
Fork 0
mirror of https://github.com/SqrtMinusOne/dotfiles.git synced 2025-12-11 11:43:03 +03:00
Code Issues Projects Releases Packages Wiki Activity Actions

emacs: experiments with sequential headers in org-mode

Browse source
This commit is contained in:
Pavel Korytov 2024-07-13 22:39:13 +03:00
parent d0488e62ce
commit 525b4fcb54
2 changed files with 240 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

115
.emacs.d/init.el
View file

@ -3787,7 +3787,21 @@ With ARG, repeats or can move backward if negative."
:commands (org-clock-agg) :commands (org-clock-agg)
:init :init
(with-eval-after-load 'org (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 (with-eval-after-load 'org
(setq org-clock-persist 'clock) (setq org-clock-persist 'clock)
@ -4006,7 +4020,15 @@ TYPE may be `ts', `ts-active', `ts-inactive', `clocked', or
(not (property "MEETING")) (not (property "MEETING"))
(ts :from -7)) (ts :from -7))
:super-groups '((:auto-outline-path-file t)))) :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) (defun my/org-ql-view--format-element-override (element)
"Format ELEMENT for `org-ql-view'. "Format ELEMENT for `org-ql-view'.
@ -4323,6 +4345,95 @@ KEYS is a list of cons cells like (<label> . <time>)."
(buffer-string))))) (buffer-string)))))
(goto-char beg))) (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 () (defun my/org-archive--get-file ()
"Get an archive version of the file." "Get an archive version of the file."
(let ((archive-file (let ((archive-file

130
Emacs.org
View file

@ -5291,7 +5291,21 @@ It's been somewhat complicated to integrate into my workflow, but I think it's b
:commands (org-clock-agg) :commands (org-clock-agg)
:init :init
(with-eval-after-load 'org (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 #+end_src
The following enables org-clock persistence between Emacs sessions. The following enables org-clock persistence between Emacs sessions.
@ -5566,7 +5580,15 @@ Putting all the above in =org-ql-views=.
(not (property "MEETING")) (not (property "MEETING"))
(ts :from -7)) (ts :from -7))
:super-groups '((:auto-outline-path-file t)))) :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 #+end_src
***** Custom format element ***** 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))) (add-hook 'emacs-startup-hook #'my/org-alert-mode)))
#+end_src #+end_src
**** Copying records **** Seqeuential headers
I like to add numbers to repeating events, like meetings. E.g. I like to add numbers to repeating events, like meetings. E.g.
#+begin_example #+begin_example
@ -5866,6 +5888,7 @@ SCHEDULED: <2022-11-14 16:00>
... ...
#+end_example #+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. 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=: 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 #+end_src
My addition to that is the form with =evil-numbers/inc-at-pt=. 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 **** Archiving records
- *CREDIT*: thanks [[https://emacs.ch/@grinn][Amy]] for pointing me to the right functionality of =org-refile=. - *CREDIT*: thanks [[https://emacs.ch/@grinn][Amy]] for pointing me to the right functionality of =org-refile=.