1 ;;; company-statistics-tests.el --- company-statistics tests
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;; emacs -batch -L . -l ert -l company-statistics-tests.el -f ert-run-tests-batch-and-exit
30 (require 'company-statistics)
31 (setq company-statistics-auto-restore nil
32 company-statistics-auto-save nil)
34 (company-statistics-mode)
38 (defun my/hash-compare (h1 h2 &optional pred)
39 "Check that hashes H1 and H2 use the same test, contain the same keys (as
40 per that test), and that their stored values agree (as per PRED, which
41 defaults to `equal')."
42 (let ((key-test (hash-table-test h1))
43 (pred (or pred 'equal)))
44 (and (eq key-test (hash-table-test h2))
45 (eq (hash-table-count h1) (hash-table-count h2))
47 (maphash (lambda (k v) (push k keys)) h1) ;get keys
48 (null ;expect no mismatch
50 (while keys ;if this finishes, it's nil
54 (setq keys (cdr keys))
55 (unless (funcall pred v1 v2)
56 (throw 'mismatch k))))))))))
58 (defun my/vector-slice-compare (v1 i1 v2 i2 count &optional pred)
59 "Check that COUNT vector entries of V1 (starting at index I1) and
60 V2 (starting at index I2) satisfy the binary predicate PRED, default
61 `equal'. Wraps around if index exceeds corresponding vector length."
62 (let ((pred (or pred 'equal)))
64 (let ((l1 (length v1))
67 (dolist (i (number-sequence 0 (1- count)))
69 (aref v1 (mod (+ i1 i) l1))
70 (aref v2 (mod (+ i2 i) l2)))
71 (throw 'mismatch t))))))))
73 (defmacro cs-fixture (&rest body)
74 "Set up a completion history."
76 ;; some setup to get a completion history
77 (let ((company-statistics-size 5))
78 (company-statistics--init)
79 (let ((major-mode 'foo-mode)
80 (buffer-file-name nil))
81 (company-statistics--finished "foo"))
82 (let ((major-mode 'foo-mode)
83 (buffer-file-name "bar-file"))
84 (company-statistics--finished "bar"))
85 (let ((major-mode 'baz-mode)
86 (buffer-file-name nil))
87 (company-statistics--finished "baz"))
88 (let ((major-mode 'baz-mode)
89 (buffer-file-name "quux-file"))
90 (company-statistics--finished "quux"))
92 ;; tear down to clean slate
93 (company-statistics--init)))
95 (defmacro cs-persistence-fixture (&rest body)
96 "Check and prepare for persistence, clean up."
97 `(let ((company-statistics-file "./cs-test-tmp"))
98 (when (and (file-exists-p company-statistics-file)
99 (file-writable-p company-statistics-file))
102 ;; clean up file system
103 (when (file-exists-p company-statistics-file)
104 (delete-file company-statistics-file))))))
108 (ert-deftest c-s-history-resize ()
109 "Test history-resize for shrinking and enlarging."
111 ;; resize several times
112 (let ((cs-scores (copy-tree company-statistics--scores))
113 (cs-history (copy-tree company-statistics--log 'vecp)))
114 (company-statistics--log-resize 'dummy 10)
115 ;; scores unaffected?
116 (should (my/hash-compare company-statistics--scores cs-scores))
117 ;; find all 4 old entries
118 (should (my/vector-slice-compare company-statistics--log
119 (- company-statistics--index 4)
122 ;; index at "old-size"
123 (should (equal company-statistics--index 5))
124 (company-statistics--log-resize 'dummy 5)
125 (should (my/hash-compare company-statistics--scores cs-scores))
126 (should (my/vector-slice-compare company-statistics--log
127 (- company-statistics--index 4)
130 ;; after shrink: index at 0
131 (should (equal company-statistics--index 0))
132 ;; lose oldest entry "foo"
133 (company-statistics--log-resize 'dummy 3)
134 ;; score should be removed
135 (should-not (gethash "foo" company-statistics--scores))
136 ;; find *3* latest entries
137 (should (my/vector-slice-compare company-statistics--log
138 (- company-statistics--index 3)
141 (should (equal company-statistics--index 0)))))
143 (ert-deftest c-s-persistence ()
144 "Test that all statistics are properly saved and restored."
145 (cs-persistence-fixture
147 (let ((cs-scores (copy-sequence company-statistics--scores))
148 (cs-history (copy-sequence company-statistics--log))
149 (cs-index company-statistics--index))
150 (company-statistics--save)
151 (company-statistics--init) ;hence shallow copies suffice
152 (company-statistics--load)
153 ;; (should (equal company-statistics--scores cs-scores))
154 (should (my/hash-compare company-statistics--scores cs-scores))
155 (should (equal company-statistics--log cs-history))
156 (should (equal company-statistics--index cs-index))))))
158 (ert-deftest c-s-score-change-default ()
159 "Test a few things about the default score updates."
160 (let ((major-mode 'foobar-mode)
161 (buffer-file-name nil)) ;must not generate context entries
162 (should (equal (company-statistics-score-change-default "dummy")
163 '((nil . 1) (foobar-mode . 1))))
164 (let ((buffer-file-name "test-file.XYZ"))
165 (should (equal (company-statistics-score-change-default "dummy")
166 '((nil . 1) (foobar-mode . 1) ("test-file.XYZ" . 1)))))))
168 (ert-deftest c-s-score-calc-default ()
169 "Test score calculation default."
171 (let ((major-mode 'foo-mode)
172 (buffer-file-name nil))
173 (should (eq (company-statistics-score-calc-default "foo") 2))
174 (should (eq (company-statistics-score-calc-default "bar") 2))
175 (should (eq (company-statistics-score-calc-default "baz") 1))
176 (should (eq (company-statistics-score-calc-default "quux") 1)))
177 (let ((major-mode 'foo-mode)
178 (buffer-file-name "bar-file"))
179 (should (eq (company-statistics-score-calc-default "foo") 2))
180 (should (eq (company-statistics-score-calc-default "bar") 3))
181 (should (eq (company-statistics-score-calc-default "baz") 1))
182 (should (eq (company-statistics-score-calc-default "quux") 1)))
183 (let ((major-mode 'baz-mode)
184 (buffer-file-name nil))
185 (should (eq (company-statistics-score-calc-default "foo") 1))
186 (should (eq (company-statistics-score-calc-default "bar") 1))
187 (should (eq (company-statistics-score-calc-default "baz") 2))
188 (should (eq (company-statistics-score-calc-default "quux") 2)))
189 (let ((major-mode 'baz-mode)
190 (buffer-file-name "quux-file"))
191 (should (eq (company-statistics-score-calc-default "foo") 1))
192 (should (eq (company-statistics-score-calc-default "bar") 1))
193 (should (eq (company-statistics-score-calc-default "baz") 2))
194 (should (eq (company-statistics-score-calc-default "quux") 3)))))
196 (ert-deftest c-s-alist-update ()
197 "Test central helper function for context/score alist update."
198 (let ((alist '((nil . 0) ("a" . 1) ("b" . 2) ("d" . some-symbol)))
199 (updates '(("a" . 1) ("c" . 3))))
200 (should (equal (company-statistics--alist-update alist updates '+)
201 '((nil . 0) ("a" . 2) ("b" . 2) ("d" . some-symbol) ("c" . 3)))))
202 ;; filter only checks on merged, so nil entry remains, and symbol should not pose a problem:
203 (let ((alist '((nil . 0) ("a" . 1) ("b" . 2) ("d" . some-symbol)))
204 (updates '(("a" . 1) ("c" . 3))))
205 (should (equal (company-statistics--alist-update alist updates '+ 'zerop)
206 '((nil . 0) ("a" . 2) ("b" . 2) ("d" . some-symbol) ("c" . 3)))))
207 (let ((alist '((nil . 0) ("a" . 1) ("b" . 2) ("d" . some-symbol)))
208 (updates '(("a" . 1) ("c" . 3))))
209 (should (equal (company-statistics--alist-update alist updates '-)
210 '((nil . 0) ("a" . 0) ("b" . 2) ("d" . some-symbol) ("c" . 3)))))
211 (let ((alist '((nil . 0) ("a" . 1) ("b" . 2) ("d" . some-symbol)))
212 (updates '(("a" . 1) ("c" . 3))))
213 (should (equal (company-statistics--alist-update alist updates '- 'zerop)
214 '((nil . 0) ("b" . 2) ("d" . some-symbol) ("c" . 3))))))
216 (ert-deftest c-s-scores-add ()
217 "Test adding scores."
220 (company-statistics--scores-add "zufpah" '((nil . 27)))
221 (should (equal (gethash "zufpah" company-statistics--scores)
223 ;; update existing entry
224 (company-statistics--scores-add "foo" '((nil . 2)))
225 (let ((h (gethash "foo" company-statistics--scores)))
226 (should (equal (assoc nil h) '(nil . 3)))
227 (should (equal (assoc 'foo-mode h) '(foo-mode . 1))))))
229 (ert-deftest c-s-history-revert ()
230 "Test reverting a score update stored in history."
231 ;; deep copies throughout!
233 ;; pointing to nil, should not change anything
234 (let ((cs-scores (copy-tree company-statistics--scores))
235 (cs-history (copy-tree company-statistics--log 'vecp))
236 (cs-index company-statistics--index))
237 (company-statistics--log-revert)
238 (should (my/hash-compare company-statistics--scores cs-scores))
239 (should (equal company-statistics--log cs-history))
240 (should (equal company-statistics--index cs-index))))
242 ;; remove existing item 2: should vanish from scores
243 (let ((cs-scores (copy-tree company-statistics--scores))
244 (cs-history (copy-tree company-statistics--log 'vecp))
245 (cs-index company-statistics--index))
246 (company-statistics--log-revert 2)
247 (should-not (gethash "baz" company-statistics--scores))
248 (should (equal company-statistics--log cs-history))
249 (should (equal company-statistics--index cs-index))))
251 ;; remove just inserted item 3 (scores should be same)
252 (let ((cs-scores (copy-tree company-statistics--scores))
253 (cs-history (copy-tree company-statistics--log 'vecp))
254 (cs-index company-statistics--index))
255 (let ((major-mode 'extra-mode))
256 (company-statistics--finished "foo")) ;adds to scores, history, index
257 (company-statistics--log-revert 4) ;reverts scores only, so...
258 (aset cs-history 4 '("foo" (nil . 1) (extra-mode . 1)))
259 (setq cs-index (mod (1+ cs-index) company-statistics-size))
260 (should (my/hash-compare company-statistics--scores cs-scores))
261 (should (equal company-statistics--log cs-history))
262 (should (equal company-statistics--index cs-index)))))
264 (ert-deftest c-s-history-store ()
265 "Test insert/overwrite of history item."
267 (let ((cs-history (copy-tree company-statistics--log 'vecp))
268 (cs-index company-statistics--index))
269 ;; only changes history and index
270 (company-statistics--log-store "foo" '((nil . 27)))
271 (aset cs-history cs-index '("foo" (nil . 27)))
272 (setq cs-index 0) ;wraps around
273 (should (equal company-statistics--log cs-history))
274 (should (equal company-statistics--index cs-index))
275 ;; now wrap around to overwrite an entry
276 (company-statistics--log-store "tagyok" '((bla . 42)))
277 (aset cs-history cs-index '("tagyok" (bla . 42)))
279 (should (equal company-statistics--log cs-history))
280 (should (equal company-statistics--index cs-index)))))
282 ;; test finished and sort functions? if the above is ok, they are trivial...