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