diff options
Diffstat (limited to 'lisp/acdw.el')
-rw-r--r-- | lisp/acdw.el | 895 |
1 files changed, 36 insertions, 859 deletions
diff --git a/lisp/acdw.el b/lisp/acdw.el index 56b661f..b13c9b6 100644 --- a/lisp/acdw.el +++ b/lisp/acdw.el | |||
@@ -1,869 +1,46 @@ | |||
1 | ;;; acdw.el --- miscellaneous -*- lexical-binding: t; coding: utf-8-unix -*- | 1 | ;;; acdw.el --- various meta-whatevers -*- lexical-binding: t -*- |
2 | |||
3 | ;; Author: Case Duckworth <(rot13-string "npqj@npqj.arg")> | ||
4 | ;; Created: Sometime during Covid-19, 2020 | ||
5 | ;; Keywords: configuration | ||
6 | ;; URL: https://tildegit.org/acdw/emacs | ||
7 | |||
8 | ;; This file is NOT part of GNU Emacs. | ||
9 | |||
10 | ;;; License: | ||
11 | ;; Everyone is permitted to do whatever with this software, without | ||
12 | ;; limitation. This software comes without any warranty whatsoever, | ||
13 | ;; but with two pieces of advice: | ||
14 | ;; - Don't hurt yourself. | ||
15 | ;; - Make good choices. | ||
16 | 2 | ||
17 | ;;; Commentary: | 3 | ;;; Commentary: |
18 | ;; `acdw.el' contains `acdw/map', its mode, and assorted ease-of-life | ||
19 | ;; functions for me, acdw. | ||
20 | |||
21 | ;;; Code: | ||
22 | |||
23 | (require 'cl-lib) | ||
24 | (require 'auth-source) | ||
25 | (require 'recentf) | ||
26 | |||
27 | ;;; Variables | ||
28 | |||
29 | (defconst acdw/system | ||
30 | (pcase system-type | ||
31 | ('gnu/linux :home) | ||
32 | ((or 'msdos 'windows-nt) :work) | ||
33 | (_ :other)) | ||
34 | "Which computer system is currently being used.") | ||
35 | |||
36 | (defmacro acdw/system (&rest args) | ||
37 | "Macro for interfacing, depending on ARGS, with symbol `acdw/system'. | ||
38 | |||
39 | When called without arguments, it returns symbol `acdw/system'. When | ||
40 | called with one (symbol) argument, it returns (eq acdw/system | ||
41 | ARG). When called with multiple arguments or a list, it returns | ||
42 | `pcase' over each argument." | ||
43 | (cond | ||
44 | ((null args) acdw/system) | ||
45 | ((atom (car args)) | ||
46 | `(when (eq acdw/system ,(car args)) | ||
47 | ,(car args))) | ||
48 | (t | ||
49 | `(pcase acdw/system | ||
50 | ,@args)))) | ||
51 | |||
52 | |||
53 | ;;; Utility functions | ||
54 | ;; I don't prefix these because ... reasons. Honestly I probably should prefix | ||
55 | ;; them. | ||
56 | |||
57 | (defun truncate-string (len str &optional ellipsis) | ||
58 | "If STR is longer than LEN, cut it down and add ELLIPSIS to the end. | ||
59 | When not specified, ELLIPSIS defaults to '...'." | ||
60 | (declare (pure t) (side-effect-free t)) | ||
61 | (unless ellipsis | ||
62 | (setq ellipsis "...")) | ||
63 | (if (> (length str) len) | ||
64 | (format "%s%s" (substring str 0 (- len (length ellipsis))) ellipsis) | ||
65 | str)) | ||
66 | |||
67 | ;; Why isn't this a thing??? | ||
68 | (defmacro fbound-and-true-p (func) | ||
69 | "Return the value of function FUNC if it is bound, else nil." | ||
70 | `(and (fboundp ,func) ,func)) | ||
71 | |||
72 | (defmacro when-unfocused (name &rest forms) | ||
73 | "Define a function NAME, executing FORMS, for when Emacs is unfocused." | ||
74 | (declare (indent 1)) | ||
75 | (let ((func-name (intern (concat "when-unfocused-" (symbol-name name))))) | ||
76 | `(progn | ||
77 | (defun ,func-name () "Defined by `when-unfocused'." | ||
78 | (when (seq-every-p #'null | ||
79 | (mapcar #'frame-focus-state (frame-list))) | ||
80 | ,@forms)) | ||
81 | (add-function :after after-focus-change-function #',func-name)))) | ||
82 | |||
83 | (defmacro with-eval-after-loads (features &rest body) | ||
84 | "Execute BODY after FEATURES are loaded. | ||
85 | This macro simplifies `with-eval-after-load' for multiple nested | ||
86 | features." | ||
87 | (declare (indent 1) | ||
88 | (debug (form def-body))) | ||
89 | (unless (listp features) | ||
90 | (setq features (list features))) | ||
91 | (if (null features) | ||
92 | (macroexp-progn body) | ||
93 | (let* ((this (car features)) | ||
94 | (rest (cdr features))) | ||
95 | `(with-eval-after-load ',this | ||
96 | (with-eval-after-loads ,rest ,@body))))) | ||
97 | |||
98 | (defmacro with-message (message &rest body) | ||
99 | "Execute BODY, messaging 'MESSAGE...' before and 'MESSAGE... Done.' after." | ||
100 | (declare (indent 1)) | ||
101 | ;; Wrap a progn inside a prog1 to return the return value of the body. | ||
102 | `(prog1 | ||
103 | (progn (message "%s..." ,message) | ||
104 | ,@body) | ||
105 | (message "%s... Done." ,message))) | ||
106 | |||
107 | (defun clone-buffer-write-file (filename &optional confirm) | ||
108 | "Clone current buffer to a file named FILENAME and switch. | ||
109 | FILENAME and CONFIRM are passed directly to `write-file'." | ||
110 | (interactive ; stolen from `write-file' | ||
111 | (list (if buffer-file-name | ||
112 | (read-file-name "Write file: " | ||
113 | nil nil nil nil) | ||
114 | (read-file-name "Write file: " default-directory | ||
115 | (expand-file-name | ||
116 | (file-name-nondirectory (buffer-name)) | ||
117 | default-directory) | ||
118 | nil nil)) | ||
119 | (not current-prefix-arg))) | ||
120 | (let ((buf (clone-buffer nil nil))) | ||
121 | (with-current-buffer buf | ||
122 | (write-file filename confirm)) | ||
123 | (switch-to-buffer buf))) | ||
124 | |||
125 | ;; https://old.reddit.com/r/emacs/comments/pjwkts | ||
126 | (defun acdw/goto-last-row () | ||
127 | "Move point to last row of buffer, but save the column." | ||
128 | (interactive) | ||
129 | (let ((col (current-column))) | ||
130 | (goto-char (point-max)) | ||
131 | (move-to-column col t))) | ||
132 | |||
133 | (defun acdw/goto-first-row () | ||
134 | "Move point to first row of buffer, but save the column." | ||
135 | (interactive) | ||
136 | (let ((col (current-column))) | ||
137 | (goto-char (point-min)) | ||
138 | (move-to-column col t))) | ||
139 | |||
140 | (defun dos2unix (buffer) | ||
141 | "Replace \r\n with \n in BUFFER." | ||
142 | (interactive "*b") | ||
143 | (save-excursion | ||
144 | (with-current-buffer buffer | ||
145 | (goto-char (point-min)) | ||
146 | (while (search-forward (string ?\C-m ?\C-j) nil t) | ||
147 | (replace-match (string ?\C-j) nil t))))) | ||
148 | |||
149 | (defun expand-file-name-exists-p (&rest args) | ||
150 | "Return `expand-file-name' ARGS if it exists, or nil." | ||
151 | (let ((file (apply #'expand-file-name args))) | ||
152 | (if (file-exists-p file) | ||
153 | file | ||
154 | nil))) | ||
155 | |||
156 | (defun kill-region-or-backward-word (arg) | ||
157 | "If region is active, kill; otherwise kill word backward with ARG." | ||
158 | (interactive "p") | ||
159 | (if (region-active-p) | ||
160 | (kill-region (region-beginning) (region-end)) | ||
161 | (if (bound-and-true-p paredit-mode) | ||
162 | (paredit-backward-kill-word) | ||
163 | (backward-kill-word arg)))) | ||
164 | |||
165 | (defun unfill-buffer (&optional buffer-or-name) | ||
166 | "Unfill entire contents of BUFFER-OR-NAME." | ||
167 | (with-current-buffer (or buffer-or-name (current-buffer)) | ||
168 | (save-excursion | ||
169 | (save-restriction | ||
170 | (unfill-region (point-min) (point-max)))))) | ||
171 | |||
172 | (defun waterfall-list (car list rest) | ||
173 | "Cons CAR with each element in LIST in a waterfall fashion, end with REST. | ||
174 | For use with the `with-eval-after-loads' function." | ||
175 | (cond ((atom list) `(,car ',list ,@rest)) | ||
176 | ((= 1 (length list)) `(,car ',(car list) ,@rest)) | ||
177 | (t | ||
178 | `(,car ',(car list) | ||
179 | ,(waterfall-list car (cdr list) rest))))) | ||
180 | |||
181 | |||
182 | ;;; Comment-or-uncomment-sexp | ||
183 | ;; from https://endlessparentheses.com/a-comment-or-uncomment-sexp-command.html | ||
184 | |||
185 | (defun uncomment-sexp (&optional n) | ||
186 | "Uncomment N sexps around point." | ||
187 | (interactive "P") | ||
188 | (let* ((initial-point (point-marker)) | ||
189 | (inhibit-field-text-motion t) | ||
190 | (p) | ||
191 | (end (save-excursion | ||
192 | (when (elt (syntax-ppss) 4) | ||
193 | (re-search-backward comment-start-skip | ||
194 | (line-beginning-position) | ||
195 | t)) | ||
196 | (setq p (point-marker)) | ||
197 | (comment-forward (point-max)) | ||
198 | (point-marker))) | ||
199 | (beg (save-excursion | ||
200 | (forward-line 0) | ||
201 | (while (and (not (bobp)) | ||
202 | (= end (save-excursion | ||
203 | (comment-forward (point-max)) | ||
204 | (point)))) | ||
205 | (forward-line -1)) | ||
206 | (goto-char (line-end-position)) | ||
207 | (re-search-backward comment-start-skip | ||
208 | (line-beginning-position) | ||
209 | t) | ||
210 | (ignore-errors | ||
211 | (while (looking-at-p comment-start-skip) | ||
212 | (forward-char -1))) | ||
213 | (point-marker)))) | ||
214 | (unless (= beg end) | ||
215 | (uncomment-region beg end) | ||
216 | (goto-char p) | ||
217 | ;; Indentify the "top-level" sexp inside the comment. | ||
218 | (while (and (ignore-errors (backward-up-list) t) | ||
219 | (>= (point) beg)) | ||
220 | (skip-chars-backward (rx (syntax expression-prefix))) | ||
221 | (setq p (point-marker))) | ||
222 | ;; Re-comment everything before it. | ||
223 | (ignore-errors | ||
224 | (comment-region beg p)) | ||
225 | ;; And everything after it. | ||
226 | (goto-char p) | ||
227 | (forward-sexp (or n 1)) | ||
228 | (skip-chars-forward "\r\n[:blank:]") | ||
229 | (if (< (point) end) | ||
230 | (ignore-errors | ||
231 | (comment-region (point) end)) | ||
232 | ;; If this is a closing delimiter, pull it up. | ||
233 | (goto-char end) | ||
234 | (skip-chars-forward "\r\n[:blank:]") | ||
235 | (when (eq 5 (car (syntax-after (point)))) | ||
236 | (delete-indentation)))) | ||
237 | ;; Without a prefix, it's more useful to leave point where | ||
238 | ;; it was. | ||
239 | (unless n | ||
240 | (goto-char initial-point)))) | ||
241 | |||
242 | (defun comment-sexp--raw () | ||
243 | "Comment the sexp at point or ahead of point." | ||
244 | (pcase (or (bounds-of-thing-at-point 'sexp) | ||
245 | (save-excursion | ||
246 | (skip-chars-forward "\r\n[:blank:]") | ||
247 | (bounds-of-thing-at-point 'sexp))) | ||
248 | (`(,l . ,r) | ||
249 | (goto-char r) | ||
250 | (skip-chars-forward "\r\n[:blank:]") | ||
251 | (save-excursion | ||
252 | (comment-region l r)) | ||
253 | (skip-chars-forward "\r\n[:blank:]")))) | ||
254 | |||
255 | (defun comment-or-uncomment-sexp (&optional n) | ||
256 | "Comment the sexp at point and move past it. | ||
257 | If already inside (or before) a comment, uncomment instead. | ||
258 | With a prefix argument N, (un)comment that many sexps." | ||
259 | (interactive "P") | ||
260 | (if (or (elt (syntax-ppss) 4) | ||
261 | (< (save-excursion | ||
262 | (skip-chars-forward "\r\n[:blank:]") | ||
263 | (point)) | ||
264 | (save-excursion | ||
265 | (comment-forward 1) | ||
266 | (point)))) | ||
267 | (uncomment-sexp n) | ||
268 | (dotimes (_ (or n 1)) | ||
269 | (comment-sexp--raw)))) | ||
270 | |||
271 | |||
272 | ;;; Sort sexps | ||
273 | ;; from https://github.com/alphapapa/unpackaged.el#sort-sexps | ||
274 | ;; and https://github.com/alphapapa/unpackaged.el/issues/20 | ||
275 | |||
276 | (defun sort-sexps (beg end &optional key-fn sort-fn) | ||
277 | "Sort sexps between BEG and END. | ||
278 | Comments stay with the code below. | ||
279 | |||
280 | Optional argument KEY-FN will determine where in each sexp to | ||
281 | start sorting. e.g. (lambda (sexp) (symbol-name (car sexp))) | ||
282 | |||
283 | Optional argument SORT-FN will determine how to sort two sexps' | ||
284 | strings. It's passed to `sort'. By default, it sorts the sexps | ||
285 | with `string<' starting with the key determined by KEY-FN." | ||
286 | (interactive "r") | ||
287 | (cl-flet ((skip-whitespace () (while (looking-at (rx (1+ (or space "\n")))) | ||
288 | (goto-char (match-end 0)))) | ||
289 | (skip-both () (while (cond ((or (nth 4 (syntax-ppss)) | ||
290 | (ignore-errors | ||
291 | (save-excursion | ||
292 | (forward-char 1) | ||
293 | (nth 4 (syntax-ppss))))) | ||
294 | (forward-line 1)) | ||
295 | ((looking-at (rx (1+ (or space "\n")))) | ||
296 | (goto-char (match-end 0))))))) | ||
297 | (save-excursion | ||
298 | (save-restriction | ||
299 | (narrow-to-region beg end) | ||
300 | (goto-char beg) | ||
301 | (skip-both) | ||
302 | (cl-destructuring-bind (sexps markers) | ||
303 | (cl-loop do (skip-whitespace) | ||
304 | for start = (point-marker) | ||
305 | for sexp = (ignore-errors | ||
306 | (read (current-buffer))) | ||
307 | for end = (point-marker) | ||
308 | while sexp | ||
309 | ;; Collect the real string, then one used for sorting. | ||
310 | collect (cons (buffer-substring (marker-position start) | ||
311 | (marker-position end)) | ||
312 | (save-excursion | ||
313 | (goto-char (marker-position start)) | ||
314 | (skip-both) | ||
315 | (if key-fn | ||
316 | (funcall key-fn sexp) | ||
317 | (buffer-substring | ||
318 | (point) | ||
319 | (marker-position end))))) | ||
320 | into sexps | ||
321 | collect (cons start end) | ||
322 | into markers | ||
323 | finally return (list sexps markers)) | ||
324 | (setq sexps (sort sexps (if sort-fn sort-fn | ||
325 | (lambda (a b) | ||
326 | (string< (cdr a) (cdr b)))))) | ||
327 | (cl-loop for (real . sort) in sexps | ||
328 | for (start . end) in markers | ||
329 | do (progn | ||
330 | (goto-char (marker-position start)) | ||
331 | (insert-before-markers real) | ||
332 | (delete-region (point) (marker-position end))))))))) | ||
333 | |||
334 | (defun acdw/sort-setups () | ||
335 | "Sort `setup' forms in the current buffer. | ||
336 | Actually sorts all forms, but based on the logic of `setup'. | ||
337 | In short, DO NOT USE THIS FUNCTION!!!" | ||
338 | (save-excursion | ||
339 | (sort-sexps | ||
340 | (point-min) (point-max) | ||
341 | ;; Key function | ||
342 | nil | ||
343 | ;; Sort function | ||
344 | (lambda (s1 s2) ; oh god, this is worse. | ||
345 | (let* ((s1 (cdr s1)) (s2 (cdr s2)) ; for the strings themselves | ||
346 | (require-regexp (rx bos (* nonl) ":require")) | ||
347 | (straight-regexp (rx bos (* nonl) ":straight")) | ||
348 | (s1-require (string-match require-regexp s1)) | ||
349 | (s2-require (string-match require-regexp s2)) | ||
350 | (s1-straight (string-match straight-regexp s1)) | ||
351 | (s2-straight (string-match straight-regexp s2))) | ||
352 | (cond | ||
353 | ;; Straight forms require some weirdness | ||
354 | ((and s1-straight s2-straight) | ||
355 | (let* ((r (rx ":straight" (? "-when") (* space) (? "("))) | ||
356 | (s1 (replace-regexp-in-string r "" s1)) | ||
357 | (s2 (replace-regexp-in-string r "" s2))) | ||
358 | (string< s1 s2))) | ||
359 | ;; requires should go first | ||
360 | ((and s1-require (not s2-require)) t) | ||
361 | ((and (not s1-require) s2-require) nil) | ||
362 | ;; straights should go last | ||
363 | ((and s1-straight (not s2-straight)) nil) | ||
364 | ((and (not s1-straight) s2-straight) t) | ||
365 | ;; else, just sort em. | ||
366 | (t (string< s1 s2)))))))) | ||
367 | |||
368 | |||
369 | ;;; Emacs configuration functions | ||
370 | |||
371 | (defun emacs-git-pull-config (&optional remote branch) | ||
372 | "`git-pull' Emacs' configuration from REMOTE and BRANCH. | ||
373 | REMOTE defaults to 'origin', BRANCH to 'main'." | ||
374 | (let ((remote (or remote "origin")) | ||
375 | (branch (or branch "main"))) | ||
376 | (with-message (format "Pulling Emacs's configuration from %s" branch) | ||
377 | (shell-command (concat "git -C " | ||
378 | "\"" (expand-file-name user-emacs-directory) "\"" | ||
379 | " pull " remote " " branch) | ||
380 | (get-buffer-create "*emacs-git-pull-config-output*") | ||
381 | (get-buffer-create "*emacs-git-pull-config-error*"))))) | ||
382 | |||
383 | (defun emacs-reload (&optional git-pull-first) | ||
384 | "Reload Emacs's configuration files. | ||
385 | With a prefix argument GIT-PULL-FIRST, run git pull on the repo | ||
386 | first." | ||
387 | (interactive "P") | ||
388 | (when git-pull-first | ||
389 | (emacs-git-pull-config)) | ||
390 | (let ((init-files (append | ||
391 | ;; Load lisp libraries first, in case their functionality | ||
392 | ;; is used by {early-,}init.el | ||
393 | (let* ((dir (expand-file-name "lisp/" | ||
394 | user-emacs-directory)) | ||
395 | (full-name (lambda (f) | ||
396 | (concat | ||
397 | (file-name-as-directory dir) f)))) | ||
398 | (mapcar full-name (directory-files dir nil "\\.el\\'"))) | ||
399 | ;; Load regular init files | ||
400 | (list (locate-user-emacs-file "early-init.el") | ||
401 | (locate-user-emacs-file "init.el" ".emacs")))) | ||
402 | (debug-on-error t)) | ||
403 | (with-message "Saving init files" | ||
404 | (save-some-buffers :no-confirm (lambda () (member (buffer-file-name) | ||
405 | init-files)))) | ||
406 | (dolist (file init-files) | ||
407 | (with-message (format "Loading %s" file) | ||
408 | (when (file-exists-p file) | ||
409 | (load-file file)))))) | ||
410 | |||
411 | |||
412 | ;;; Specialized functions | ||
413 | |||
414 | (defun acdw/copy-region-plain (beg end) | ||
415 | "Copy a region from BEG to END to clipboard, removing all Org formatting." | ||
416 | (interactive "r") | ||
417 | (let ((s (buffer-substring-no-properties beg end)) | ||
418 | (extracted-heading (when (derived-mode-p 'org-mode) | ||
419 | (acdw/org-extract-heading-text)))) | ||
420 | (with-temp-buffer | ||
421 | (insert s) | ||
422 | (let ((sentence-end-double-space nil)) | ||
423 | ;; Remove org stuff | ||
424 | (when extracted-heading ; Replace org heading with plaintext | ||
425 | (goto-char (point-min)) | ||
426 | (kill-line) | ||
427 | (insert extracted-heading)) | ||
428 | ;; Delete property drawers | ||
429 | (replace-regexp org-property-drawer-re "") | ||
430 | ;; Delete logbook drawers | ||
431 | (replace-regexp org-logbook-drawer-re "") | ||
432 | ;; Replace list items with their contents, paragraphed | ||
433 | (replace-regexp org-list-full-item-re " | ||
434 | \4") | ||
435 | ;; Delete comment lines | ||
436 | (replace-regexp (concat org-comment-regexp ".*$") "") | ||
437 | ;; Re-fill text for clipboard | ||
438 | (unfill-region (point-min) (point-max)) | ||
439 | (flush-lines "^$" (point-min) (point-max))) | ||
440 | ;; Copy buffer | ||
441 | (copy-region-as-kill (point-min) (point-max)))) | ||
442 | (when (called-interactively-p 'interactive) | ||
443 | (indicate-copied-region)) | ||
444 | (setq deactivate-mark t) | ||
445 | nil) | ||
446 | 4 | ||
447 | ;; https://emacs.stackexchange.com/questions/36366/ | 5 | ;; What's that saying about how the hardest things in computer science |
448 | (defun html-body-id-filter (output backend info) | 6 | ;; are naming and off-by-one errors? Well, the naming one I know very |
449 | "Remove random ID attributes generated by Org." | 7 | ;; well. I've been trying to figure out a good way to prefix my |
450 | (when (eq backend 'html) | 8 | ;; bespoke functions, other stuff I found online, and various emacs |
451 | (replace-regexp-in-string | 9 | ;; lisp detritus for quite some time (I reckon at over a year, as of |
452 | " id=\"[[:alpha:]-]*org[[:alnum:]]\\{7\\}\"" | 10 | ;; 2021-11-02). Finally, I found the answer in the writings of Daniel |
453 | "" | 11 | ;; Mendler: I'll prefix everything with a `+' ! |
454 | output t))) | ||
455 | 12 | ||
456 | (defun html-body-div-filter (output backend info) | 13 | ;; To that end, pretty much everything in lisp/ will have a filename |
457 | "Remove wrapping divs generated by Org." | 14 | ;; like "+org.el", except of course this file, and maybe a few |
458 | (when (eq backend 'html) | 15 | ;; /actually original/ libraries I haven't had the wherewithal to |
459 | (replace-regexp-in-string | 16 | ;; package out properly yet. |
460 | "</?div[^>]*>\n*" "" | ||
461 | output t))) | ||
462 | 17 | ||
463 | (defun org-demote-headings (backend) | 18 | ;; Is it perfect? No. Is it fine? Yes. Here it is. |
464 | (while (/= (point) (point-max)) | ||
465 | (org-next-visible-heading 1) | ||
466 | (org-demote-subtree))) | ||
467 | 19 | ||
468 | (defun acdw/org-export-copy-html () | 20 | ;;; Code: |
469 | "Copy a tree as HTML." | ||
470 | (interactive) | ||
471 | (require 'ox-html) | ||
472 | (org-export-with-buffer-copy | ||
473 | ;; (add-hook 'org-export-before-parsing-hook #'org-demote-headings nil t) | ||
474 | (let ((extracted-heading (acdw/org-extract-heading-text)) | ||
475 | (org-export-show-temporary-export-buffer nil) | ||
476 | (org-export-filter-final-output-functions | ||
477 | '(html-body-id-filter html-body-div-filter))) | ||
478 | (insert "* ORG IS STUPID SOMETIMES\n") | ||
479 | (goto-char (point-min)) | ||
480 | (org-html-export-as-html nil t nil t | ||
481 | (list :with-smart-quotes nil | ||
482 | :with-special-strings t)) | ||
483 | (with-current-buffer "*Org HTML Export*" | ||
484 | (goto-char (point-min)) | ||
485 | (replace-regexp "<h2>.*</h2>" "") | ||
486 | (insert "<h2>" extracted-heading "</h2>") | ||
487 | (flush-lines "^$" (point-min) (point-max)) | ||
488 | (let ((sentence-end-double-space nil)) | ||
489 | (unfill-region (point-min) (point-max))) | ||
490 | (replace-regexp "<h" "\n<h" nil (1+ (point-min)) (point-max)) | ||
491 | (replace-regexp "<p" "\n<p" nil (point-min) (point-max)) | ||
492 | (replace-regexp "<p> +" "<p>" nil (point-min) (point-max)) | ||
493 | (replace-regexp " +</p>" "</p>" nil (point-min) (point-max)) | ||
494 | (copy-region-as-kill (point-min) (point-max))))) | ||
495 | (when (called-interactively-p 'interactive) | ||
496 | (indicate-copied-region)) | ||
497 | (setq deactivate-mark t) | ||
498 | nil) | ||
499 | |||
500 | (defun acdw/org-export-copy () | ||
501 | "Copy a tree as ASCII." | ||
502 | (interactive) | ||
503 | (require 'ox-ascii) | ||
504 | (let ((extracted-heading (acdw/org-extract-heading-text))) | ||
505 | ;; Export to ASCII - not async, subtree only, visible-only, body-only | ||
506 | (let ((org-export-show-temporary-export-buffer nil)) | ||
507 | (org-ascii-export-as-ascii nil t nil t | ||
508 | (list :with-smart-quotes t | ||
509 | :with-special-strings t))) | ||
510 | (with-current-buffer "*Org ASCII Export*" | ||
511 | (goto-char (point-min)) | ||
512 | (insert extracted-heading) | ||
513 | (newline 2) | ||
514 | |||
515 | (replace-regexp org-list-full-item-re "\n\4") | ||
516 | |||
517 | (let ((sentence-end-double-space nil)) | ||
518 | (unfill-region (point-min) (point-max))) | ||
519 | (flush-lines "^$" (point-min) (point-max)) | ||
520 | |||
521 | (copy-region-as-kill (point-min) (point-max))) | ||
522 | |||
523 | (when (called-interactively-p 'interactive) | ||
524 | (indicate-copied-region)) | ||
525 | (setq deactivate-mark t) | ||
526 | nil)) | ||
527 | |||
528 | (defun acdw/org-extract-heading-text () | ||
529 | "Extract the heading text from an `org-mode' heading." | ||
530 | (let ((heading (org-no-properties (org-get-heading t t t t)))) | ||
531 | (message | ||
532 | (replace-regexp-in-string org-link-bracket-re | ||
533 | (lambda (match) | ||
534 | (match-string-no-properties 2 match)) | ||
535 | heading)))) | ||
536 | |||
537 | (defun acdw/sync-dir (&optional file make-directory) | ||
538 | "Return FILE from ~/Sync. | ||
539 | Optional argument MAKE-DIRECTORY makes the directory. | ||
540 | Logic is as in `acdw/dir', which see." | ||
541 | (let ((dir (expand-file-name (convert-standard-filename "~/Sync/")))) | ||
542 | (if file | ||
543 | (let ((file-name (expand-file-name (convert-standard-filename file) | ||
544 | dir))) | ||
545 | (when make-directory | ||
546 | (make-directory (file-name-directory file-name) 'parents)) | ||
547 | file-name) | ||
548 | dir))) | ||
549 | |||
550 | (defun acdw/dir (&optional file make-directory) | ||
551 | "Place Emacs files in one place. | ||
552 | |||
553 | If called without parameters, `acdw/dir' expands to | ||
554 | ~/.emacs.d/var or similar. If called with FILE, `acdw/dir' | ||
555 | expands FILE to ~/.emacs.d/var, optionally making its directory | ||
556 | if MAKE-DIRECTORY is non-nil." | ||
557 | (let ((dir (expand-file-name (convert-standard-filename "var/") | ||
558 | user-emacs-directory))) | ||
559 | (if file | ||
560 | (let ((file-name (expand-file-name (convert-standard-filename file) | ||
561 | dir))) | ||
562 | (when make-directory | ||
563 | (make-directory (file-name-directory file-name) 'parents)) | ||
564 | file-name) | ||
565 | dir))) | ||
566 | |||
567 | (defun acdw/find-emacs-source () ;; doesn't work right now | ||
568 | "Find where Emacs' source tree is." | ||
569 | (acdw/system | ||
570 | (:work (expand-file-name | ||
571 | (concat "~/src/emacs-" emacs-version "/src"))) | ||
572 | (:home (expand-file-name "~/src/pkg/emacs/src/emacs-git/src")) | ||
573 | (:other nil))) | ||
574 | |||
575 | (defun acdw/gc-disable () | ||
576 | "Functionally disable the Garbage collector." | ||
577 | (setq gc-cons-threshold most-positive-fixnum | ||
578 | gc-cons-percentage 0.8)) | ||
579 | |||
580 | (defun acdw/gc-enable () | ||
581 | "Enable the Garbage collector." | ||
582 | (setq gc-cons-threshold (* 800 1024 1024) | ||
583 | gc-cons-percentage 0.1)) | ||
584 | |||
585 | (defun acdw/insert-iso-date (arg) | ||
586 | "Insert the ISO-8601-formatted date, optionally including time (pass ARG)." | ||
587 | (interactive "P") | ||
588 | (let ((format (if arg "%FT%T%z" "%F"))) | ||
589 | (insert (format-time-string format (current-time))))) | ||
590 | |||
591 | (defun acdw/kill-a-buffer (&optional prefix) | ||
592 | "Kill this buffer, or other buffers, depending on PREFIX. | ||
593 | |||
594 | \\[acdw/kill-a-buffer] : Kill CURRENT buffer and window | ||
595 | \\[universal-argument] \\[acdw/kill-a-buffer] : Kill OTHER buffer and window | ||
596 | \\[universal-argument] \\[universal-argument] \\[acdw/kill-a-buffer] : Kill ALL OTHER buffers and windows | ||
597 | |||
598 | Prompt only if there are unsaved changes." | ||
599 | (interactive "P") | ||
600 | (pcase (or (car prefix) 0) | ||
601 | (0 (kill-current-buffer) | ||
602 | (unless (one-window-p) (delete-window))) | ||
603 | (4 (other-window 1) | ||
604 | (kill-current-buffer) | ||
605 | (unless (one-window-p) (delete-window))) | ||
606 | (16 (mapc 'kill-buffer (delq (current-buffer) (buffer-list))) | ||
607 | (delete-other-windows)))) | ||
608 | |||
609 | (defun acdw/sunrise-sunset (sunrise-command sunset-command) | ||
610 | "Run SUNRISE-COMMAND at sunrise, and SUNSET-COMMAND at sunset." | ||
611 | (let* ((times-regex (rx (* nonl) | ||
612 | (: (any ?s ?S) "unrise") " " | ||
613 | (group (repeat 1 2 digit) ":" | ||
614 | (repeat 1 2 digit) | ||
615 | (: (any ?a ?A ?p ?P) (any ?m ?M))) | ||
616 | (* nonl) | ||
617 | (: (any ?s ?S) "unset") " " | ||
618 | (group (repeat 1 2 digit) ":" | ||
619 | (repeat 1 2 digit) | ||
620 | (: (any ?a ?A ?p ?P) (any ?m ?M))) | ||
621 | (* nonl))) | ||
622 | (ss (acdw/supress-messages #'sunrise-sunset)) | ||
623 | (_m (string-match times-regex ss)) | ||
624 | (sunrise-time (match-string 1 ss)) | ||
625 | (sunset-time (match-string 2 ss))) | ||
626 | (run-at-time sunrise-time (* 60 60 24) sunrise-command) | ||
627 | (run-at-time sunset-time (* 60 60 24) sunset-command) | ||
628 | (run-at-time "12:00am" (* 60 60 24) sunset-command))) | ||
629 | |||
630 | (defun acdw/supress-messages (oldfn &rest args) ; from pkal | ||
631 | "Advice wrapper for suppressing `message'. | ||
632 | OLDFN is the wrapped function, that is passed the arguments | ||
633 | ARGS." | ||
634 | (let ((msg (current-message))) | ||
635 | (prog1 | ||
636 | (let ((inhibit-message t)) | ||
637 | (apply oldfn args)) | ||
638 | (when msg | ||
639 | (message "%s" msg))))) | ||
640 | |||
641 | (defun acdw/setup-fringes () | ||
642 | "Set up fringes how I likes 'em." | ||
643 | (define-fringe-bitmap 'left-curly-arrow | ||
644 | [#b01100000 | ||
645 | #b00110000 | ||
646 | #b00011000 | ||
647 | #b00001100] | ||
648 | 4 8 'center) | ||
649 | (define-fringe-bitmap 'right-curly-arrow | ||
650 | [#b00000011 | ||
651 | #b00000110 | ||
652 | #b00001100 | ||
653 | #b00011000] | ||
654 | 4 8 'center) | ||
655 | (define-fringe-bitmap 'left-arrow | ||
656 | [#b01100000 | ||
657 | #b01010000] | ||
658 | 2 8 '(top t)) | ||
659 | (define-fringe-bitmap 'right-arrow | ||
660 | [#b00000011 | ||
661 | #b00000101] | ||
662 | 2 8 '(top t)) | ||
663 | (setq-local indicate-empty-lines nil | ||
664 | indicate-buffer-boundaries '((top . right) | ||
665 | (bottom . right))) | ||
666 | (custom-set-faces '(fringe | ||
667 | ((t (:foreground "dim gray")))))) | ||
668 | |||
669 | |||
670 | ;;; Recentf renaming with dired | ||
671 | ;; from ... somewhere. 'rjs', apparently? | ||
672 | ;; I'm throwing these here because they look better here than in init.el. | ||
673 | ;; Comments are "rjs"'s. | ||
674 | |||
675 | ;; Magic advice to rename entries in recentf when moving files in | ||
676 | ;; dired. | ||
677 | (defun rjs/recentf-rename-notify (oldname newname &rest _args) | ||
678 | "Magically rename files from OLDNAME to NEWNAME when moved in `dired'." | ||
679 | (if (file-directory-p newname) | ||
680 | (rjs/recentf-rename-directory oldname newname) | ||
681 | (rjs/recentf-rename-file oldname newname))) | ||
682 | |||
683 | (defun rjs/recentf-rename-file (oldname newname) | ||
684 | "Rename a file from OLDNAME to NEWNAME in `recentf-list'." | ||
685 | (setq recentf-list | ||
686 | (mapcar (lambda (name) | ||
687 | (if (string-equal name oldname) | ||
688 | newname | ||
689 | oldname)) | ||
690 | recentf-list))) | ||
691 | |||
692 | (defun rjs/recentf-rename-directory (oldname newname) | ||
693 | "Rename directory from OLDNAME to NEWNAME in `recentf-list'." | ||
694 | ;; oldname, newname and all entries of recentf-list should already | ||
695 | ;; be absolute and normalised so I think this can just test whether | ||
696 | ;; oldname is a prefix of the element. | ||
697 | (setq recentf-list | ||
698 | (mapcar (lambda (name) | ||
699 | (if (string-prefix-p oldname name) | ||
700 | (concat newname (substring name (length oldname))) | ||
701 | name)) | ||
702 | recentf-list))) | ||
703 | |||
704 | |||
705 | ;;; Sort setq... | ||
706 | ;; https://emacs.stackexchange.com/questions/33039/ | ||
707 | |||
708 | (defun sort-setq () | ||
709 | "Sort a setq. Must be a defun." | ||
710 | (interactive) | ||
711 | (save-excursion | ||
712 | (save-restriction | ||
713 | (let ((sort-end (progn (end-of-defun) | ||
714 | (backward-char) | ||
715 | (point-marker))) | ||
716 | (sort-beg (progn (beginning-of-defun) | ||
717 | (re-search-forward "[ \\t]*(" (point-at-eol)) | ||
718 | (forward-sexp) | ||
719 | (re-search-forward "\\_<" (point-at-eol)) | ||
720 | (point-marker)))) | ||
721 | (narrow-to-region (1- sort-beg) (1+ sort-end)) | ||
722 | (sort-subr nil #'sort-setq-next-record #'sort-setq-end-record))))) | ||
723 | |||
724 | (defun sort-setq-next-record () | ||
725 | "Sort the next record of a `setq' form." | ||
726 | (condition-case nil | ||
727 | (progn | ||
728 | (forward-sexp 1) | ||
729 | (backward-sexp)) | ||
730 | ('scan-error (goto-char (point-max))))) | ||
731 | |||
732 | (defun sort-setq-end-record () | ||
733 | "Sort the end of a `setq' record." | ||
734 | (condition-case nil | ||
735 | (forward-sexp 2) | ||
736 | ('scan-error (goto-char (point-max))))) | ||
737 | |||
738 | |||
739 | ;;; Crux tweaks | ||
740 | |||
741 | ;; `crux-other-window-or-switch-buffer' doesn't take an argument. | ||
742 | (defun acdw/other-window-or-switch-buffer (&optional arg) | ||
743 | "Call `other-window' with ARG or switch buffers, depending on window count." | ||
744 | (interactive "P") | ||
745 | (if (one-window-p) | ||
746 | (switch-to-buffer nil) | ||
747 | (other-window (or arg 1)))) | ||
748 | |||
749 | (defun acdw/other-window-or-switch-buffer-backward () | ||
750 | "Do `acdw/other-window-or-switch-buffer', but backward." | ||
751 | (interactive) | ||
752 | (acdw/other-window-or-switch-buffer -1)) | ||
753 | |||
754 | |||
755 | ;;; Auth-sources | ||
756 | ;; https://github.com/emacs-circe/circe/wiki/Configuration | ||
757 | (defun acdw/fetch-password (&rest params) | ||
758 | "Fetch a password from `auth-source' using PARAMS. | ||
759 | This function is internal. Use `acdw/make-password-fetcher' instead." | ||
760 | (let ((match (car (apply #'auth-source-search params)))) | ||
761 | (if match | ||
762 | (let ((secret (plist-get match :secret))) | ||
763 | (if (functionp secret) | ||
764 | (funcall secret) | ||
765 | secret)) | ||
766 | (message "Password not found for %S" params)))) | ||
767 | |||
768 | (defun acdw/make-password-fetcher (&rest params) | ||
769 | "Make a function that will call `acdw/fetch-password' with PARAMS." | ||
770 | (lambda (&rest _) | ||
771 | (apply #'acdw/fetch-password params))) | ||
772 | |||
773 | |||
774 | ;;; Paren annoyances | ||
775 | (defun acdw/stop-paren-annoyances (&optional buffer) | ||
776 | "Locally turn off paren-checking functions in BUFFER." | ||
777 | (with-current-buffer (or buffer (current-buffer)) | ||
778 | (setq-local blink-matching-paren nil | ||
779 | show-paren-mode nil))) | ||
780 | |||
781 | |||
782 | ;;; 💩 | ||
783 | (defun 💩 (&optional n) | ||
784 | "💩 x N." | ||
785 | (interactive "p") | ||
786 | (let ((n (or n 1))) | ||
787 | (while (> n 0) | ||
788 | (insert "💩") | ||
789 | (setq n (1- n))))) | ||
790 | |||
791 | |||
792 | ;;; Fat finger solutions | ||
793 | (defun acdw/fat-finger-exit (&optional prefix) | ||
794 | "Delete a frame, or kill Emacs with confirmation. | ||
795 | When called with PREFIX, just kill Emacs without confirmation." | ||
796 | (interactive "P") | ||
797 | (if (or prefix | ||
798 | (and (= 1 (length (frame-list))) | ||
799 | (yes-or-no-p "This is the last frame! Wanna quit?"))) | ||
800 | (kill-emacs) | ||
801 | (ignore-errors | ||
802 | (delete-frame)))) | ||
803 | |||
804 | (defun acdw/disabled-command-function (&optional cmd keys) | ||
805 | (let ((cmd (or cmd this-command)) | ||
806 | (keys (or keys (this-command-keys)))) | ||
807 | ;; this logic stolen from original `disabled-command-function' | ||
808 | (if (or (eq (aref keys 0) (if (stringp keys) | ||
809 | (aref "\M-x" 0) | ||
810 | ?\M-x)) | ||
811 | (and (>= (length keys) 2) | ||
812 | (eq (aref keys 0) meta-prefix-char) | ||
813 | (eq (aref keys 1) ?x))) | ||
814 | ;; it's been run as an M-x command, we want to do it | ||
815 | (call-interactively cmd) | ||
816 | ;; else, tell the user it's disabled. | ||
817 | (message (substitute-command-keys | ||
818 | (concat "Command `%s' has been disabled. " | ||
819 | "Run with \\[execute-extended-command].")) | ||
820 | cmd)))) | ||
821 | |||
822 | |||
823 | ;;; cribbed | ||
824 | |||
825 | ;; https://jao.io/blog/2021-09-08-high-signal-to-noise-emacs-command.html | ||
826 | (defun jao-buffer-same-mode (&rest modes) | ||
827 | "Pop to a buffer with a mode among MODES, or the current one if not given." | ||
828 | (interactive) | ||
829 | (let* ((modes (or modes (list major-mode))) | ||
830 | (pred (lambda (b) | ||
831 | (let ((b (get-buffer (if (consp b) (car b) b)))) | ||
832 | (member (buffer-local-value 'major-mode b) modes))))) | ||
833 | (pop-to-buffer (read-buffer "Buffer: " nil t pred)))) | ||
834 | |||
835 | ;;; BLAH | ||
836 | |||
837 | (defun open-paragraph () | ||
838 | "Open a paragraph after point. | ||
839 | A paragraph is defined as continguous non-empty lines of text | ||
840 | surrounded by empty lines, so opening a paragraph means to make | ||
841 | three blank lines, then place the point on the second one." | ||
842 | (interactive) | ||
843 | ;; Go to next blank line. This /isn't/ `end-of-paragraph-text' because | ||
844 | ;; that's weird with org, and I'm guessing other modes too. | ||
845 | (while (not (looking-at "^$")) | ||
846 | (forward-line 1)) | ||
847 | (newline) | ||
848 | (delete-blank-lines) | ||
849 | (newline 2) | ||
850 | (forward-line -1)) | ||
851 | 21 | ||
852 | (defun require/ (feature &optional filename noerror) | 22 | ;;; Define a directory and an expanding function |
853 | "If FEATURE is not loaded, load it from FILENAME. | 23 | |
854 | This function works just like `require', with one crucial | 24 | (defmacro +define-dir (name directory &optional docstring inhibit-mkdir) |
855 | difference: if the FEATURE name contains a slash, the FILENAME | 25 | "Define a variable and function NAME expanding to DIRECTORY. |
856 | will as well -- unless, of course, FILENAME is set. This allows | 26 | DOCSTRING is applied to the variable. Ensure DIRECTORY exists in |
857 | for `require/' to require files within subdirectories of | 27 | the filesystem, unless INHIBIT-MKDIR is non-nil." |
858 | directories of `load-path'. Of course, NOERROR isn't affected by | 28 | (declare (indent 2)) |
859 | the change." | 29 | (unless inhibit-mkdir |
860 | (let* ((feature-name (if (symbolp feature) | 30 | (make-directory (eval directory) :parents)) |
861 | (symbol-name feature) | 31 | `(progn |
862 | feature)) | 32 | (defvar ,name ,directory |
863 | (filename (or filename | 33 | ,(concat docstring (when docstring "\n") |
864 | (and (string-match-p "/" feature-name) | 34 | "Defined by `/define-dir'.")) |
865 | feature-name)))) | 35 | (defun ,name (file &optional mkdir) |
866 | (require (intern feature-name) filename noerror))) | 36 | ,(concat "Expand FILE relative to variable `" (symbol-name name) "'.\n" |
37 | "If MKDIR is non-nil, the directory is created.\n" | ||
38 | "Defined by `/define-dir'.") | ||
39 | (let ((file-name (expand-file-name (convert-standard-filename file) | ||
40 | ,name))) | ||
41 | (when mkdir | ||
42 | (make-directory (file-name-directory file-name) :parents)) | ||
43 | file-name)))) | ||
867 | 44 | ||
868 | (provide 'acdw) | 45 | (provide 'acdw) |
869 | ;;; acdw.el ends here | 46 | ;;; acdw.el ends here |