701 lines
30 KiB
EmacsLisp
701 lines
30 KiB
EmacsLisp
;;; hierarchy-tests.el --- Tests for hierarchy.el -*- lexical-binding:t -*-
|
||
|
||
;; 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 (_) 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)))))
|
||
|
||
(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.
|
||
Basically, 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 '(190 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
|