1 files changed, 0 insertions, 293 deletions

@@ -1,293 +0,0 @@
-;;; 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