From a2657993bad828af6743c68931a0e848bfcdec53 Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Sun, 21 Nov 2021 23:57:41 -0600 Subject: I DECLARE BANKRUPTCY ... 8 Didn't think to do this till pretty .. written, so here we are. --- lisp/acdw-org.el | 517 ------------------------------------------------------- 1 file changed, 517 deletions(-) delete mode 100644 lisp/acdw-org.el (limited to 'lisp/acdw-org.el') diff --git a/lisp/acdw-org.el b/lisp/acdw-org.el deleted file mode 100644 index f0a1d49..0000000 --- a/lisp/acdw-org.el +++ /dev/null @@ -1,517 +0,0 @@ -;;; 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: -- cgit 1.4.1-21-gabe81