diff options
Diffstat (limited to 'lisp/acdw-org.el')
-rw-r--r-- | lisp/acdw-org.el | 517 |
1 files changed, 0 insertions, 517 deletions
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 @@ | |||
1 | ;;; acdw-org.el --- org extras -*- lexical-binding: t; coding: utf-8-unix -*- | ||
2 | ;; Author: Various | ||
3 | ;; URL: https://tildegit.org/acdw/emacs | ||
4 | |||
5 | ;; This file is NOT part of GNU Emacs. | ||
6 | |||
7 | ;;; License: | ||
8 | |||
9 | ;; Everyone is permitted to do whatever with this software, without | ||
10 | ;; limitation. This software comes without any warranty whatsoever, | ||
11 | ;; but with two pieces of advice: | ||
12 | ;; - Don't hurt yourself. | ||
13 | ;; - Make good choices. | ||
14 | |||
15 | ;;; Commentary: | ||
16 | |||
17 | ;; This file is for the weird little `org-mode' functions that just take up | ||
18 | ;; space in my main init file. I've tried to give credit where credit is due. | ||
19 | |||
20 | ;; 2021-09-13 Hi readers of "Emacs News!" I just saw that Sacha decided to | ||
21 | ;; include this in her weekly newsletter. Thanks for the gold kind stranger, | ||
22 | ;; etc. If you're looking for stuff in here that /isn't/ just ripped | ||
23 | ;; wholesale from something else on the internet, you'll want the following | ||
24 | ;; (updated as I write more/remember to update them): | ||
25 | |||
26 | ;; `acdw-org/fix-blank-lines-in-buffer' | ||
27 | ;; `acdw-org/count-words-stupidly' | ||
28 | ;; `acdw/org-next-heading-widen' | ||
29 | ;; `acdw/org-previous-heading-widen' | ||
30 | ;; `acdw-org/work-month-headings' | ||
31 | |||
32 | ;; To be honest, I could easily (and probably should) extract some of these out | ||
33 | ;; into their own /real/ libraries. | ||
34 | |||
35 | ;; Until then, just require this file /after/ you require org -- i.e., | ||
36 | ;; (with-eval-after-load 'org (require 'acdw-org)) -- or else it'll load every | ||
37 | ;; time you start up Emacs. | ||
38 | |||
39 | ;;; Code: | ||
40 | |||
41 | (require 'dom) | ||
42 | (require 'org) | ||
43 | (require 'org-element) | ||
44 | (require 'ox) | ||
45 | (require 'subr-x) | ||
46 | (require 'calendar) | ||
47 | |||
48 | |||
49 | ;;; unpackaged.el: https://github.com/alphapapa/unpackaged.el | ||
50 | |||
51 | (defun acdw-org/element-descendant-of (type element) | ||
52 | "Return non-nil if ELEMENT is a descendant of TYPE. | ||
53 | TYPE should be an element type, like `item' or `paragraph'. | ||
54 | ELEMENT should be a list like that returned by `org-element-context'." | ||
55 | ;; MAYBE: Use `org-element-lineage'. | ||
56 | (when-let* ((parent (org-element-property :parent element))) | ||
57 | (or (eq type (car parent)) | ||
58 | (acdw-org/element-descendant-of type parent)))) | ||
59 | |||
60 | (defun acdw-org/return-dwim (&optional prefix) | ||
61 | "A helpful replacement for `org-return'. With PREFIX, call `org-return'. | ||
62 | |||
63 | On headings, move point to position after entry content. In | ||
64 | lists, insert a new item or end the list, with checkbox if | ||
65 | appropriate. In tables, insert a new row or end the table." | ||
66 | ;; Inspired by John Kitchin: | ||
67 | ;; http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/ | ||
68 | (interactive "P") | ||
69 | ;; Auto-fill if enabled | ||
70 | (when auto-fill-function | ||
71 | (if (listp auto-fill-function) | ||
72 | (dolist (func auto-fill-function) | ||
73 | (funcall func)) | ||
74 | (funcall auto-fill-function))) | ||
75 | (if prefix | ||
76 | ;; Handle prefix args | ||
77 | (pcase prefix | ||
78 | ('(4) (newline)) | ||
79 | ('(16) (newline 2)) | ||
80 | ;; this is ... not ideal. but whatever. | ||
81 | (_ (newline prefix))) | ||
82 | (cond | ||
83 | ;; Act depending on context around point. | ||
84 | ((and org-return-follows-link | ||
85 | (eq 'link (car (org-element-context)))) | ||
86 | ;; Link: Open it. | ||
87 | (org-open-at-point-global)) | ||
88 | |||
89 | ((org-at-heading-p) | ||
90 | ;; Heading: Move to position after entry content. | ||
91 | ;; NOTE: This is probably the most interesting feature of this function. | ||
92 | (let ((heading-start (org-entry-beginning-position))) | ||
93 | (goto-char (org-entry-end-position)) | ||
94 | (cond ((and (org-at-heading-p) | ||
95 | (= heading-start (org-entry-beginning-position))) | ||
96 | ;; Entry ends on its heading; add newline after | ||
97 | (end-of-line) | ||
98 | (insert "\n\n")) | ||
99 | (t | ||
100 | ;; Entry ends after its heading; back up | ||
101 | (forward-line -1) | ||
102 | (end-of-line) | ||
103 | (when (org-at-heading-p) | ||
104 | ;; At the same heading | ||
105 | (forward-line) | ||
106 | (insert "\n") | ||
107 | (forward-line -1)) | ||
108 | (while (not | ||
109 | (looking-back | ||
110 | (rx (repeat 3 (seq (optional blank) "\n"))) | ||
111 | nil)) | ||
112 | (insert "\n")) | ||
113 | (forward-line -1))))) | ||
114 | |||
115 | ((org-at-item-checkbox-p) | ||
116 | ;; Checkbox: Insert new item with checkbox. | ||
117 | (org-insert-todo-heading nil)) | ||
118 | |||
119 | ((org-in-item-p) | ||
120 | ;; Plain list | ||
121 | (let* ((context (org-element-context)) | ||
122 | (first-item-p (eq 'plain-list (car context))) | ||
123 | (itemp (eq 'item (car context))) | ||
124 | (emptyp (eq (org-element-property :contents-begin context) | ||
125 | (org-element-property :contents-end context))) | ||
126 | (item-child-p | ||
127 | (acdw-org/element-descendant-of 'item context))) | ||
128 | ;; The original function from unpackaged just tested the (or ...) test | ||
129 | ;; in this cond, in an if. However, that doesn't auto-end nested | ||
130 | ;; lists. So I made this form a cond and added the (and...) test in | ||
131 | ;; the first position, which is clunky (the delete-region... stuff | ||
132 | ;; comes twice) and might not be needed. More testing, obviously, but | ||
133 | ;; for now, it works well enough. | ||
134 | (cond ((and itemp emptyp) | ||
135 | (delete-region (line-beginning-position) (line-end-position)) | ||
136 | (insert "\n\n")) | ||
137 | ((or first-item-p | ||
138 | (and itemp (not emptyp)) | ||
139 | item-child-p) | ||
140 | (org-insert-item)) | ||
141 | (t (delete-region (line-beginning-position) (line-end-position)) | ||
142 | (insert "\n"))))) | ||
143 | |||
144 | ((when (fboundp 'org-inlinetask-in-task-p) | ||
145 | (org-inlinetask-in-task-p)) | ||
146 | ;; Inline task: Don't insert a new heading. | ||
147 | (org-return)) | ||
148 | |||
149 | ((org-at-table-p) | ||
150 | (cond ((save-excursion | ||
151 | (beginning-of-line) | ||
152 | ;; See `org-table-next-field'. | ||
153 | (cl-loop with end = (line-end-position) | ||
154 | for cell = (org-element-table-cell-parser) | ||
155 | always (equal (org-element-property :contents-begin cell) | ||
156 | (org-element-property :contents-end cell)) | ||
157 | while (re-search-forward "|" end t))) | ||
158 | ;; Empty row: end the table. | ||
159 | (delete-region (line-beginning-position) (line-end-position)) | ||
160 | (org-return)) | ||
161 | (t | ||
162 | ;; Non-empty row: call `org-return'. | ||
163 | (org-return)))) | ||
164 | (t | ||
165 | ;; All other cases: call `org-return'. | ||
166 | (org-return))))) | ||
167 | |||
168 | (defun acdw-org/fix-blank-lines (&optional prefix) | ||
169 | "Ensure blank lines around headings. | ||
170 | Optional PREFIX argument operates on the entire buffer. | ||
171 | Drawers are included with their headings." | ||
172 | (interactive "P") | ||
173 | (org-map-entries (lambda () | ||
174 | (org-with-wide-buffer | ||
175 | ;; `org-map-entries' narrows the buffer, which | ||
176 | ;; prevents us from seeing newlines before the | ||
177 | ;; current heading, so we do this part widened. | ||
178 | (while (not (looking-back "\n\n" nil)) | ||
179 | ;; Insert blank lines before heading. | ||
180 | (insert "\n"))) | ||
181 | (let ((end (org-entry-end-position))) | ||
182 | ;; Insert blank lines before entry content | ||
183 | (forward-line) | ||
184 | (while (and (org-at-planning-p) | ||
185 | (< (point) (point-max))) | ||
186 | ;; Skip planning lines | ||
187 | (forward-line)) | ||
188 | (while (re-search-forward | ||
189 | org-drawer-regexp end t) | ||
190 | ;; Skip drawers. You might think that | ||
191 | ;; `org-at-drawer-p' would suffice, but for | ||
192 | ;; some reason it doesn't work correctly when | ||
193 | ;; operating on hidden text. This works, taken | ||
194 | ;; from `org-agenda-get-some-entry-text'. | ||
195 | (re-search-forward "^[ \t]*:END:.*\n?" end t) | ||
196 | (goto-char (match-end 0))) | ||
197 | (unless (or (= (point) (point-max)) | ||
198 | (org-at-heading-p) | ||
199 | (looking-at-p "\n")) | ||
200 | (insert "\n")))) | ||
201 | t | ||
202 | (if prefix | ||
203 | nil | ||
204 | 'tree))) | ||
205 | |||
206 | |||
207 | ;;; Generate custom IDs: | ||
208 | ;; https://amitp.blogspot.com/2021/04/automatically-generate-ids-for-emacs.html | ||
209 | |||
210 | (defun acdw-org/generate-custom-ids () | ||
211 | "Generate CUSTOM_ID for any headings that are missing one." | ||
212 | (let ((existing-ids (org-map-entries (lambda () | ||
213 | (org-entry-get nil "CUSTOM_ID"))))) | ||
214 | (org-map-entries | ||
215 | (lambda () | ||
216 | (let* ((custom-id (org-entry-get nil "CUSTOM_ID")) | ||
217 | (heading (org-heading-components)) | ||
218 | (level (nth 0 heading)) | ||
219 | (todo (nth 2 heading)) | ||
220 | (headline (nth 4 heading)) | ||
221 | (slug (acdw-org/title-to-filename headline)) | ||
222 | (duplicate-id (member slug existing-ids))) | ||
223 | (when (and (not custom-id) | ||
224 | (< level 4) | ||
225 | (not todo) | ||
226 | (not duplicate-id)) | ||
227 | (message "Adding entry '%s' to '%s'" slug headline) | ||
228 | (org-entry-put nil "CUSTOM_ID" slug))))))) | ||
229 | |||
230 | (defun acdw-org/title-to-filename (title) | ||
231 | "Convert TITLE to a reasonable filename." | ||
232 | ;; Based on the slug logic in `org-roam', but `org-roam' also uses a | ||
233 | ;; timestamp, and I only use the slug. | ||
234 | (setq title (downcase title)) | ||
235 | (setq title (replace-regexp-in-string "[^a-zA-Z0-9]+" "-" title)) | ||
236 | (setq title (replace-regexp-in-string "-+" "-" title)) | ||
237 | (setq title (replace-regexp-in-string "^-" "" title)) | ||
238 | (setq title (replace-regexp-in-string "-$" "" title)) | ||
239 | title) | ||
240 | |||
241 | |||
242 | ;;; ADVICE AND TWEAKS | ||
243 | |||
244 | ;; I definitely got this from somewhere. | ||
245 | ;; Correct `org-delete-backward-char' to use `backward-delete-char-untabify' | ||
246 | (defun acdw-org/delete-backward-char (N) | ||
247 | "Keep tables aligned while deleting N characters backward. | ||
248 | When deleting backwards, in tables this function will insert | ||
249 | whitespace in front of the next \"|\" separator, to keep the | ||
250 | table aligned. The table will still be marked for re-alignment | ||
251 | if the field did fill the entire column, because, in this case | ||
252 | the deletion might narrow the column." | ||
253 | (interactive "p") | ||
254 | (save-match-data | ||
255 | (org-check-before-invisible-edit 'delete-backward) | ||
256 | (if (and (= N 1) | ||
257 | (not overwrite-mode) | ||
258 | (not (org-region-active-p)) | ||
259 | (not (eq (char-before) ?|)) | ||
260 | (save-excursion (skip-chars-backward " \t") (not (bolp))) | ||
261 | (looking-at-p ".*?|") | ||
262 | (org-at-table-p)) | ||
263 | (progn (forward-char -1) (org-delete-char 1)) | ||
264 | (backward-delete-char-untabify N) | ||
265 | (org-fix-tags-on-the-fly)))) | ||
266 | |||
267 | ;; Same here. | ||
268 | (defun acdw-org/org-table-copy-down (n) | ||
269 | "Call `org-table-copy-down', or `org-return' outside of a table. | ||
270 | N is passed to the functions." | ||
271 | (interactive "p") | ||
272 | (if (org-table-check-inside-data-field 'noerror) | ||
273 | (org-table-copy-down n) | ||
274 | (acdw-org/return-dwim n))) | ||
275 | |||
276 | ;; This isn't the best code, but it'll do. | ||
277 | (defun acdw-org/count-words-stupidly (start end &optional limit) | ||
278 | "Count words between START and END, ignoring a lot. | ||
279 | |||
280 | Since this function is, for some reason, pricy, the optional | ||
281 | parameter LIMIT sets a word limit at which to stop counting. | ||
282 | Once the function hits that number, it'll return -LIMIT | ||
283 | instead of the true count." | ||
284 | (interactive (list nil nil)) | ||
285 | (cond ((not (called-interactively-p 'any)) | ||
286 | (let ((words 0) | ||
287 | (continue t)) | ||
288 | (save-excursion | ||
289 | (save-restriction | ||
290 | (narrow-to-region start end) | ||
291 | (goto-char (point-min)) | ||
292 | (while (and continue | ||
293 | (< (point) (point-max))) | ||
294 | (cond | ||
295 | ;; Ignore comments | ||
296 | ((or (org-at-comment-p) | ||
297 | (org-in-commented-heading-p)) | ||
298 | (forward-line)) | ||
299 | ;; Ignore headings | ||
300 | ((or (org-at-heading-p)) | ||
301 | (forward-line)) | ||
302 | ;; Ignore property and log drawers | ||
303 | ((or (looking-at org-drawer-regexp) | ||
304 | (looking-at org-clock-drawer-re)) | ||
305 | (search-forward ":END:" nil :noerror) | ||
306 | (forward-line)) | ||
307 | ;; Ignore DEADLINE and SCHEDULED keywords | ||
308 | ((or (looking-at org-deadline-regexp) | ||
309 | (looking-at org-scheduled-regexp) | ||
310 | (looking-at org-closed-time-regexp)) | ||
311 | (forward-line)) | ||
312 | ;; Ignore tables | ||
313 | ((org-at-table-p) (forward-line)) | ||
314 | ;; Ignore hyperlinks, but count the descriptions | ||
315 | ((looking-at org-link-bracket-re) | ||
316 | (when-let ((desc (match-string-no-properties 5))) | ||
317 | (save-match-data | ||
318 | (setq words (+ words | ||
319 | (length (remove "" | ||
320 | (org-split-string | ||
321 | desc "\\W"))))))) | ||
322 | (goto-char (match-end 0))) | ||
323 | ;; Ignore source blocks | ||
324 | ((org-in-src-block-p) (forward-line)) | ||
325 | ;; Ignore blank lines | ||
326 | ((looking-at "^$") | ||
327 | (forward-line)) | ||
328 | ;; Count everything else | ||
329 | (t | ||
330 | ;; ... unless it's in a few weird contexts | ||
331 | (let ((contexts (org-context))) | ||
332 | (cond ((or (assoc :todo-keyword contexts) | ||
333 | (assoc :priority contexts) | ||
334 | (assoc :keyword contexts) | ||
335 | (assoc :checkbox contexts)) | ||
336 | (forward-word-strictly)) | ||
337 | |||
338 | (t (setq words (1+ words)) | ||
339 | (if (and limit | ||
340 | (> words limit)) | ||
341 | (setq words (- limit) | ||
342 | continue nil)) | ||
343 | (forward-word-strictly))))))))) | ||
344 | words)) | ||
345 | ((use-region-p) | ||
346 | (message "%d words in region" | ||
347 | (acdw-org/count-words-stupidly (region-beginning) | ||
348 | (region-end)))) | ||
349 | (t | ||
350 | (message "%d words in buffer" | ||
351 | (acdw-org/count-words-stupidly (point-min) | ||
352 | (point-max)))))) | ||
353 | |||
354 | |||
355 | ;;; Zero-width spaces | ||
356 | ;; https://blog.tecosaur.com/tmio/2021-05-31-async.html#easy-zero-width | ||
357 | |||
358 | (defun insert-zero-width-space () | ||
359 | "Insert a zero-width space." | ||
360 | (interactive) | ||
361 | (insert "\u200b")) | ||
362 | |||
363 | (defun org-export-remove-zero-width-spaces (text _backend _info) | ||
364 | "Remove zero-width spaces from TEXT." | ||
365 | (unless (org-export-derived-backend-p 'org) | ||
366 | (replace-regexp-in-string "\u200b" "" text))) | ||
367 | |||
368 | |||
369 | ;;; Insert links .. DWIM | ||
370 | ;; https://xenodium.com/emacs-dwim-do-what-i-mean/ | ||
371 | |||
372 | (defun org-insert-link-dwim () | ||
373 | "Like `org-insert-link' but with personal dwim preferences." | ||
374 | (interactive) | ||
375 | (let* ((point-in-link (org-in-regexp org-link-any-re 1)) | ||
376 | (clipboard-url (when (string-match-p | ||
377 | (rx (sequence bos | ||
378 | (or "http" | ||
379 | "gemini" | ||
380 | "gopher"))) | ||
381 | (current-kill 0)) | ||
382 | (current-kill 0))) | ||
383 | (region-content (when (region-active-p) | ||
384 | (buffer-substring-no-properties (region-beginning) | ||
385 | (region-end))))) | ||
386 | (cond ((and region-content clipboard-url (not point-in-link)) | ||
387 | (delete-region (region-beginning) (region-end)) | ||
388 | (insert (org-link-make-string clipboard-url region-content))) | ||
389 | ((and clipboard-url (not point-in-link)) | ||
390 | (insert (org-link-make-string | ||
391 | clipboard-url | ||
392 | (read-string "title: " | ||
393 | (with-current-buffer | ||
394 | (url-retrieve-synchronously | ||
395 | clipboard-url) | ||
396 | (dom-text | ||
397 | (car | ||
398 | (dom-by-tag (libxml-parse-html-region | ||
399 | (point-min) | ||
400 | (point-max)) | ||
401 | 'title)))))))) | ||
402 | (t | ||
403 | (call-interactively 'org-insert-link))))) | ||
404 | |||
405 | |||
406 | ;;; Next and previous heading, with widening | ||
407 | (defun acdw/org-next-heading-widen (arg) | ||
408 | "Find the ARGth next org heading, widening if necessary." | ||
409 | (interactive "p") | ||
410 | (let ((current-point (point)) | ||
411 | (point-target (if (> arg 0) (point-max) (point-min)))) | ||
412 | (org-next-visible-heading arg) | ||
413 | (when (and (buffer-narrowed-p) | ||
414 | (= (point) point-target) | ||
415 | (or (and (> arg 0)) | ||
416 | (and (< arg 0) | ||
417 | (= (point) current-point)))) | ||
418 | (widen) | ||
419 | (org-next-visible-heading arg)))) | ||
420 | |||
421 | (defun acdw/org-previous-heading-widen (arg) | ||
422 | "Find the ARGth previous org heading, widening if necessary." | ||
423 | (interactive "p") | ||
424 | (acdw/org-next-heading-widen (- arg))) | ||
425 | |||
426 | |||
427 | ;;; Add headings for every day of the work month | ||
428 | ;; Gets rid of weekends. | ||
429 | |||
430 | (defun acdw-org/work-month-headings (&optional month year) | ||
431 | "Create headings for every workday in MONTH and YEAR, or this month. | ||
432 | Workdays are Monday through Friday. This function inserts a new | ||
433 | heading with an inactive timestamp for each workday of MONTH in YEAR. | ||
434 | |||
435 | I use this function to attempt to organize my work month. I'll | ||
436 | probably abandon it at some point for a better solution (see: | ||
437 | `org-agenda')." | ||
438 | (interactive (list | ||
439 | (read-number "Month: " (car (calendar-current-date))) | ||
440 | (read-number "Year: " (nth 2 (calendar-current-date))))) | ||
441 | (let ((month (or month | ||
442 | (car (calendar-current-date)))) | ||
443 | (year (or year | ||
444 | (car (last (calendar-current-date)))))) | ||
445 | (dotimes (day (calendar-last-day-of-month month year)) | ||
446 | (let* ((day (1+ day)) | ||
447 | (day-of-week (calendar-day-of-week (list month day year)))) | ||
448 | (unless (memq day-of-week '(0 6)) ; weekend | ||
449 | (end-of-line) | ||
450 | (org-insert-heading nil t t) | ||
451 | (insert (concat "[" (mapconcat (lambda (n) | ||
452 | (format "%02d" n)) | ||
453 | (list year month day) | ||
454 | "-") | ||
455 | " " | ||
456 | (nth day-of-week '("Sun" "Mon" "Tue" "Wed" "Thu" | ||
457 | "Fri" "Sat")) | ||
458 | "]"))))))) | ||
459 | |||
460 | ;;; Org task stuff | ||
461 | |||
462 | (defun org-narrow-to-task () | ||
463 | "Narrow buffer to the nearest task and its subtree." | ||
464 | (interactive) | ||
465 | (save-excursion | ||
466 | (save-match-data | ||
467 | (widen) | ||
468 | (while (not (or (org-entry-is-todo-p) | ||
469 | (org-entry-is-done-p))) | ||
470 | ;; TODO: need a better error message | ||
471 | (org-previous-visible-heading 1)) | ||
472 | (org-narrow-to-subtree)))) | ||
473 | |||
474 | |||
475 | ;;; Hide everything but the current headline | ||
476 | ;; https://stackoverflow.com/questions/25161792/ | ||
477 | |||
478 | (defun acdw-org/show-next-heading-tidily () | ||
479 | "Show next entry, keeping other entries closed." | ||
480 | (interactive) | ||
481 | (if (save-excursion (end-of-line) (outline-invisible-p)) | ||
482 | (progn (org-show-entry) (outline-show-children)) | ||
483 | (outline-next-heading) | ||
484 | (unless (and (bolp) (org-at-heading-p)) | ||
485 | (org-up-heading-safe) | ||
486 | (outline-hide-subtree) | ||
487 | (error "Boundary reached")) | ||
488 | (org-overview) | ||
489 | (org-reveal t) | ||
490 | (org-show-entry) | ||
491 | (recenter-top-bottom) | ||
492 | (outline-show-children) | ||
493 | (recenter-top-bottom))) | ||
494 | |||
495 | (defun acdw-org/show-previous-heading-tidily () | ||
496 | "Show previous entry, keeping other entries closed." | ||
497 | (interactive) | ||
498 | (let ((pos (point))) | ||
499 | (outline-previous-heading) | ||
500 | (unless (and (< (point) pos) (bolp) (org-at-heading-p)) | ||
501 | (goto-char pos) | ||
502 | (outline-hide-subtree) | ||
503 | (error "Boundary reached")) | ||
504 | (org-overview) | ||
505 | (org-reveal t) | ||
506 | (org-show-entry) | ||
507 | (recenter-top-bottom) | ||
508 | (outline-show-children) | ||
509 | (recenter-top-bottom))) | ||
510 | |||
511 | |||
512 | (provide 'acdw-org) | ||
513 | ;;; acdw-org.el ends here | ||
514 | |||
515 | ;; Local Variables: | ||
516 | ;; flymake-inhibit: t | ||
517 | ;; End: | ||