From eb4c17fbe64542a9877cd16753cda29188c700a0 Mon Sep 17 00:00:00 2001 From: Morgan Willcock 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 . + +;;; 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