summary refs log tree commit diff stats
path: root/lisp
diff options
context:
space:
mode:
authorCase Duckworth2021-04-14 10:05:47 -0500
committerCase Duckworth2021-04-14 10:05:47 -0500
commit627350d33dd83fc39d48b8b6fc61f76868d3cff4 (patch)
treec2aa808470feab85c7b5d4291e786dc24ad81e91 /lisp
parentRemove company-active-map keys (diff)
parentChange (insert "\n\n") -> (newline) (diff)
downloademacs-627350d33dd83fc39d48b8b6fc61f76868d3cff4.tar.gz
emacs-627350d33dd83fc39d48b8b6fc61f76868d3cff4.zip
Merge branch 'main' of https://tildegit.org/acdw/emacs
Diffstat (limited to 'lisp')
-rw-r--r--lisp/acdw-org.el125
1 files changed, 77 insertions, 48 deletions
diff --git a/lisp/acdw-org.el b/lisp/acdw-org.el index 47e8eb2..06803d3 100644 --- a/lisp/acdw-org.el +++ b/lisp/acdw-org.el
@@ -17,49 +17,42 @@
17 17
18;;; Code: 18;;; Code:
19 19
20
20;;; unpackaged.el: https://github.com/alphapapa/unpackaged.el 21;;; unpackaged.el: https://github.com/alphapapa/unpackaged.el
21 22
22;;; ORG-RETURN-DWIM
23
24(defun unpackaged/org-element-descendant-of (type element) 23(defun unpackaged/org-element-descendant-of (type element)
25 "Return non-nil if ELEMENT is a descendant of TYPE. 24 "Return non-nil if ELEMENT is a descendant of TYPE.
26TYPE should be an element type, like `item' or `paragraph'. 25TYPE should be an element type, like `item' or `paragraph'.
27ELEMENT should be a list like that returned by 26ELEMENT should be a list like that returned by `org-element-context'."
28`org-element-context'."
29 ;; MAYBE: Use `org-element-lineage'. 27 ;; MAYBE: Use `org-element-lineage'.
30 (when-let* ((parent (org-element-property :parent element))) 28 (when-let* ((parent (org-element-property :parent element)))
31 (or (eq type (car parent)) 29 (or (eq type (car parent))
32 (unpackaged/org-element-descendant-of type parent)))) 30 (unpackaged/org-element-descendant-of type parent))))
33 31
32;;;###autoload
34(defun unpackaged/org-return-dwim (&optional default) 33(defun unpackaged/org-return-dwim (&optional default)
35 "A helpful replacement for `org-return'. With prefix, 34 "A helpful replacement for `org-return'. With prefix, call `org-return'.
36call `org-return'.
37 35
38On headings, move point to position after entry content. In 36On headings, move point to position after entry content. In
39lists, insert a new item or end the list, with checkbox if 37lists, insert a new item or end the list, with checkbox if
40appropriate. In tables, insert a new row or end the table." 38appropriate. In tables, insert a new row or end the table."
41 ;; Inspired by John Kitchin: 39 ;; Inspired by John Kitchin: http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/
42 ;; http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/
43 (interactive "P") 40 (interactive "P")
44 (if default 41 (if default
45 (org-return) 42 (org-return)
46 (cond 43 (cond
47 ;; Act depending on context around point. 44 ;; Act depending on context around point.
48 45
49 ;; NOTE: I prefer RET to not follow links, but by uncommenting 46 ;; NOTE: I prefer RET to not follow links, but by uncommenting this block, links will be
50 ;; this block, links will be followed. 47 ;; followed.
51 ;; FURTHER NOTE: Ideally, I would follow links unless point
52 ;; /appeared/ to be at the end of the line (even if it's still
53 ;; inside the link) -- when it would do `org-return'. That
54 ;; would take some /doing/, however.
55 48
56 ;; ((eq 'link (car (org-element-context))) 49 ;; ((eq 'link (car (org-element-context)))
57 ;; ;; Link: Open it. 50 ;; ;; Link: Open it.
58 ;; (org-open-at-point-global)) 51 ;; (org-open-at-point-global))
59 52
60 ((org-at-heading-p) 53 ((org-at-heading-p)
61 ;; Heading: Move to position after entry content. NOTE: This is 54 ;; Heading: Move to position after entry content.
62 ;; probably the most interesting feature of this function. 55 ;; NOTE: This is probably the most interesting feature of this function.
63 (let ((heading-start (org-entry-beginning-position))) 56 (let ((heading-start (org-entry-beginning-position)))
64 (goto-char (org-entry-end-position)) 57 (goto-char (org-entry-end-position))
65 (cond ((and (org-at-heading-p) 58 (cond ((and (org-at-heading-p)
@@ -76,13 +69,8 @@ appropriate. In tables, insert a new row or end the table."
76 (forward-line) 69 (forward-line)
77 (insert "\n") 70 (insert "\n")
78 (forward-line -1)) 71 (forward-line -1))
79 ;; FIXME: looking-back is supposed to be called with 72 ;; FIXME: looking-back is supposed to be called with more arguments.
80 ;; more arguments. 73 (while (not (looking-back (rx (repeat 3 (seq (optional blank) "\n")))))
81 (while (not (looking-back (rx
82 (repeat 3
83 (seq (optional blank)
84 "\n")))
85 nil))
86 (insert "\n")) 74 (insert "\n"))
87 (forward-line -1))))) 75 (forward-line -1)))))
88 76
@@ -91,23 +79,33 @@ appropriate. In tables, insert a new row or end the table."
91 (org-insert-todo-heading nil)) 79 (org-insert-todo-heading nil))
92 80
93 ((org-in-item-p) 81 ((org-in-item-p)
94 ;; Plain list. Yes, this gets a little complicated... 82 ;; Plain list
95 (let ((context (org-element-context))) 83 (let* ((context (org-element-context))
96 (if (or (eq 'plain-list (car context)) ; First item in list 84 (first-item-p (eq 'plain-list (car context)))
97 (and (eq 'item (car context)) 85 (itemp (eq 'item (car context)))
98 (not (eq (org-element-property 86 (emptyp (eq (org-element-property :contents-begin context)
99 :contents-begin context) 87 (org-element-property :contents-end context)))
100 (org-element-property 88 (item-child-p
101 :contents-end context)))) 89 (unpackaged/org-element-descendant-of 'item context)))
102 ;; Element in list item, e.g. a link 90 (message "(or %S (and %S %S) %S)"
103 (unpackaged/org-element-descendant-of 'item context)) 91 first-item-p
104 ;; Non-empty item: Add new item. 92 itemp (not emptyp)
105 (org-insert-item) 93 item-child-p)
106 ;; Empty item: Close the list. 94 ;; The original function from unpackaged just tested the (or ...) test
107 ;; TODO: Do this with org functions rather than operating 95 ;; in this cond, in an if. However, that doesn't auto-end nested
108 ;; on the text. Can't seem to find the right function. 96 ;; lists. So I made this form a cond and added the (and...) test in
109 (delete-region (line-beginning-position) (line-end-position)) 97 ;; the first position, which is clunky (the delete-region... stuff
110 (insert "\n")))) 98 ;; comes twice) and might not be needed. More testing, obviously, but
99 ;; for now, it works well enough.
100 (cond ((and itemp emptyp)
101 (delete-region (line-beginning-position) (line-end-position))
102 (newline 2))
103 ((or first-item-p
104 (and itemp (not emptyp))
105 item-child-p)
106 (org-insert-item))
107 (t (delete-region (line-beginning-position) (line-end-position))
108 (newline)))))
111 109
112 ((when (fboundp 'org-inlinetask-in-task-p) 110 ((when (fboundp 'org-inlinetask-in-task-p)
113 (org-inlinetask-in-task-p)) 111 (org-inlinetask-in-task-p))
@@ -120,14 +118,11 @@ appropriate. In tables, insert a new row or end the table."
120 ;; See `org-table-next-field'. 118 ;; See `org-table-next-field'.
121 (cl-loop with end = (line-end-position) 119 (cl-loop with end = (line-end-position)
122 for cell = (org-element-table-cell-parser) 120 for cell = (org-element-table-cell-parser)
123 always (equal (org-element-property 121 always (equal (org-element-property :contents-begin cell)
124 :contents-begin cell) 122 (org-element-property :contents-end cell))
125 (org-element-property
126 :contents-end cell))
127 while (re-search-forward "|" end t))) 123 while (re-search-forward "|" end t)))
128 ;; Empty row: end the table. 124 ;; Empty row: end the table.
129 (delete-region (line-beginning-position) 125 (delete-region (line-beginning-position) (line-end-position))
130 (line-end-position))
131 (org-return)) 126 (org-return))
132 (t 127 (t
133 ;; Non-empty row: call `org-return'. 128 ;; Non-empty row: call `org-return'.
@@ -136,8 +131,6 @@ appropriate. In tables, insert a new row or end the table."
136 ;; All other cases: call `org-return'. 131 ;; All other cases: call `org-return'.
137 (org-return))))) 132 (org-return)))))
138 133
139;;; ORG-FIX-BLANK-LINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
140
141(defun unpackaged/org-fix-blank-lines (&optional prefix) 134(defun unpackaged/org-fix-blank-lines (&optional prefix)
142 "Ensure that blank lines exist between headings and 135 "Ensure that blank lines exist between headings and
143 between headings and their contents. With prefix, operate on 136 between headings and their contents. With prefix, operate on
@@ -181,6 +174,42 @@ appropriate. In tables, insert a new row or end the table."
181 (let ((current-prefix-arg 4)) 174 (let ((current-prefix-arg 4))
182 (call-interactively #'unpackaged/org-fix-blank-lines)))) 175 (call-interactively #'unpackaged/org-fix-blank-lines))))
183 176
177
178;;; Generate custom IDs:
179;; https://amitp.blogspot.com/2021/04/automatically-generate-ids-for-emacs.html
180
181(defun acdw-org/generate-custom-ids ()
182 "Generate CUSTOM_ID for any headings that are missing one."
183 (let ((existing-ids (org-map-entries (lambda ()
184 (org-entry-get nil "CUSTOM_ID")))))
185 (org-map-entries
186 (lambda ()
187 (let* ((custom-id (org-entry-get nil "CUSTOM_ID"))
188 (heading (org-heading-components))
189 (level (nth 0 heading))
190 (todo (nth 2 heading))
191 (headline (nth 4 heading))
192 (slug (acdw-org/title-to-filename headline))
193 (duplicate-id (member slug existing-ids)))
194 (when (and (not custom-id)
195 (< level 4)
196 (not todo)
197 (not duplicate-id))
198 (message "Adding entry '%s' to '%s'" slug headline)
199 (org-entry-put nil "CUSTOM_ID" slug)))))))
200
201(defun acdw-org/title-to-filename (title)
202 "Convert TITLE to a reasonable filename."
203 ;; Based on the slug logic in `org-roam', but `org-roam' also uses a
204 ;; timestamp, and I only use the slug.
205 (setq title (s-downcase title))
206 (setq title (s-replace-regexp "[^a-zA-Z0-9]+" "-" title))
207 (setq title (s-replace-regexp "-+" "-" title))
208 (setq title (s-replace-regexp "^-" "" title))
209 (setq title (s-replace-regexp "-$" "" title))
210 title)
211
212
184;;; ADVICE 213;;; ADVICE
185 214
186;; Correct `org-delete-backward-char' to use `backward-delete-char-untabify' 215;; Correct `org-delete-backward-char' to use `backward-delete-char-untabify'