diff options
| -rw-r--r-- | etc/NEWS | 8 | ||||
| -rw-r--r-- | lisp/emacs-lisp/hierarchy.el | 85 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/hierarchy-tests.el | 143 |
3 files changed, 218 insertions, 18 deletions
@@ -2664,6 +2664,14 @@ commands with a warning face as you type. *** New user option 'calc-kill-line-numbering'. Set it to nil to exclude line numbering from kills and copies. +** Hierarchy + ++++ +*** Tree Display can delay computation of children. +'hierarchy-add-tree' and 'hierarchy-add-trees' have an optional +argument which allows tree-widget display to be activated and computed +only when the user expands the node. + ** Miscellaneous --- diff --git a/lisp/emacs-lisp/hierarchy.el b/lisp/emacs-lisp/hierarchy.el index 6c95d86b47e..4cb5ba64a8d 100644 --- a/lisp/emacs-lisp/hierarchy.el +++ b/lisp/emacs-lisp/hierarchy.el @@ -71,7 +71,8 @@ (:conc-name hierarchy--)) (roots (list)) ; list of the hierarchy roots (no parent) (parents (make-hash-table :test 'equal)) ; map an item to its parent - (children (make-hash-table :test 'equal)) ; map an item to its childre + (children (make-hash-table :test 'equal)) ; map an item to its children + (delaying-parents (make-hash-table :test 'equal)) ; map an item to its childrenfn ;; cache containing the set of all items in the hierarchy (seen-items (make-hash-table :test 'equal))) ; map an item to t @@ -133,7 +134,8 @@ keys are :key and :test." "Create a hierarchy and return it." (hierarchy--make)) -(defun hierarchy-add-tree (hierarchy item parentfn &optional childrenfn acceptfn) +(defun hierarchy-add-tree (hierarchy item parentfn + &optional childrenfn acceptfn delay-children-p) "In HIERARCHY, add ITEM. PARENTFN is either nil or a function defining the child-to-parent @@ -151,27 +153,39 @@ CHILDRENFN are expected to be coherent with each other. ACCEPTFN is a function returning non-nil if its parameter (any object) should be an item of the hierarchy. By default, ACCEPTFN returns non-nil -if its parameter is non-nil." +if its parameter is non-nil. + +DELAY-CHILDREN-P is a predicate determining whether the children that would +normally be processed by CHILDRENFN should, instead, have their processing be +delayed and stored to be processed by CHILDRENFN when the child is selected +during use of the hierarchy." (unless (hierarchy-has-item hierarchy item) (let ((acceptfn (or acceptfn #'identity))) (hierarchy--seen-items-add hierarchy item) (let ((parent (and parentfn (funcall parentfn item)))) (when (funcall acceptfn parent) (hierarchy--add-relation hierarchy item parent acceptfn) - (hierarchy-add-tree hierarchy parent parentfn childrenfn))) - (let ((children (and childrenfn (funcall childrenfn item)))) - (mapc (lambda (child) - (when (funcall acceptfn child) - (hierarchy--add-relation hierarchy child item acceptfn) - (hierarchy-add-tree hierarchy child parentfn childrenfn))) - children))))) - -(defun hierarchy-add-trees (hierarchy items parentfn &optional childrenfn acceptfn) + (hierarchy-add-tree hierarchy parent + parentfn (if delay-children-p nil childrenfn)))) + (if (and childrenfn delay-children-p) + (map-put! (hierarchy--delaying-parents hierarchy) item childrenfn) + (let ((children (and childrenfn (funcall childrenfn item)))) + (map-put! (hierarchy--delaying-parents hierarchy) item nil) + (mapc (lambda (child) + (when (funcall acceptfn child) + (hierarchy--add-relation hierarchy child item acceptfn) + (hierarchy-add-tree hierarchy child parentfn childrenfn))) + children)))))) + +(defun hierarchy-add-trees (hierarchy items parentfn + &optional childrenfn acceptfn delay-children-p) "Call `hierarchy-add-tree' on HIERARCHY and each element of ITEMS. -PARENTFN, CHILDRENFN and ACCEPTFN have the same meaning as in `hierarchy-add'." +PARENTFN, CHILDRENFN, ACCEPTFN, and DELAY-CHILDREN-P have the same meaning as in +`hierarchy-add'." (seq-map (lambda (item) - (hierarchy-add-tree hierarchy item parentfn childrenfn acceptfn)) + (hierarchy-add-tree hierarchy item parentfn + childrenfn acceptfn delay-children-p)) items)) (defun hierarchy-add-list (hierarchy list &optional wrap childrenfn) @@ -541,6 +555,30 @@ nil. The buffer is returned." buffer)) (declare-function widget-convert "wid-edit") +(defun hierarchy--create-delayed-tree-widget (elem labelfn indent childrenfn) + "Return a list of tree-widgets for the children generated. + +ELEM is the element of the hierarchy passed from +`hierarchy-convert-to-tree-widget'; it and the CHILDRENFN are used to generate +the children of the element dynamically. + +LABELFN is the same function passed to `hierarchy-convert-to-tree-widget'. + +INDENT is the same function passed to `hierarchy-convert-to-tree-widget'. + +CHILDRENFN is the function used to discover the children of ELEM." + (lambda (widget) + (mapcar + (lambda (item) + (widget-convert + 'tree-widget + :tag (hierarchy-labelfn-to-string labelfn item indent) + :expander (hierarchy--create-delayed-tree-widget + item + labelfn + (1+ indent) + childrenfn))) + (funcall childrenfn elem)))) (defun hierarchy-convert-to-tree-widget (hierarchy labelfn) "Return a tree-widget for HIERARCHY. @@ -550,10 +588,21 @@ node label." (require 'wid-edit) (require 'tree-widget) (hierarchy-map-tree (lambda (item indent children) - (widget-convert - 'tree-widget - :tag (hierarchy-labelfn-to-string labelfn item indent) - :args children)) + (let ((childrenfn (map-elt + (hierarchy--delaying-parents hierarchy) + item))) + (apply + #'widget-convert + (list 'tree-widget + :tag (hierarchy-labelfn-to-string labelfn item indent) + (if childrenfn :expander :args) + (if childrenfn + (hierarchy--create-delayed-tree-widget + item + labelfn + (1+ indent) + childrenfn) + children))))) hierarchy)) (defun hierarchy-tree-display (hierarchy labelfn &optional buffer) diff --git a/test/lisp/emacs-lisp/hierarchy-tests.el b/test/lisp/emacs-lisp/hierarchy-tests.el index 41d3f2f3ccf..d83460a2baa 100644 --- a/test/lisp/emacs-lisp/hierarchy-tests.el +++ b/test/lisp/emacs-lisp/hierarchy-tests.el @@ -552,5 +552,148 @@ (hierarchy-sort organisms) (should (equal (hierarchy-roots organisms) '(animal plant))))) +(defun hierarchy-examples-delayed--find-number (num) + "Find a number, NUM, by adding 1s together until you reach it. +This is entire contrived and mostly meant to be purposefully inefficient to +not be possible on a large scale. +Running the number 200 causes this function to crash; running this function in +`hierarchy-add-tree' with a root of 80 and no delayed children causes that to + crash. +If generating hierarchy children is not delayed, tests for that functionality +should fail as this function will crash." + + (funcall (lambda (funct) (funcall funct 1 funct)) + (lambda (n funct) + (if (< n num) + (+ 1 (funcall funct (+ 1 n) funct)) + 1)))) + +(defun hierarchy-examples-delayed--childrenfn (hier-elem) + "Return the children of HIER-ELEM. +Basially, feed the number, minus 1, to `hierarchy-examples-delayed--find-number' +and then create a list of the number plus 0.0–0.9." + + (when (> hier-elem 1) + (let ((next (hierarchy-examples-delayed--find-number (1- hier-elem)))) + (mapcar (lambda (dec) (+ next dec)) '(.0 .1 .2 .3 .4 .5 .6 .7 .8 .9))))) + +(ert-deftest hierarchy-delayed-add-one-root () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 190 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (should (equal (hierarchy-roots hierarchy) '(190))))) + +(ert-deftest hierarchy-delayed-add-one-item-with-parent () + (let ((parentfn (lambda (item) + (cl-case item + (190 191)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 190 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (should (equal (hierarchy-roots hierarchy) '(191))) + (should (equal (hierarchy-children hierarchy 191) '(190))) + (should (equal (hierarchy-children hierarchy 190) '())))) + +(ert-deftest hierarchy-delayed-add-one-item-with-parent-and-grand-parent () + (let ((parentfn (lambda (item) + (cl-case item + (190 191) + (191 192)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 190 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (should (equal (hierarchy-roots hierarchy) '(192))) + (should (equal (hierarchy-children hierarchy 192) '(191))) + (should (equal (hierarchy-children hierarchy 191) '(190))) + (should (equal (hierarchy-children hierarchy 190) '())))) + +(ert-deftest hierarchy-delayed-add-same-root-twice () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 190 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (hierarchy-add-tree hierarchy 190 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (should (equal (hierarchy-roots hierarchy) '(190))))) + +(ert-deftest hierarchy-delayed-add-same-child-twice () + (let ((parentfn (lambda (item) + (cl-case item + (190 191)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 190 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (hierarchy-add-tree hierarchy 190 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (should (equal (hierarchy-roots hierarchy) '(191))) + (should (equal (hierarchy-children hierarchy 191) '(190))) + (should (equal (hierarchy-children hierarchy 190) '())))) + +(ert-deftest hierarchy-delayed-add-item-and-its-parent () + (let ((parentfn (lambda (item) + (cl-case item + (190 191)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 190 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (hierarchy-add-tree hierarchy 191 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (should (equal (hierarchy-roots hierarchy) '(191))) + (should (equal (hierarchy-children hierarchy 191) '(190))) + (should (equal (hierarchy-children hierarchy 190) '())))) + +(ert-deftest hierarchy-delayed-add-item-and-its-child () + (let ((parentfn (lambda (item) + (cl-case item + (190 191)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 191 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (hierarchy-add-tree hierarchy 190 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (should (equal (hierarchy-roots hierarchy) '(191))) + (should (equal (hierarchy-children hierarchy 191) '(190))) + (should (equal (hierarchy-children hierarchy 190) '())))) + +(ert-deftest hierarchy-delayed-add-two-items-sharing-parent () + (let ((parentfn (lambda (item) + (cl-case item + (190 191) + (190.5 191)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 190 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (hierarchy-add-tree hierarchy 190.5 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (should (equal (hierarchy-roots hierarchy) '(191))) + (should (equal (hierarchy-children hierarchy 191) '(190 190.5))))) + +(ert-deftest hierarchy-delayed-add-two-hierarchies () + (let ((parentfn (lambda (item) + (cl-case item + (190 191) + (circle 'shape)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 190 parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (hierarchy-add-tree hierarchy 'circle parentfn) + (should (equal (hierarchy-roots hierarchy) '(191 shape))) + (should (equal (hierarchy-children hierarchy 191) '(190))) + (should (equal (hierarchy-children hierarchy 'shape) '(circle))))) + +(ert-deftest hierarchy-delayed-add-trees () + (let ((parentfn (lambda (item) + (cl-case item + (190 '191) + (190.5 '191) + (191 '192)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-trees hierarchy '(191 190.5) parentfn + #'hierarchy-examples-delayed--childrenfn nil t) + (should (equal (hierarchy-roots hierarchy) '(192))) + (should (equal (hierarchy-children hierarchy '192) '(191))) + (should (equal (hierarchy-children hierarchy '191) '(190 190.5))))) + (provide 'hierarchy-tests) ;;; hierarchy-tests.el ends here |