path: root/lisp/acdw-macs.el

;;; 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