branch: scratch/hook-helpers commit e253e03ba5d298d52bb201bdf5b1045d0f9e24ae Author: Ian Dunn <du...@gnu.org> Commit: Ian Dunn <du...@gnu.org>
Implemented new design for anonymous helpers This involved a complete refactoring of hook-helpers.el that users shouldn't notice. Functions are no longer created in the background, but instead lambda functions are used. * hook-helpers-tests.el: Created tests for the new functions and macros. * README.org: Updated documentation. --- hook-helpers.el | 189 +++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 147 insertions(+), 42 deletions(-) diff --git a/hook-helpers.el b/hook-helpers.el index c4b781b..cc793a3 100644 --- a/hook-helpers.el +++ b/hook-helpers.el @@ -1,11 +1,11 @@ -;;; hook-helpers.el --- Functions and macros to help with handling hooks +;;; hook-helpers.el --- Anonymous, modifiable hook functions ;; Copyright (C) 2016 Ian Dunn ;; Author: Ian Dunn <du...@gnu.org> ;; Keywords: development, hooks ;; URL: https://savannah.nongnu.org/projects/hook-helpers-el/ -;; Version: 1.0 +;; Version: 1.1alpha1 ;; Created: 06 May 2016 ;; Modified: 21 May 2016 @@ -32,11 +32,110 @@ ;; The ‘define-hook-helper’ macro is a solution to this. Think of it as an ;; anaphoric ‘add-hook’, but one that can be called many times without risking ;; redundant hook functions. It gives a cleaner look and feel to Emacs -;; configuration files, and could even be used in actual libraries. +;; configuration files. ;;; Code: -(defconst hook-helper--helper-prefix "hook-helper") +(defvar hkhlp--helpers-map nil + "Map of IDs to helpers.") + +(cl-defstruct hook-helper + id function hooks source-file) + +(defun hkhlp-normalize-hook-spec (hook-spec) + "Turns HOOK-SPEC into a list of cons-cells, each one (HOOK . APPEND) + +HOOK is the name of the full variable to use +APPEND is a Boolean" + (cond + ((symbolp hook-spec) + ;; HOOK + (list (cons hook-spec nil))) + ((and (consp hook-spec) + (booleanp (cdr hook-spec))) + ;; (HOOK . APPEND) + (list hook-spec)) + ((listp hook-spec) + ;; List of specs + (apply 'append (mapcar (lambda (spec) (hkhlp-normalize-hook-spec spec)) hook-spec))) + (t + (warn "Unrecognized hook-spec %s" hook-spec)))) + +(defun add-hook-helper (id hook-spec) + "Adds an existing helper ID to HOOK-SPEC." + (let ((normalized-spec (hkhlp-normalize-hook-spec hook-spec)) + (helper (alist-get id hkhlp--helpers-map))) + (pcase-dolist (`(,hook . ,append) normalized-spec) + (add-hook hook (hook-helper-function helper) append) + (cl-pushnew hook (hook-helper-hooks helper) :test 'equal)))) + +(defun remove-hook-helper (id hook-spec) + "Removes the helper ID from each element of HOOK-SPEC." + (let ((normalized-spec (hkhlp-normalize-hook-spec hook-spec)) + (helper (alist-get id hkhlp--helpers-map))) + (pcase-dolist (`(,hook . _) normalized-spec) + (remove-hook hook (hook-helper-function helper)) + (cl-delete hook (hook-helper-hooks helper) :test 'equal)))) + +(cl-defmethod hkhlp-update-helper ((old hook-helper) (new hook-helper)) + "Updates instances of OLD to NEW. + +For each hook HOOK in the original: + + - If HOOK is not in NEW, remove OLD from it + - Else, update OLD to NEW +" + (let* ((old-func (hook-helper-function old)) + (new-func (hook-helper-function new)) + (old-hooks (hook-helper-hooks old)) + (new-hooks (hook-helper-hooks new))) + (dolist (hook old-hooks) + (let ((hook-val (and (boundp hook) (symbol-value hook)))) + (cond + ((not hook-val) nil) + ((member hook new-hooks) + ;; Update the helper in hooks + (when-let ((elt (cl-position old-func hook-val :test 'equal))) + (setf (nth elt hook-val) new-func))) + (t + ;; Delete the helper from the hooks + (cl-delete old-func (symbol-value hook) :test 'equal))))))) + +(defmacro create-hook-helper (id args &optional docstring &rest body) + "Creates a new hook helper ID for the hooks in HOOKS. + +If a hook helper with id ID already exists, it's overridden. All instances of +the helper in its associated hooks are replaced. + +See `hkhlp-normalize-hook-spec' for an explanation of HOOKS. + +\(fn ID ARGS &optional DOCSTRING &keys HOOKS &rest BODY)" + (declare (indent defun) (doc-string 3)) + (when (and docstring (not (stringp docstring))) + ;; Some trickiness, since what appears to be the docstring may really be + ;; the first element of the body. + (push docstring body) + (setq docstring nil)) + ;; Process the key words + (let ((hook-spec nil)) + (while (keywordp (car body)) + (pcase (pop body) + (`:hooks (setq hook-spec (pop body))) + (_ (pop body)))) + `(let* ((id-sym (quote ,id)) + (func (lambda ,args ,docstring ,@body)) + (normalized-hooks (hkhlp-normalize-hook-spec (quote ,hook-spec))) + (source-file ,(or load-file-name buffer-file-name)) + (helper (make-hook-helper :id id-sym + :function func + :source-file source-file + :hooks (mapcar 'car normalized-hooks)))) + ;; Update an old helper + (when-let ((old-helper (alist-get id-sym hkhlp--helpers-map))) + (hkhlp-update-helper old-helper helper)) + (setf (alist-get id-sym hkhlp--helpers-map) helper) + ;; Add to the new hook-spec + (add-hook-helper id-sym (quote ,hook-spec))))) ;;;###autoload (defmacro define-hook-helper (hook args &optional docstring &rest body) @@ -74,22 +173,15 @@ quoted. The keywords are: (`:append (setq append (pop body))) (`:suffix (setq suffix (pop body))) (_ (pop body)))) - (let ((func-sym (intern (format "%s--%s%s" hook-helper--helper-prefix (symbol-name hook) (if name (concat "/" (symbol-name name)) ""))))) - `(progn - (defun ,func-sym ,args - ,(format "Function to run for %s-%s" (symbol-name hook) suffix) - ,@body) - (add-hook (quote ,(intern (concat (symbol-name hook) "-" suffix))) - (function ,func-sym) - ,append))))) - -(cl-defmacro remove-hook-helper (hook &key name (suffix "hook")) - "Remove a hook helper from HOOK-hook. - -NAME and SUFFIX are exactly as in ‘define-hook-helper’, and can -be used to find the exact helper to remove." - (let ((func-sym (intern (format "%s--%s%s" hook-helper--helper-prefix (symbol-name hook) (if name (concat "/" (symbol-name name)) ""))))) - `(remove-hook (quote ,(intern (concat (symbol-name hook) "-" suffix))) (function ,func-sym)))) + (let* ((suffix-string (if (stringp suffix) suffix (symbol-name suffix))) + (hook-name (concat (symbol-name hook) "-" suffix-string)) + (func-sym (intern (format "%s%s" hook-name + (if name (concat "/" (symbol-name name)) "")))) + (hook (intern hook-name))) + `(create-hook-helper ,func-sym ,args + ,docstring + :hooks ((,hook . ,append)) + ,@body)))) ;;;###autoload (defmacro define-hook-function (function args &optional docstring &rest body) @@ -98,27 +190,40 @@ be used to find the exact helper to remove." The hooks to add are specified by the :hooks keyword. This is a simple list of hooks, unquoted, and the new function is added to each one." - (declare (indent defun) (doc-string 3)) - ;; From `define-derived-mode' - (when (and docstring (not (stringp docstring))) - ;; Some trickiness, since what appears to be the docstring may really be - ;; the first element of the body. - (push docstring body) - (setq docstring nil)) - ;; Process the key words - (let ((hooks nil)) - (while (keywordp (car body)) - (pcase (pop body) - ;; Hooks is a keyword to allow it to be specified, without requiring the - ;; docstring. - (`:hooks (setq hooks (pop body))) - (_ (pop body)))) - `(progn - (defun ,function ,args - ,docstring - ,@body) - (dolist (h (quote ,hooks)) - (add-hook h (function ,function)))))) + (declare (indent defun) + (doc-string 3) + (obsolete create-hook-helper "1.1")) + `(create-hook-helper ,function ,args ,docstring ,@body)) + +;; TODO Link to source file +(cl-defmethod hkhlp--pp ((helper hook-helper) indent) + (let* ((func (hook-helper-function helper)) + (pp-string (pp-to-string func)) + (id (hook-helper-id helper)) + (indent-first (min (- indent (length (symbol-name id))) 1)) + (pp-lines (split-string pp-string "\n" t))) + (concat (symbol-name id) (make-string indent-first ?\ ) (car pp-lines) "\n" + (mapconcat + (lambda (str) + (concat (make-string indent ?\ ) + str)) + (cdr pp-lines) + "\n") + "\n"))) + +(defun describe-hook-helpers () + "Describe the currently defined hook helpers." + (interactive) + (let ((hook-alist nil)) + (pcase-dolist (`(_ . ,helper) hkhlp--helpers-map) + (dolist (hook (hook-helper-hooks helper)) + (push helper (alist-get hook hook-alist)))) + (with-output-to-temp-buffer "*Hook Helpers*" + (pcase-dolist (`(,hook . ,helpers) hook-alist) + (princ (format "%s\n%s\n" hook (make-string 40 ?-))) + (dolist (helper helpers) + (princ (hkhlp--pp helper 16))) + (princ "\n"))))) ;; Add font lock for both macros. (font-lock-add-keywords @@ -126,7 +231,7 @@ each one." '(("(\\(define-hook-helper\\)\\_>[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)?" (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) - ("(\\(define-hook-function\\)\\_>[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)?" + ("(\\(create-hook-helper\\)\\_>[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)?" (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))))