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

   1 ;;; company-statistics.el --- Sort candidates using completion history  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2014-2015  Free Software Foundation, Inc.
   4
   5 ;; Author: Ingo Lohmar <i.lohmar@gmail.com>
   6 ;; URL: https://github.com/company-mode/company-statistics
   7 ;; Version: 0.2.2
   8 ;; Keywords: abbrev, convenience, matching
   9 ;; Package-Requires: ((emacs "24.3") (company "0.8.5"))
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27 ;;
  28 ;; Package installed from elpa.gnu.org:
  29 ;;
  30 ;;   (add-hook 'after-init-hook #'company-statistics-mode)
  31 ;;
  32 ;; Manually installed: make sure that this file is in load-path, and
  33 ;;
  34 ;;   (require 'company-statistics)
  35 ;;   (company-statistics-mode)
  36 ;;
  37 ;; Every time a candidate is chosen using company-mode, we keep track of this
  38 ;; (for a limited amount of recent choices).  When presenting completion
  39 ;; candidates next time, they are sorted according to the score thus acquired.
  40 ;;
  41 ;; The same candidate might occur in different modes, projects, files etc., and
  42 ;; possibly has a different meaning each time.  Therefore along with the
  43 ;; completion, we store some context information.  In the default (heavy)
  44 ;; configuration, we track the overall frequency, the major-mode of the buffer,
  45 ;; the last preceding keyword, the parent symbol, and the filename (if it
  46 ;; applies), and the same criteria are used to score all possible candidates.
  47
  48 ;;; Code:
  49
  50 (require 'company)
  51
  52 (defgroup company-statistics nil
  53   "Completion candidates ranking by historical statistics."
  54   :group 'company)
  55
  56 (defcustom company-statistics-size 400
  57   "Number of completion choices that `company-statistics' keeps track of.
  58 As this is a global cache, making it too small defeats the purpose."
  59   :type 'integer
  60   :initialize #'custom-initialize-default
  61   :set #'company-statistics--log-resize)
  62
  63 (defcustom company-statistics-file
  64   (concat user-emacs-directory "company-statistics-cache.el")
  65   "File to save company-statistics state."
  66   :type 'string)
  67
  68 (defcustom company-statistics-auto-save t
  69   "Whether to save the statistics when leaving emacs."
  70   :type 'boolean)
  71
  72 (defcustom company-statistics-auto-restore t
  73   "Whether to restore statistics when company-statistics is enabled and has
  74 not been used before."
  75   :type 'boolean)
  76
  77 (defcustom company-statistics-capture-context #'company-statistics-capture-context-heavy
  78   "Function called with single argument (t if completion started manually).
  79 This is the place to store any context information for a completion run."
  80   :type 'function)
  81
  82 (defcustom company-statistics-score-change #'company-statistics-score-change-heavy
  83   "Function called with completion choice.  Using arbitrary other info,
  84 it should produce an alist, each entry labeling a context and the
  85 associated score update: ((ctx-a . 1) (\"str\" . 0.5) (nil . 1)).  Nil is
  86 the global context."
  87   :type 'function)
  88
  89 (defcustom company-statistics-score-calc #'company-statistics-score-calc-heavy
  90   "Function called with completion candidate.  Using arbitrary other info,
  91 eg, on the current context, it should evaluate to the candidate's score (a
  92 number)."
  93   :type 'function)
  94
  95 ;; internal vars, persistence
  96
  97 (defvar company-statistics--scores nil
  98   "Store selection frequency of candidates in given contexts.")
  99
 100 (defvar company-statistics--log nil
 101   "Ring keeping a log of statistics updates.")
 102
 103 (defvar company-statistics--index nil
 104   "Index into the log.")
 105
 106 (defun company-statistics--init ()
 107   "Initialize company-statistics."
 108   (setq company-statistics--scores
 109         (make-hash-table :test #'equal :size company-statistics-size))
 110   (setq company-statistics--log (make-vector company-statistics-size nil)
 111         company-statistics--index 0))
 112
 113 (defun company-statistics--initialized-p ()
 114   (hash-table-p company-statistics--scores))
 115
 116 (defun company-statistics--log-resize (option new-size)
 117   (when (company-statistics--initialized-p)
 118     ;; hash scoresheet auto-resizes, but log does not
 119     (let ((new-hist (make-vector new-size nil))
 120           ;; use actual length, to also work for freshly restored stats
 121           (company-statistics-size (length company-statistics--log)))
 122       ;; copy newest entries (possibly nil) to new-hist
 123       (dolist (i (number-sequence 0 (1- (min new-size company-statistics-size))))
 124         (let ((old-i (mod (+ (- company-statistics--index new-size) i)
 125                           company-statistics-size)))
 126           (aset new-hist i (aref company-statistics--log old-i))))
 127       ;; remove discarded log entry (when shrinking) from scores
 128       (when (< new-size company-statistics-size)
 129         (dolist (i (number-sequence
 130                     company-statistics--index
 131                     (+ company-statistics-size
 132                        company-statistics--index
 133                        (1- new-size))))
 134           (company-statistics--log-revert (mod i company-statistics-size))))
 135       (setq company-statistics--log new-hist)
 136       (setq company-statistics--index (if (<= new-size company-statistics-size)
 137                                           0
 138                                         company-statistics-size))))
 139   (setq company-statistics-size new-size))
 140
 141 (defun company-statistics--save ()
 142   "Save statistics."
 143   (with-temp-buffer
 144     (let (print-level print-length)
 145       (insert
 146        (format
 147         "%S"
 148         `(setq
 149           company-statistics--scores ,company-statistics--scores
 150           company-statistics--log ,company-statistics--log
 151           company-statistics--index ,company-statistics--index))))
 152     (write-file company-statistics-file)))
 153
 154 (defun company-statistics--maybe-save ()
 155   (when (and (company-statistics--initialized-p)
 156              company-statistics-auto-save)
 157     (company-statistics--save)))
 158
 159 (defun company-statistics--load ()
 160   "Restore statistics."
 161   (load company-statistics-file 'noerror nil 'nosuffix))
 162
 163 ;; score calculation for insert/retrieval --- can be changed on-the-fly
 164
 165 (defun company-statistics-score-change-light (cand)
 166   "Count for global score and mode context."
 167   (list (cons nil 1)
 168         (cons major-mode 1)))           ;major-mode is never nil
 169
 170 (defun company-statistics-score-calc-light (cand)
 171   "Global score, and bonus for matching major mode."
 172   (let ((scores (gethash cand company-statistics--scores)))
 173     (if scores
 174         ;; cand may be in scores and still have no global score left
 175         (+ (or (cdr (assoc nil scores)) 0)
 176            (or (cdr (assoc major-mode scores)) 0))
 177       0)))
 178
 179 (defvar company-statistics--context nil
 180   "Current completion context, a list of entries searched using `assoc'.")
 181
 182 (defun company-statistics--last-keyword ()
 183   "Return last keyword, ie, text of region fontified with the
 184 font-lock-keyword-face up to point, or nil."
 185   (let ((face-pos (point)))
 186     (while (and (number-or-marker-p face-pos)
 187                 (< (point-min) face-pos)
 188                 (not (eq (get-text-property (1- face-pos) 'face)
 189                          'font-lock-keyword-face)))
 190       (setq face-pos
 191             (previous-single-property-change face-pos 'face nil (point-min))))
 192     (when (and (number-or-marker-p face-pos)
 193                (eq (get-text-property (max (point-min) (1- face-pos)) 'face)
 194                    'font-lock-keyword-face))
 195       (list :keyword
 196             (buffer-substring-no-properties
 197              (previous-single-property-change face-pos 'face nil (point-min))
 198              face-pos)))))
 199
 200 (defun company-statistics--parent-symbol ()
 201   "Return symbol immediately preceding current completion prefix, or nil.
 202 May be separated by punctuation, but not by whitespace."
 203   ;; expects to be at start of company-prefix; little sense for lisps
 204   (let ((preceding (save-excursion
 205                      (unless (zerop (skip-syntax-backward "."))
 206                        (substring-no-properties (symbol-name (symbol-at-point)))))))
 207     (when preceding
 208       (list :symbol preceding))))
 209
 210 (defun company-statistics--file-name ()
 211   "Return buffer file name, or nil."
 212   (when buffer-file-name
 213     (list :file buffer-file-name)))
 214
 215 (defun company-statistics-capture-context-heavy (manual)
 216   "Calculate some context, once for the whole completion run."
 217   (save-excursion
 218     (backward-char (length company-prefix))
 219     (setq company-statistics--context
 220           (delq nil
 221                 (list (company-statistics--last-keyword)
 222                       (company-statistics--parent-symbol)
 223                       (company-statistics--file-name))))))
 224
 225 (defun company-statistics-score-change-heavy (cand)
 226   "Count for global score, mode context, last keyword, parent symbol,
 227 buffer file name."
 228   (let ((last-kwd (assoc :keyword company-statistics--context))
 229         (parent-symbol (assoc :symbol company-statistics--context))
 230         (file (assoc :file company-statistics--context)))
 231     (nconc                                ;when's nil is removed
 232      (list (cons nil 1)
 233            (cons major-mode 1)) ;major-mode is never nil
 234      ;; only add pieces of context if non-nil
 235      (when last-kwd (list (cons last-kwd 1)))
 236      (when parent-symbol (list (cons parent-symbol 1)))
 237      (when file (list (cons file 1))))))
 238
 239 (defun company-statistics-score-calc-heavy (cand)
 240   "Global score, and bonus for matching major mode, last keyword, parent
 241 symbol, buffer file name."
 242   (let ((scores (gethash cand company-statistics--scores))
 243         (last-kwd (assoc :keyword company-statistics--context))
 244         (parent-symbol (assoc :symbol company-statistics--context))
 245         (file (assoc :file company-statistics--context)))
 246     (if scores
 247         ;; cand may be in scores and still have no global score left
 248         (+ (or (cdr (assoc nil scores)) 0)
 249            (or (cdr (assoc major-mode scores)) 0)
 250            ;; some context may not apply, make sure to not get nil context
 251            (or (cdr (when last-kwd (assoc last-kwd scores))) 0)
 252            (or (cdr (when parent-symbol (assoc parent-symbol scores))) 0)
 253            (or (cdr (when file (assoc file scores))) 0))
 254       0)))
 255
 256 ;; score manipulation in one place --- know about hash value alist structure
 257
 258 (defun company-statistics--alist-update (alist updates merger &optional filter)
 259   "Return new alist with conses from ALIST.  Their cdrs are updated
 260 to (merger cdr update-cdr) if the UPDATES alist contains an entry with an
 261 equal-matching car.  If FILTER called with the result is non-nil, remove
 262 the cons from the result.  If no matching cons exists in ALIST, add the new
 263 one.  ALIST structure and cdrs may be changed!"
 264   (let ((filter (or filter 'ignore))
 265         (updated alist)
 266         (new nil))
 267     (mapc
 268      (lambda (upd)
 269        (let ((found (assoc (car upd) alist)))
 270          (if found
 271              (let ((result (funcall merger (cdr found) (cdr upd))))
 272                (if (funcall filter result)
 273                    (setq updated (delete found updated))
 274                  (setcdr found result)))
 275            (push upd new))))
 276      updates)
 277     (nconc updated new)))
 278
 279 (defun company-statistics--scores-add (cand score-updates)
 280   (puthash cand
 281            (company-statistics--alist-update
 282             (gethash cand company-statistics--scores)
 283             score-updates
 284             #'+)
 285            company-statistics--scores))
 286
 287 (defun company-statistics--log-revert (&optional index)
 288   "Revert score updates for log entry.  INDEX defaults to
 289 `company-statistics--index'."
 290   (let ((hist-entry
 291          (aref company-statistics--log
 292                (or index company-statistics--index))))
 293     (when hist-entry                    ;ignore nil entry
 294       (let* ((cand (car hist-entry))
 295              (score-updates (cdr hist-entry))
 296              (new-scores
 297               (company-statistics--alist-update
 298                (gethash cand company-statistics--scores)
 299                score-updates
 300                #'-
 301                #'zerop)))
 302         (if new-scores                    ;sth left
 303             (puthash cand new-scores company-statistics--scores)
 304           (remhash cand company-statistics--scores))))))
 305
 306 (defun company-statistics--log-store (result score-updates)
 307   "Insert/overwrite result and associated score updates."
 308   (aset company-statistics--log company-statistics--index
 309         (cons result score-updates))
 310   (setq company-statistics--index
 311         (mod (1+ company-statistics--index) company-statistics-size)))
 312
 313 ;; core functions: updater, actual sorting transformer, minor-mode
 314
 315 (defun company-statistics--start (manual)
 316   (funcall company-statistics-capture-context manual))
 317
 318 (defun company-statistics--finished (result)
 319   "After completion, update scores and log."
 320   (let* ((score-updates (funcall company-statistics-score-change result))
 321          (result (substring-no-properties result)))
 322     (company-statistics--scores-add result score-updates)
 323     (company-statistics--log-revert)
 324     (company-statistics--log-store result score-updates)))
 325
 326 (defun company-sort-by-statistics (candidates)
 327   "Sort candidates by historical statistics.  Stable sort, so order is only
 328 changed for candidates distinguishable by score."
 329   (setq candidates
 330         (sort candidates
 331               (lambda (cand1 cand2)
 332                 (>  (funcall company-statistics-score-calc cand1)
 333                     (funcall company-statistics-score-calc cand2))))))
 334
 335 ;;;###autoload
 336 (define-minor-mode company-statistics-mode
 337   "Statistical sorting for company-mode.  Ranks completion candidates by
 338 the frequency with which they have been chosen in recent (as given by
 339 `company-statistics-size') history.
 340
 341 Turning this mode on and off preserves the statistics.  They are also
 342 preserved automatically between Emacs sessions in the default
 343 configuration.  You can customize this behavior with
 344 `company-statistics-auto-save', `company-statistics-auto-restore' and
 345 `company-statistics-file'."
 346   nil nil nil
 347   :global t
 348   (if company-statistics-mode
 349       (progn
 350         (unless (company-statistics--initialized-p)
 351           (if (and company-statistics-auto-restore
 352                    (company-statistics--load))
 353               ;; maybe of different size
 354               (company-statistics--log-resize nil company-statistics-size)
 355             (company-statistics--init)))
 356         (add-to-list 'company-transformers
 357                      'company-sort-by-statistics 'append)
 358         (add-hook 'company-completion-started-hook
 359                   'company-statistics--start)
 360         (add-hook 'company-completion-finished-hook
 361                   'company-statistics--finished))
 362     (setq company-transformers
 363           (delq 'company-sort-by-statistics company-transformers))
 364     (remove-hook 'company-completion-started-hook
 365                  'company-statistics--start)
 366     (remove-hook 'company-completion-finished-hook
 367                  'company-statistics--finished)))
 368
 369 (add-hook 'kill-emacs-hook 'company-statistics--maybe-save)
 370
 371 (provide 'company-statistics)
 372 ;;; company-statistics.el ends here