;;; 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 (org-entry-is-todo-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: