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/+org.el | 341 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 341 insertions(+) create mode 100644 lisp/+org.el (limited to 'lisp/+org.el') diff --git a/lisp/+org.el b/lisp/+org.el new file mode 100644 index 0000000..a4ce230 --- /dev/null +++ b/lisp/+org.el @@ -0,0 +1,341 @@ +;;; +org.el -*- lexical-binding: t; -*- + +;;; Code: + +(require 'org) +(require 'org-element) +(require 'ox) + +;;; org-return-dwim - https://github.com/alphapapa/unpackaged.el +;; http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/ + +(defun +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)) + (+org-element-descendant-of type parent)))) + +(defun +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." + (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 + (+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 +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) + (+org-return-dwim n))) + +;;; org-fix-blank-lines - unpackaged.el + +(defun +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))) + +;;; org-count-words + +(defun +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" + (+org-count-words-stupidly (region-beginning) + (region-end)))) + (t + (message "%d words in buffer" + (+org-count-words-stupidly (point-min) + (point-max)))))) + +;;; org-insert-link-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))))) + +;;; Navigate headings with widening + +(defun +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 +org-previous-heading-widen (arg) + "Find the ARGth previous org heading, widening if necessary." + (interactive "p") + (+org-next-heading-widen (- arg))) + +;;; Hooks & Advice + +(defun +org-before-save@prettify-buffer () + (save-mark-and-excursion + (mark-whole-buffer) + ;;(org-fill-paragraph nil t) + (+org-fix-blank-lines t) + (org-align-tags t))) + +(defun +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)))) + +(provide '+org) +;;; +org.el ends here -- cgit 1.4.1-21-gabe81