[ELPA] A Setup package

[Philip K.]

Hi,

I would like to propose adding a package to ELPA:

;;; setup.el --- Helpful Configuration Macro    -*- lexical-binding: t -*-

;; Author: Philip K. <philipk@posteo.net>
;; Maintainer: Philip K. <philipk@posteo.net>
;; Version: 0.1.0
;; Package-Requires: ((emacs "25.1"))
;; Keywords: lisp, local

;; This file is NOT part of Emacs.
;;
;; This file is in the public domain, to the extent possible under law,
;; published under the CC0 1.0 Universal license.
;;
;; For a full copy of the CC0 license see
;; https://creativecommons.org/publicdomain/zero/1.0/legalcode

;;; Commentary:

;; The `setup' macro simplifies repetitive configuration patterns.
;; For example, these macros:

;;     (setup shell
;;       (let ((key "C-c s"))
;;         (global (key shell))
;;         (bind (key bury-buffer))))
;;
;;
;;     (setup (package paredit)
;;       (hide-lighter)
;;       (hook-into scheme-mode lisp-mode))

;; will be replaced with the functional equivalent of

;;     (global-set-key (kbd "C-c s") #'shell)
;;     (with-eval-after-load 'shell
;;        (define-key shell-mode-map (kbd "C-c s") #'bury-buffer))
;;
;;
;;     (unless (package-install-p 'paredit)
;;       (package-install 'paredit ))
;;     (delq (assq 'paredit-mode minor-mode-alist)
;;           minor-mode-alist)
;;     (add-hook 'scheme-mode-hook #'paredit-mode)
;;     (add-hook 'lisp-mode-hook #'paredit-mode)

;; Additional "keywords" can be defined using `setup-define'.

;;; Code:

(eval-when-compile (require 'cl-macs))


;;; `setup' macros

(defvar setup-macros nil
  "Local macro definitions to be bound in `setup' bodies.")

(defun setup-after-load (body)
  "Wrap BODY in a `with-eval-after-load'."
  ``(with-eval-after-load setup-name ,,body))

;;;###autoload
(defmacro setup (&rest body)
  "Configure a feature or subsystem.
BODY may contain special forms defined by `setup-define', but
will otherwise just be evaluated as is."
  (declare (indent defun))
  (let* ((name (if (and (listp (car body))
                        (get (caar body) 'setup-get-name))
                   (funcall (get (caar body) 'setup-get-name)
                            (car body))
                 (car body)))
         (mode (if (string-match-p "-mode\\'" (symbol-name name))
                   name
                 (intern (format "%s-mode" name)))))
    (when (symbolp (car body))
      (pop body))
    `(let ((setup-name ',name)
           (setup-mode ',mode)          ;best guess
           (setup-map ',(intern (format "%s-map" mode)))
          (setup-hook ',(intern (format "%s-hook" mode))))
       (ignore setup-name setup-mode setup-map setup-hook)
       (catch 'setup-exit
         (cl-macrolet ,setup-macros
           ,@body)))))

;;;###autoload
(defun setup-define (name fn &rest opts)
  "Define `setup'-local macro NAME using function FN.
The plist OPTS may contain the key-value pairs:

  :name
Specify a function to use, for extracting the feature name of a
NAME entry, if it is the first element in a setup macro.

  :indent
Set the symbol property `lisp-indent-function' for NAME.

  :wrap
Specify a function used to wrap the results of a NAME entry.

  :sig
Give an advertised calling convention.

  :doc
A documentation string."
  (declare (indent 1))
  (cl-assert (symbolp name))
  (cl-assert (functionp fn))
  (cl-assert (listp opts))
  ;; save metadata
  (put name 'setup-get-name (plist-get opts :name))
  (put name 'setup-documentation (plist-get opts :doc))
  (put name 'setup-signature (plist-get opts :sig))
  (put name 'lisp-indent-function (plist-get opts :indent))
  ;; forget previous definition
  (setq setup-macros (delq (assq name setup-macros)
                           setup-macros))
  ;; define macro for `cl-macrolet'
  (push (let ((arity (func-arity fn)))
          (cl-flet ((wrap (result)
                          (if (plist-get opts :wrap)
                              (funcall (plist-get opts :wrap) result)
                            result)))
            (cond ((eq (cdr arity) 'many)
                   `(,name (&rest args) ,(wrap `(apply #',fn args))))
                  ((eq (cdr arity) 0)
                   `(,name () ,(wrap `(funcall #',fn))))
                  ((= (car arity) (cdr arity))
                   `(,name (&rest args)
                           (unless (zerop (mod (length args) ,(car arity)))
                             (error "Illegal arguments"))
                           (let ((aggr (list 'progn)))
                             (while args
                               (let ((rest (nthcdr ,(car arity) args)))
                                 (setf (nthcdr ,(car arity) args) nil)
                                 (push (apply #',fn args) aggr)
                                 (setq args rest)))
                             ,(wrap `(nreverse aggr)))))
                  ((error "Illegal function")))))
        setup-macros)
  (set-advertised-calling-convention name (plist-get opts :sig) nil))

(defun setup-help ()
  "Generate and display a help buffer for the `setup' macro."
  (interactive)
  (with-help-window (help-buffer)
    (princ "The `setup' macro defines the following local macros:\n\n")
    (dolist (sym (mapcar #'car setup-macros))
      (let ((doc (or (get sym 'setup-documentation)
                     "No documentation."))
            (sig (if (get sym 'setup-signature)
                     (cons sym (get sym 'setup-signature))
                   (list sym))))
        (princ (format "- %s\n\n%s\n\n" sig doc))))))


;;; definitions of `setup' keywords

(setup-define 'with-mode
  (lambda (mode &rest body)
    `(let ((setup-mode ',mode)
           (setup-map ',(intern (format "%s-map" mode)))
           (setup-hook ',(intern (format "%s-hook" mode))))
       (ignore setup-mode setup-map setup-hook)
       ,@body))
  :sig '(MODE &body BODY)
  :doc "Change the MODE that BODY is configuring."
  :indent 1)

(setup-define 'with-map
  (lambda (map &rest body)
    `(let ((setup-map ',map))
       ,@body))
  :sig '(MAP &body BODY)
  :doc "Change the MAP that BODY will bind to"
  :indent 1)

(setup-define 'with-hook
  (lambda (hook &body body)
    `(let ((setup-hook ',hook))
       ,@body))
  :sig '(HOOK &body BODY)
  :doc "Change the HOOK that BODY will use."
  :indent 1)

(setup-define 'package
  (lambda (package)
    `(unless (package-installed-p ',package)
       (package-install ',package)))
  :sig '(PACKAGE *)
  :doc "Install PACKAGE if it hasn't been installed yet."
  :name #'cadr)

(setup-define 'global
  (lambda (bind)
    (let ((key (car bind))
          (fn (cadr bind)))
      `(global-set-key ,(if (atom key) `(kbd ,key) key) #',fn)))
  :sig '((KEY FUNCTION)*)
  :doc "Globally bind KEY to FUNCTION.
If KEY is an atom, the function `kbd' will be applied.")

(setup-define 'bind
  (lambda (bind)
    (let ((key (car bind))
          (fn (cadr bind)))
      `(define-key (eval setup-map) ,(if (atom key) `(kbd ,key) key) #',fn)))
  :sig '((KEY FUNCTION)*)
  :doc "Bind KEY to FUNCTION in current map.
If KEY is an atom, the function `kbd' will be applied."
  :wrap #'setup-after-load)

(setup-define 'unbind
  (lambda (key)
    `(define-key (eval setup-map) ,(if (atom key) `(kbd ,key) key) nil))
  :sig '(KEY *)
  :doc "Unbind KEY in current map.
If KEY is an atom, the function `kbd' will be applied."
  :wrap #'setup-after-load)

(setup-define 'hook
  (lambda (hook)
    `(add-hook setup-hook #',hook))
  :sig '(FUNCTION *)
  :doc "Add FUNCTION to current hook.")

(setup-define 'hook-into
  (lambda (mode)
    `(add-hook ',(intern (concat (symbol-name mode) "-hook"))
               setup-mode))
  :sig '(HOOK *)
  :doc "Add current mode to HOOK.")

(setup-define 'option
  (lambda (assign)
    (let ((opt (car assign))
          (val (cadr assign)))
      `(progn
         (customize-set-variable ',opt ,val)
         (put ',opt 'saved-value nil))))
  :sig '((NAME VAL) *)
  :doc "Set the option NAME to VAL.")

(setup-define 'hide-lighter
  (lambda ()
    `(delq (assq setup-mode minor-mode-alist)
           minor-mode-alist))
  :doc "Hide the mode-line lighter of the current mode."
  :body 'after-load)

(setup-define 'local-set
  (lambda (assign)
    (let ((var (car assign))
          (val (cadr assign)))
      `(add-hook setup-hook (lambda () (setq-local ,var ,val)))))
  :sig '((VAR VAL) *)
  :doc "Set the value of VAR to VAL in buffers of the current mode."
  :wrap #'setup-after-load)

(setup-define 'local-hook
  (lambda (entry)
    (let ((hook (car entry))
          (fn (cadr entry)))
      `(add-hook setup-hook
                 (lambda ()
                   (add-hook ,hook #',fn nil t)))))
  :sig '((HOOK FUNCTION) *)
  :doc "Add FUNCTION to HOOK only in buffers of the current mode.")

(setup-define 'needs
  (lambda (binary)
    `(unless (executable-find ,binary)
       (throw 'setup-exit nil)))
  :sig '(PROGRAM *)
  :doc "If PROGRAM is not in the path, stop here.")

(setup-define 'require
  (lambda (feature) `(require ,feature))
  :sig '(FEATURE)
  :doc "Require FEATURE to be loaded."
  :name #'cadr)

(setup-define 'when-loaded
  (lambda (&rest body) `(progn ,@body))
  :sig '(&body BODY)
  :doc "Evaluate BODY after the current feature has been loaded."
  :wrap #'setup-after-load)

(provide 'setup)

;;; setup.el ends here

This can be compared to use-package. The difference is that instead of
the keyword-argument structure, it uses local macros that allow
interleaving regular lisp with the configuration syntax. In this sense,
it /might/ be compared to Common Lisp's Loop[0] and Iterate[1] control
structures.

I'll just quote an example from the commentary section to demonstrate
how this looks like:

        The `setup' macro simplifies repetitive configuration patterns.
        For example, these macros:

            (setup shell
              (let ((key "C-c s"))
                (global (key shell))
                (bind (key bury-buffer))))

            (setup (package paredit)
              (hide-lighter)
              (hook-into scheme-mode lisp-mode))

        will be replaced with the functional equivalent of

            (global-set-key (kbd "C-c s") #'shell)
            (with-eval-after-load 'shell
               (define-key shell-mode-map (kbd "C-c s") #'bury-buffer))

            (unless (package-install-p 'paredit)
              (package-install 'paredit ))
            (delq (assq 'paredit-mode minor-mode-alist)
                  minor-mode-alist)
            (add-hook 'scheme-mode-hook #'paredit-mode)
            (add-hook 'lisp-mode-hook #'paredit-mode)


If there are any comments/improvements on the code itself, I'd be glad
to fix them. I am the only author, so there should be no copyright
issues.

[0] http://www.lispworks.com/documentation/HyperSpec/Body/m_loop.htm
[1] https://common-lisp.net/project/iterate/doc/Don_0027t-Loop-Iterate.html

-- 
        Philip K.