1 files changed, 142 insertions, 0 deletions

@@ -0,0 +1,142 @@
+;;; def.el --- defining macros  -*- lexical-binding: t; -*-
+
+;;; Code:
+
+(require 'cl-lib)
+
+;;; Utility
+
+(defun def--assert-args (pred args &optional error-type &rest error-args)
+  "Assert that ARGS follows PRED.
+If it doesn't, raise an error.  ERROR-TYPE will be the type of
+that error (defaults to `user-error'), and it and ERROR-ARGS are
+passed in a list to `signal'."
+  (unless (funcall pred args)
+    (funcall #'signal
+             (or error-type 'user-error)
+             (or error-args
+                 (list "Wrong arguments" args)))))
+
+(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))))))
+
+;; TODO: I need to figure out where this function goes.
+(defun def--delete2 (list &rest elems)
+  "Delete each element of ELEMS, and the next item, from LIST."
+  (let ((r nil))
+    (while (consp list)
+      (if (member (car list) elems)
+          (setf list (cdr list))
+        (setf r (cons (car list) r)))
+      (setf list (cdr list)))
+    (reverse r)))
+
+;;; Keybindings
+
+(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))
+  (def--assert-args (o cl-evenp length) bindings
+    'wrong-number-of-arguments 'defkeys '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))))
+
+;;; Hooks
+
+(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" (symbol-name (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 (def--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))))))
+
+(provide 'def)
+;;; def.el ends here