diff options
author | Case Duckworth | 2023-01-03 23:03:03 -0600 |
---|---|---|
committer | Case Duckworth | 2023-01-03 23:03:03 -0600 |
commit | 59a1f58695d09ab29ddf992b2c0711c94a4039ea (patch) | |
tree | 1de8114d3b60d11b9a3b92422d178f17e1841ea0 /lisp/acdw-macs.el | |
parent | bleh (diff) | |
download | emacs-59a1f58695d09ab29ddf992b2c0711c94a4039ea.tar.gz emacs-59a1f58695d09ab29ddf992b2c0711c94a4039ea.zip |
Switch to use-package
Diffstat (limited to 'lisp/acdw-macs.el')
-rw-r--r-- | lisp/acdw-macs.el | 293 |
1 files changed, 293 insertions, 0 deletions
diff --git a/lisp/acdw-macs.el b/lisp/acdw-macs.el new file mode 100644 index 0000000..e2258fa --- /dev/null +++ b/lisp/acdw-macs.el | |||
@@ -0,0 +1,293 @@ | |||
1 | ;;; acdw-macs.el --- extra macros -*- lexical-binding: t; -*- | ||
2 | |||
3 | (eval-when-compile | ||
4 | (require 'cl-lib) | ||
5 | (require 'tempo) | ||
6 | (declare-function derived-mode-abbrev-table-name "tempo")) | ||
7 | |||
8 | ;;; Extra functionality for `eval-after-load' | ||
9 | |||
10 | (defun eval-after-init (thunk) | ||
11 | "Evaluate THUNK after Emacs initiation, or now if already initialized." | ||
12 | (if after-init-time | ||
13 | (funcall thunk) | ||
14 | (add-hook 'after-init-hook thunk))) | ||
15 | |||
16 | (defmacro eval-after (prereqs &rest body) | ||
17 | "Evaluate body after PREREQS. | ||
18 | PREREQS can be a feature, a number, `t', or a list of those. | ||
19 | |||
20 | Features are used as arguments to `eval-after-load'. Numbers are | ||
21 | used as arguments to `run-with-idle-timer'. `t' will ensure BODY | ||
22 | runs after Emacs's init time. | ||
23 | |||
24 | When given a list of PREREQS, `eval-after' will nest each one | ||
25 | from left to right." | ||
26 | (declare (indent 1) (debug (form def-body))) | ||
27 | (setf prereqs (ensure-list prereqs)) | ||
28 | (if (null prereqs) | ||
29 | (macroexp-progn body) | ||
30 | (let* ((this (car prereqs)) | ||
31 | (form `((lambda () (eval-after ,(cdr prereqs) ,@body))))) | ||
32 | (cond | ||
33 | ((eq this :init) | ||
34 | (append '(eval-after-init) form)) | ||
35 | ((numberp this) | ||
36 | (append `(run-with-idle-timer ,this nil) form)) | ||
37 | ((symbolp this) | ||
38 | (append `(eval-after-load ',this) form)) | ||
39 | (:else (user-error "Eval-after: Bad prereq: %S" this)))))) | ||
40 | |||
41 | |||
42 | ;;; Easier customization of options | ||
43 | ;; At some point it might be nice to include more forms in the VAR slots, like | ||
44 | ;; `setup's `:option' macro. | ||
45 | |||
46 | (if (fboundp 'setopt) | ||
47 | ;; Emacs 29 introduces `setopt', which does basically the same thing as the | ||
48 | ;; macro below. Not exactly the same, of course---it uses `setopt--set' | ||
49 | ;; instead of `customize-set-variable'---but I'm going to trust the Emacs | ||
50 | ;; devs on this one. | ||
51 | (defalias 'setc 'setopt) | ||
52 | (defmacro setc (&rest args) | ||
53 | "Customize user options in a `setq'-like way." | ||
54 | (declare (debug setq)) | ||
55 | (unless (zerop (mod (length args) 2)) | ||
56 | (signal 'wrong-number-of-arguments `(evenp ,(length args)))) | ||
57 | (let (form defuns) | ||
58 | (while args | ||
59 | (let* ((var (pop args)) | ||
60 | (val (pop args))) | ||
61 | (when (memq (car-safe val) '(defun defmacro)) | ||
62 | (push val defuns) | ||
63 | (setq val `(function ,(cadr val)))) | ||
64 | (push `(customize-set-variable ',var ,val "Set by `setc'.") | ||
65 | form))) | ||
66 | `(progn ,@(append (nreverse defuns) (nreverse form)))))) | ||
67 | |||
68 | |||
69 | ;;; Extra def- forms | ||
70 | |||
71 | (defmacro defdir (name directory &optional docstring) | ||
72 | "Define a variable and a function NAME expanding to DIRECTORY. | ||
73 | DOCSTRING is applied to the variable; its default is DIRECTORY's | ||
74 | path." | ||
75 | (declare (indent 2) (doc-string 3)) | ||
76 | `(progn | ||
77 | (defvar ,name ,directory | ||
78 | ,(concat (or docstring (format "%s" directory)) "\n" | ||
79 | "Defined by `defdir'.")) | ||
80 | (defun ,name (file &optional mkdir) | ||
81 | ,(concat "Expand FILE relative to variable `" (symbol-name name) "'.\n" | ||
82 | "If MKDIR is non-nil, parent directories are created.\n" | ||
83 | "Defined by `defdir'.") | ||
84 | (let ((file-name (expand-file-name | ||
85 | (convert-standard-filename file) ,name))) | ||
86 | (when mkdir | ||
87 | (make-directory (file-name-directory file-name) :parents)) | ||
88 | file-name)))) | ||
89 | |||
90 | (defmacro defkeys (maps &rest bindings) | ||
91 | "Define key BINDINGS in MAPS. | ||
92 | If MAPS is nil or t, bind to `current-global-map'. Otherwise, | ||
93 | bind each of BINDINGS to the map or list of maps provided. | ||
94 | |||
95 | BINDINGS is a `setq'-style list of pairs of keys and definitions. | ||
96 | The key part of each binding can be a string, in which case it's | ||
97 | passed to `kbd', or a vector or anything else `define-key' | ||
98 | accepts in the KEY position. The definition part, likewise, can | ||
99 | be any form `define-key' accepts in that position, with this | ||
100 | addition: if the form is a `defun' form, it will be defined | ||
101 | before any keys are bound." | ||
102 | (declare (indent 1)) | ||
103 | (unless (cl-evenp (length bindings)) | ||
104 | (signal 'wrong-number-of-arguments `(evenp ,(length bindings)))) | ||
105 | `(progn | ||
106 | ,@(cl-loop | ||
107 | for map in (ensure-list maps) | ||
108 | for first-map-p = t then nil | ||
109 | append | ||
110 | (cl-loop | ||
111 | for (keys def) on bindings by #'cddr | ||
112 | for defp = (memq (car-safe def) '(defmap defun defmacro)) | ||
113 | if (and defp first-map-p) collect def into defuns | ||
114 | append | ||
115 | (cl-loop | ||
116 | for key in (ensure-list keys) | ||
117 | collect (list 'define-key | ||
118 | (if (memq map '(t nil)) | ||
119 | '(current-global-map) | ||
120 | (or (car-safe map) map)) | ||
121 | (if (stringp key) | ||
122 | `(kbd ,key) | ||
123 | key) | ||
124 | (if defp | ||
125 | (cl-case (car def) | ||
126 | ((defmap) (cadr def)) | ||
127 | ((defun defmacro) `#',(cadr def)) | ||
128 | (otherwise (error "Bad def type: %S" | ||
129 | (car def)))) | ||
130 | def))) | ||
131 | into keydefs | ||
132 | finally return | ||
133 | (let ((all (append defuns keydefs))) | ||
134 | (if-let ((after (plist-get (cdr-safe map) :after))) | ||
135 | `((eval-after ,after | ||
136 | ,@all)) | ||
137 | all)))))) | ||
138 | |||
139 | (defmacro defmap (name docstring &rest bindings) | ||
140 | "Define a keymap named NAME, with BINDINGS." | ||
141 | (declare (indent 1) (doc-string 2)) | ||
142 | `(,(if (boundp name) 'setq 'defvar) ,name | ||
143 | ;;; ^ probably a terrible hack | ||
144 | (let ((map (make-sparse-keymap))) | ||
145 | (defkeys map ,@bindings) | ||
146 | map) | ||
147 | ,@(unless (boundp name) (list docstring)))) | ||
148 | |||
149 | (defmacro defhook (hooks &rest body) | ||
150 | "Define a function to hook into HOOKS. | ||
151 | NAME and ARGS are passed to the generated `defun' form. | ||
152 | Each hook in HOOKS can be the name of a hook or a list of the form | ||
153 | (HOOK DEPTH LOCAL), where each argument is the same as in | ||
154 | `add-hook'." | ||
155 | (declare (indent 1)) | ||
156 | (let* ((name (or (plist-get body :name) | ||
157 | (intern (format "%s/h" | ||
158 | (mapconcat | ||
159 | (lambda (h) | ||
160 | (string-remove-suffix | ||
161 | "-hook" | ||
162 | (if (and (consp h) | ||
163 | (caddr h)) | ||
164 | (format "%s:local" (car h)) | ||
165 | (format "%s" (or (car-safe h) | ||
166 | h))))) | ||
167 | (ensure-list hooks) | ||
168 | "|"))))) | ||
169 | (args (or (plist-get body :args) nil)) | ||
170 | (doc (or (plist-get body :doc) nil)) | ||
171 | (forms ; (DEFUN . FUNCS) | ||
172 | (cl-loop for form in (delete2 body :name :args :doc) | ||
173 | if (eq (car form) 'function) | ||
174 | collect form into funcs | ||
175 | else collect form into defuns | ||
176 | finally return (cons defuns funcs))) | ||
177 | (defun-forms (car forms)) | ||
178 | (func-forms (cdr forms))) | ||
179 | `(progn | ||
180 | ,@(when defun-forms | ||
181 | `((defun ,name ,args ,@(when doc (list doc)) ,@defun-forms))) | ||
182 | ,@(cl-loop for hook in (ensure-list hooks) | ||
183 | for h = (or (car-safe hook) hook) | ||
184 | for ha = (cdr-safe hook) | ||
185 | if defun-forms | ||
186 | collect `(add-hook ',h #',name ,@ha) | ||
187 | append | ||
188 | (cl-loop for fn in func-forms | ||
189 | collect `(add-hook ',h ,fn ,@ha)))))) | ||
190 | |||
191 | ;; (autoload FUNCTION FILE &optional DOCSTRING INTERACTIVE TYPE) | ||
192 | (defmacro defautoload (file &rest fns) | ||
193 | "Autoload FNS from FILE. | ||
194 | Each of FNS can be an atom (function name) or a list of the | ||
195 | form (FUNCTION ARGS), where ARGS is a plist. ARGS's possible | ||
196 | keys are `:doc' (docstring), `:interactive', and `:type', which are | ||
197 | used as the optional arguments to `autoload'. | ||
198 | |||
199 | You can also pass `:interactive' and `:type' as keyword arguments | ||
200 | just after FILE, and they'll serve as the default for the | ||
201 | autoloaded FNS." | ||
202 | (declare (indent 1)) | ||
203 | (let ((interactive (plist-get fns :interactive)) | ||
204 | (type (plist-get fns :type)) | ||
205 | (fns (delete2 fns :interactive :type))) | ||
206 | `(progn | ||
207 | ,@(cl-loop for fn in fns | ||
208 | for name = (or (car-safe fn) fn) | ||
209 | for args = (cdr-safe fn) | ||
210 | collect | ||
211 | `(autoload ',name ,(format "%s" file) | ||
212 | ,(plist-get args :doc) | ||
213 | ,(or (plist-get args :interactive) | ||
214 | interactive) | ||
215 | ,(or (plist-get args :type) | ||
216 | type)))))) | ||
217 | |||
218 | |||
219 | ;;; Miscellaneous | ||
220 | |||
221 | (defmacro with-message (message &rest body) | ||
222 | "Display MESSAGE then execute BODY. | ||
223 | If BODY executes without errors, display MESSAGE...done." | ||
224 | (declare (indent 1)) | ||
225 | (let ((msym (gensym)) | ||
226 | (esym (gensym))) | ||
227 | `(let ((,msym ,message)) | ||
228 | (condition-case ,esym | ||
229 | (progn (message "%s..." ,msym) | ||
230 | ,@body) | ||
231 | (:success (message "%s...done" ,msym)) | ||
232 | (t (signal (car ,esym) (cdr ,esym))))))) | ||
233 | |||
234 | (defmacro o (&rest fns) | ||
235 | "Compose FNS into a new function for one argument." | ||
236 | (if (null fns) | ||
237 | `(lambda (&rest args) args) | ||
238 | `(lambda (&rest args) | ||
239 | (apply | ||
240 | #',(car fns) | ||
241 | (ensure-list (apply (o ,@(cdr fns)) args)))))) | ||
242 | |||
243 | (defmacro with-region-or-buffer (&rest funcs) | ||
244 | "Advise FUNCS with `advise-region-or-buffer'." | ||
245 | `(progn | ||
246 | ,@(cl-loop for fn in funcs | ||
247 | collect | ||
248 | `(advice-add ',fn :before #'advise-region-or-buffer)))) | ||
249 | |||
250 | (defmacro with-region-or-line (&rest funcs) | ||
251 | "Advise FUNCS with `advise-region-or-line'." | ||
252 | `(progn | ||
253 | ,@(cl-loop for fn in funcs | ||
254 | collect | ||
255 | `(advice-add ',fn :before #'advise-region-or-line)))) | ||
256 | |||
257 | (defmacro with-region-or-to-eol (&rest funcs) | ||
258 | "Advise FUNCS with `advise-region-or-to-eol'." | ||
259 | `(progn | ||
260 | ,@(cl-loop for fn in funcs | ||
261 | collect | ||
262 | `(advice-add ',fn :before #'advise-region-or-to-eol)))) | ||
263 | |||
264 | (defmacro define-tempo (tag doc &rest elements) | ||
265 | "Define a template and add its tag to MODE's abbrev-table. | ||
266 | TAG, DOC, and ELEMENTS are passed to `tempo-define-template', which see. | ||
267 | ABBREV, if given, is the abbrev string to use for template expansion | ||
268 | under MODE's abbrev-table. If ABBREV isn't given, TAG will be used." | ||
269 | (declare (indent 1)) | ||
270 | (let* ((template (gensym)) | ||
271 | (tag (cond ((stringp tag) tag) | ||
272 | ((symbolp tag) (symbol-name tag)) | ||
273 | (t (user-error "TAG must be a string or symbol: %S" tag)))) | ||
274 | (mode (or (plist-get elements :mode) nil)) | ||
275 | (abbrev (or (plist-get elements :abbrev) tag)) | ||
276 | (taglist (or (plist-get elements :taglist) nil)) | ||
277 | (table (let ((tname (and mode (derived-mode-abbrev-table-name mode)))) | ||
278 | (while (and tname (not (memq tname abbrev-table-name-list))) | ||
279 | (setq tname (and (get mode 'derived-mode-parent) | ||
280 | (derived-mode-abbrev-table-name | ||
281 | (get mode 'derived-mode-parent))))) | ||
282 | (or tname 'global-abbrev-table))) | ||
283 | (elements (delete2 elements :mode :abbrev :taglist))) | ||
284 | `(let ((,template (tempo-define-template ,tag | ||
285 | ',elements | ||
286 | ,(or abbrev tag) | ||
287 | ,doc | ||
288 | ,taglist))) | ||
289 | (define-abbrev ,table ,tag "" ,template :system t) | ||
290 | (put ,template 'no-self-insert t)))) | ||
291 | |||
292 | (provide 'acdw-macs) | ||
293 | ;;; acdw-macs.el ends here | ||