358 lines
15 KiB
EmacsLisp
358 lines
15 KiB
EmacsLisp
;;; acdw-org.el -*- 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.
|
||
|
||
;;; Code:
|
||
|
||
|
||
;;; 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 default)
|
||
"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 default
|
||
(org-return)
|
||
(cond
|
||
;; Act depending on context around point.
|
||
|
||
;; NOTE: I prefer RET to not follow links, but by uncommenting this block, links will be
|
||
;; followed.
|
||
|
||
;; ((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))
|
||
;; FIXME: looking-back is supposed to be called with more arguments.
|
||
(while (not (looking-back (rx (repeat 3 (seq (optional blank) "\n")))))
|
||
(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 that blank lines exist between headings and
|
||
between headings and their contents. With prefix, operate on
|
||
whole buffer. Ensures that blank lines exist after each
|
||
headings's drawers."
|
||
(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)))
|
||
|
||
(defun acdw-org/fix-blank-lines-in-buffer ()
|
||
(when (eq major-mode 'org-mode)
|
||
(let ((current-prefix-arg 4))
|
||
(call-interactively #'acdw-org/fix-blank-lines))))
|
||
|
||
|
||
;;; 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 (s-downcase title))
|
||
(setq title (s-replace-regexp "[^a-zA-Z0-9]+" "-" title))
|
||
(setq title (s-replace-regexp "-+" "-" title))
|
||
(setq title (s-replace-regexp "^-" "" title))
|
||
(setq title (s-replace-regexp "-$" "" title))
|
||
title)
|
||
|
||
|
||
;;; ADVICE AND TWEAKS
|
||
|
||
;; Correct `org-delete-backward-char' to use `backward-delete-char-untabify'
|
||
(defun acdw-org/delete-backward-char (N)
|
||
"Like `delete-backward-char-untabify', insert whitespace at field end in tables.
|
||
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))))
|
||
|
||
(defun acdw-org/org-table-copy-down (n)
|
||
"Like `org-table-copy-down', except instead of erroring when
|
||
that command makes no sense, just call `org-return'."
|
||
(interactive "p")
|
||
(if (org-table-check-inside-data-field 'noerror)
|
||
(org-table-copy-down n)
|
||
(acdw-org/return-dwim n)))
|
||
|
||
(defun acdw-org/count-words (start end)
|
||
"Count words between START and END, respecting `org-mode' conventions."
|
||
(interactive (list nil nil))
|
||
(cond ((not (called-interactively-p 'any))
|
||
(let ((words 0))
|
||
(save-excursion
|
||
(save-restriction
|
||
(narrow-to-region start end)
|
||
(goto-char (point-min))
|
||
(while (< (point) (point-max))
|
||
(cond
|
||
;; Ignore comments
|
||
((or (org-at-comment-p)
|
||
(org-in-commented-heading-p)) nil)
|
||
;; Ignore tables
|
||
((org-at-table-p) nil)
|
||
;; Ignore hyperlinks, but count the descriptions
|
||
((looking-at org-bracket-link-analytic-regexp)
|
||
(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 code blocks
|
||
((org-in-src-block-p) nil)
|
||
;; Ignore footnotes
|
||
((or (org-footnote-at-definition-p)
|
||
(org-footnote-at-reference-p))
|
||
nil)
|
||
;; else... check the context
|
||
(t (let ((contexts (org-context)))
|
||
(cond
|
||
;; Ignore tags, TODO keywords, etc.
|
||
((or (assoc :todo-keyword contexts)
|
||
(assoc :priority contexts)
|
||
(assoc :keyword contexts)
|
||
(assoc :checkbox contexts))
|
||
nil)
|
||
;; Ignore sections tagged :no-export
|
||
((assoc :tags contexts)
|
||
(if (intersection (org-get-tags-at)
|
||
org-export-exclude-tags
|
||
:test 'equal)
|
||
(org-forward-same-level 1)
|
||
nil))
|
||
;; else... count the word
|
||
(t (setq words (1+ words)))))))
|
||
(re-search-forward "\\w+\\W*")))
|
||
words)))
|
||
((use-region-p)
|
||
(message "%d words in region"
|
||
(acdw-org/count-words (region-beginning) (region-end))))
|
||
(t
|
||
(message "%d words in buffer"
|
||
(acdw-org/count-words (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-make-link-string clipboard-url region-content)))
|
||
((and clipboard-url (not point-in-link))
|
||
(insert (org-make-link-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)))))
|
||
|
||
|
||
(provide 'acdw-org)
|
||
;; acdw-org.el ends here
|