[elpa] scratch/hook-helpers e253e03 11/19: Implemented new design for anonymous helpers

[Ian Dunn]

branch: scratch/hook-helpers
commit e253e03ba5d298d52bb201bdf5b1045d0f9e24ae
Author: Ian Dunn <address@hidden>
Commit: Ian Dunn <address@hidden>

    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 <address@hidden>
 ;; 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))))