518 lines
20 KiB
EmacsLisp
518 lines
20 KiB
EmacsLisp
;;; acdw-org.el --- org extras -*- lexical-binding: t; coding: utf-8-unix -*-
|
||
;; Author: Various
|
||
;; URL: https://tildegit.org/acdw/emacs
|
||
|
||
;; This file is NOT part of GNU Emacs.
|
||
|
||
;;; License:
|
||
|
||
;; Everyone is permitted to do whatever with this software, without
|
||
;; limitation. This software comes without any warranty whatsoever,
|
||
;; but with two pieces of advice:
|
||
;; - Don't hurt yourself.
|
||
;; - Make good choices.
|
||
|
||
;;; Commentary:
|
||
|
||
;; This file is for the weird little `org-mode' functions that just take up
|
||
;; space in my main init file. I've tried to give credit where credit is due.
|
||
|
||
;; 2021-09-13 Hi readers of "Emacs News!" I just saw that Sacha decided to
|
||
;; include this in her weekly newsletter. Thanks for the gold kind stranger,
|
||
;; etc. If you're looking for stuff in here that /isn't/ just ripped
|
||
;; wholesale from something else on the internet, you'll want the following
|
||
;; (updated as I write more/remember to update them):
|
||
|
||
;; `acdw-org/fix-blank-lines-in-buffer'
|
||
;; `acdw-org/count-words-stupidly'
|
||
;; `acdw/org-next-heading-widen'
|
||
;; `acdw/org-previous-heading-widen'
|
||
;; `acdw-org/work-month-headings'
|
||
|
||
;; To be honest, I could easily (and probably should) extract some of these out
|
||
;; into their own /real/ libraries.
|
||
|
||
;; Until then, just require this file /after/ you require org -- i.e.,
|
||
;; (with-eval-after-load 'org (require 'acdw-org)) -- or else it'll load every
|
||
;; time you start up Emacs.
|
||
|
||
;;; Code:
|
||
|
||
(require 'dom)
|
||
(require 'org)
|
||
(require 'org-element)
|
||
(require 'ox)
|
||
(require 'subr-x)
|
||
(require 'calendar)
|
||
|
||
|
||
;;; unpackaged.el: https://github.com/alphapapa/unpackaged.el
|
||
|
||
(defun acdw-org/element-descendant-of (type element)
|
||
"Return non-nil if ELEMENT is a descendant of TYPE.
|
||
TYPE should be an element type, like `item' or `paragraph'.
|
||
ELEMENT should be a list like that returned by `org-element-context'."
|
||
;; MAYBE: Use `org-element-lineage'.
|
||
(when-let* ((parent (org-element-property :parent element)))
|
||
(or (eq type (car parent))
|
||
(acdw-org/element-descendant-of type parent))))
|
||
|
||
(defun acdw-org/return-dwim (&optional prefix)
|
||
"A helpful replacement for `org-return'. With PREFIX, call `org-return'.
|
||
|
||
On headings, move point to position after entry content. In
|
||
lists, insert a new item or end the list, with checkbox if
|
||
appropriate. In tables, insert a new row or end the table."
|
||
;; Inspired by John Kitchin:
|
||
;; http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/
|
||
(interactive "P")
|
||
;; Auto-fill if enabled
|
||
(when auto-fill-function
|
||
(if (listp auto-fill-function)
|
||
(dolist (func auto-fill-function)
|
||
(funcall func))
|
||
(funcall auto-fill-function)))
|
||
(if prefix
|
||
;; Handle prefix args
|
||
(pcase prefix
|
||
('(4) (newline))
|
||
('(16) (newline 2))
|
||
;; this is ... not ideal. but whatever.
|
||
(_ (newline prefix)))
|
||
(cond
|
||
;; Act depending on context around point.
|
||
((and org-return-follows-link
|
||
(eq 'link (car (org-element-context))))
|
||
;; Link: Open it.
|
||
(org-open-at-point-global))
|
||
|
||
((org-at-heading-p)
|
||
;; Heading: Move to position after entry content.
|
||
;; NOTE: This is probably the most interesting feature of this function.
|
||
(let ((heading-start (org-entry-beginning-position)))
|
||
(goto-char (org-entry-end-position))
|
||
(cond ((and (org-at-heading-p)
|
||
(= heading-start (org-entry-beginning-position)))
|
||
;; Entry ends on its heading; add newline after
|
||
(end-of-line)
|
||
(insert "\n\n"))
|
||
(t
|
||
;; Entry ends after its heading; back up
|
||
(forward-line -1)
|
||
(end-of-line)
|
||
(when (org-at-heading-p)
|
||
;; At the same heading
|
||
(forward-line)
|
||
(insert "\n")
|
||
(forward-line -1))
|
||
(while (not
|
||
(looking-back
|
||
(rx (repeat 3 (seq (optional blank) "\n")))
|
||
nil))
|
||
(insert "\n"))
|
||
(forward-line -1)))))
|
||
|
||
((org-at-item-checkbox-p)
|
||
;; Checkbox: Insert new item with checkbox.
|
||
(org-insert-todo-heading nil))
|
||
|
||
((org-in-item-p)
|
||
;; Plain list
|
||
(let* ((context (org-element-context))
|
||
(first-item-p (eq 'plain-list (car context)))
|
||
(itemp (eq 'item (car context)))
|
||
(emptyp (eq (org-element-property :contents-begin context)
|
||
(org-element-property :contents-end context)))
|
||
(item-child-p
|
||
(acdw-org/element-descendant-of 'item context)))
|
||
;; The original function from unpackaged just tested the (or ...) test
|
||
;; in this cond, in an if. However, that doesn't auto-end nested
|
||
;; lists. So I made this form a cond and added the (and...) test in
|
||
;; the first position, which is clunky (the delete-region... stuff
|
||
;; comes twice) and might not be needed. More testing, obviously, but
|
||
;; for now, it works well enough.
|
||
(cond ((and itemp emptyp)
|
||
(delete-region (line-beginning-position) (line-end-position))
|
||
(insert "\n\n"))
|
||
((or first-item-p
|
||
(and itemp (not emptyp))
|
||
item-child-p)
|
||
(org-insert-item))
|
||
(t (delete-region (line-beginning-position) (line-end-position))
|
||
(insert "\n")))))
|
||
|
||
((when (fboundp 'org-inlinetask-in-task-p)
|
||
(org-inlinetask-in-task-p))
|
||
;; Inline task: Don't insert a new heading.
|
||
(org-return))
|
||
|
||
((org-at-table-p)
|
||
(cond ((save-excursion
|
||
(beginning-of-line)
|
||
;; See `org-table-next-field'.
|
||
(cl-loop with end = (line-end-position)
|
||
for cell = (org-element-table-cell-parser)
|
||
always (equal (org-element-property :contents-begin cell)
|
||
(org-element-property :contents-end cell))
|
||
while (re-search-forward "|" end t)))
|
||
;; Empty row: end the table.
|
||
(delete-region (line-beginning-position) (line-end-position))
|
||
(org-return))
|
||
(t
|
||
;; Non-empty row: call `org-return'.
|
||
(org-return))))
|
||
(t
|
||
;; All other cases: call `org-return'.
|
||
(org-return)))))
|
||
|
||
(defun acdw-org/fix-blank-lines (&optional prefix)
|
||
"Ensure blank lines around headings.
|
||
Optional PREFIX argument operates on the entire buffer.
|
||
Drawers are included with their headings."
|
||
(interactive "P")
|
||
(org-map-entries (lambda ()
|
||
(org-with-wide-buffer
|
||
;; `org-map-entries' narrows the buffer, which
|
||
;; prevents us from seeing newlines before the
|
||
;; current heading, so we do this part widened.
|
||
(while (not (looking-back "\n\n" nil))
|
||
;; Insert blank lines before heading.
|
||
(insert "\n")))
|
||
(let ((end (org-entry-end-position)))
|
||
;; Insert blank lines before entry content
|
||
(forward-line)
|
||
(while (and (org-at-planning-p)
|
||
(< (point) (point-max)))
|
||
;; Skip planning lines
|
||
(forward-line))
|
||
(while (re-search-forward
|
||
org-drawer-regexp end t)
|
||
;; Skip drawers. You might think that
|
||
;; `org-at-drawer-p' would suffice, but for
|
||
;; some reason it doesn't work correctly when
|
||
;; operating on hidden text. This works, taken
|
||
;; from `org-agenda-get-some-entry-text'.
|
||
(re-search-forward "^[ \t]*:END:.*\n?" end t)
|
||
(goto-char (match-end 0)))
|
||
(unless (or (= (point) (point-max))
|
||
(org-at-heading-p)
|
||
(looking-at-p "\n"))
|
||
(insert "\n"))))
|
||
t
|
||
(if prefix
|
||
nil
|
||
'tree)))
|
||
|
||
|
||
;;; Generate custom IDs:
|
||
;; https://amitp.blogspot.com/2021/04/automatically-generate-ids-for-emacs.html
|
||
|
||
(defun acdw-org/generate-custom-ids ()
|
||
"Generate CUSTOM_ID for any headings that are missing one."
|
||
(let ((existing-ids (org-map-entries (lambda ()
|
||
(org-entry-get nil "CUSTOM_ID")))))
|
||
(org-map-entries
|
||
(lambda ()
|
||
(let* ((custom-id (org-entry-get nil "CUSTOM_ID"))
|
||
(heading (org-heading-components))
|
||
(level (nth 0 heading))
|
||
(todo (nth 2 heading))
|
||
(headline (nth 4 heading))
|
||
(slug (acdw-org/title-to-filename headline))
|
||
(duplicate-id (member slug existing-ids)))
|
||
(when (and (not custom-id)
|
||
(< level 4)
|
||
(not todo)
|
||
(not duplicate-id))
|
||
(message "Adding entry '%s' to '%s'" slug headline)
|
||
(org-entry-put nil "CUSTOM_ID" slug)))))))
|
||
|
||
(defun acdw-org/title-to-filename (title)
|
||
"Convert TITLE to a reasonable filename."
|
||
;; Based on the slug logic in `org-roam', but `org-roam' also uses a
|
||
;; timestamp, and I only use the slug.
|
||
(setq title (downcase title))
|
||
(setq title (replace-regexp-in-string "[^a-zA-Z0-9]+" "-" title))
|
||
(setq title (replace-regexp-in-string "-+" "-" title))
|
||
(setq title (replace-regexp-in-string "^-" "" title))
|
||
(setq title (replace-regexp-in-string "-$" "" title))
|
||
title)
|
||
|
||
|
||
;;; ADVICE AND TWEAKS
|
||
|
||
;; I definitely got this from somewhere.
|
||
;; Correct `org-delete-backward-char' to use `backward-delete-char-untabify'
|
||
(defun acdw-org/delete-backward-char (N)
|
||
"Keep tables aligned while deleting N characters backward.
|
||
When deleting backwards, in tables this function will insert
|
||
whitespace in front of the next \"|\" separator, to keep the
|
||
table aligned. The table will still be marked for re-alignment
|
||
if the field did fill the entire column, because, in this case
|
||
the deletion might narrow the column."
|
||
(interactive "p")
|
||
(save-match-data
|
||
(org-check-before-invisible-edit 'delete-backward)
|
||
(if (and (= N 1)
|
||
(not overwrite-mode)
|
||
(not (org-region-active-p))
|
||
(not (eq (char-before) ?|))
|
||
(save-excursion (skip-chars-backward " \t") (not (bolp)))
|
||
(looking-at-p ".*?|")
|
||
(org-at-table-p))
|
||
(progn (forward-char -1) (org-delete-char 1))
|
||
(backward-delete-char-untabify N)
|
||
(org-fix-tags-on-the-fly))))
|
||
|
||
;; Same here.
|
||
(defun acdw-org/org-table-copy-down (n)
|
||
"Call `org-table-copy-down', or `org-return' outside of a table.
|
||
N is passed to the functions."
|
||
(interactive "p")
|
||
(if (org-table-check-inside-data-field 'noerror)
|
||
(org-table-copy-down n)
|
||
(acdw-org/return-dwim n)))
|
||
|
||
;; This isn't the best code, but it'll do.
|
||
(defun acdw-org/count-words-stupidly (start end &optional limit)
|
||
"Count words between START and END, ignoring a lot.
|
||
|
||
Since this function is, for some reason, pricy, the optional
|
||
parameter LIMIT sets a word limit at which to stop counting.
|
||
Once the function hits that number, it'll return -LIMIT
|
||
instead of the true count."
|
||
(interactive (list nil nil))
|
||
(cond ((not (called-interactively-p 'any))
|
||
(let ((words 0)
|
||
(continue t))
|
||
(save-excursion
|
||
(save-restriction
|
||
(narrow-to-region start end)
|
||
(goto-char (point-min))
|
||
(while (and continue
|
||
(< (point) (point-max)))
|
||
(cond
|
||
;; Ignore comments
|
||
((or (org-at-comment-p)
|
||
(org-in-commented-heading-p))
|
||
(forward-line))
|
||
;; Ignore headings
|
||
((or (org-at-heading-p))
|
||
(forward-line))
|
||
;; Ignore property and log drawers
|
||
((or (looking-at org-drawer-regexp)
|
||
(looking-at org-clock-drawer-re))
|
||
(search-forward ":END:" nil :noerror)
|
||
(forward-line))
|
||
;; Ignore DEADLINE and SCHEDULED keywords
|
||
((or (looking-at org-deadline-regexp)
|
||
(looking-at org-scheduled-regexp)
|
||
(looking-at org-closed-time-regexp))
|
||
(forward-line))
|
||
;; Ignore tables
|
||
((org-at-table-p) (forward-line))
|
||
;; Ignore hyperlinks, but count the descriptions
|
||
((looking-at org-link-bracket-re)
|
||
(when-let ((desc (match-string-no-properties 5)))
|
||
(save-match-data
|
||
(setq words (+ words
|
||
(length (remove ""
|
||
(org-split-string
|
||
desc "\\W")))))))
|
||
(goto-char (match-end 0)))
|
||
;; Ignore source blocks
|
||
((org-in-src-block-p) (forward-line))
|
||
;; Ignore blank lines
|
||
((looking-at "^$")
|
||
(forward-line))
|
||
;; Count everything else
|
||
(t
|
||
;; ... unless it's in a few weird contexts
|
||
(let ((contexts (org-context)))
|
||
(cond ((or (assoc :todo-keyword contexts)
|
||
(assoc :priority contexts)
|
||
(assoc :keyword contexts)
|
||
(assoc :checkbox contexts))
|
||
(forward-word-strictly))
|
||
|
||
(t (setq words (1+ words))
|
||
(if (and limit
|
||
(> words limit))
|
||
(setq words (- limit)
|
||
continue nil))
|
||
(forward-word-strictly)))))))))
|
||
words))
|
||
((use-region-p)
|
||
(message "%d words in region"
|
||
(acdw-org/count-words-stupidly (region-beginning)
|
||
(region-end))))
|
||
(t
|
||
(message "%d words in buffer"
|
||
(acdw-org/count-words-stupidly (point-min)
|
||
(point-max))))))
|
||
|
||
|
||
;;; Zero-width spaces
|
||
;; https://blog.tecosaur.com/tmio/2021-05-31-async.html#easy-zero-width
|
||
|
||
(defun insert-zero-width-space ()
|
||
"Insert a zero-width space."
|
||
(interactive)
|
||
(insert "\u200b"))
|
||
|
||
(defun org-export-remove-zero-width-spaces (text _backend _info)
|
||
"Remove zero-width spaces from TEXT."
|
||
(unless (org-export-derived-backend-p 'org)
|
||
(replace-regexp-in-string "\u200b" "" text)))
|
||
|
||
|
||
;;; Insert links .. DWIM
|
||
;; https://xenodium.com/emacs-dwim-do-what-i-mean/
|
||
|
||
(defun org-insert-link-dwim ()
|
||
"Like `org-insert-link' but with personal dwim preferences."
|
||
(interactive)
|
||
(let* ((point-in-link (org-in-regexp org-link-any-re 1))
|
||
(clipboard-url (when (string-match-p
|
||
(rx (sequence bos
|
||
(or "http"
|
||
"gemini"
|
||
"gopher")))
|
||
(current-kill 0))
|
||
(current-kill 0)))
|
||
(region-content (when (region-active-p)
|
||
(buffer-substring-no-properties (region-beginning)
|
||
(region-end)))))
|
||
(cond ((and region-content clipboard-url (not point-in-link))
|
||
(delete-region (region-beginning) (region-end))
|
||
(insert (org-link-make-string clipboard-url region-content)))
|
||
((and clipboard-url (not point-in-link))
|
||
(insert (org-link-make-string
|
||
clipboard-url
|
||
(read-string "title: "
|
||
(with-current-buffer
|
||
(url-retrieve-synchronously
|
||
clipboard-url)
|
||
(dom-text
|
||
(car
|
||
(dom-by-tag (libxml-parse-html-region
|
||
(point-min)
|
||
(point-max))
|
||
'title))))))))
|
||
(t
|
||
(call-interactively 'org-insert-link)))))
|
||
|
||
|
||
;;; Next and previous heading, with widening
|
||
(defun acdw/org-next-heading-widen (arg)
|
||
"Find the ARGth next org heading, widening if necessary."
|
||
(interactive "p")
|
||
(let ((current-point (point))
|
||
(point-target (if (> arg 0) (point-max) (point-min))))
|
||
(org-next-visible-heading arg)
|
||
(when (and (buffer-narrowed-p)
|
||
(= (point) point-target)
|
||
(or (and (> arg 0))
|
||
(and (< arg 0)
|
||
(= (point) current-point))))
|
||
(widen)
|
||
(org-next-visible-heading arg))))
|
||
|
||
(defun acdw/org-previous-heading-widen (arg)
|
||
"Find the ARGth previous org heading, widening if necessary."
|
||
(interactive "p")
|
||
(acdw/org-next-heading-widen (- arg)))
|
||
|
||
|
||
;;; Add headings for every day of the work month
|
||
;; Gets rid of weekends.
|
||
|
||
(defun acdw-org/work-month-headings (&optional month year)
|
||
"Create headings for every workday in MONTH and YEAR, or this month.
|
||
Workdays are Monday through Friday. This function inserts a new
|
||
heading with an inactive timestamp for each workday of MONTH in YEAR.
|
||
|
||
I use this function to attempt to organize my work month. I'll
|
||
probably abandon it at some point for a better solution (see:
|
||
`org-agenda')."
|
||
(interactive (list
|
||
(read-number "Month: " (car (calendar-current-date)))
|
||
(read-number "Year: " (nth 2 (calendar-current-date)))))
|
||
(let ((month (or month
|
||
(car (calendar-current-date))))
|
||
(year (or year
|
||
(car (last (calendar-current-date))))))
|
||
(dotimes (day (calendar-last-day-of-month month year))
|
||
(let* ((day (1+ day))
|
||
(day-of-week (calendar-day-of-week (list month day year))))
|
||
(unless (memq day-of-week '(0 6)) ; weekend
|
||
(end-of-line)
|
||
(org-insert-heading nil t t)
|
||
(insert (concat "[" (mapconcat (lambda (n)
|
||
(format "%02d" n))
|
||
(list year month day)
|
||
"-")
|
||
" "
|
||
(nth day-of-week '("Sun" "Mon" "Tue" "Wed" "Thu"
|
||
"Fri" "Sat"))
|
||
"]")))))))
|
||
|
||
;;; Org task stuff
|
||
|
||
(defun org-narrow-to-task ()
|
||
"Narrow buffer to the nearest task and its subtree."
|
||
(interactive)
|
||
(save-excursion
|
||
(save-match-data
|
||
(widen)
|
||
(while (not (or (org-entry-is-todo-p)
|
||
(org-entry-is-done-p)))
|
||
;; TODO: need a better error message
|
||
(org-previous-visible-heading 1))
|
||
(org-narrow-to-subtree))))
|
||
|
||
|
||
;;; Hide everything but the current headline
|
||
;; https://stackoverflow.com/questions/25161792/
|
||
|
||
(defun acdw-org/show-next-heading-tidily ()
|
||
"Show next entry, keeping other entries closed."
|
||
(interactive)
|
||
(if (save-excursion (end-of-line) (outline-invisible-p))
|
||
(progn (org-show-entry) (outline-show-children))
|
||
(outline-next-heading)
|
||
(unless (and (bolp) (org-at-heading-p))
|
||
(org-up-heading-safe)
|
||
(outline-hide-subtree)
|
||
(error "Boundary reached"))
|
||
(org-overview)
|
||
(org-reveal t)
|
||
(org-show-entry)
|
||
(recenter-top-bottom)
|
||
(outline-show-children)
|
||
(recenter-top-bottom)))
|
||
|
||
(defun acdw-org/show-previous-heading-tidily ()
|
||
"Show previous entry, keeping other entries closed."
|
||
(interactive)
|
||
(let ((pos (point)))
|
||
(outline-previous-heading)
|
||
(unless (and (< (point) pos) (bolp) (org-at-heading-p))
|
||
(goto-char pos)
|
||
(outline-hide-subtree)
|
||
(error "Boundary reached"))
|
||
(org-overview)
|
||
(org-reveal t)
|
||
(org-show-entry)
|
||
(recenter-top-bottom)
|
||
(outline-show-children)
|
||
(recenter-top-bottom)))
|
||
|
||
|
||
(provide 'acdw-org)
|
||
;;; acdw-org.el ends here
|
||
|
||
;; Local Variables:
|
||
;; flymake-inhibit: t
|
||
;; End:
|