From 59a1f58695d09ab29ddf992b2c0711c94a4039ea Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Tue, 3 Jan 2023 23:03:03 -0600 Subject: Switch to use-package --- lisp/acdw-macs.el | 293 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 293 insertions(+) create mode 100644 lisp/acdw-macs.el (limited to 'lisp/acdw-macs.el') 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 @@ +;;; acdw-macs.el --- extra macros -*- lexical-binding: t; -*- + +(eval-when-compile + (require 'cl-lib) + (require 'tempo) + (declare-function derived-mode-abbrev-table-name "tempo")) + +;;; Extra functionality for `eval-after-load' + +(defun eval-after-init (thunk) + "Evaluate THUNK after Emacs initiation, or now if already initialized." + (if after-init-time + (funcall thunk) + (add-hook 'after-init-hook thunk))) + +(defmacro eval-after (prereqs &rest body) + "Evaluate body after PREREQS. +PREREQS can be a feature, a number, `t', or a list of those. + +Features are used as arguments to `eval-after-load'. Numbers are +used as arguments to `run-with-idle-timer'. `t' will ensure BODY +runs after Emacs's init time. + +When given a list of PREREQS, `eval-after' will nest each one +from left to right." + (declare (indent 1) (debug (form def-body))) + (setf prereqs (ensure-list prereqs)) + (if (null prereqs) + (macroexp-progn body) + (let* ((this (car prereqs)) + (form `((lambda () (eval-after ,(cdr prereqs) ,@body))))) + (cond + ((eq this :init) + (append '(eval-after-init) form)) + ((numberp this) + (append `(run-with-idle-timer ,this nil) form)) + ((symbolp this) + (append `(eval-after-load ',this) form)) + (:else (user-error "Eval-after: Bad prereq: %S" this)))))) + + +;;; Easier customization of options +;; At some point it might be nice to include more forms in the VAR slots, like +;; `setup's `:option' macro. + +(if (fboundp 'setopt) + ;; Emacs 29 introduces `setopt', which does basically the same thing as the + ;; macro below. Not exactly the same, of course---it uses `setopt--set' + ;; instead of `customize-set-variable'---but I'm going to trust the Emacs + ;; devs on this one. + (defalias 'setc 'setopt) + (defmacro setc (&rest args) + "Customize user options in a `setq'-like way." + (declare (debug setq)) + (unless (zerop (mod (length args) 2)) + (signal 'wrong-number-of-arguments `(evenp ,(length args)))) + (let (form defuns) + (while args + (let* ((var (pop args)) + (val (pop args))) + (when (memq (car-safe val) '(defun defmacro)) + (push val defuns) + (setq val `(function ,(cadr val)))) + (push `(customize-set-variable ',var ,val "Set by `setc'.") + form))) + `(progn ,@(append (nreverse defuns) (nreverse form)))))) + + +;;; Extra def- forms + +(defmacro defdir (name directory &optional docstring) + "Define a variable and a function NAME expanding to DIRECTORY. +DOCSTRING is applied to the variable; its default is DIRECTORY's +path." + (declare (indent 2) (doc-string 3)) + `(progn + (defvar ,name ,directory + ,(concat (or docstring (format "%s" directory)) "\n" + "Defined by `defdir'.")) + (defun ,name (file &optional mkdir) + ,(concat "Expand FILE relative to variable `" (symbol-name name) "'.\n" + "If MKDIR is non-nil, parent directories are created.\n" + "Defined by `defdir'.") + (let ((file-name (expand-file-name + (convert-standard-filename file) ,name))) + (when mkdir + (make-directory (file-name-directory file-name) :parents)) + file-name)))) + +(defmacro defkeys (maps &rest bindings) + "Define key BINDINGS in MAPS. +If MAPS is nil or t, bind to `current-global-map'. Otherwise, +bind each of BINDINGS to the map or list of maps provided. + +BINDINGS is a `setq'-style list of pairs of keys and definitions. +The key part of each binding can be a string, in which case it's +passed to `kbd', or a vector or anything else `define-key' +accepts in the KEY position. The definition part, likewise, can +be any form `define-key' accepts in that position, with this +addition: if the form is a `defun' form, it will be defined +before any keys are bound." + (declare (indent 1)) + (unless (cl-evenp (length bindings)) + (signal 'wrong-number-of-arguments `(evenp ,(length bindings)))) + `(progn + ,@(cl-loop + for map in (ensure-list maps) + for first-map-p = t then nil + append + (cl-loop + for (keys def) on bindings by #'cddr + for defp = (memq (car-safe def) '(defmap defun defmacro)) + if (and defp first-map-p) collect def into defuns + append + (cl-loop + for key in (ensure-list keys) + collect (list 'define-key + (if (memq map '(t nil)) + '(current-global-map) + (or (car-safe map) map)) + (if (stringp key) + `(kbd ,key) + key) + (if defp + (cl-case (car def) + ((defmap) (cadr def)) + ((defun defmacro) `#',(cadr def)) + (otherwise (error "Bad def type: %S" + (car def)))) + def))) + into keydefs + finally return + (let ((all (append defuns keydefs))) + (if-let ((after (plist-get (cdr-safe map) :after))) + `((eval-after ,after + ,@all)) + all)))))) + +(defmacro defmap (name docstring &rest bindings) + "Define a keymap named NAME, with BINDINGS." + (declare (indent 1) (doc-string 2)) + `(,(if (boundp name) 'setq 'defvar) ,name + ;;; ^ probably a terrible hack + (let ((map (make-sparse-keymap))) + (defkeys map ,@bindings) + map) + ,@(unless (boundp name) (list docstring)))) + +(defmacro defhook (hooks &rest body) + "Define a function to hook into HOOKS. +NAME and ARGS are passed to the generated `defun' form. +Each hook in HOOKS can be the name of a hook or a list of the form +(HOOK DEPTH LOCAL), where each argument is the same as in +`add-hook'." + (declare (indent 1)) + (let* ((name (or (plist-get body :name) + (intern (format "%s/h" + (mapconcat + (lambda (h) + (string-remove-suffix + "-hook" + (if (and (consp h) + (caddr h)) + (format "%s:local" (car h)) + (format "%s" (or (car-safe h) + h))))) + (ensure-list hooks) + "|"))))) + (args (or (plist-get body :args) nil)) + (doc (or (plist-get body :doc) nil)) + (forms ; (DEFUN . FUNCS) + (cl-loop for form in (delete2 body :name :args :doc) + if (eq (car form) 'function) + collect form into funcs + else collect form into defuns + finally return (cons defuns funcs))) + (defun-forms (car forms)) + (func-forms (cdr forms))) + `(progn + ,@(when defun-forms + `((defun ,name ,args ,@(when doc (list doc)) ,@defun-forms))) + ,@(cl-loop for hook in (ensure-list hooks) + for h = (or (car-safe hook) hook) + for ha = (cdr-safe hook) + if defun-forms + collect `(add-hook ',h #',name ,@ha) + append + (cl-loop for fn in func-forms + collect `(add-hook ',h ,fn ,@ha)))))) + +;; (autoload FUNCTION FILE &optional DOCSTRING INTERACTIVE TYPE) +(defmacro defautoload (file &rest fns) + "Autoload FNS from FILE. +Each of FNS can be an atom (function name) or a list of the +form (FUNCTION ARGS), where ARGS is a plist. ARGS's possible +keys are `:doc' (docstring), `:interactive', and `:type', which are +used as the optional arguments to `autoload'. + +You can also pass `:interactive' and `:type' as keyword arguments +just after FILE, and they'll serve as the default for the +autoloaded FNS." + (declare (indent 1)) + (let ((interactive (plist-get fns :interactive)) + (type (plist-get fns :type)) + (fns (delete2 fns :interactive :type))) + `(progn + ,@(cl-loop for fn in fns + for name = (or (car-safe fn) fn) + for args = (cdr-safe fn) + collect + `(autoload ',name ,(format "%s" file) + ,(plist-get args :doc) + ,(or (plist-get args :interactive) + interactive) + ,(or (plist-get args :type) + type)))))) + + +;;; Miscellaneous + +(defmacro with-message (message &rest body) + "Display MESSAGE then execute BODY. +If BODY executes without errors, display MESSAGE...done." + (declare (indent 1)) + (let ((msym (gensym)) + (esym (gensym))) + `(let ((,msym ,message)) + (condition-case ,esym + (progn (message "%s..." ,msym) + ,@body) + (:success (message "%s...done" ,msym)) + (t (signal (car ,esym) (cdr ,esym))))))) + +(defmacro o (&rest fns) + "Compose FNS into a new function for one argument." + (if (null fns) + `(lambda (&rest args) args) + `(lambda (&rest args) + (apply + #',(car fns) + (ensure-list (apply (o ,@(cdr fns)) args)))))) + +(defmacro with-region-or-buffer (&rest funcs) + "Advise FUNCS with `advise-region-or-buffer'." + `(progn + ,@(cl-loop for fn in funcs + collect + `(advice-add ',fn :before #'advise-region-or-buffer)))) + +(defmacro with-region-or-line (&rest funcs) + "Advise FUNCS with `advise-region-or-line'." + `(progn + ,@(cl-loop for fn in funcs + collect + `(advice-add ',fn :before #'advise-region-or-line)))) + +(defmacro with-region-or-to-eol (&rest funcs) + "Advise FUNCS with `advise-region-or-to-eol'." + `(progn + ,@(cl-loop for fn in funcs + collect + `(advice-add ',fn :before #'advise-region-or-to-eol)))) + +(defmacro define-tempo (tag doc &rest elements) + "Define a template and add its tag to MODE's abbrev-table. +TAG, DOC, and ELEMENTS are passed to `tempo-define-template', which see. +ABBREV, if given, is the abbrev string to use for template expansion +under MODE's abbrev-table. If ABBREV isn't given, TAG will be used." + (declare (indent 1)) + (let* ((template (gensym)) + (tag (cond ((stringp tag) tag) + ((symbolp tag) (symbol-name tag)) + (t (user-error "TAG must be a string or symbol: %S" tag)))) + (mode (or (plist-get elements :mode) nil)) + (abbrev (or (plist-get elements :abbrev) tag)) + (taglist (or (plist-get elements :taglist) nil)) + (table (let ((tname (and mode (derived-mode-abbrev-table-name mode)))) + (while (and tname (not (memq tname abbrev-table-name-list))) + (setq tname (and (get mode 'derived-mode-parent) + (derived-mode-abbrev-table-name + (get mode 'derived-mode-parent))))) + (or tname 'global-abbrev-table))) + (elements (delete2 elements :mode :abbrev :taglist))) + `(let ((,template (tempo-define-template ,tag + ',elements + ,(or abbrev tag) + ,doc + ,taglist))) + (define-abbrev ,table ,tag "" ,template :system t) + (put ,template 'no-self-insert t)))) + +(provide 'acdw-macs) +;;; acdw-macs.el ends here -- cgit 1.4.1-21-gabe81