From aab5bfd074e57d06a79e39d7c7c4760e1f385a06 Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Mon, 17 Oct 2022 21:41:28 -0500 Subject: Bankruptcy 9 --- lisp/+org.el | 816 ----------------------------------------------------------- 1 file changed, 816 deletions(-) delete mode 100644 lisp/+org.el (limited to 'lisp/+org.el') diff --git a/lisp/+org.el b/lisp/+org.el deleted file mode 100644 index dc0ce1b..0000000 --- a/lisp/+org.el +++ /dev/null @@ -1,816 +0,0 @@ -;;; +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) - (org-hide-drawer-all) - (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))) - - -;;; +org-toggle-view-emphasis -;; I thought this function was already written somewhere... -(defun +org-toggle-view-emphasis () - "Toggle `org-hide-emphasis-markers' and redraw the buffer." - (interactive) - (setq-local org-hide-emphasis-markers (not org-hide-emphasis-markers)) - (font-lock-update)) - - -;;; 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 -- cgit 1.4.1-21-gabe81