code.delx.au - gnu-emacs-elpa/blob - packages/company-statistics/company-statistics-tests.el

   1 ;;; company-statistics-tests.el --- company-statistics tests
   2
   3 ;; Copyright (C) 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Ingo Lohmar
   6
   7 ;; This file is part of GNU Emacs.
   8
   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.
  13
  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.
  18
  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/>.
  21
  22
  23 ;;; Commentary:
  24 ;; emacs -batch -L . -l ert -l company-statistics-tests.el  -f ert-run-tests-batch-and-exit
  25
  26 ;;; Code:
  27
  28 (require 'ert)
  29
  30 (require 'company-statistics)
  31 (setq company-statistics-auto-restore nil
  32       company-statistics-auto-save nil)
  33
  34 (company-statistics-mode)
  35
  36 ;;; Core
  37
  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))
  46          (let ((keys nil))
  47            (maphash (lambda (k v) (push k keys)) h1) ;get keys
  48            (null                                     ;expect no mismatch
  49             (catch 'mismatch
  50               (while keys               ;if this finishes, it's nil
  51                 (let* ((k (car keys))
  52                        (v1 (gethash k h1))
  53                        (v2 (gethash k h2)))
  54                   (setq keys (cdr keys))
  55                   (unless (funcall pred v1 v2)
  56                     (throw 'mismatch k))))))))))
  57
  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)))
  63     (null
  64      (let ((l1 (length v1))
  65            (l2 (length v2)))
  66        (catch 'mismatch
  67          (dolist (i (number-sequence 0 (1- count)))
  68            (unless (funcall pred
  69                             (aref v1 (mod (+ i1 i) l1))
  70                             (aref v2 (mod (+ i2 i) l2)))
  71              (throw 'mismatch t))))))))
  72
  73 (defmacro cs-fixture (&rest body)
  74   "Set up a completion history."
  75   `(unwind-protect
  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"))
  91          ,@body)
  92      ;; tear down to clean slate
  93      (company-statistics--init)))
  94
  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))
 100        (unwind-protect
 101            (progn ,@body)
 102          ;; clean up file system
 103          (when (file-exists-p company-statistics-file)
 104            (delete-file company-statistics-file))))))
 105
 106 ;; tests themselves
 107
 108 (ert-deftest c-s-history-resize ()
 109   "Test history-resize for shrinking and enlarging."
 110   (cs-fixture
 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)
 120                                       cs-history 0
 121                                       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)
 128                                       cs-history 0
 129                                       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)
 139                                       cs-history 1
 140                                       3))
 141      (should (equal company-statistics--index 0)))))
 142
 143 (ert-deftest c-s-persistence ()
 144   "Test that all statistics are properly saved and restored."
 145   (cs-persistence-fixture
 146    (cs-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))))))
 157
 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)))))))
 167
 168 (ert-deftest c-s-score-calc-default ()
 169   "Test score calculation default."
 170   (cs-fixture
 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)))))
 195
 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))))))
 215
 216 (ert-deftest c-s-scores-add ()
 217   "Test adding scores."
 218   (cs-fixture
 219    ;; new entry
 220    (company-statistics--scores-add "zufpah" '((nil . 27)))
 221    (should (equal (gethash "zufpah" company-statistics--scores)
 222                   '((nil . 27))))
 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))))))
 228
 229 (ert-deftest c-s-history-revert ()
 230   "Test reverting a score update stored in history."
 231   ;; deep copies throughout!
 232   (cs-fixture
 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))))
 241   (cs-fixture
 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))))
 250   (cs-fixture
 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)))))
 263
 264 (ert-deftest c-s-history-store ()
 265   "Test insert/overwrite of history item."
 266   (cs-fixture
 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)))
 278      (setq cs-index 1)
 279      (should (equal company-statistics--log cs-history))
 280      (should (equal company-statistics--index cs-index)))))
 281
 282 ;; test finished and sort functions?  if the above is ok, they are trivial...