From d13816ce3ed0dea7e1c3b4871100d14c6e68fd86 Mon Sep 17 00:00:00 2001
From: Henrik Lissner <henrik@lissner.net>
Date: Fri, 1 Oct 2021 19:07:37 +0200
Subject: [PATCH] feat(lib): extend function deftypes in letf! macro

This adds support for two new definition types to the left! convenience
macro: defun* and defadvice.

First, defun* is for defining recursive, local functions (uses
cl-labels under the hood). e.g.

  (letf! (defun* triangle (number)
           (cond ((<= number 0) 0)
                 ((= number 1) 1)
                 ((> number 1)
                  (+ number (triangle (1- number))))))
    ...)

Second, defadvice is for defining temporary advice (which has a global
effect; it can later be improved to limit scope by redefining things
with cl-letf). e.g.

  (letf! (defadvice my-fixed-triangle (fn number)
           :around #'triangle
           (funcall fn (1+ number)))
    ...)
---
 core/core-lib.el | 44 +++++++++++++++++++++++++++++---------------
 1 file changed, 29 insertions(+), 15 deletions(-)

diff --git a/core/core-lib.el b/core/core-lib.el
index aa4fd8e84..f5ff7ac4e 100644
--- a/core/core-lib.el
+++ b/core/core-lib.el
@@ -140,33 +140,47 @@ at the values with which this function was called."
      ,@body))
 
 (defmacro letf! (bindings &rest body)
-  "Temporarily rebind function and macros in BODY.
-Intended as a simpler version of `cl-letf' and `cl-macrolet'.
+  "Temporarily rebind function, macros, and advice in BODY.
 
-BINDINGS is either a) a list of, or a single, `defun' or `defmacro'-ish form, or
-b) a list of (PLACE VALUE) bindings as `cl-letf*' would accept.
+Intended as syntax sugar for `cl-letf', `cl-labels', `cl-macrolet', and
+temporary advice.
 
-TYPE is either `defun' or `defmacro'. NAME is the name of the function. If an
-original definition for NAME exists, it can be accessed as a lexical variable by
-the same name, for use with `funcall' or `apply'. ARGLIST and BODY are as in
-`defun'.
+BINDINGS is either:
+
+  A list of, or a single, `defun', `defun*', `defmacro', or `defadvice' forms.
+  A list of (PLACE VALUE) bindings as `cl-letf*' would accept.
+
+TYPE is one of:
+
+  `defun' (uses `cl-letf')
+  `defun*' (uses `cl-labels'; allows recursive references),
+  `defmacro' (uses `cl-macrolet')
+  `defadvice' (uses `defadvice!' before BODY, then `undefadvice!' after)
+
+NAME, ARGLIST, and BODY are the same as `defun', `defun*', `defmacro', and
+`defadvice!', respectively.
 
 \(fn ((TYPE NAME ARGLIST &rest BODY) ...) BODY...)"
   (declare (indent defun))
   (setq body (macroexp-progn body))
-  (when (memq (car bindings) '(defun defmacro))
+  (when (memq (car bindings) '(defun defun* defmacro defadvice))
     (setq bindings (list bindings)))
-  (dolist (binding (reverse bindings) (macroexpand body))
+  (dolist (binding (reverse bindings) body)
     (let ((type (car binding))
           (rest (cdr binding)))
       (setq
        body (pcase type
               (`defmacro `(cl-macrolet ((,@rest)) ,body))
-              (`defun `(cl-letf* ((,(car rest) (symbol-function #',(car rest)))
-                                  ((symbol-function #',(car rest))
-                                   (lambda ,(cadr rest) ,@(cddr rest))))
-                         (ignore ,(car rest))
-                         ,body))
+              (`defadvice `(progn (defadvice! ,@rest)
+                                  (unwind-protect ,body (undefadvice! ,@rest))))
+              ((or `defun `defun*)
+               `(cl-letf ((,(car rest) (symbol-function #',(car rest))))
+                  (ignore ,(car rest))
+                  ,(if (eq type 'defun*)
+                       `(cl-labels ((,@rest)) ,body)
+                     `(cl-letf (((symbol-function #',(car rest))
+                                 (fn! ,(cadr rest) ,@(cddr rest))))
+                        ,body))))
               (_
                (when (eq (car-safe type) 'function)
                  (setq type (list 'symbol-function type)))