;;; +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)))) ;;; Smarter {super,sub}scripts ;; https://old.reddit.com/r/emacs/comments/qzlzm0/what_are_your_top_key_bindings_rebindings_minor/hmwyhm3/ ;; I don't use this currently because I found out about ;; `org-pretty-entities-include-sub-superscripts', which really does exactly ;; what I wanted. (defface +org-script-markers '((t :inherit shadow)) "Face to be used for sub/superscripts markers i.e., ^, _, {, }.") ;; Hiding the super and subscript markers is extremely annoying ;; since any remotely complex equation becomes a chore. And leaving ;; it not raised is jarring to the eye. So this fontifies the ;; buffer just like how auctex does -- use a muted colour to ;; highlight the markup and raise the script. (defun +org-raise-scripts (limit) "Differences from `org-raise-scripts' are: - It doesn't actually hide the markup used for super and subscript. - It uses a custom face to highlight the markup: +org-script-markers. - It doesn't require `org-pretty-entities' to be t." (when (and org-pretty-entities-include-sub-superscripts (re-search-forward (if (eq org-use-sub-superscripts t) org-match-substring-regexp org-match-substring-with-braces-regexp) limit t)) (let* ((pos (point)) table-p comment-p (mpos (match-beginning 3)) (emph-p (get-text-property mpos 'org-emphasis)) (link-p (get-text-property mpos 'mouse-face)) (keyw-p (eq 'org-special-keyword (get-text-property mpos 'face)))) (goto-char (point-at-bol)) (setq table-p (looking-at-p org-table-dataline-regexp) comment-p (looking-at-p "^[ \t]*#[ +]")) (goto-char pos) ;; Handle a_b^c (when (member (char-after) '(?_ ?^)) (goto-char (1- pos))) (unless (or comment-p emph-p link-p keyw-p) (put-text-property (match-beginning 3) (match-end 0) 'display (if (equal (char-after (match-beginning 2)) ?^) ;; (nth (if table-p 3 1) org-script-display) (nth 3 org-script-display) ;; (nth (if table-p 2 0) org-script-display) (nth 2 org-script-display))) (put-text-property (match-beginning 2) (match-end 2) 'face 'vz/org-script-markers) (when (and (eq (char-after (match-beginning 3)) ?{) (eq (char-before (match-end 3)) ?})) (put-text-property (match-beginning 3) (1+ (match-beginning 3)) 'face '+org-script-markers) (put-text-property (1- (match-end 3)) (match-end 3) 'face '+org-script-markers))) t))) ;; Extra link types (defun +org-tel-open (number _) "Notify the user of what phone NUMBER to call." (message "Call: %s" number)) (provide '+org) ;;; +org.el ends here