From: Morgan Willcock <morgan@ice9.digital>
To: Eli Zaretskii <eliz@gnu.org>
Cc: 73533@debbugs.gnu.org
Subject: bug#73533: [PATCH] Rewrite speedbar expansion for all descendants
Date: Tue, 08 Oct 2024 19:36:06 +0100 [thread overview]
Message-ID: <87ttdm4f3d.fsf@ice9.digital> (raw)
In-Reply-To: <8734lhgfnn.fsf@ice9.digital> (Morgan Willcock's message of "Mon, 30 Sep 2024 19:28:12 +0100")
[-- Attachment #1: Type: text/plain, Size: 954 bytes --]
Attached is a patch for a replacement function and an additional patch
which adds tests for expanding all descendants.
I couldn't see a direct way to test a Speedbar without creating a frame,
and because the Speedbar code doesn't implement any type of hierarchy
itself I've used eieio-speedbar to make something minimal to test.
Each test runs by converting a list of strings into objects which
implement a Speedbar display, making state changes for the functions
being tested, and then converting the objects back into strings - this
was the simplest way I could find to create a reusable interface for
tests. The conversion back to a string is customizable to allow
whatever state change is under test to be represented.
If the tests are problematic or considered too complicated, perhaps they
can just be used to test the current function and the replacement
function and not committed. The current function fails 3/9 tests.
--
Morgan Willcock
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Rewrite-speedbar-expansion-for-all-descendants.patch --]
[-- Type: text/x-diff, Size: 3187 bytes --]
From 50c623de5e4ac3a101a2fa19de97f75132063554 Mon Sep 17 00:00:00 2001
From: Morgan Willcock <morgan@ice9.digital>
Date: Sat, 5 Oct 2024 18:33:51 +0100
Subject: [PATCH 1/2] Rewrite speedbar expansion for all descendants
Rewrite 'speedbar-expand-line-descendants' to avoid getting into
an infinite loop by reaching max-lisp-eval-depth. The new
method avoids querying and displaying information for every
movement, instead using a single message to indicate that
expansion is in progress, and so is significantly faster. The
narrowing per item introduced by the fix for bug#35014 is
removed because it prevented expanded descendant items when the
top-level item was already expanded.
* lisp/speedbar.el (speedbar--get-line-indent-level): New
function to return the indentation level of the current line.
(speedbar-expand-line-descendants): Use simpler line motion and
no recursion. Output messages indicating when expansion is in
progress and when it is completed. Fix expansion of descendants
where the top-level item was already expanded.
---
lisp/speedbar.el | 37 ++++++++++++++++++++++---------------
1 file changed, 22 insertions(+), 15 deletions(-)
diff --git a/lisp/speedbar.el b/lisp/speedbar.el
index c13c977938b..38fb641acf7 100644
--- a/lisp/speedbar.el
+++ b/lisp/speedbar.el
@@ -3168,25 +3168,32 @@ speedbar-toggle-line-expansion
(speedbar-do-function-pointer))
(error (speedbar-position-cursor-on-line))))
+(defun speedbar--get-line-indent-level ()
+ "Return the indentation level of the current line."
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at "[0-9]+:")
+ (string-to-number (match-string 0))
+ 0)))
+
(defun speedbar-expand-line-descendants (&optional arg)
"Expand the line under the cursor and all descendants.
Optional argument ARG indicates that any cache should be flushed."
(interactive "P")
- (save-restriction
- (narrow-to-region (line-beginning-position)
- (line-beginning-position 2))
- (speedbar-expand-line arg)
- ;; Now, inside the area expanded here, expand all subnodes of
- ;; the same descendant type.
- (save-excursion
- (speedbar-next 1) ;; Move into the list.
- (let ((err nil))
- (while (not err)
- (condition-case nil
- (progn
- (speedbar-expand-line-descendants arg)
- (speedbar-restricted-next 1))
- (error (setq err t))))))))
+ (dframe-message "Expanding all descendants...")
+ (save-excursion
+ (let ((top-depth (speedbar--get-line-indent-level)))
+ ;; Attempt to expand the top-level item.
+ (speedbar-expand-line arg)
+ ;; Move forwards, either into the newly expanded list, onto an
+ ;; already expanded list, onto a sibling item, or to the end of
+ ;; the buffer.
+ (while (and (zerop (forward-line 1))
+ (not (eobp))
+ (> (speedbar--get-line-indent-level) top-depth)
+ (speedbar-expand-line arg)))))
+ (dframe-message "Expanding all descendants...done")
+ (speedbar-position-cursor-on-line))
(defun speedbar-contract-line-descendants ()
"Expand the line under the cursor and all descendants."
--
2.39.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-Add-initial-Speedbar-tests.patch --]
[-- Type: text/x-diff, Size: 14736 bytes --]
From eb4c17fbe64542a9877cd16753cda29188c700a0 Mon Sep 17 00:00:00 2001
From: Morgan Willcock <morgan@ice9.digital>
Date: Tue, 8 Oct 2024 17:34:20 +0100
Subject: [PATCH 2/2] Add initial Speedbar tests
Add initial Speedbar tests which test the operation of
'speedbar-expand-line-descendants'.
* test/lisp/speedbar-tests.el (speedbar-tests-container)
(eieio-speedbar-object-children)
(speedbar-tests-item)
(speedbar-tests--make-object)
(speedbar-tests--setup-strings)
(speedbar-tests--object-hierarchy)
(speedbar-tests--base-items)
(speedbar-tests--clean-up)
(speedbar-tests--initialize)
(speedbar-tests--object-name-expanded)
(speedbar-tests--object-name-function)
(speedbar-tests--objects-as-strings)
(speedbar-tests--state-test)
(speedbar-tests--expand-descendants-single)
(speedbar-tests--expand-descendants-nested)
(speedbar-tests--expand-descendants-nested-wide)
(speedbar-tests--expand-descendants-of-first)
(speedbar-tests--expand-descendants-of-first-expanded)
(speedbar-tests--expand-descendants-of-last)
(speedbar-tests--expand-descendants-of-last-expanded)
(speedbar-tests--expand-descendants-of-middle)
(speedbar-tests--expand-descendants-of-middle-expanded):
Test 'speedbar-expand-line-descendants'.
---
test/lisp/speedbar-tests.el | 318 ++++++++++++++++++++++++++++++++++++
1 file changed, 318 insertions(+)
create mode 100644 test/lisp/speedbar-tests.el
diff --git a/test/lisp/speedbar-tests.el b/test/lisp/speedbar-tests.el
new file mode 100644
index 00000000000..5450d211b1a
--- /dev/null
+++ b/test/lisp/speedbar-tests.el
@@ -0,0 +1,318 @@
+;;; speedbar-tests.el --- Tests for speedbar.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'eieio-base)
+(require 'eieio-speedbar)
+
+(defclass speedbar-tests-container (eieio-named eieio-speedbar-file-button)
+ ((child-items :initarg :child-items
+ :type list))
+ "An expandable Speedbar item which can contain other items.")
+
+(cl-defmethod eieio-speedbar-object-children ((item speedbar-tests-container))
+ "Return the list of child items for ITEM."
+ (slot-value item 'child-items))
+
+(defclass speedbar-tests-item (eieio-named eieio-speedbar)
+ nil
+ "A Speedbar item which cannot contain other items.")
+
+(defun speedbar-tests--make-object (item-spec)
+ "Return an object representing a Speedbar item.
+
+The object is constructed based on the specification ITEM-SPEC which
+should be a cons pair of the form (NAME . CHILD-ITEMS). NAME is a
+string which will be used for display purposes. CHILD-ITEMS is a list
+of additional ITEM-SPEC values which will be referenced as children."
+ (let ((name (car item-spec))
+ (child-items (cdr item-spec)))
+ (unless (stringp name)
+ (error "Item name must be a string"))
+ (unless (listp child-items)
+ (error "Child-items must be a list"))
+ (if child-items
+ (speedbar-tests-container
+ :object-name name
+ :child-items (mapcar #'speedbar-tests--make-object
+ child-items))
+ (speedbar-tests-item
+ :object-name name))))
+
+(defvar speedbar-tests--setup-strings nil
+ "An alist of strings which represents a hierarchy of Speedbar items.")
+
+(defvar speedbar-tests--object-hierarchy nil
+ "The current object hierarchy for the Speedbar being tested.")
+
+(defun speedbar-tests--base-items (_directory)
+ "Return the list of top-level objects for the Speedbar."
+ (setq speedbar-tests--object-hierarchy
+ (mapcar #'speedbar-tests--make-object
+ speedbar-tests--setup-strings)))
+
+(eieio-speedbar-create #'eieio-speedbar-make-map
+ 'eieio-speedbar-key-map
+ 'eieio-speedbar-menu
+ "Test"
+ #'speedbar-tests--base-items)
+
+(defun speedbar-tests--clean-up ()
+ "Clean-up after Speedbar test."
+ (when (framep speedbar-frame)
+ (delete-frame speedbar-frame)))
+
+(defun speedbar-tests--initialize ()
+ "Initialize a Speedbar for testing."
+ (speedbar-get-focus)
+ (speedbar-change-initial-expansion-list "Test"))
+
+(defun speedbar-tests--object-name-expanded (object)
+ "Return the string name of OBJECT when it is expanded."
+ (let ((name (eieio-speedbar-object-buttonname object)))
+ (if (slot-value object 'expanded)
+ (concat name "+")
+ name)))
+
+(defvar speedbar-tests--object-name-function
+ #'eieio-speedbar-object-buttonname
+ "The function which returns the string representation of an object.")
+
+(defun speedbar-tests--objects-as-strings (object-list)
+ "Return the object hierarchy OBJECT-LIST as an alist of strings.
+
+The string used to represent the object is determined by the function
+bound to `speedbar-tests--object-name-function' is a function, which
+should accept the object as the only argument and return a string to use
+as the name."
+ (mapcar (lambda (object)
+ (let ((name (funcall speedbar-tests--object-name-function
+ object))
+ (child-items (eieio-speedbar-object-children
+ object)))
+ (cons name (speedbar-tests--objects-as-strings
+ child-items))))
+ object-list))
+
+(cl-defmacro speedbar-tests--state-test
+ ((&optional &key setup final name-function) &rest body)
+ "Evaluate BODY and verify the Speedbar is in an expected state.
+
+`:setup' specifies an alist of strings which will be used to create an
+object hierarchy used for the Speedbar display.
+
+`:final' specifies an alist of strings which should represent the final
+Speedbar state once BODY has been evaluated and the object hierarchy has
+been converted back to an alist of strings. `:name-function' specifies
+the function to use to generate a string from an object, which should
+accept the object as an argument and return a string which represents
+the object as well as its state."
+ (declare (indent 1))
+ (let ((let-vars `((speedbar-tests--setup-strings ',setup))))
+ (when name-function
+ (push `(speedbar-tests--object-name-function #',name-function)
+ let-vars))
+ `(unwind-protect
+ (let ,let-vars
+ (speedbar-tests--initialize)
+ (should (equal (speedbar-tests--objects-as-strings
+ speedbar-tests--object-hierarchy)
+ ',setup))
+ ,@body
+ (should (equal (speedbar-tests--objects-as-strings
+ speedbar-tests--object-hierarchy)
+ ',final)))
+ (speedbar-tests--clean-up))))
+
+(ert-deftest speedbar-tests--expand-descendants-single ()
+ "Expand the first item."
+ (skip-when noninteractive)
+ (speedbar-tests--state-test
+ ( :setup (("A" . (("A1"))))
+ :final (("A+" . (("A1"))))
+ :name-function speedbar-tests--object-name-expanded)
+ (with-current-buffer speedbar-buffer
+ (goto-char (point-min))
+ (should (string-equal "A" (speedbar-line-text)))
+ (speedbar-expand-line-descendants 'nocache))))
+
+(ert-deftest speedbar-tests--expand-descendants-nested ()
+ "Expand the first item and its only child."
+ (skip-when noninteractive)
+ (speedbar-tests--state-test
+ ( :setup (("A" . (("A1" . (("A1A"))))))
+ :final (("A+" . (("A1+" . (("A1A"))))))
+ :name-function speedbar-tests--object-name-expanded)
+ (with-current-buffer speedbar-buffer
+ (goto-char (point-min))
+ (should (string-equal "A" (speedbar-line-text)))
+ (speedbar-expand-line-descendants 'nocache))))
+
+(ert-deftest speedbar-tests--expand-descendants-nested-wide ()
+ "Expand all descendants of first item which has multiple children."
+ (skip-when noninteractive)
+ (speedbar-tests--state-test
+ ( :setup (("A" . (("A1" . (("A1A")))
+ ("A2" . (("A2A"))))))
+ :final (("A+" . (("A1+" . (("A1A")))
+ ("A2+" . (("A2A"))))))
+ :name-function speedbar-tests--object-name-expanded)
+ (with-current-buffer speedbar-buffer
+ (goto-char (point-min))
+ (should (string-equal "A" (speedbar-line-text)))
+ (speedbar-expand-line-descendants 'nocache))))
+
+(ert-deftest speedbar-tests--expand-descendants-of-first ()
+ "Expand the first item and all descendants."
+ (skip-when noninteractive)
+ (speedbar-tests--state-test
+ ( :setup (("A" . (("A1" . (("A1A")))
+ ("A2" . (("A2A")))))
+ ("B" . (("B1" . (("B1B")))
+ ("B2" . (("B2B"))))))
+ :final (("A+" . (("A1+" . (("A1A")))
+ ("A2+" . (("A2A")))))
+ ("B" . (("B1" . (("B1B")))
+ ("B2" . (("B2B"))))))
+ :name-function speedbar-tests--object-name-expanded)
+ (with-current-buffer speedbar-buffer
+ (goto-char (point-min))
+ (should (string-equal "A" (speedbar-line-text)))
+ (speedbar-expand-line-descendants 'nocache))))
+
+(ert-deftest speedbar-tests--expand-descendants-of-first-expanded ()
+ "Expand the already expanded first item and all descendants."
+ (skip-when noninteractive)
+ (speedbar-tests--state-test
+ ( :setup (("A" . (("A1" . (("A1A")))
+ ("A2" . (("A2A")))))
+ ("B" . (("B1" . (("B1B")))
+ ("B2" . (("B2B"))))))
+ :final (("A+" . (("A1+" . (("A1A")))
+ ("A2+" . (("A2A")))))
+ ("B" . (("B1" . (("B1B")))
+ ("B2" . (("B2B"))))))
+ :name-function speedbar-tests--object-name-expanded)
+ (with-current-buffer speedbar-buffer
+ (goto-char (point-min))
+ (should (string-equal "A" (speedbar-line-text)))
+ (speedbar-expand-line 'nocache)
+ (speedbar-expand-line-descendants 'nocache))))
+
+(ert-deftest speedbar-tests--expand-descendants-of-last ()
+ "Expand the last item and all descendants."
+ (skip-when noninteractive)
+ (speedbar-tests--state-test
+ ( :setup (("A" . (("A1" . (("A1A")))
+ ("A2" . (("A2A")))))
+ ("B" . (("B1" . (("B1B")))
+ ("B2" . (("B2B"))))))
+ :final (("A" . (("A1" . (("A1A")))
+ ("A2" . (("A2A")))))
+ ("B+" . (("B1+" . (("B1B")))
+ ("B2+" . (("B2B"))))))
+ :name-function speedbar-tests--object-name-expanded)
+ (with-current-buffer speedbar-buffer
+ (goto-char (point-min))
+ (forward-line)
+ (should (string-equal "B" (speedbar-line-text)))
+ (speedbar-expand-line-descendants 'nocache))))
+
+(ert-deftest speedbar-tests--expand-descendants-of-last-expanded ()
+ "Expand the already expanded last item and all descendants."
+ (skip-when noninteractive)
+ (speedbar-tests--state-test
+ ( :setup (("A" . (("A1" . (("A1A")))
+ ("A2" . (("A2A")))))
+ ("B" . (("B1" . (("B1B")))
+ ("B2" . (("B2B"))))))
+ :final (("A" . (("A1" . (("A1A")))
+ ("A2" . (("A2A")))))
+ ("B+" . (("B1+" . (("B1B")))
+ ("B2+" . (("B2B"))))))
+ :name-function speedbar-tests--object-name-expanded)
+ (with-current-buffer speedbar-buffer
+ (goto-char (point-min))
+ (save-excursion
+ (forward-line)
+ (should (string-equal "B" (speedbar-line-text)))
+ (speedbar-expand-line 'nocache))
+ (save-excursion
+ (forward-line)
+ (should (string-equal "B" (speedbar-line-text)))
+ (speedbar-expand-line-descendants 'nocache)))))
+
+(ert-deftest speedbar-tests--expand-descendants-of-middle ()
+ "Expand the middle item and all descendants."
+ (skip-when noninteractive)
+ (speedbar-tests--state-test
+ ( :setup (("A" . (("A1" . (("A1A")))
+ ("A2" . (("A2A")))))
+ ("B" . (("B1" . (("B1B")))
+ ("B2" . (("B2B")))))
+ ("C" . (("C1" . (("C1C")))
+ ("C2" . (("C2C"))))))
+ :final (("A" . (("A1" . (("A1A")))
+ ("A2" . (("A2A")))))
+ ("B+" . (("B1+" . (("B1B")))
+ ("B2+" . (("B2B")))))
+ ("C" . (("C1" . (("C1C")))
+ ("C2" . (("C2C"))))))
+ :name-function speedbar-tests--object-name-expanded)
+ (with-current-buffer speedbar-buffer
+ (goto-char (point-min))
+ (goto-char (point-min))
+ (forward-line)
+ (should (string-equal "B" (speedbar-line-text)))
+ (speedbar-expand-line-descendants 'nocache))))
+
+(ert-deftest speedbar-tests--expand-descendants-of-middle-expanded ()
+ "Expand the already expanded middle item and all descendants."
+ (skip-when noninteractive)
+ (speedbar-tests--state-test
+ ( :setup (("A" . (("A1" . (("A1A")))
+ ("A2" . (("A2A")))))
+ ("B" . (("B1" . (("B1B")))
+ ("B2" . (("B2B")))))
+ ("C" . (("C1" . (("C1C")))
+ ("C2" . (("C2C"))))))
+ :final (("A" . (("A1" . (("A1A")))
+ ("A2" . (("A2A")))))
+ ("B+" . (("B1+" . (("B1B")))
+ ("B2+" . (("B2B")))))
+ ("C" . (("C1" . (("C1C")))
+ ("C2" . (("C2C"))))))
+ :name-function speedbar-tests--object-name-expanded)
+ (with-current-buffer speedbar-buffer
+ (goto-char (point-min))
+ (save-excursion
+ (forward-line)
+ (should (string-equal "B" (speedbar-line-text)))
+ (speedbar-expand-line 'nocache))
+ (save-excursion
+ (forward-line)
+ (should (string-equal "B" (speedbar-line-text)))
+ (speedbar-expand-line-descendants 'nocache)))))
+
+(provide 'speedbar-tests)
+;;; speedbar-tests.el ends here
--
2.39.5
next prev parent reply other threads:[~2024-10-08 18:36 UTC|newest]
Thread overview: 9+ messages / expand[flat|nested] mbox.gz Atom feed top
2024-09-28 19:05 bug#73533: [PATCH] Rewrite speedbar expansion for all descendants Morgan Willcock
2024-09-29 4:46 ` Eli Zaretskii
2024-09-29 9:52 ` Morgan Willcock
2024-09-30 9:03 ` Morgan Willcock
2024-09-30 18:28 ` Morgan Willcock
2024-10-08 18:36 ` Morgan Willcock [this message]
2024-10-19 7:42 ` Eli Zaretskii
2024-10-19 17:30 ` Morgan Willcock
2024-10-19 17:41 ` Eli Zaretskii
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87ttdm4f3d.fsf@ice9.digital \
--to=morgan@ice9.digital \
--cc=73533@debbugs.gnu.org \
--cc=eliz@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).