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

   1 ;;; company-statistics.el --- sort candidates using completion history
   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 ;; - backends decide on available candidates (depends on prefix)
  25 ;; - we store how often a candidate is chosen (independent of prefixes)
  26 ;; - challenge: same candidate in several modes/projects/files,
  27 ;;   but with different meaning --- handled by context information
  28
  29 ;;; Code:
  30
  31 (require 'company)
  32
  33 (defgroup company-statistics nil
  34   "Completion candidates ranking by historical statistics."
  35   :group 'company)
  36
  37 (defcustom company-statistics-size 400
  38   "Number of completion choices that `company-statistics' keeps track of.
  39 As this is a global cache, making it too small defeats the purpose."
  40   :group 'company-statistics
  41   :type 'integer
  42   :initialize (lambda (option init-size) (setq company-statistics-size init-size))
  43   :set 'company-statistics--log-resize)
  44
  45 (defcustom company-statistics-file
  46   (concat user-emacs-directory "company-statistics-cache.el")
  47   "File to save company-statistics state."
  48   :group 'company-statistics
  49   :type 'string)
  50
  51 (defcustom company-statistics-auto-save t
  52   "Whether to save the statistics when leaving emacs."
  53   :group 'company-statistics
  54   :type 'boolean)
  55
  56 (defcustom company-statistics-auto-restore t
  57   "Whether to restore statistics when company-statistics is enabled and has
  58 not been used before."
  59   :group 'company-statistics
  60   :type 'boolean)
  61
  62 (defcustom company-statistics-score-change 'company-statistics-score-change-default
  63   "Function called with completion choice.  Using arbitrary other info,
  64 it should produce an alist, each entry labeling a context and the
  65 associated score update: ((ctx-a . 1) (\"str\" . 0.5) (nil . 1)).  Nil is
  66 the global context."
  67   :group 'company-statistics
  68   :type 'function)
  69
  70 (defcustom company-statistics-score-calc 'company-statistics-score-calc-default
  71   "Function called with completion candidate.  Using arbitrary other info,
  72 eg, on the current context, it should evaluate to the candidate's score (a
  73 number)."
  74   :group 'company-statistics
  75   :type 'function)
  76
  77 ;; internal vars, persistence
  78
  79 (defvar company-statistics--scores nil
  80   "Store selection frequency of candidates in given contexts.")
  81
  82 (defvar company-statistics--log nil
  83   "Ring keeping a log of statistics updates.")
  84
  85 (defvar company-statistics--index nil
  86   "Index into the log.")
  87
  88 (defun company-statistics--init ()
  89   "Initialize company-statistics."
  90   (setq company-statistics--scores
  91         (make-hash-table :test 'equal :size company-statistics-size))
  92   (setq company-statistics--log (make-vector company-statistics-size nil)
  93         company-statistics--index 0))
  94
  95 (defun company-statistics--initialized-p ()
  96   (hash-table-p company-statistics--scores))
  97
  98 (defun company-statistics--log-resize (option new-size)
  99   (when (company-statistics--initialized-p)
 100     ;; hash scoresheet auto-resizes, but log does not
 101     (let ((new-hist (make-vector new-size nil))
 102           ;; use actual length, to also work for freshly restored stats
 103           (company-statistics-size (length company-statistics--log)))
 104       ;; copy newest entries (possibly nil) to new-hist
 105       (dolist (i (number-sequence 0 (1- (min new-size company-statistics-size))))
 106         (let ((old-i (mod (+ (- company-statistics--index new-size) i)
 107                           company-statistics-size)))
 108           (aset new-hist i (aref company-statistics--log old-i))))
 109       ;; remove discarded log entry (when shrinking) from scores
 110       (when (< new-size company-statistics-size)
 111         (dolist (i (number-sequence
 112                     company-statistics--index
 113                     (+ company-statistics-size
 114                        company-statistics--index
 115                        (1- new-size))))
 116           (company-statistics--log-revert (mod i company-statistics-size))))
 117       (setq company-statistics--log new-hist)
 118       (setq company-statistics--index (if (<= new-size company-statistics-size)
 119                                           0
 120                                         company-statistics-size))))
 121   (setq company-statistics-size new-size))
 122
 123 (defun company-statistics--save ()
 124   "Save statistics."
 125   (with-temp-buffer
 126     (let (print-level print-length)
 127       (insert
 128        (format
 129         "%S"
 130         `(setq
 131           company-statistics--scores ,company-statistics--scores
 132           company-statistics--log ,company-statistics--log
 133           company-statistics--index ,company-statistics--index))))
 134     (write-file company-statistics-file)))
 135
 136 (defun company-statistics--maybe-save ()
 137   (when company-statistics-auto-save
 138     (company-statistics--save)))
 139
 140 (defun company-statistics--load ()
 141   "Restore statistics."
 142   (load company-statistics-file 'noerror nil 'nosuffix))
 143
 144 ;; score calculation for insert/retrieval --- can be changed on-the-fly
 145
 146 (defun company-statistics-score-change-default (cand)
 147   "Count for global score, mode context, filename context."
 148   (nconc                                ;when's nil is removed
 149    (list (cons nil 1) (cons major-mode 1)) ;major-mode is never nil
 150    (when buffer-file-name
 151      (list (cons buffer-file-name 1)))))
 152
 153 (defun company-statistics-score-calc-default (cand)
 154   "Global score, and bonus for matching major mode and filename."
 155   (let ((scores (gethash cand company-statistics--scores)))
 156     (if scores
 157         (+ (cdr (assoc nil scores))
 158            (or (cdr (assoc major-mode scores)) 0)
 159            (or (cdr (when buffer-file-name ;to not get nil context
 160                       (assoc buffer-file-name scores))) 0))
 161       0)))
 162
 163 ;; score manipulation in one place --- know about hash value alist structure
 164
 165 (defun company-statistics--alist-update (alist updates merger &optional filter)
 166   "Return new alist with conses from ALIST.  Their cdrs are updated
 167 to (merger cdr update-cdr) if the UPDATES alist contains an entry with an
 168 equal-matching car.  If FILTER called with the result is non-nil, remove
 169 the cons from the result.  If no matching cons exists in ALIST, add the new
 170 one.  ALIST structure and cdrs may be changed!"
 171   (let ((filter (or filter 'ignore))
 172         (updated alist)
 173         (new nil))
 174     (mapc
 175      (lambda (upd)
 176        (let ((found (assoc (car upd) alist)))
 177          (if found
 178              (let ((result (funcall merger (cdr found) (cdr upd))))
 179                (if (funcall filter result)
 180                    (setq updated (delete found updated))
 181                  (setcdr found result)))
 182            (push upd new))))
 183      updates)
 184     (nconc updated new)))
 185
 186 (defun company-statistics--scores-add (cand score-updates)
 187   (puthash cand
 188            (company-statistics--alist-update
 189             (gethash cand company-statistics--scores)
 190             score-updates
 191             '+)
 192            company-statistics--scores))
 193
 194 (defun company-statistics--log-revert (&optional index)
 195   "Revert score updates for log entry.  INDEX defaults to
 196 `company-statistics--index'."
 197   (let ((hist-entry
 198          (aref company-statistics--log
 199                (or index company-statistics--index))))
 200     (when hist-entry                    ;ignore nil entry
 201       (let* ((cand (car hist-entry))
 202              (score-updates (cdr hist-entry))
 203              (new-scores
 204               (company-statistics--alist-update
 205                (gethash cand company-statistics--scores)
 206                score-updates
 207                '-
 208                'zerop)))
 209         (if new-scores                    ;sth left
 210             (puthash cand new-scores company-statistics--scores)
 211           (remhash cand company-statistics--scores))))))
 212
 213 (defun company-statistics--log-store (result score-updates)
 214   "Insert/overwrite result and associated score updates."
 215   (aset company-statistics--log company-statistics--index
 216         (cons result score-updates))
 217   (setq company-statistics--index
 218         (mod (1+ company-statistics--index) company-statistics-size)))
 219
 220 ;; core functions: updater, actual sorting transformer, minor-mode
 221
 222 (defun company-statistics--finished (result)
 223   "After completion, update scores and log."
 224   (let* ((result (substring-no-properties result))
 225          (score-updates (funcall company-statistics-score-change result)))
 226     (company-statistics--scores-add result score-updates)
 227     (company-statistics--log-revert)
 228     (company-statistics--log-store result score-updates)))
 229
 230 (defun company-sort-by-statistics (candidates)
 231   "Sort candidates by historical statistics.  Stable sort, so order is only
 232 changed for candidates distinguishable by score."
 233   (setq candidates
 234         (sort candidates
 235               (lambda (cand1 cand2)
 236                 (>  (funcall company-statistics-score-calc cand1)
 237                     (funcall company-statistics-score-calc cand2))))))
 238
 239 ;;;###autoload
 240 (define-minor-mode company-statistics-mode
 241   "Statistical sorting for company-mode.  Ranks completion candidates by
 242 the frequency with which they have been chosen in recent (as given by
 243 `company-statistics-size') history.
 244
 245 Turning this mode on and off preserves the statistics.  They are also
 246 preserved automatically between Emacs sessions in the default
 247 configuration.  You can customize this behavior with
 248 `company-statistics-auto-save', `company-statistics-auto-restore' and
 249 `company-statistics-file'."
 250   nil nil nil
 251   :global t
 252   (if company-statistics-mode
 253       (progn
 254         (unless (company-statistics--initialized-p)
 255           (if (and company-statistics-auto-restore
 256                    (company-statistics--load))
 257               ;; maybe of different size
 258               (company-statistics--log-resize nil company-statistics-size)
 259             (company-statistics--init)))
 260         (add-to-list 'company-transformers
 261                      'company-sort-by-statistics 'append)
 262         (add-hook 'company-completion-finished-hook
 263                   'company-statistics--finished))
 264     (setq company-transformers
 265           (delq 'company-sort-by-statistics company-transformers))
 266     (remove-hook 'company-completion-finished-hook
 267                  'company-statistics--finished)))
 268
 269 (add-hook 'kill-emacs-hook 'company-statistics--maybe-save)
 270
 271 (provide 'company-statistics)
 272 ;;; company-statistics.el ends here