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

   1 ;;; company-statistics-tests.el --- company-statistics tests  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2014-2015  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 ../company-mode/ -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                (company-statistics--context
  81                 '((:keyword "if")
  82                   (:symbol "parent")
  83                   (:file "foo-file"))))
  84            (company-statistics--finished "foo"))
  85          (let ((major-mode 'foo-mode)
  86                (company-statistics--context
  87                 '((:symbol "statistics")
  88                   (:file "bar-file"))))
  89            (company-statistics--finished "bar"))
  90          (let ((major-mode 'baz-mode)
  91                (company-statistics--context
  92                 '((:keyword "unless")
  93                   (:symbol "company"))))
  94            (company-statistics--finished "baz"))
  95          (let ((major-mode 'baz-mode)
  96                (company-statistics--context
  97                 '((:keyword "when")
  98                   (:file "quux-file"))))
  99            (company-statistics--finished "quux"))
 100          ,@body)
 101      ;; tear down to clean slate
 102      (company-statistics--init)))
 103
 104 (defmacro cs-persistence-fixture (&rest body)
 105   "Check and prepare for persistence, clean up."
 106   `(let ((company-statistics-file "./cs-test-tmp"))
 107      (when (and (file-exists-p company-statistics-file)
 108                 (file-writable-p company-statistics-file))
 109        (unwind-protect
 110            (progn ,@body)
 111          ;; clean up file system
 112          (when (file-exists-p company-statistics-file)
 113            (delete-file company-statistics-file))))))
 114
 115 ;; tests themselves
 116
 117 (ert-deftest c-s-history-resize ()
 118   "Test history-resize for shrinking and enlarging."
 119   (cs-fixture
 120    ;; resize several times
 121    (let ((cs-scores (copy-tree company-statistics--scores))
 122          (cs-history (copy-tree company-statistics--log 'vecp)))
 123      (company-statistics--log-resize 'dummy 10)
 124      ;; scores unaffected?
 125      (should (my/hash-compare company-statistics--scores cs-scores))
 126      ;; find all 4 old entries
 127      (should (my/vector-slice-compare company-statistics--log
 128                                       (- company-statistics--index 4)
 129                                       cs-history 0
 130                                       4))
 131      ;; index at "old-size"
 132      (should (equal company-statistics--index 5))
 133      (company-statistics--log-resize 'dummy 5)
 134      (should (my/hash-compare company-statistics--scores cs-scores))
 135      (should (my/vector-slice-compare company-statistics--log
 136                                       (- company-statistics--index 4)
 137                                       cs-history 0
 138                                       4))
 139      ;; after shrink: index at 0
 140      (should (equal company-statistics--index 0))
 141      ;; lose oldest entry "foo"
 142      (company-statistics--log-resize 'dummy 3)
 143      ;; score should be removed
 144      (should-not (gethash "foo" company-statistics--scores))
 145      ;; find *3* latest entries
 146      (should (my/vector-slice-compare company-statistics--log
 147                                       (- company-statistics--index 3)
 148                                       cs-history 1
 149                                       3))
 150      (should (equal company-statistics--index 0)))))
 151
 152 (ert-deftest c-s-persistence ()
 153   "Test that all statistics are properly saved and restored."
 154   (cs-persistence-fixture
 155    (cs-fixture
 156     (let ((cs-scores (copy-sequence company-statistics--scores))
 157           (cs-history (copy-sequence company-statistics--log))
 158           (cs-index company-statistics--index))
 159       (company-statistics--save)
 160       (company-statistics--init)        ;hence shallow copies suffice
 161       (company-statistics--load)
 162       ;; (should (equal company-statistics--scores cs-scores))
 163       (should (my/hash-compare company-statistics--scores cs-scores))
 164       (should (equal company-statistics--log cs-history))
 165       (should (equal company-statistics--index cs-index))))))
 166
 167 (ert-deftest c-s-score-change-light ()
 168   "Test a few things about the default score updates."
 169   (let ((major-mode 'foobar-mode))
 170     (should (equal (company-statistics-score-change-light "dummy")
 171                    '((nil . 1) (foobar-mode . 1))))))
 172
 173 (ert-deftest c-s-score-calc-light ()
 174   "Test score calculation default."
 175   (cs-fixture
 176    ;; FIXME assumes that light context is a subset of the heavy context?
 177    (let ((major-mode 'foo-mode))
 178      (should (eq (company-statistics-score-calc-light "foo") 2))
 179      (should (eq (company-statistics-score-calc-light "bar") 2))
 180      (should (eq (company-statistics-score-calc-light "baz") 1))
 181      (should (eq (company-statistics-score-calc-light "quux") 1)))
 182    (let ((major-mode 'baz-mode))
 183      (should (eq (company-statistics-score-calc-light "foo") 1))
 184      (should (eq (company-statistics-score-calc-light "bar") 1))
 185      (should (eq (company-statistics-score-calc-light "baz") 2))
 186      (should (eq (company-statistics-score-calc-light "quux") 2)))))
 187
 188 (ert-deftest c-s-score-change-heavy ()
 189   "Test a few things about the heavy score updates."
 190   (let ((major-mode 'foobar-mode))
 191     (should (equal (company-statistics-score-change-heavy "dummy")
 192                    '((nil . 1) (foobar-mode . 1))))
 193     (let ((company-statistics--context
 194            '((:keyword "kwd")
 195              nil                        ;deliberately omit parent symbol
 196              (:file "test-file.XYZ"))))
 197       (should (equal (company-statistics-score-change-heavy "dummy")
 198                      '((nil . 1) (foobar-mode . 1)
 199                        ((:keyword "kwd") . 1)
 200                        ((:file "test-file.XYZ") . 1)))))))
 201
 202 (ert-deftest c-s-score-calc-heavy ()
 203   "Test heavy score calculation."
 204   (cs-fixture
 205    (let ((major-mode 'foo-mode)
 206          (company-statistics--context
 207           '((:symbol "company")
 208             (:file "foo-file"))))
 209      (should (eq (company-statistics-score-calc-heavy "dummy") 0))
 210      (should (eq (company-statistics-score-calc-heavy "foo") 3))
 211      (should (eq (company-statistics-score-calc-heavy "bar") 2))
 212      (should (eq (company-statistics-score-calc-heavy "baz") 2))
 213      (should (eq (company-statistics-score-calc-heavy "quux") 1)))
 214    (let ((major-mode 'foo-mode)
 215          (company-statistics--context
 216           '((:keyword "unless")
 217             (:symbol "parent")
 218             (:file "quux-file"))))
 219      (should (eq (company-statistics-score-calc-heavy "dummy") 0))
 220      (should (eq (company-statistics-score-calc-heavy "foo") 3))
 221      (should (eq (company-statistics-score-calc-heavy "bar") 2))
 222      (should (eq (company-statistics-score-calc-heavy "baz") 2))
 223      (should (eq (company-statistics-score-calc-heavy "quux") 2)))
 224    (let ((major-mode 'baz-mode)
 225          (company-statistics--context
 226           '((:keyword "when")
 227             (:file "baz-file"))))
 228      (should (eq (company-statistics-score-calc-heavy "dummy") 0))
 229      (should (eq (company-statistics-score-calc-heavy "foo") 1))
 230      (should (eq (company-statistics-score-calc-heavy "bar") 1))
 231      (should (eq (company-statistics-score-calc-heavy "baz") 2))
 232      (should (eq (company-statistics-score-calc-heavy "quux") 3)))
 233    (let ((major-mode 'baz-mode)
 234          (company-statistics--context
 235           '((:keyword "if")
 236             (:symbol "statistics")
 237             (:file "quux-file"))))
 238      (should (eq (company-statistics-score-calc-heavy "dummy") 0))
 239      (should (eq (company-statistics-score-calc-heavy "foo") 2))
 240      (should (eq (company-statistics-score-calc-heavy "bar") 2))
 241      (should (eq (company-statistics-score-calc-heavy "baz") 2))
 242      (should (eq (company-statistics-score-calc-heavy "quux") 3)))))
 243
 244 (ert-deftest c-s-alist-update ()
 245   "Test central helper function for context/score alist update."
 246   (let ((alist '((nil . 0) ("a" . 1) ("b" . 2) ("d" . some-symbol)))
 247         (updates '(("a" . 1) ("c" . 3))))
 248     (should (equal (company-statistics--alist-update alist updates '+)
 249                    '((nil . 0) ("a" . 2) ("b" . 2) ("d" . some-symbol) ("c" . 3)))))
 250   ;; filter only checks on merged, so nil entry remains, and symbol should not pose a problem:
 251   (let ((alist '((nil . 0) ("a" . 1) ("b" . 2) ("d" . some-symbol)))
 252         (updates '(("a" . 1) ("c" . 3))))
 253     (should (equal (company-statistics--alist-update alist updates '+ 'zerop)
 254                    '((nil . 0) ("a" . 2) ("b" . 2) ("d" . some-symbol) ("c" . 3)))))
 255   (let ((alist '((nil . 0) ("a" . 1) ("b" . 2) ("d" . some-symbol)))
 256         (updates '(("a" . 1) ("c" . 3))))
 257     (should (equal (company-statistics--alist-update alist updates '-)
 258                    '((nil . 0) ("a" . 0) ("b" . 2) ("d" . some-symbol) ("c" . 3)))))
 259   (let ((alist '((nil . 0) ("a" . 1) ("b" . 2) ("d" . some-symbol)))
 260         (updates '(("a" . 1) ("c" . 3))))
 261     (should (equal (company-statistics--alist-update alist updates '- 'zerop)
 262                    '((nil . 0) ("b" . 2) ("d" . some-symbol) ("c" . 3))))))
 263
 264 (ert-deftest c-s-scores-add ()
 265   "Test adding scores."
 266   (cs-fixture
 267    ;; new entry
 268    (company-statistics--scores-add "zufpah" '((nil . 27)))
 269    (should (equal (gethash "zufpah" company-statistics--scores)
 270                   '((nil . 27))))
 271    ;; update existing entry
 272    (company-statistics--scores-add "foo" '((nil . 2)))
 273    (let ((h (gethash "foo" company-statistics--scores)))
 274      (should (equal (assoc nil h) '(nil . 3)))
 275      (should (equal (assoc 'foo-mode h) '(foo-mode . 1))))))
 276
 277 (ert-deftest c-s-history-revert ()
 278   "Test reverting a score update stored in history."
 279   ;; deep copies throughout!
 280   (cs-fixture
 281    ;; pointing to nil, should not change anything
 282    (let ((cs-scores (copy-tree company-statistics--scores))
 283          (cs-history (copy-tree company-statistics--log 'vecp))
 284          (cs-index company-statistics--index))
 285      (company-statistics--log-revert)
 286      (should (my/hash-compare company-statistics--scores cs-scores))
 287      (should (equal company-statistics--log cs-history))
 288      (should (equal company-statistics--index cs-index))))
 289   (cs-fixture
 290    ;; remove existing item 2: should vanish from scores
 291    (let ((cs-scores (copy-tree company-statistics--scores))
 292          (cs-history (copy-tree company-statistics--log 'vecp))
 293          (cs-index company-statistics--index))
 294      (company-statistics--log-revert 2)
 295      (should-not (gethash "baz" company-statistics--scores))
 296      (should (equal company-statistics--log cs-history))
 297      (should (equal company-statistics--index cs-index))))
 298   (cs-fixture
 299    ;; remove just inserted item 3 (scores should be same)
 300    (let ((cs-scores (copy-tree company-statistics--scores))
 301          (cs-history (copy-tree company-statistics--log 'vecp))
 302          (cs-index company-statistics--index))
 303      (let ((major-mode 'extra-mode))
 304        (company-statistics--finished "foo")) ;adds to scores, history, index
 305      (company-statistics--log-revert 4) ;reverts scores only, so...
 306      (aset cs-history 4 '("foo" (nil . 1) (extra-mode . 1)))
 307      (setq cs-index (mod (1+ cs-index) company-statistics-size))
 308      (should (my/hash-compare company-statistics--scores cs-scores))
 309      (should (equal company-statistics--log cs-history))
 310      (should (equal company-statistics--index cs-index)))))
 311
 312 (ert-deftest c-s-history-store ()
 313   "Test insert/overwrite of history item."
 314   (cs-fixture
 315    (let ((cs-history (copy-tree company-statistics--log 'vecp))
 316          (cs-index company-statistics--index))
 317      ;; only changes history and index
 318      (company-statistics--log-store "foo" '((nil . 27)))
 319      (aset cs-history cs-index '("foo" (nil . 27)))
 320      (setq cs-index 0)                  ;wraps around
 321      (should (equal company-statistics--log cs-history))
 322      (should (equal company-statistics--index cs-index))
 323      ;; now wrap around to overwrite an entry
 324      (company-statistics--log-store "tagyok" '((bla . 42)))
 325      (aset cs-history cs-index '("tagyok" (bla . 42)))
 326      (setq cs-index 1)
 327      (should (equal company-statistics--log cs-history))
 328      (should (equal company-statistics--index cs-index)))))
 329
 330 ;; test finished and sort functions?  if the above is ok, they are trivial...