807 lines
33 KiB
EmacsLisp
807 lines
33 KiB
EmacsLisp
;;; +org.el -*- lexical-binding: t; -*-
|
||
|
||
;;; Code:
|
||
|
||
(require 'el-patch)
|
||
(require 'org)
|
||
(require 'org-element)
|
||
(require 'ox)
|
||
|
||
;;; org-return-dwim - [[https://github.com/alphapapa/unpackaged.el][unpackaged]] and [[http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/][kitchin]]
|
||
|
||
(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 (or
|
||
;; Empty list item (regular)
|
||
(eq (org-element-property :contents-begin context)
|
||
(org-element-property :contents-end context))
|
||
;; Empty list item (definition)
|
||
;; This seems to work, with minimal testing. -- 2022-02-17
|
||
(looking-at " *::")))
|
||
(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"))
|
||
((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")
|
||
(let ((org-element-use-cache nil))
|
||
(org-map-entries (lambda ()
|
||
(let ((beg (org-entry-beginning-position))
|
||
(end (org-entry-end-position)))
|
||
(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")))
|
||
|
||
;; 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--get-title-and-headings (url)
|
||
"Retrieve title and headings from URL.
|
||
Return as a list."
|
||
(with-current-buffer (url-retrieve-synchronously url)
|
||
(let ((dom (libxml-parse-html-region (point-min) (point-max))))
|
||
(cl-remove-if
|
||
(lambda (i) (string= i ""))
|
||
(apply #'append (mapcar (lambda (tag)
|
||
(mapcar #'dom-text
|
||
(dom-by-tag dom tag)))
|
||
'(title h1 h2 h3 h4 h5 h6)))))))
|
||
|
||
(defun +org-insert-link-dwim (&optional interactivep)
|
||
"Like `org-insert-link' but with personal dwim preferences."
|
||
(interactive '(t))
|
||
(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"
|
||
"tel"
|
||
"mailto")))
|
||
(current-kill 0))
|
||
(current-kill 0)))
|
||
(region-content (when (region-active-p)
|
||
(buffer-substring-no-properties (region-beginning)
|
||
(region-end))))
|
||
(org-link (when (and clipboard-url (not point-in-link))
|
||
(org-link-make-string
|
||
(string-trim clipboard-url)
|
||
(or region-content
|
||
(let ((clipboard-headings
|
||
(+org-insert--get-title-and-headings clipboard-url)))
|
||
(read-string "title (edit): "
|
||
(completing-read
|
||
"title: " clipboard-headings
|
||
nil nil nil nil (car clipboard-headings)))))))))
|
||
(if interactivep
|
||
(cond ((and region-content clipboard-url (not point-in-link))
|
||
(delete-region (region-beginning) (region-end))
|
||
(insert org-link))
|
||
((and clipboard-url (not point-in-link))
|
||
(insert org-link))
|
||
(t
|
||
(call-interactively 'org-insert-link)))
|
||
org-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
|
||
|
||
(defvar +org-before-save-prettify-buffer t
|
||
"Prettify org buffers before saving.")
|
||
|
||
(put '+org-before-save-prettify-buffer 'safe-local-variable #'booleanp)
|
||
|
||
(defun +org-before-save@prettify-buffer ()
|
||
(when +org-before-save-prettify-buffer
|
||
(save-mark-and-excursion
|
||
(+org-unsmartify)
|
||
(+org-fix-blank-lines t)
|
||
(org-align-tags t)
|
||
(when (buffer-narrowed-p)
|
||
(goto-char (point-min))
|
||
(forward-line 1)
|
||
(org-narrow-to-subtree)))))
|
||
|
||
(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 '+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))
|
||
|
||
(defun +org-sms-open (number _)
|
||
"Notify the user of what phone NUMBER to text."
|
||
(message "SMS: %s" number))
|
||
|
||
;; Make a horizontal rule!
|
||
|
||
(defun +org-horizontal-rule ()
|
||
"Make a horizontal rule after the current line."
|
||
(interactive nil org-mode)
|
||
(unless (eq (line-beginning-position) (line-end-position))
|
||
(end-of-line)
|
||
(newline))
|
||
(dotimes (_ fill-column)
|
||
(insert "-")))
|
||
|
||
;; Follow links, DWIM style
|
||
|
||
(defun +org-open-at-point-dwim (&optional arg)
|
||
"Open thing at point, or if there isn't something, list things."
|
||
(interactive "P")
|
||
(save-excursion
|
||
(let* ((this-char-type (org-element-type (org-element-context)))
|
||
(prev-char-type (ignore-errors
|
||
(save-excursion
|
||
(backward-char)
|
||
(org-element-type (org-element-context)))))
|
||
(types '(citation citation-reference clock comment comment-block
|
||
footnote-definition footnote-reference headline
|
||
inline-src-block inlinetask keyword link
|
||
node-property planning src-block timestamp))
|
||
(type this-char-type))
|
||
(when (and (memq this-char-type types) (memq prev-char-type types))
|
||
(backward-char)
|
||
(setq type prev-char-type)) ; what the fuckckckckck
|
||
;; Okay, so this ^ is pretty janky and doesn't /really/ work that well,
|
||
;; especially on DEADLINE (and probably SCHEDULED) lines. However, since
|
||
;; I really just want to open the list of URLs /most of the time/, I'm
|
||
;; fixing it like this instead.
|
||
(unless (and (memq type types)
|
||
(ignore-errors (org-open-at-point arg)
|
||
t))
|
||
(while (not
|
||
(progn
|
||
(org-back-to-heading)
|
||
(car (org-offer-links-in-entry (current-buffer) (point) 1))))
|
||
(org-up-heading-all 1))
|
||
(org-open-at-point arg)))))
|
||
|
||
;;; Open local HTML files with `browse-url'
|
||
|
||
(defun +org-open-html (file-path link-string)
|
||
"Open FILE-PATH with `browse-url'.
|
||
This function is intended to use with `org-file-apps'. See the
|
||
documentation of that function for a description of the two
|
||
arguments here, FILE-PATH and LINK-STRING."
|
||
(message "Opening %s (%s)..." file-path link-string)
|
||
(browse-url file-path))
|
||
|
||
(defun +org-insert-horizontal-rule (prefix)
|
||
"Insert a horizontal rule (-----) after the current line.
|
||
With PREFIX, insert before the current line."
|
||
(interactive "P")
|
||
(if prefix
|
||
(move-beginning-of-line nil)
|
||
(move-end-of-line nil)
|
||
(forward-line 1))
|
||
(insert "-----\n"))
|
||
|
||
;;; Make code snippets in org-mode easier to type
|
||
;; http://mbork.pl/2022-01-17_Making_code_snippets_in_Org-mode_easier_to_type
|
||
|
||
(defun +org-insert-backtick ()
|
||
"Insert a backtick using `org-self-insert-command'."
|
||
(interactive)
|
||
(setq last-command-event ?`)
|
||
(call-interactively #'org-self-insert-command))
|
||
|
||
(defvar-local +org-insert-tilde-language nil
|
||
"Default language name in the current Org file.
|
||
If nil, `org-insert-tilde' after 2 tildes inserts an \"example\"
|
||
block. If a string, it inserts a \"src\" block with the given
|
||
language name.")
|
||
|
||
(defun +org-insert-tilde ()
|
||
"Insert a tilde using `org-self-insert-command'."
|
||
(interactive)
|
||
(if (string= (buffer-substring-no-properties (- (point) 3) (point))
|
||
"\n~~")
|
||
(progn (delete-char -2)
|
||
(if +org-insert-tilde-language
|
||
(insert (format "#+begin_src %s\n#+end_src"
|
||
+org-insert-tilde-language))
|
||
(insert "#+begin_example\n#+end_example"))
|
||
(forward-line -1)
|
||
(if (string= +org-insert-tilde-language "")
|
||
(move-end-of-line nil)
|
||
;;(org-edit-special) ; Useful really only with splits.
|
||
))
|
||
(setq last-command-event ?~)
|
||
(call-interactively #'org-self-insert-command)))
|
||
|
||
;;; Better org faces
|
||
;; see `org-emphasis-alist'
|
||
|
||
(defface org-bold '((t (:weight bold)))
|
||
"Bold face in `org-mode' documents.")
|
||
|
||
(defface org-italic '((t (:slant italic)))
|
||
"Italic face in `org-mode' documents.")
|
||
|
||
(defface org-underline '((t (:underline t)))
|
||
"Underline face in `org-mode' documents.")
|
||
|
||
(defface org-strikethrough '((t (:strike-through t)))
|
||
"Strike-through face for `org-mode' documents.")
|
||
|
||
;; `org-verbatim' and `org-code' are apparently already things, so we skip them
|
||
;; here.
|
||
|
||
;;; Copy org trees as HTML
|
||
|
||
;; Thanks to Oleh Krehel, via [[https://emacs.stackexchange.com/questions/54292/copy-results-of-org-export-directly-to-clipboard][this StackExchange question]].
|
||
(defun +org-export-clip-to-html
|
||
(&optional async subtreep visible-only body-only ext-plist post-process)
|
||
"Export region to HTML, and copy it to the clipboard.
|
||
Arguments ASYNC, SUBTREEP, VISIBLE-ONLY, BODY-ONLY, EXT-PLIST,
|
||
and POST-PROCESS are passed to `org-export-to-file'."
|
||
(interactive) ; XXX: hould this be interactive?
|
||
(message "Exporting Org to HTML...")
|
||
(let ((org-tmp-file "/tmp/org.html"))
|
||
(org-export-to-file 'html org-tmp-file
|
||
async subtreep visible-only body-only ext-plist post-process)
|
||
(start-process "xclip" "*xclip*"
|
||
"xclip" "-verbose"
|
||
"-i" org-tmp-file
|
||
"-t" "text/html"
|
||
"-selection" "clipboard"))
|
||
(message "Exporting Org to HTML...done."))
|
||
|
||
;; Specialized functions
|
||
(defun +org-export-clip-subtree-to-html ()
|
||
"Export current subtree to HTML."
|
||
(interactive)
|
||
(+org-export-clip-to-html nil :subtree))
|
||
|
||
;;; Unsmartify quotes and dashes and stuff.
|
||
(defun +org-unsmartify ()
|
||
"Replace \"smart\" punctuation with their \"dumb\" counterparts."
|
||
(interactive)
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(while (re-search-forward "[“”‘’–—]" nil t)
|
||
(let ((replace (pcase (match-string 0)
|
||
((or "“" "”") "\"")
|
||
((or "‘" "’") "'")
|
||
("–" "--")
|
||
("—" "---"))))
|
||
(replace-match replace nil nil)))))
|
||
|
||
;;; go forward and backward in the tree, ~ cleanly ~
|
||
;; https://stackoverflow.com/a/25201697/10756297
|
||
|
||
(defun +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) (show-children))
|
||
(outline-next-heading)
|
||
(unless (and (bolp) (org-on-heading-p))
|
||
(org-up-heading-safe)
|
||
(hide-subtree)
|
||
(user-error "Boundary reached"))
|
||
(org-overview)
|
||
(org-reveal t)
|
||
(org-show-entry)
|
||
(recenter-top-bottom)
|
||
(show-children)
|
||
(recenter-top-bottom 1)))
|
||
|
||
(defun +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-on-heading-p))
|
||
(goto-char pos)
|
||
(hide-subtree)
|
||
(user-error "Boundary reached"))
|
||
(org-overview)
|
||
(org-reveal t)
|
||
(org-show-entry)
|
||
(recenter-top-bottom)
|
||
(show-children)
|
||
(recenter-top-bottom 1)))
|
||
|
||
;;; Make `org-flag-region' (which folds subtrees) recognize
|
||
;; [[https://teddit.net/r/orgmode/comments/u3du0v/how_to_make_orgcycle_respect_and_always_show_the/][from u/yantar92]]
|
||
|
||
;; (advice-add 'org-flag-region :around #'org-flag-region@unfold-page-breaks)
|
||
(defun org-flag-region@unfold-page-breaks (oldfun from to flag &optional spec)
|
||
"ADVICE to unfold all the page-break lines inside a folded region."
|
||
(funcall oldfun from to flag spec)
|
||
(when (and flag (not (eq 'visible spec)))
|
||
(org-with-point-at from
|
||
(while (re-search-forward "\n\u000c\n" to t)
|
||
(org-flag-region (match-beginning 0) (match-end 0) t 'visible)))))
|
||
|
||
;;; Emacs 28+: wrap on hyphens
|
||
;; https://emacs.stackexchange.com/a/71342/37239
|
||
|
||
(defcustom +org-category-table (let ((table (copy-category-table)))
|
||
(modify-category-entry ?- ?| table)
|
||
table)
|
||
"Character category table for `org-mode'."
|
||
:type 'sexp)
|
||
|
||
(defun +org-wrap-on-hyphens ()
|
||
"Soft-wrap `org-mode' buffers on spaces and hyphens."
|
||
(set-category-table +org-category-table)
|
||
(setq-local word-wrap-by-category t))
|
||
|
||
|
||
;;; Inhibit hooks on `org-agenda'
|
||
;; It's really annoying when I call `org-agenda' and five hundred Ispell
|
||
;; processes are created because I have `flyspell-mode' in the hook. This mode
|
||
;; inhibits those hooks when entering the agenda, but runs them when opening the
|
||
;; actual buffer.
|
||
|
||
(defun +org-agenda-inhibit-hooks (fn &rest r)
|
||
"Advice to inhibit hooks when entering `org-agenda'."
|
||
(dlet ((org-mode-hook nil)) ; I'm not sure if `dlet' is strictly needed
|
||
(apply fn r)))
|
||
|
||
(defvar-local +org-hook-has-run-p nil
|
||
"Whether `org-mode-hook' has run in the current buffer.")
|
||
|
||
(defun +org-agenda-switch-run-hooks (&rest _)
|
||
"Advice to run `org-mode-hook' when entering org-mode.
|
||
This should only fire when switching to a buffer from `org-agenda'."
|
||
(unless +org-hook-has-run-p
|
||
(run-mode-hooks 'org-mode-hook)
|
||
(setq +org-hook-has-run-p t)))
|
||
|
||
(define-minor-mode +org-agenda-inhibit-hooks-mode
|
||
"Inhibit `org-mode-hook' when opening `org-agenda'."
|
||
:lighter ""
|
||
:global t
|
||
(if +org-agenda-inhibit-hooks-mode
|
||
(progn ; Enable
|
||
(advice-add 'org-agenda :around #'+org-agenda-inhibit-hooks)
|
||
(advice-add 'org-agenda-switch-to :after #'+org-agenda-switch-run-hooks))
|
||
(progn ; Disable
|
||
(advice-remove 'org-agenda #'+org-agenda-inhibit-hooks)
|
||
(advice-remove 'org-agenda-switch-to #'+org-agenda-switch-run-hooks))))
|
||
|
||
|
||
;;; "Fix" `org-align-tags'
|
||
|
||
(el-patch-defun org-align-tags (&optional all)
|
||
"Align tags in current entry.
|
||
When optional argument ALL is non-nil, align all tags in the
|
||
visible part of the buffer."
|
||
(let ((get-indent-column
|
||
(lambda ()
|
||
(let ((offset (el-patch-swap
|
||
(if (bound-and-true-p org-indent-mode)
|
||
(* (1- org-indent-indentation-per-level)
|
||
(1- (org-current-level)))
|
||
0)
|
||
0)))
|
||
(+ org-tags-column
|
||
(if (> org-tags-column 0) (- offset) offset))))))
|
||
(if (and (not all) (org-at-heading-p))
|
||
(org--align-tags-here (funcall get-indent-column))
|
||
(save-excursion
|
||
(if all
|
||
(progn
|
||
(goto-char (point-min))
|
||
(while (re-search-forward org-tag-line-re nil t)
|
||
(org--align-tags-here (funcall get-indent-column))))
|
||
(org-back-to-heading t)
|
||
(org--align-tags-here (funcall get-indent-column)))))))
|
||
|
||
;;; Meta-return
|
||
|
||
(defun +org-meta-return (&optional arg)
|
||
"Insert a new line, or wrap a region in a table.
|
||
See `org-meta-return', but `+org-return-dwim' does most of the
|
||
stuff I would want out of that function already.
|
||
|
||
When called with a prefix ARG, will still unconditionally call
|
||
`org-insert-heading'."
|
||
(interactive "P")
|
||
(org-fold-check-before-invisible-edit 'insert)
|
||
(or (run-hook-with-args-until-success 'org-metareturn-hook) ; Allow customizations
|
||
(call-interactively (cond (arg #'org-insert-heading)
|
||
((org-at-table-p) #'org-table-wrap-region)
|
||
(t #'org-return)))))
|
||
|
||
|
||
;;; move org archives to a dedicated file
|
||
(defun +org-archive-monthwise (archive-file)
|
||
(if (file-exists-p archive-file)
|
||
(with-current-buffer (find-file-noselect archive-file)
|
||
(let ((dir (file-name-directory (file-truename archive-file)))
|
||
(prog (make-progress-reporter (format "Archiving from %s..." archive-file)))
|
||
(keep-going t))
|
||
(goto-char (point-min))
|
||
(while keep-going
|
||
(when-let* ((time (or (org-entry-get (point) "ARCHIVE_TIME")
|
||
(org-get-deadline-time (point))))
|
||
(parsed-time (and time
|
||
(org-parse-time-string time)))
|
||
(refile-target (format "%s%02d-%02d.org"
|
||
dir
|
||
(decoded-time-year parsed-time)
|
||
(decoded-time-month parsed-time)))
|
||
(title-str (format "#+title: Archive for %02d-%02d (%s)\n\n"
|
||
(decoded-time-year parsed-time)
|
||
(decoded-time-month parsed-time)
|
||
(file-truename archive-file))))
|
||
(unless (file-exists-p refile-target)
|
||
(with-current-buffer (find-file-noselect refile-target)
|
||
(insert title-str)
|
||
(save-buffer)))
|
||
(org-refile nil nil (list ""
|
||
refile-target
|
||
nil
|
||
0)))
|
||
(progress-reporter-update prog)
|
||
(org-next-visible-heading 1)
|
||
(when (>= (point) (point-max))
|
||
(setq keep-going nil)))))
|
||
(message "Archive file %s does not exist!" archive-file)))
|
||
|
||
|
||
;;; el-patch
|
||
|
||
(el-patch-defun org-format-outline-path (path &optional width prefix separator)
|
||
"Format the outline path PATH for display.
|
||
WIDTH is the maximum number of characters that is available.
|
||
PREFIX is a prefix to be included in the returned string,
|
||
such as the file name.
|
||
SEPARATOR is inserted between the different parts of the path,
|
||
the default is \"/\"."
|
||
(setq width (or width 79))
|
||
(setq path (delq nil path))
|
||
(unless (> width 0)
|
||
(user-error "Argument `width' must be positive"))
|
||
(setq separator (or separator "/"))
|
||
(let* ((org-odd-levels-only nil)
|
||
(fpath (concat
|
||
prefix (and prefix path separator)
|
||
(mapconcat
|
||
(lambda (s) (replace-regexp-in-string "[ \t]+\\'" "" s))
|
||
(cl-loop for head in path
|
||
for n from 0
|
||
collect (el-patch-swap
|
||
(org-add-props
|
||
head nil 'face
|
||
(nth (% n org-n-level-faces) org-level-faces))
|
||
head))
|
||
separator))))
|
||
(when (> (length fpath) width)
|
||
(if (< width 7)
|
||
;; It's unlikely that `width' will be this small, but don't
|
||
;; waste characters by adding ".." if it is.
|
||
(setq fpath (substring fpath 0 width))
|
||
(setf (substring fpath (- width 2)) "..")))
|
||
fpath))
|
||
|
||
|
||
(provide '+org)
|
||
;;; +org.el ends here
|