Don't look inside functions

[monnier]

I was idly browsing the buttercup.el code when I bumped into the buttercup--enclosed-expr horror. I don't mean it as a criticism (I've written my share of such hacks in the past), but to point out that it's exactly these kinds of needs which motivated me to develop OClosures.

OClosures are new in Emacs-29, so we can't just replace that code willy-nilly, but the patch below makes buttercup.el use OClosures when available to avoid looking inside functions (and as a bonus it makes it work with bytecompiled functions as well).

diff --git a/.gitignore b/.gitignore
index 17d5c56fc8..9c10b913dc 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,2 +1,6 @@
 *.elc
 /dist
+
+# ELPA-generated files
+/buttercup-autoloads.el
+/buttercup-pkg.el
diff --git a/buttercup-compat.el b/buttercup-compat.el
index 56dbc7998a..9c908bb9f6 100644
--- a/buttercup-compat.el
+++ b/buttercup-compat.el
@@ -1,7 +1,7 @@
-;;; buttercup-compat.el --- Compatibility definitions for buttercup -*-lexical-binding:nil-*-
+;;; buttercup-compat.el --- Compatibility definitions for buttercup  -*- lexical-binding: t; -*-

 ;; Copyright (C) 2015  Jorgen Schaefer
-;; Copyright (C) 2015  Free Software Foundation, Inc.
+;; Copyright (C) 2015-2023  Free Software Foundation, Inc.

 ;; Author: Jorgen Schaefer <contact@jorgenschaefer.de>

@@ -29,31 +29,7 @@

 ;;; Code:

-;;;;;;;;;;;;;;;;;;;;;;
-;;; Introduced in 24.4
-
-(when (not (fboundp 'define-error))
-  (defun define-error (name message &optional parent)
-    "Define NAME as a new error signal.
-MESSAGE is a string that will be output to the echo area if such an error
-is signaled without being caught by a `condition-case'.
-PARENT is either a signal or a list of signals from which it inherits.
-Defaults to `error'."
-    (unless parent (setq parent 'error))
-    (let ((conditions
-           (if (consp parent)
-               (apply #'append
-                      (mapcar (lambda (parent)
-                                (cons parent
-                                      (or (get parent 'error-conditions)
-                                          (error "Unknown signal `%s'" parent))))
-                              parent))
-             (cons parent (get parent 'error-conditions)))))
-      (put name 'error-conditions
-           (delete-dups (copy-sequence (cons name conditions))))
-      (when message (put name 'error-message message)))))
-
-;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;
 ;;; Introduced in 25.1

 (when (not (fboundp 'directory-files-recursively))
@@ -68,7 +44,7 @@ If INCLUDE-DIRECTORIES, also include directories that have matching names."
           ;; also be offered.  We shall suppress them.
           (tramp-mode (and tramp-mode (file-remote-p dir))))
       (dolist (file (sort (file-name-all-completions "" dir)
-                          'string<))
+                          #'string<))
         (unless (member file '("./" "../"))
           (if (directory-name-p file)
               (let* ((leaf (substring file 0 (1- (length file))))
diff --git a/buttercup.el b/buttercup.el
index 34fa11e913..9f5eaf71be 100644
--- a/buttercup.el
+++ b/buttercup.el
@@ -64,8 +64,12 @@
               "Bad test expression"
               'buttercup-internals-error)

+(eval-and-compile
+  (when (fboundp 'oclosure-define)      ;Emacs≥29
+    (oclosure-define buttercup-thunk expr)))
+
 (defun buttercup--enclosed-expr (fun)
-  "Given a zero-arg function FUN, return its unevaluated expression.
+  "Given a `buttercup-thunk', return its unevaluated expression.

 The function MUST be byte-compiled or have one of the following
 forms:
@@ -77,6 +81,9 @@ and the return value will be EXPR, unevaluated. The quoted EXPR
 is useful if EXPR is a macro call, in which case the `quote'
 ensures access to the un-expanded form."
   (cl-assert (functionp fun) t "Expected FUN to be a function")
+  (if (and (fboundp 'buttercup-thunk--p)      ;Emacs≥29
+           (buttercup-thunk--p fun))
+      (buttercup-thunk--expr fun)
   (pcase fun
     ;; This should be the normal case, a closure with unknown enclosed
     ;; variables, empty arglist and a body containing
@@ -95,15 +102,15 @@ ensures access to the un-expanded form."
     (`(lambda nil
         (quote ,expr) (buttercup--mark-stackframe) ,_expanded)
      expr)
-    ;;; This is when FUN has been byte compiled, as when the entire
-    ;;; test file has been byte compiled. Check that it has an empty
-    ;;; arglist, that is all that is possible at this point. The
-    ;;; return value is byte compiled code, not the original
-    ;;; expressions. Also what is possible at this point.
+    ;; This is when FUN has been byte compiled, as when the entire
+    ;; test file has been byte compiled. Check that it has an empty
+    ;; arglist, that is all that is possible at this point. The
+    ;; return value is byte compiled code, not the original
+    ;; expressions. Also what is possible at this point.
     ((and (pred byte-code-function-p) (guard (member (aref fun 0) '(nil 0))))
      (aref fun 1))
     ;; Error
-    (_ (signal 'buttercup-enclosed-expression-error (format "Not a zero-arg one-expression closure: %S" fun)))))
+    (_ (signal 'buttercup-enclosed-expression-error (format "Not a zero-arg one-expression closure: %S" fun))))))

 (defun buttercup--expr-and-value (fun)
   "Given a function, return its quoted expression and value.
@@ -171,11 +178,15 @@ Does not have the IGNORE-MISSING and SPLIT parameters."
 (define-error 'buttercup-pending "Buttercup test is pending" 'buttercup-error-base)

 (defun buttercup--wrap-expr (expr)
-  "Wrap EXPR to be used by `buttercup-expect'."
-  `(lambda ()
-     (quote ,expr)
-     (buttercup--mark-stackframe)
-     ,expr))
+  "Wrap EXPR in a `buttercup-thunk' to be used by `buttercup-expect'."
+  (if (fboundp 'oclosure-lambda)        ;Emacs≥29
+      `(oclosure-lambda (buttercup-thunk (expr ',expr)) ()
+         (buttercup--mark-stackframe)
+         ,expr)
+    `(lambda ()
+       (quote ,expr)
+       (buttercup--mark-stackframe)
+       ,expr)))

 (defmacro expect (arg &optional matcher &rest args)
   "Expect a condition to be true.
@@ -712,7 +723,7 @@ UNEVALUATED-EXPR if it did not raise any signal."
   (setq spy (funcall spy))
   (cl-assert (symbolp spy))
   (setq args (mapcar #'funcall args))
-  (let* ((calls (mapcar 'spy-context-args (spy-calls-all spy))))
+  (let* ((calls (mapcar #'spy-context-args (spy-calls-all spy))))
     (cond
      ((not calls)
       (cons nil
@@ -789,8 +800,10 @@ Return CHILD."
     (cons (buttercup-suite-or-spec-parent suite-or-spec)
           (buttercup-suite-or-spec-parents (buttercup-suite-or-spec-parent suite-or-spec)))))

-(define-obsolete-function-alias 'buttercup-suite-parents 'buttercup-suite-or-spec-parents "emacs-buttercup 1.10")
-(define-obsolete-function-alias 'buttercup-spec-parents 'buttercup-suite-or-spec-parents "emacs-buttercup 1.10")
+(define-obsolete-function-alias 'buttercup-suite-parents
+  #'buttercup-suite-or-spec-parents "emacs-buttercup 1.10")
+(define-obsolete-function-alias 'buttercup-spec-parents
+  #'buttercup-suite-or-spec-parents "emacs-buttercup 1.10")

 (defun buttercup-suites-total-specs-defined (suite-list)
   "Return the number of specs defined in all suites in SUITE-LIST."
@@ -909,7 +922,7 @@ DESCRIPTION when the spec is run. Return SPEC."
 Do not set this globally. It is let-bound by the `describe'
 form.")

-(defmacro describe (description &rest body)
+(defmacro describe (description &rest body) ;;FIXME: Namespace!
   "Describe a test suite.

 DESCRIPTION is a string. BODY is a sequence of instructions,
@@ -962,7 +975,7 @@ is a function containing the body instructions passed to
 ;;;;;;;;;;;;;
 ;;; Specs: it

-(defmacro it (description &rest body)
+(defmacro it (description &rest body) ;;FIXME: Namespace!
   "Define a spec.

 DESCRIPTION is a string. BODY is a sequence of instructions,
@@ -993,7 +1006,7 @@ the created spec object."
 ;;;;;;;;;;;;;;;;;;;;;;
 ;;; Setup and Teardown

-(defmacro before-each (&rest body)
+(defmacro before-each (&rest body) ;;FIXME: Namespace!
   "Run BODY before each spec in the current suite."
   (declare (indent 0) (debug (&define def-body)))
   `(buttercup-before-each (lambda () ,@body)))
@@ -1007,7 +1020,7 @@ FUNCTION is a function containing the body instructions passed to
         (append (buttercup-suite-before-each buttercup--current-suite)
                 (list function))))

-(defmacro after-each (&rest body)
+(defmacro after-each (&rest body) ;;FIXME: Namespace!
   "Run BODY after each spec in the current suite."
   (declare (indent 0) (debug (&define def-body)))
   `(buttercup-after-each (lambda () ,@body)))
@@ -1021,7 +1034,7 @@ FUNCTION is a function containing the body instructions passed to
         (append (buttercup-suite-after-each buttercup--current-suite)
                 (list function))))

-(defmacro before-all (&rest body)
+(defmacro before-all (&rest body) ;;FIXME: Namespace!
   "Run BODY before every spec in the current suite."
   (declare (indent 0) (debug (&define def-body)))
   `(buttercup-before-all (lambda () ,@body)))
@@ -1035,7 +1048,7 @@ FUNCTION is a function containing the body instructions passed to
         (append (buttercup-suite-before-all buttercup--current-suite)
                 (list function))))

-(defmacro after-all (&rest body)
+(defmacro after-all (&rest body) ;;FIXME: Namespace!
   "Run BODY after every spec in the current suite."
   (declare (indent 0) (debug (&define def-body)))
   `(buttercup-after-all (lambda () ,@body)))
@@ -1091,7 +1104,7 @@ FUNCTION is a function containing the body instructions passed to
          (error "Unrecognized form in `xdescribe': `%s'" (pp-to-string form)))
         ))))

-(defmacro xdescribe (description &rest body)
+(defmacro xdescribe (description &rest body) ;;FIXME: Namespace!
   "Like `describe', but mark any specs as disabled.

 DESCRIPTION is a string. BODY is a sequence of instructions,
@@ -1105,7 +1118,7 @@ mainly calls to `describe', `it' and `before-each'."
 ;;;;;;;;;;;;;;;;;;;;;;
 ;;; Pending Specs: xit

-(defmacro xit (description &rest body)
+(defmacro xit (description &rest body) ;;FIXME: Namespace!
   "Like `it', but mark the spec as disabled.

 A disabled spec is not run.
@@ -1350,11 +1363,11 @@ in a `buttercup-with-cleanup' environment.")

 (defun spy-calls-count-returned (spy)
   "Return the number of times SPY has been called successfully so far."
-  (cl-count-if 'spy-context-return-p (spy-calls-all spy)))
+  (cl-count-if #'spy-context-return-p (spy-calls-all spy)))

 (defun spy-calls-count-errors (spy)
   "Return the number of times SPY has been called and thrown errors so far."
-  (cl-count-if 'spy-context-thrown-p (spy-calls-all spy)))
+  (cl-count-if #'spy-context-thrown-p (spy-calls-all spy)))

 (defun spy-calls-args-for (spy index)
   "Return the context of the INDEXth call to SPY."
@@ -1366,7 +1379,7 @@ in a `buttercup-with-cleanup' environment.")

 (defun spy-calls-all-args (spy)
   "Return the arguments for every recorded call to SPY."
-  (mapcar 'spy-context-args (spy-calls-all spy)))
+  (mapcar #'spy-context-args (spy-calls-all spy)))

 (defun spy-calls-most-recent (spy)
   "Return the context of the most recent call to SPY."
@@ -1701,7 +1714,7 @@ Do not change the global value.")
   "Update SUITE-OR-SPEC with the result of calling FUNCTION with ARGS.
 Sets the `status', `failure-description', and `failure-stack' for
 failed and pending specs."
-  (let* ((result (apply 'buttercup--funcall function args))
+  (let* ((result (apply #'buttercup--funcall function args))
          (status (elt result 0))
          (description (elt result 1))
          (stack (elt result 2)))
@@ -1935,7 +1948,7 @@ Colorize parts of the output if COLOR is non-nil."
 FMT and ARGS are passed to `format'."
   (send-string-to-terminal (apply #'format fmt args)))

-(defun buttercup--display-warning (fn type message &optional level buffer-name)
+(defun buttercup--display-warning (fn type message &optional level buffer-name &rest args)
   "Log all warnings to a special buffer while running buttercup specs.

 Emacs' normal display logic for warnings doesn't mix well with
@@ -1955,8 +1968,8 @@ finishes."
       (cl-letf
           ((warning-minimum-level :emergency)
            ((symbol-function 'message) 'ignore))
-        (funcall fn type message level buffer-name))
-    (funcall fn type message level buffer-name)))
+        (apply fn type message level buffer-name args))
+    (apply fn type message level buffer-name args)))

 (advice-add 'display-warning :around #'buttercup--display-warning)

@@ -2008,7 +2021,7 @@ EVENT and ARG are described in `buttercup-reporter'."
                                 (with-current-buffer buf
                                   (let ((inhibit-read-only t))
                                     (goto-char (point-max))
-                                    (insert (apply 'format fmt args))))))
+                                    (insert (apply #'format fmt args))))))
       (unwind-protect
           (let ((buttercup-color))
             (buttercup-reporter-batch event arg))
@@ -2052,7 +2065,7 @@ ARGS according to `debugger'."
                  (unless (eq signal-type 'buttercup-pending)
                    (buttercup--backtrace))))))

-(defalias 'buttercup--mark-stackframe 'ignore
+(defalias 'buttercup--mark-stackframe #'ignore
   "Marker to find where the backtrace start.")

 (defun buttercup--backtrace ()

[alphapapa]

Thanks for sending this, Stefan. (I'm not a maintainer here, but I reported a nasty bug whose fix is relevant here, IIRC.)

You mention this patch on the mailing list here: https://lists.gnu.org/archive/html/emacs-devel/2024-01/msg01178.html IIUC that means that this patch to Buttercup is going to be necessary on Emacs 30+, right?

[monnier]

You mention this patch on the mailing list here: https://lists.gnu.org/archive/html/emacs-devel/2024-01/msg01178.html IIUC that means that this patch to Buttercup is going to be necessary on Emacs 30+, right?

That's possible (it depends on how that discussion goes, and also on whether I finish and cleanup the PoC patch I sent). Also "this patch ... necessary" is not quite correct: some patch would be necessary, but the one I sent is not the only one that would work.

IOW, the motivation for my patch to Buttercup is to make the code cleaner and more robust (including against changes like the one being discussed over at emacs-devel).