Add the new library hierarchy.el
* lisp/emacs-lisp/hierarchy.el: New file.
This commit is contained in:
Damien Cassou
Lars Ingebrigtsen
parent
d586bae501
commit
8e82baf5a7
3 changed files with 1139 additions and 0 deletions
4
etc/NEWS
4
etc/NEWS
|
|
@ -737,6 +737,10 @@ The recentf files are no longer backed up.
|
|||
|
||||
** Miscellaneous
|
||||
|
||||
*** The new library hierarchy.el has been added.
|
||||
It's a library to create, query, navigate and display hierarchy
|
||||
structures.
|
||||
|
||||
---
|
||||
*** The width of the buffer-name column in 'list-buffers' is now dynamic.
|
||||
The width now depends of the width of the window, but will never be
|
||||
|
|
|
|||
579
lisp/emacs-lisp/hierarchy.el
Normal file
579
lisp/emacs-lisp/hierarchy.el
Normal file
|
|
@ -0,0 +1,579 @@
|
|||
;;; hierarchy.el --- Library to create and display hierarchy structures -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2020 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Damien Cassou <damien@cassou.me>
|
||||
;; Maintainer: emacs-devel@gnu.org
|
||||
|
||||
;; 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:
|
||||
|
||||
;; Library to create, query, navigate and display hierarchy structures.
|
||||
|
||||
;; Creation: After having created a hierarchy with `hierarchy-new',
|
||||
;; populate it by calling `hierarchy-add-tree' or
|
||||
;; `hierarchy-add-trees'. You can then optionally sort its element
|
||||
;; with `hierarchy-sort'.
|
||||
|
||||
;; Querying: You can learn more about your hierarchy by using
|
||||
;; functions such as `hierarchy-roots', `hierarchy-has-item',
|
||||
;; `hierarchy-length', `hierarchy-parent', `hierarchy-descendant-p'.
|
||||
|
||||
;; Navigation: When your hierarchy is ready, you can use
|
||||
;; `hierarchy-map-item', `hierarchy-map', and `map-tree' to apply
|
||||
;; functions to elements of the hierarchy.
|
||||
|
||||
;; Display: You can display a hierarchy as a tabulated list using
|
||||
;; `hierarchy-tabulated-display' and as an expandable/foldable tree
|
||||
;; using `hierarchy-convert-to-tree-widget'. The
|
||||
;; `hierarchy-labelfn-*' functions will help you display each item of
|
||||
;; the hierarchy the way you want it.
|
||||
|
||||
;;; Limitation:
|
||||
|
||||
;; - Current implementation uses #'equal to find and distinguish
|
||||
;; elements. Support for user-provided equality definition is
|
||||
;; desired but not yet implemented;
|
||||
;;
|
||||
;; - nil can't be added to a hierarchy;
|
||||
;;
|
||||
;; - the hierarchy is computed eagerly.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'seq)
|
||||
(require 'map)
|
||||
(require 'subr-x)
|
||||
(require 'cl-lib)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Helpers
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(cl-defstruct (hierarchy
|
||||
(:constructor hierarchy--make)
|
||||
(: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
|
||||
;; cache containing the set of all items in the hierarchy
|
||||
(seen-items (make-hash-table :test 'equal))) ; map an item to t
|
||||
|
||||
(defun hierarchy--seen-items-add (hierarchy item)
|
||||
"In HIERARCHY, add ITEM to seen items."
|
||||
(map-put! (hierarchy--seen-items hierarchy) item t))
|
||||
|
||||
(defun hierarchy--compute-roots (hierarchy)
|
||||
"Search roots of HIERARCHY and return them."
|
||||
(cl-set-difference
|
||||
(map-keys (hierarchy--seen-items hierarchy))
|
||||
(map-keys (hierarchy--parents hierarchy))
|
||||
:test #'equal))
|
||||
|
||||
(defun hierarchy--sort-roots (hierarchy sortfn)
|
||||
"Compute, sort and store the roots of HIERARCHY.
|
||||
|
||||
SORTFN is a function taking two items of the hierarchy as parameter and
|
||||
returning non-nil if the first parameter is lower than the second."
|
||||
(setf (hierarchy--roots hierarchy)
|
||||
(sort (hierarchy--compute-roots hierarchy)
|
||||
sortfn)))
|
||||
|
||||
(defun hierarchy--add-relation (hierarchy item parent acceptfn)
|
||||
"In HIERARCHY, add ITEM as child of PARENT.
|
||||
|
||||
ACCEPTFN is a function returning non-nil if its parameter (any object)
|
||||
should be an item of the hierarchy."
|
||||
(let* ((existing-parent (hierarchy-parent hierarchy item))
|
||||
(has-parent-p (funcall acceptfn existing-parent)))
|
||||
(cond
|
||||
((and has-parent-p (not (equal existing-parent parent)))
|
||||
(error "An item (%s) can only have one parent: '%s' vs '%s'"
|
||||
item existing-parent parent))
|
||||
((not has-parent-p)
|
||||
(let ((existing-children (map-elt (hierarchy--children hierarchy)
|
||||
parent (list))))
|
||||
(map-put! (hierarchy--children hierarchy)
|
||||
parent (append existing-children (list item))))
|
||||
(map-put! (hierarchy--parents hierarchy) item parent)))))
|
||||
|
||||
(defun hierarchy--set-equal (list1 list2 &rest cl-keys)
|
||||
"Return non-nil if LIST1 and LIST2 have same elements.
|
||||
|
||||
I.e., if every element of LIST1 also appears in LIST2 and if
|
||||
every element of LIST2 also appears in LIST1.
|
||||
|
||||
CL-KEYS are key-value pairs just like in `cl-subsetp'. Supported
|
||||
keys are :key and :test."
|
||||
(and (apply 'cl-subsetp list1 list2 cl-keys)
|
||||
(apply 'cl-subsetp list2 list1 cl-keys)))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Creation
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun hierarchy-new ()
|
||||
"Create a hierarchy and return it."
|
||||
(hierarchy--make))
|
||||
|
||||
(defun hierarchy-add-tree (hierarchy item parentfn &optional childrenfn acceptfn)
|
||||
"In HIERARCHY, add ITEM.
|
||||
|
||||
PARENTFN is either nil or a function defining the child-to-parent
|
||||
relationship: this function takes an item as parameter and should return
|
||||
the parent of this item in the hierarchy. If the item has no parent in the
|
||||
hierarchy (i.e., it should be a root), the function should return an object
|
||||
not accepted by acceptfn (i.e., nil for the default value of acceptfn).
|
||||
|
||||
CHILDRENFN is either nil or a function defining the parent-to-children
|
||||
relationship: this function takes an item as parameter and should return a
|
||||
list of children of this item in the hierarchy.
|
||||
|
||||
If both PARENTFN and CHILDRENFN are non-nil, the results of PARENTFN and
|
||||
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."
|
||||
(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)
|
||||
"Call `hierarchy-add-tree' on HIERARCHY and each element of ITEMS.
|
||||
|
||||
PARENTFN, CHILDRENFN and ACCEPTFN have the same meaning as in `hierarchy-add'."
|
||||
(seq-map (lambda (item)
|
||||
(hierarchy-add-tree hierarchy item parentfn childrenfn acceptfn))
|
||||
items))
|
||||
|
||||
(defun hierarchy-add-list (hierarchy list &optional wrap childrenfn)
|
||||
"Add to HIERARCHY the sub-lists in LIST.
|
||||
|
||||
If WRAP is non-nil, allow duplicate items in LIST by wraping each
|
||||
item in a cons (id . item). The root's id is 1.
|
||||
|
||||
CHILDRENFN is a function (defaults to `cdr') taking LIST as a
|
||||
parameter which should return LIST's children (a list). Each
|
||||
child is (recursively) passed as a parameter to CHILDRENFN to get
|
||||
its own children. Because of this parameter, LIST can be
|
||||
anything, not necessarily a list."
|
||||
(let* ((childrenfn (or childrenfn #'cdr))
|
||||
(id 0)
|
||||
(wrapfn (lambda (item)
|
||||
(if wrap
|
||||
(cons (setq id (1+ id)) item)
|
||||
item)))
|
||||
(unwrapfn (if wrap #'cdr #'identity)))
|
||||
(hierarchy-add-tree
|
||||
hierarchy (funcall wrapfn list) nil
|
||||
(lambda (item)
|
||||
(mapcar wrapfn (funcall childrenfn
|
||||
(funcall unwrapfn item)))))
|
||||
hierarchy))
|
||||
|
||||
(defun hierarchy-from-list (list &optional wrap childrenfn)
|
||||
"Create and return a hierarchy built from LIST.
|
||||
|
||||
This function passes LIST, WRAP and CHILDRENFN unchanged to
|
||||
`hierarchy-add-list'."
|
||||
(hierarchy-add-list (hierarchy-new) list wrap childrenfn))
|
||||
|
||||
(defun hierarchy-sort (hierarchy &optional sortfn)
|
||||
"Modify HIERARCHY so that its roots and item's children are sorted.
|
||||
|
||||
SORTFN is a function taking two items of the hierarchy as parameter and
|
||||
returning non-nil if the first parameter is lower than the second. By
|
||||
default, SORTFN is `string-lessp'."
|
||||
(let ((sortfn (or sortfn #'string-lessp)))
|
||||
(hierarchy--sort-roots hierarchy sortfn)
|
||||
(mapc (lambda (parent)
|
||||
(setf
|
||||
(map-elt (hierarchy--children hierarchy) parent)
|
||||
(sort (map-elt (hierarchy--children hierarchy) parent) sortfn)))
|
||||
(map-keys (hierarchy--children hierarchy)))))
|
||||
|
||||
(defun hierarchy-extract-tree (hierarchy item)
|
||||
"Return a copy of HIERARCHY with ITEM's descendants and parents."
|
||||
(if (not (hierarchy-has-item hierarchy item))
|
||||
nil
|
||||
(let ((tree (hierarchy-new)))
|
||||
(hierarchy-add-tree tree item
|
||||
(lambda (each) (hierarchy-parent hierarchy each))
|
||||
(lambda (each)
|
||||
(when (or (equal each item)
|
||||
(hierarchy-descendant-p hierarchy each item))
|
||||
(hierarchy-children hierarchy each))))
|
||||
tree)))
|
||||
|
||||
(defun hierarchy-copy (hierarchy)
|
||||
"Return a copy of HIERARCHY.
|
||||
|
||||
Items in HIERARCHY are shared, but structure is not."
|
||||
(hierarchy-map-hierarchy (lambda (item _) (identity item)) hierarchy))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Querying
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun hierarchy-items (hierarchy)
|
||||
"Return a list of all items of HIERARCHY."
|
||||
(map-keys (hierarchy--seen-items hierarchy)))
|
||||
|
||||
(defun hierarchy-has-item (hierarchy item)
|
||||
"Return t if HIERARCHY includes ITEM."
|
||||
(map-contains-key (hierarchy--seen-items hierarchy) item))
|
||||
|
||||
(defun hierarchy-empty-p (hierarchy)
|
||||
"Return t if HIERARCHY is empty."
|
||||
(= 0 (hierarchy-length hierarchy)))
|
||||
|
||||
(defun hierarchy-length (hierarchy)
|
||||
"Return the number of items in HIERARCHY."
|
||||
(hash-table-count (hierarchy--seen-items hierarchy)))
|
||||
|
||||
(defun hierarchy-has-root (hierarchy item)
|
||||
"Return t if one of HIERARCHY's roots is ITEM.
|
||||
|
||||
A root is an item with no parent."
|
||||
(seq-contains-p (hierarchy-roots hierarchy) item))
|
||||
|
||||
(defun hierarchy-roots (hierarchy)
|
||||
"Return all roots of HIERARCHY.
|
||||
|
||||
A root is an item with no parent."
|
||||
(let ((roots (hierarchy--roots hierarchy)))
|
||||
(or roots
|
||||
(hierarchy--compute-roots hierarchy))))
|
||||
|
||||
(defun hierarchy-leafs (hierarchy &optional node)
|
||||
"Return all leafs of HIERARCHY.
|
||||
|
||||
A leaf is an item with no child.
|
||||
|
||||
If NODE is an item of HIERARCHY, only return leafs under NODE."
|
||||
(let ((leafs (cl-set-difference
|
||||
(map-keys (hierarchy--seen-items hierarchy))
|
||||
(map-keys (hierarchy--children hierarchy)))))
|
||||
(if (hierarchy-has-item hierarchy node)
|
||||
(seq-filter (lambda (item)
|
||||
(hierarchy-descendant-p hierarchy item node))
|
||||
leafs)
|
||||
leafs)))
|
||||
|
||||
(defun hierarchy-parent (hierarchy item)
|
||||
"In HIERARCHY, return parent of ITEM."
|
||||
(map-elt (hierarchy--parents hierarchy) item))
|
||||
|
||||
(defun hierarchy-children (hierarchy parent)
|
||||
"In HIERARCHY, return children of PARENT."
|
||||
(map-elt (hierarchy--children hierarchy) parent (list)))
|
||||
|
||||
(defun hierarchy-child-p (hierarchy item1 item2)
|
||||
"In HIERARCHY, return non-nil if and only if ITEM1 is a child of ITEM2."
|
||||
(equal (hierarchy-parent hierarchy item1) item2))
|
||||
|
||||
(defun hierarchy-descendant-p (hierarchy item1 item2)
|
||||
"In HIERARCHY, return non-nil if and only if ITEM1 is a descendant of ITEM2.
|
||||
|
||||
ITEM1 is a descendant of ITEM2 if and only if both are items of HIERARCHY
|
||||
and either:
|
||||
|
||||
- ITEM1 is child of ITEM2, or
|
||||
- ITEM1's parent is a descendant of ITEM2."
|
||||
(and
|
||||
(hierarchy-has-item hierarchy item1)
|
||||
(hierarchy-has-item hierarchy item2)
|
||||
(or
|
||||
(hierarchy-child-p hierarchy item1 item2)
|
||||
(hierarchy-descendant-p
|
||||
hierarchy (hierarchy-parent hierarchy item1) item2))))
|
||||
|
||||
(defun hierarchy-equal (hierarchy1 hierarchy2)
|
||||
"Return t if HIERARCHY1 and HIERARCHY2 are equal.
|
||||
|
||||
Two equal hierarchies share the same items and the same
|
||||
relationships among them."
|
||||
(and (hierarchy-p hierarchy1)
|
||||
(hierarchy-p hierarchy2)
|
||||
(= (hierarchy-length hierarchy1) (hierarchy-length hierarchy2))
|
||||
;; parents are the same
|
||||
(seq-every-p (lambda (child)
|
||||
(equal (hierarchy-parent hierarchy1 child)
|
||||
(hierarchy-parent hierarchy2 child)))
|
||||
(map-keys (hierarchy--parents hierarchy1)))
|
||||
;; children are the same
|
||||
(seq-every-p (lambda (parent)
|
||||
(hierarchy--set-equal
|
||||
(hierarchy-children hierarchy1 parent)
|
||||
(hierarchy-children hierarchy2 parent)
|
||||
:test #'equal))
|
||||
(map-keys (hierarchy--children hierarchy1)))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Navigation
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun hierarchy-map-item (func item hierarchy &optional indent)
|
||||
"Return the result of applying FUNC to ITEM and its descendants in HIERARCHY.
|
||||
|
||||
This function navigates the tree top-down: FUNCTION is first called on item
|
||||
and then on each of its children. Results are concatenated in a list.
|
||||
|
||||
INDENT is a number (default 0) representing the indentation of ITEM in
|
||||
HIERARCHY. FUNC should take 2 argument: the item and its indentation
|
||||
level."
|
||||
(let ((indent (or indent 0)))
|
||||
(cons
|
||||
(funcall func item indent)
|
||||
(seq-mapcat (lambda (child) (hierarchy-map-item func child
|
||||
hierarchy (1+ indent)))
|
||||
(hierarchy-children hierarchy item)))))
|
||||
|
||||
(defun hierarchy-map (func hierarchy &optional indent)
|
||||
"Return the result of applying FUNC to each element of HIERARCHY.
|
||||
|
||||
This function navigates the tree top-down: FUNCTION is first called on each
|
||||
root. To do so, it calls `hierarchy-map-item' on each root
|
||||
sequentially. Results are concatenated in a list.
|
||||
|
||||
FUNC should take 2 arguments: the item and its indentation level.
|
||||
|
||||
INDENT is a number (default 0) representing the indentation of HIERARCHY's
|
||||
roots."
|
||||
(let ((indent (or indent 0)))
|
||||
(seq-mapcat (lambda (root) (hierarchy-map-item func root hierarchy indent))
|
||||
(hierarchy-roots hierarchy))))
|
||||
|
||||
(defun hierarchy-map-tree (function hierarchy &optional item indent)
|
||||
"Apply FUNCTION on each item of HIERARCHY under ITEM.
|
||||
|
||||
This function navigates the tree bottom-up: FUNCTION is first called on
|
||||
leafs and the result is passed as parameter when calling FUNCTION on
|
||||
parents.
|
||||
|
||||
FUNCTION should take 3 parameters: the current item, its indentation
|
||||
level (a number), and a list representing the result of applying
|
||||
`hierarchy-map-tree' to each child of the item.
|
||||
|
||||
INDENT is 0 by default and is passed as second parameter to FUNCTION.
|
||||
INDENT is incremented by 1 at each level of the tree.
|
||||
|
||||
This function returns the result of applying FUNCTION to ITEM (the first
|
||||
root if nil)."
|
||||
(let ((item (or item (car (hierarchy-roots hierarchy))))
|
||||
(indent (or indent 0)))
|
||||
(funcall function item indent
|
||||
(mapcar (lambda (child)
|
||||
(hierarchy-map-tree function hierarchy
|
||||
child (1+ indent)))
|
||||
(hierarchy-children hierarchy item)))))
|
||||
|
||||
(defun hierarchy-map-hierarchy (function hierarchy)
|
||||
"Apply FUNCTION to each item of HIERARCHY in a new hierarchy.
|
||||
|
||||
FUNCTION should take 2 parameters, the current item and its
|
||||
indentation level (a number), and should return an item to be
|
||||
added to the new hierarchy."
|
||||
(let* ((items (make-hash-table :test #'equal))
|
||||
(transform (lambda (item) (map-elt items item))))
|
||||
;; Make 'items', a table mapping original items to their
|
||||
;; transformation
|
||||
(hierarchy-map (lambda (item indent)
|
||||
(map-put! items item (funcall function item indent)))
|
||||
hierarchy)
|
||||
(hierarchy--make
|
||||
:roots (mapcar transform (hierarchy-roots hierarchy))
|
||||
:parents (let ((result (make-hash-table :test #'equal)))
|
||||
(map-apply (lambda (child parent)
|
||||
(map-put! result
|
||||
(funcall transform child)
|
||||
(funcall transform parent)))
|
||||
(hierarchy--parents hierarchy))
|
||||
result)
|
||||
:children (let ((result (make-hash-table :test #'equal)))
|
||||
(map-apply (lambda (parent children)
|
||||
(map-put! result
|
||||
(funcall transform parent)
|
||||
(seq-map transform children)))
|
||||
(hierarchy--children hierarchy))
|
||||
result)
|
||||
:seen-items (let ((result (make-hash-table :test #'equal)))
|
||||
(map-apply (lambda (item v)
|
||||
(map-put! result
|
||||
(funcall transform item)
|
||||
v))
|
||||
(hierarchy--seen-items hierarchy))
|
||||
result))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Display
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun hierarchy-labelfn-indent (labelfn &optional indent-string)
|
||||
"Return a function rendering LABELFN indented with INDENT-STRING.
|
||||
|
||||
INDENT-STRING defaults to a 2-space string. Indentation is
|
||||
multiplied by the depth of the displayed item."
|
||||
(let ((indent-string (or indent-string " ")))
|
||||
(lambda (item indent)
|
||||
(dotimes (_ indent) (insert indent-string))
|
||||
(funcall labelfn item indent))))
|
||||
|
||||
(defun hierarchy-labelfn-button (labelfn actionfn)
|
||||
"Return a function rendering LABELFN in a button.
|
||||
|
||||
Clicking the button triggers ACTIONFN. ACTIONFN is a function
|
||||
taking an item of HIERARCHY and an indentation value (a number)
|
||||
as input. This function is called when an item is clicked. The
|
||||
return value of ACTIONFN is ignored."
|
||||
(lambda (item indent)
|
||||
(let ((start (point)))
|
||||
(funcall labelfn item indent)
|
||||
(make-text-button start (point)
|
||||
'action (lambda (_) (funcall actionfn item indent))))))
|
||||
|
||||
(defun hierarchy-labelfn-button-if (labelfn buttonp actionfn)
|
||||
"Return a function rendering LABELFN as a button if BUTTONP.
|
||||
|
||||
Pass LABELFN and ACTIONFN to `hierarchy-labelfn-button' if
|
||||
BUTTONP is non-nil. Otherwise, render LABELFN without making it
|
||||
a button.
|
||||
|
||||
BUTTONP is a function taking an item of HIERARCHY and an
|
||||
indentation value (a number) as input."
|
||||
(lambda (item indent)
|
||||
(if (funcall buttonp item indent)
|
||||
(funcall (hierarchy-labelfn-button labelfn actionfn) item indent)
|
||||
(funcall labelfn item indent))))
|
||||
|
||||
(defun hierarchy-labelfn-to-string (labelfn item indent)
|
||||
"Execute LABELFN on ITEM and INDENT. Return result as a string."
|
||||
(with-temp-buffer
|
||||
(funcall labelfn item indent)
|
||||
(buffer-substring (point-min) (point-max))))
|
||||
|
||||
(defun hierarchy-print (hierarchy &optional to-string)
|
||||
"Insert HIERARCHY in current buffer as plain text.
|
||||
|
||||
Use TO-STRING to convert each element to a string. TO-STRING is
|
||||
a function taking an item of HIERARCHY as input and returning a
|
||||
string. If nil, TO-STRING defaults to a call to `format' with \"%s\"."
|
||||
(let ((to-string (or to-string (lambda (item) (format "%s" item)))))
|
||||
(hierarchy-map
|
||||
(hierarchy-labelfn-indent (lambda (item _)
|
||||
(insert (funcall to-string item) "\n")))
|
||||
hierarchy)))
|
||||
|
||||
(defun hierarchy-to-string (hierarchy &optional to-string)
|
||||
"Return a string representing HIERARCHY.
|
||||
|
||||
TO-STRING is passed unchanged to `hierarchy-print'."
|
||||
(with-temp-buffer
|
||||
(hierarchy-print hierarchy to-string)
|
||||
(buffer-substring (point-min) (point-max))))
|
||||
|
||||
(defun hierarchy-tabulated-imenu-action (_item-name position)
|
||||
"Move to ITEM-NAME at POSITION in current buffer."
|
||||
(goto-char position)
|
||||
(back-to-indentation))
|
||||
|
||||
(define-derived-mode hierarchy-tabulated-mode tabulated-list-mode "Hierarchy tabulated"
|
||||
"Major mode to display a hierarchy as a tabulated list."
|
||||
(setq-local imenu-generic-expression
|
||||
;; debbugs: 26457 - Cannot pass a function to
|
||||
;; imenu-generic-expression. Add
|
||||
;; `hierarchy-tabulated-imenu-action' to the end of the
|
||||
;; list when bug is fixed
|
||||
'(("Item" "^[[:space:]]+\\(?1:.+\\)$" 1))))
|
||||
|
||||
(defun hierarchy-tabulated-display (hierarchy labelfn &optional buffer)
|
||||
"Display HIERARCHY as a tabulated list in `hierarchy-tabulated-mode'.
|
||||
|
||||
LABELFN is a function taking an item of HIERARCHY and an indentation
|
||||
level (a number) as input and inserting a string to be displayed in the
|
||||
table.
|
||||
|
||||
The tabulated list is displayed in BUFFER, or a newly created buffer if
|
||||
nil. The buffer is returned."
|
||||
(let ((buffer (or buffer (generate-new-buffer "hierarchy-tabulated"))))
|
||||
(with-current-buffer buffer
|
||||
(hierarchy-tabulated-mode)
|
||||
(setq tabulated-list-format
|
||||
(vector '("Item name" 0 nil)))
|
||||
(setq tabulated-list-entries
|
||||
(hierarchy-map (lambda (item indent)
|
||||
(list item (vector (hierarchy-labelfn-to-string
|
||||
labelfn item indent))))
|
||||
hierarchy))
|
||||
(tabulated-list-init-header)
|
||||
(tabulated-list-print))
|
||||
buffer))
|
||||
|
||||
(declare-function widget-convert "wid-edit")
|
||||
(defun hierarchy-convert-to-tree-widget (hierarchy labelfn)
|
||||
"Return a tree-widget for HIERARCHY.
|
||||
|
||||
LABELFN is a function taking an item of HIERARCHY and an indentation
|
||||
value (a number) as parameter and inserting a string to be displayed as a
|
||||
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))
|
||||
hierarchy))
|
||||
|
||||
(defun hierarchy-tree-display (hierarchy labelfn &optional buffer)
|
||||
"Display HIERARCHY as a tree widget in a new buffer.
|
||||
|
||||
HIERARCHY and LABELFN are passed unchanged to
|
||||
`hierarchy-convert-to-tree-widget'.
|
||||
|
||||
The tree widget is displayed in BUFFER, or a newly created buffer if
|
||||
nil. The buffer is returned."
|
||||
(let ((buffer (or buffer (generate-new-buffer "*hierarchy-tree*")))
|
||||
(tree-widget (hierarchy-convert-to-tree-widget hierarchy labelfn)))
|
||||
(with-current-buffer buffer
|
||||
(setq-local buffer-read-only t)
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer)
|
||||
(widget-create tree-widget)
|
||||
(goto-char (point-min))
|
||||
(special-mode)))
|
||||
buffer))
|
||||
|
||||
(provide 'hierarchy)
|
||||
|
||||
;;; hierarchy.el ends here
|
||||
556
test/lisp/emacs-lisp/hierarchy-tests.el
Normal file
556
test/lisp/emacs-lisp/hierarchy-tests.el
Normal file
|
|
@ -0,0 +1,556 @@
|
|||
;;; hierarchy-tests.el --- Tests for hierarchy.el
|
||||
|
||||
;; Copyright (C) 2017-2019 Damien Cassou
|
||||
|
||||
;; Author: Damien Cassou <damien@cassou.me>
|
||||
;; Maintainer: emacs-devel@gnu.org
|
||||
|
||||
;; 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:
|
||||
|
||||
;; Tests for hierarchy.el
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'hierarchy)
|
||||
|
||||
(defun hierarchy-animals ()
|
||||
"Create a sorted animal hierarchy."
|
||||
(let ((parentfn (lambda (item) (cl-case item
|
||||
(dove 'bird)
|
||||
(pigeon 'bird)
|
||||
(bird 'animal)
|
||||
(dolphin 'animal)
|
||||
(cow 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'dove parentfn)
|
||||
(hierarchy-add-tree hierarchy 'pigeon parentfn)
|
||||
(hierarchy-add-tree hierarchy 'dolphin parentfn)
|
||||
(hierarchy-add-tree hierarchy 'cow parentfn)
|
||||
(hierarchy-sort hierarchy)
|
||||
hierarchy))
|
||||
|
||||
(ert-deftest hierarchy-add-one-root ()
|
||||
(let ((parentfn (lambda (_) nil))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'animal parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))))
|
||||
|
||||
(ert-deftest hierarchy-add-one-item-with-parent ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))))
|
||||
|
||||
(ert-deftest hierarchy-add-one-item-with-parent-and-grand-parent ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(dove 'bird)
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'dove parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove)))))
|
||||
|
||||
(ert-deftest hierarchy-add-same-root-twice ()
|
||||
(let ((parentfn (lambda (_) nil))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'animal parentfn)
|
||||
(hierarchy-add-tree hierarchy 'animal parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))))
|
||||
|
||||
(ert-deftest hierarchy-add-same-child-twice ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn)
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))))
|
||||
|
||||
(ert-deftest hierarchy-add-item-and-its-parent ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn)
|
||||
(hierarchy-add-tree hierarchy 'animal parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))))
|
||||
|
||||
(ert-deftest hierarchy-add-item-and-its-child ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'animal parentfn)
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))))
|
||||
|
||||
(ert-deftest hierarchy-add-two-items-sharing-parent ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(dove 'bird)
|
||||
(pigeon 'bird))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'dove parentfn)
|
||||
(hierarchy-add-tree hierarchy 'pigeon parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(bird)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-add-two-hierarchies ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(dove 'bird)
|
||||
(circle 'shape))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'dove parentfn)
|
||||
(hierarchy-add-tree hierarchy 'circle parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(bird shape)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove)))
|
||||
(should (equal (hierarchy-children hierarchy 'shape) '(circle)))))
|
||||
|
||||
(ert-deftest hierarchy-add-with-childrenfn ()
|
||||
(let ((childrenfn (lambda (item)
|
||||
(cl-case item
|
||||
(animal '(bird))
|
||||
(bird '(dove pigeon)))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'animal nil childrenfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-add-with-parentfn-and-childrenfn ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal)
|
||||
(animal 'life-form))))
|
||||
(childrenfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird '(dove pigeon))
|
||||
(pigeon '(ashy-wood-pigeon)))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn childrenfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(life-form)))
|
||||
(should (equal (hierarchy-children hierarchy 'life-form) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon)))
|
||||
(should (equal (hierarchy-children hierarchy 'pigeon) '(ashy-wood-pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-add-twice-with-parentfn-and-childrenfn ()
|
||||
(let* ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(dove 'bird)
|
||||
(bird 'animal))))
|
||||
(childrenfn (lambda (item)
|
||||
(cl-case item
|
||||
(animal '(bird))
|
||||
(bird '(dove)))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn childrenfn)
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove)))))
|
||||
|
||||
(ert-deftest hierarchy-add-trees ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(dove 'bird)
|
||||
(pigeon 'bird)
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-trees hierarchy '(dove pigeon) parentfn)
|
||||
(should (equal (hierarchy-roots hierarchy) '(animal)))
|
||||
(should (equal (hierarchy-children hierarchy 'animal) '(bird)))
|
||||
(should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-from-list ()
|
||||
(let ((hierarchy (hierarchy-from-list
|
||||
'(animal (bird (dove)
|
||||
(pigeon))
|
||||
(cow)
|
||||
(dolphin)))))
|
||||
(hierarchy-sort hierarchy (lambda (item1 item2)
|
||||
(string< (car item1)
|
||||
(car item2))))
|
||||
(should (equal (hierarchy-to-string hierarchy (lambda (item) (symbol-name (car item))))
|
||||
"animal\n bird\n dove\n pigeon\n cow\n dolphin\n"))))
|
||||
|
||||
(ert-deftest hierarchy-from-list-with-duplicates ()
|
||||
(let ((hierarchy (hierarchy-from-list
|
||||
'(a (b) (b))
|
||||
t)))
|
||||
(hierarchy-sort hierarchy (lambda (item1 item2)
|
||||
;; sort by ID
|
||||
(< (car item1) (car item2))))
|
||||
(should (equal (hierarchy-length hierarchy) 3))
|
||||
(should (equal (hierarchy-to-string
|
||||
hierarchy
|
||||
(lambda (item)
|
||||
(format "%s(%s)"
|
||||
(cadr item)
|
||||
(car item))))
|
||||
"a(1)\n b(2)\n b(3)\n"))))
|
||||
|
||||
(ert-deftest hierarchy-from-list-with-childrenfn ()
|
||||
(let ((hierarchy (hierarchy-from-list
|
||||
"abc"
|
||||
nil
|
||||
(lambda (item)
|
||||
(when (string= item "abc")
|
||||
(split-string item "" t))))))
|
||||
(hierarchy-sort hierarchy (lambda (item1 item2) (string< item1 item2)))
|
||||
(should (equal (hierarchy-length hierarchy) 4))
|
||||
(should (equal (hierarchy-to-string hierarchy)
|
||||
"abc\n a\n b\n c\n"))))
|
||||
|
||||
(ert-deftest hierarchy-add-relation-check-error-when-different-parent ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'bird parentfn)
|
||||
(should-error
|
||||
(hierarchy--add-relation hierarchy 'bird 'cow #'identity))))
|
||||
|
||||
(ert-deftest hierarchy-empty-p-return-non-nil-for-empty ()
|
||||
(should (hierarchy-empty-p (hierarchy-new))))
|
||||
|
||||
(ert-deftest hierarchy-empty-p-return-nil-for-non-empty ()
|
||||
(should-not (hierarchy-empty-p (hierarchy-animals))))
|
||||
|
||||
(ert-deftest hierarchy-length-of-empty-is-0 ()
|
||||
(should (equal (hierarchy-length (hierarchy-new)) 0)))
|
||||
|
||||
(ert-deftest hierarchy-length-of-non-empty-counts-items ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal)
|
||||
(dove 'bird)
|
||||
(pigeon 'bird))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'dove parentfn)
|
||||
(hierarchy-add-tree hierarchy 'pigeon parentfn)
|
||||
(should (equal (hierarchy-length hierarchy) 4))))
|
||||
|
||||
(ert-deftest hierarchy-has-root ()
|
||||
(let ((parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(bird 'animal)
|
||||
(dove 'bird)
|
||||
(pigeon 'bird))))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(should-not (hierarchy-has-root hierarchy 'animal))
|
||||
(should-not (hierarchy-has-root hierarchy 'bird))
|
||||
(hierarchy-add-tree hierarchy 'dove parentfn)
|
||||
(hierarchy-add-tree hierarchy 'pigeon parentfn)
|
||||
(should (hierarchy-has-root hierarchy 'animal))
|
||||
(should-not (hierarchy-has-root hierarchy 'bird))))
|
||||
|
||||
(ert-deftest hierarchy-leafs ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (equal (hierarchy-leafs animals)
|
||||
'(dove pigeon dolphin cow)))))
|
||||
|
||||
(ert-deftest hierarchy-leafs-includes-lonely-roots ()
|
||||
(let ((parentfn (lambda (item) nil))
|
||||
(hierarchy (hierarchy-new)))
|
||||
(hierarchy-add-tree hierarchy 'foo parentfn)
|
||||
(should (equal (hierarchy-leafs hierarchy)
|
||||
'(foo)))))
|
||||
|
||||
(ert-deftest hierarchy-leafs-of-node ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (equal (hierarchy-leafs animals 'cow) '()))
|
||||
(should (equal (hierarchy-leafs animals 'animal) '(dove pigeon dolphin cow)))
|
||||
(should (equal (hierarchy-leafs animals 'bird) '(dove pigeon)))
|
||||
(should (equal (hierarchy-leafs animals 'dove) '()))))
|
||||
|
||||
(ert-deftest hierarchy-child-p ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (hierarchy-child-p animals 'dove 'bird))
|
||||
(should (hierarchy-child-p animals 'bird 'animal))
|
||||
(should (hierarchy-child-p animals 'cow 'animal))
|
||||
(should-not (hierarchy-child-p animals 'cow 'bird))
|
||||
(should-not (hierarchy-child-p animals 'bird 'cow))
|
||||
(should-not (hierarchy-child-p animals 'animal 'dove))
|
||||
(should-not (hierarchy-child-p animals 'animal 'bird))))
|
||||
|
||||
(ert-deftest hierarchy-descendant ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (hierarchy-descendant-p animals 'dove 'animal))
|
||||
(should (hierarchy-descendant-p animals 'dove 'bird))
|
||||
(should (hierarchy-descendant-p animals 'bird 'animal))
|
||||
(should (hierarchy-descendant-p animals 'cow 'animal))
|
||||
(should-not (hierarchy-descendant-p animals 'cow 'bird))
|
||||
(should-not (hierarchy-descendant-p animals 'bird 'cow))
|
||||
(should-not (hierarchy-descendant-p animals 'animal 'dove))
|
||||
(should-not (hierarchy-descendant-p animals 'animal 'bird))))
|
||||
|
||||
(ert-deftest hierarchy-descendant-if-not-same ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should-not (hierarchy-descendant-p animals 'cow 'cow))
|
||||
(should-not (hierarchy-descendant-p animals 'dove 'dove))
|
||||
(should-not (hierarchy-descendant-p animals 'bird 'bird))
|
||||
(should-not (hierarchy-descendant-p animals 'animal 'animal))))
|
||||
|
||||
;; keywords supported: :test :key
|
||||
(ert-deftest hierarchy--set-equal ()
|
||||
(should (hierarchy--set-equal '(1 2 3) '(1 2 3)))
|
||||
(should (hierarchy--set-equal '(1 2 3) '(3 2 1)))
|
||||
(should (hierarchy--set-equal '(3 2 1) '(1 2 3)))
|
||||
(should-not (hierarchy--set-equal '(2 3) '(3 2 1)))
|
||||
(should-not (hierarchy--set-equal '(1 2 3) '(2 3)))
|
||||
(should-not (hierarchy--set-equal '("1" "2") '("2" "1") :test #'eq))
|
||||
(should (hierarchy--set-equal '("1" "2") '("2" "1") :test #'equal))
|
||||
(should-not (hierarchy--set-equal '(1 2) '(-1 -2)))
|
||||
(should (hierarchy--set-equal '(1 2) '(-1 -2) :key #'abs))
|
||||
(should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2))))
|
||||
(should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car))
|
||||
(should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :test #'equal))
|
||||
(should (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car :test #'equal)))
|
||||
|
||||
(ert-deftest hierarchy-equal-returns-true-for-same-hierarchy ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (hierarchy-equal animals animals))
|
||||
(should (hierarchy-equal (hierarchy-animals) animals))))
|
||||
|
||||
(ert-deftest hierarchy-equal-returns-true-for-hierarchy-copies ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (hierarchy-equal animals (hierarchy-copy animals)))))
|
||||
|
||||
(ert-deftest hierarchy-map-item-on-leaf ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-map-item (lambda (item indent) (cons item indent))
|
||||
'cow
|
||||
animals)))
|
||||
(should (equal result '((cow . 0))))))
|
||||
|
||||
(ert-deftest hierarchy-map-item-on-leaf-with-indent ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-map-item (lambda (item indent) (cons item indent))
|
||||
'cow
|
||||
animals
|
||||
2)))
|
||||
(should (equal result '((cow . 2))))))
|
||||
|
||||
(ert-deftest hierarchy-map-item-on-parent ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-map-item (lambda (item indent) (cons item indent))
|
||||
'bird
|
||||
animals)))
|
||||
(should (equal result '((bird . 0) (dove . 1) (pigeon . 1))))))
|
||||
|
||||
(ert-deftest hierarchy-map-item-on-grand-parent ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-map-item (lambda (item indent) (cons item indent))
|
||||
'animal
|
||||
animals)))
|
||||
(should (equal result '((animal . 0) (bird . 1) (dove . 2) (pigeon . 2)
|
||||
(cow . 1) (dolphin . 1))))))
|
||||
|
||||
(ert-deftest hierarchy-map-conses ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-map (lambda (item indent)
|
||||
(cons item indent))
|
||||
animals)))
|
||||
(should (equal result '((animal . 0)
|
||||
(bird . 1)
|
||||
(dove . 2)
|
||||
(pigeon . 2)
|
||||
(cow . 1)
|
||||
(dolphin . 1))))))
|
||||
|
||||
(ert-deftest hierarchy-map-tree ()
|
||||
(let ((animals (hierarchy-animals)))
|
||||
(should (equal (hierarchy-map-tree (lambda (item indent children)
|
||||
(list item indent children))
|
||||
animals)
|
||||
'(animal
|
||||
0
|
||||
((bird 1 ((dove 2 nil) (pigeon 2 nil)))
|
||||
(cow 1 nil)
|
||||
(dolphin 1 nil)))))))
|
||||
|
||||
(ert-deftest hierarchy-map-hierarchy-keeps-hierarchy ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-map-hierarchy (lambda (item _) (identity item))
|
||||
animals)))
|
||||
(should (hierarchy-equal animals result))))
|
||||
|
||||
(ert-deftest hierarchy-map-applies-function ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(parentfn (lambda (item)
|
||||
(cond
|
||||
((equal item "bird") "animal")
|
||||
((equal item "dove") "bird")
|
||||
((equal item "pigeon") "bird")
|
||||
((equal item "cow") "animal")
|
||||
((equal item "dolphin") "animal"))))
|
||||
(expected (hierarchy-new)))
|
||||
(hierarchy-add-tree expected "dove" parentfn)
|
||||
(hierarchy-add-tree expected "pigeon" parentfn)
|
||||
(hierarchy-add-tree expected "cow" parentfn)
|
||||
(hierarchy-add-tree expected "dolphin" parentfn)
|
||||
(should (hierarchy-equal
|
||||
(hierarchy-map-hierarchy (lambda (item _) (symbol-name item)) animals)
|
||||
expected))))
|
||||
|
||||
(ert-deftest hierarchy-extract-tree ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(birds (hierarchy-extract-tree animals 'bird)))
|
||||
(hierarchy-sort birds)
|
||||
(should (equal (hierarchy-roots birds) '(animal)))
|
||||
(should (equal (hierarchy-children birds 'animal) '(bird)))
|
||||
(should (equal (hierarchy-children birds 'bird) '(dove pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-extract-tree-nil-if-not-in-hierarchy ()
|
||||
(let* ((animals (hierarchy-animals)))
|
||||
(should-not (hierarchy-extract-tree animals 'foobar))))
|
||||
|
||||
(ert-deftest hierarchy-items-of-empty-hierarchy-is-empty ()
|
||||
(should (seq-empty-p (hierarchy-items (hierarchy-new)))))
|
||||
|
||||
(ert-deftest hierarchy-items-returns-sequence-of-same-length ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-items animals)))
|
||||
(should (= (seq-length result) (hierarchy-length animals)))))
|
||||
|
||||
(ert-deftest hierarchy-items-return-all-elements-of-hierarchy ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-items animals)))
|
||||
(should (equal (seq-sort #'string< result) '(animal bird cow dolphin dove pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-indent-no-indent-if-0 ()
|
||||
(let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(labelfn (hierarchy-labelfn-indent labelfn-base)))
|
||||
(should (equal
|
||||
(with-temp-buffer
|
||||
(funcall labelfn "bar" 0)
|
||||
(buffer-substring (point-min) (point-max)))
|
||||
"foo"))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-indent-three-times-if-3 ()
|
||||
(let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(labelfn (hierarchy-labelfn-indent labelfn-base)))
|
||||
(should (equal
|
||||
(with-temp-buffer
|
||||
(funcall labelfn "bar" 3)
|
||||
(buffer-substring (point-min) (point-max)))
|
||||
" foo"))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-indent-default-indent-string ()
|
||||
(let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(labelfn (hierarchy-labelfn-indent labelfn-base)))
|
||||
(should (equal
|
||||
(with-temp-buffer
|
||||
(funcall labelfn "bar" 1)
|
||||
(buffer-substring (point-min) (point-max)))
|
||||
" foo"))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-indent-custom-indent-string ()
|
||||
(let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(labelfn (hierarchy-labelfn-indent labelfn-base "###"))
|
||||
(content (with-temp-buffer
|
||||
(funcall labelfn "bar" 1)
|
||||
(buffer-substring (point-min) (point-max)))))
|
||||
(should (equal content "###foo"))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-button-propertize ()
|
||||
(let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(actionfn #'identity)
|
||||
(labelfn (hierarchy-labelfn-button labelfn-base actionfn))
|
||||
(properties (with-temp-buffer
|
||||
(funcall labelfn "bar" 1)
|
||||
(text-properties-at 1))))
|
||||
(should (equal (car properties) 'action))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-button-execute-labelfn ()
|
||||
(let* ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(actionfn #'identity)
|
||||
(labelfn (hierarchy-labelfn-button labelfn-base actionfn))
|
||||
(content (with-temp-buffer
|
||||
(funcall labelfn "bar" 1)
|
||||
(buffer-substring-no-properties (point-min) (point-max)))))
|
||||
(should (equal content "foo"))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-button-if-does-not-button-unless-condition ()
|
||||
(let ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(spy-count 0)
|
||||
(condition (lambda (_item _indent) nil)))
|
||||
(cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count)))))
|
||||
(funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil)
|
||||
(should (equal spy-count 0)))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-button-if-does-button-when-condition ()
|
||||
(let ((labelfn-base (lambda (_item _indent) (insert "foo")))
|
||||
(spy-count 0)
|
||||
(condition (lambda (_item _indent) t)))
|
||||
(cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count)))))
|
||||
(funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil)
|
||||
(should (equal spy-count 1)))))
|
||||
|
||||
(ert-deftest hierarchy-labelfn-to-string ()
|
||||
(let ((labelfn (lambda (item _indent) (insert item))))
|
||||
(should (equal (hierarchy-labelfn-to-string labelfn "foo" 1) "foo"))))
|
||||
|
||||
(ert-deftest hierarchy-print ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (with-temp-buffer
|
||||
(hierarchy-print animals)
|
||||
(buffer-substring-no-properties (point-min) (point-max)))))
|
||||
(should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n"))))
|
||||
|
||||
(ert-deftest hierarchy-to-string ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(result (hierarchy-to-string animals)))
|
||||
(should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n"))))
|
||||
|
||||
(ert-deftest hierarchy-tabulated-display ()
|
||||
(let* ((animals (hierarchy-animals))
|
||||
(labelfn (lambda (item _indent) (insert (symbol-name item))))
|
||||
(contents (with-temp-buffer
|
||||
(hierarchy-tabulated-display animals labelfn (current-buffer))
|
||||
(buffer-substring-no-properties (point-min) (point-max)))))
|
||||
(should (equal contents "animal\nbird\ndove\npigeon\ncow\ndolphin\n"))))
|
||||
|
||||
(ert-deftest hierarchy-sort-non-root-nodes ()
|
||||
(let* ((animals (hierarchy-animals)))
|
||||
(should (equal (hierarchy-roots animals) '(animal)))
|
||||
(should (equal (hierarchy-children animals 'animal) '(bird cow dolphin)))
|
||||
(should (equal (hierarchy-children animals 'bird) '(dove pigeon)))))
|
||||
|
||||
(ert-deftest hierarchy-sort-roots ()
|
||||
(let* ((organisms (hierarchy-new))
|
||||
(parentfn (lambda (item)
|
||||
(cl-case item
|
||||
(oak 'plant)
|
||||
(bird 'animal)))))
|
||||
(hierarchy-add-tree organisms 'oak parentfn)
|
||||
(hierarchy-add-tree organisms 'bird parentfn)
|
||||
(hierarchy-sort organisms)
|
||||
(should (equal (hierarchy-roots organisms) '(animal plant)))))
|
||||
|
||||
(provide 'hierarchy-tests)
|
||||
;;; hierarchy-tests.el ends here
|
||||
Loading…
Add table
Reference in a new issue