X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/fd99dfe4bc82545d113f109cc87450918db56fba..4b07f2cf9a93f14a7a322c7624f17ab5dbeaf6e2:/packages/company-statistics/company-statistics.el diff --git a/packages/company-statistics/company-statistics.el b/packages/company-statistics/company-statistics.el index bf6a50f1a..62c3c1d18 100644 --- a/packages/company-statistics/company-statistics.el +++ b/packages/company-statistics/company-statistics.el @@ -1,10 +1,10 @@ -;;; company-statistics.el --- Sort candidates using completion history -*- lexical-binding:t -*- +;;; company-statistics.el --- Sort candidates using completion history -*- lexical-binding: t -*- ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ;; Author: Ingo Lohmar ;; URL: https://github.com/company-mode/company-statistics -;; Version: 0.1.1 +;; Version: 0.2.2 ;; Keywords: abbrev, convenience, matching ;; Package-Requires: ((emacs "24.3") (company "0.8.5")) @@ -27,7 +27,7 @@ ;; ;; Package installed from elpa.gnu.org: ;; -;; (add-hook 'after-init-hook 'company-statistics-mode) +;; (add-hook 'after-init-hook #'company-statistics-mode) ;; ;; Manually installed: make sure that this file is in load-path, and ;; @@ -40,10 +40,10 @@ ;; ;; The same candidate might occur in different modes, projects, files etc., and ;; possibly has a different meaning each time. Therefore along with the -;; completion, we store some context information. In the default configuration, -;; we track the overall frequency, the major-mode of the buffer, and the -;; filename (if it applies), and the same criteria are used to score all -;; possible candidates. +;; completion, we store some context information. In the default (heavy) +;; configuration, we track the overall frequency, the major-mode of the buffer, +;; the last preceding keyword, the parent symbol, and the filename (if it +;; applies), and the same criteria are used to score all possible candidates. ;;; Code: @@ -57,7 +57,7 @@ "Number of completion choices that `company-statistics' keeps track of. As this is a global cache, making it too small defeats the purpose." :type 'integer - :initialize (lambda (_option init-size) (setq company-statistics-size init-size)) + :initialize #'custom-initialize-default :set #'company-statistics--log-resize) (defcustom company-statistics-file @@ -74,14 +74,19 @@ As this is a global cache, making it too small defeats the purpose." not been used before." :type 'boolean) -(defcustom company-statistics-score-change #'company-statistics-score-change-default +(defcustom company-statistics-capture-context #'company-statistics-capture-context-heavy + "Function called with single argument (t if completion started manually). +This is the place to store any context information for a completion run." + :type 'function) + +(defcustom company-statistics-score-change #'company-statistics-score-change-heavy "Function called with completion choice. Using arbitrary other info, it should produce an alist, each entry labeling a context and the associated score update: ((ctx-a . 1) (\"str\" . 0.5) (nil . 1)). Nil is the global context." :type 'function) -(defcustom company-statistics-score-calc 'company-statistics-score-calc-default +(defcustom company-statistics-score-calc #'company-statistics-score-calc-heavy "Function called with completion candidate. Using arbitrary other info, eg, on the current context, it should evaluate to the candidate's score (a number)." @@ -101,14 +106,14 @@ number)." (defun company-statistics--init () "Initialize company-statistics." (setq company-statistics--scores - (make-hash-table :test 'equal :size company-statistics-size)) + (make-hash-table :test #'equal :size company-statistics-size)) (setq company-statistics--log (make-vector company-statistics-size nil) company-statistics--index 0)) (defun company-statistics--initialized-p () (hash-table-p company-statistics--scores)) -(defun company-statistics--log-resize (_option new-size) +(defun company-statistics--log-resize (option new-size) (when (company-statistics--initialized-p) ;; hash scoresheet auto-resizes, but log does not (let ((new-hist (make-vector new-size nil)) @@ -157,22 +162,95 @@ number)." ;; score calculation for insert/retrieval --- can be changed on-the-fly -(defun company-statistics-score-change-default (_cand) - "Count for global score, mode context, filename context." - (nconc ;when's nil is removed - (list (cons nil 1) (cons major-mode 1)) ;major-mode is never nil - (when buffer-file-name - (list (cons buffer-file-name 1))))) +(defun company-statistics-score-change-light (cand) + "Count for global score and mode context." + (list (cons nil 1) + (cons major-mode 1))) ;major-mode is never nil -(defun company-statistics-score-calc-default (cand) - "Global score, and bonus for matching major mode and filename." +(defun company-statistics-score-calc-light (cand) + "Global score, and bonus for matching major mode." (let ((scores (gethash cand company-statistics--scores))) + (if scores + ;; cand may be in scores and still have no global score left + (+ (or (cdr (assoc nil scores)) 0) + (or (cdr (assoc major-mode scores)) 0)) + 0))) + +(defvar company-statistics--context nil + "Current completion context, a list of entries searched using `assoc'.") + +(defun company-statistics--last-keyword () + "Return last keyword, ie, text of region fontified with the +font-lock-keyword-face up to point, or nil." + (let ((face-pos (point))) + (while (and (number-or-marker-p face-pos) + (< (point-min) face-pos) + (not (eq (get-text-property (1- face-pos) 'face) + 'font-lock-keyword-face))) + (setq face-pos + (previous-single-property-change face-pos 'face nil (point-min)))) + (when (and (number-or-marker-p face-pos) + (eq (get-text-property (max (point-min) (1- face-pos)) 'face) + 'font-lock-keyword-face)) + (list :keyword + (buffer-substring-no-properties + (previous-single-property-change face-pos 'face nil (point-min)) + face-pos))))) + +(defun company-statistics--parent-symbol () + "Return symbol immediately preceding current completion prefix, or nil. +May be separated by punctuation, but not by whitespace." + ;; expects to be at start of company-prefix; little sense for lisps + (let ((preceding (save-excursion + (unless (zerop (skip-syntax-backward ".")) + (substring-no-properties (symbol-name (symbol-at-point))))))) + (when preceding + (list :symbol preceding)))) + +(defun company-statistics--file-name () + "Return buffer file name, or nil." + (when buffer-file-name + (list :file buffer-file-name))) + +(defun company-statistics-capture-context-heavy (manual) + "Calculate some context, once for the whole completion run." + (save-excursion + (backward-char (length company-prefix)) + (setq company-statistics--context + (delq nil + (list (company-statistics--last-keyword) + (company-statistics--parent-symbol) + (company-statistics--file-name)))))) + +(defun company-statistics-score-change-heavy (cand) + "Count for global score, mode context, last keyword, parent symbol, +buffer file name." + (let ((last-kwd (assoc :keyword company-statistics--context)) + (parent-symbol (assoc :symbol company-statistics--context)) + (file (assoc :file company-statistics--context))) + (nconc ;when's nil is removed + (list (cons nil 1) + (cons major-mode 1)) ;major-mode is never nil + ;; only add pieces of context if non-nil + (when last-kwd (list (cons last-kwd 1))) + (when parent-symbol (list (cons parent-symbol 1))) + (when file (list (cons file 1)))))) + +(defun company-statistics-score-calc-heavy (cand) + "Global score, and bonus for matching major mode, last keyword, parent +symbol, buffer file name." + (let ((scores (gethash cand company-statistics--scores)) + (last-kwd (assoc :keyword company-statistics--context)) + (parent-symbol (assoc :symbol company-statistics--context)) + (file (assoc :file company-statistics--context))) (if scores ;; cand may be in scores and still have no global score left (+ (or (cdr (assoc nil scores)) 0) (or (cdr (assoc major-mode scores)) 0) - (or (cdr (when buffer-file-name ;to not get nil context - (assoc buffer-file-name scores))) 0)) + ;; some context may not apply, make sure to not get nil context + (or (cdr (when last-kwd (assoc last-kwd scores))) 0) + (or (cdr (when parent-symbol (assoc parent-symbol scores))) 0) + (or (cdr (when file (assoc file scores))) 0)) 0))) ;; score manipulation in one place --- know about hash value alist structure @@ -203,7 +281,7 @@ one. ALIST structure and cdrs may be changed!" (company-statistics--alist-update (gethash cand company-statistics--scores) score-updates - '+) + #'+) company-statistics--scores)) (defun company-statistics--log-revert (&optional index) @@ -219,8 +297,8 @@ one. ALIST structure and cdrs may be changed!" (company-statistics--alist-update (gethash cand company-statistics--scores) score-updates - '- - 'zerop))) + #'- + #'zerop))) (if new-scores ;sth left (puthash cand new-scores company-statistics--scores) (remhash cand company-statistics--scores)))))) @@ -234,6 +312,9 @@ one. ALIST structure and cdrs may be changed!" ;; core functions: updater, actual sorting transformer, minor-mode +(defun company-statistics--start (manual) + (funcall company-statistics-capture-context manual)) + (defun company-statistics--finished (result) "After completion, update scores and log." (let* ((score-updates (funcall company-statistics-score-change result)) @@ -274,10 +355,14 @@ configuration. You can customize this behavior with (company-statistics--init))) (add-to-list 'company-transformers 'company-sort-by-statistics 'append) + (add-hook 'company-completion-started-hook + 'company-statistics--start) (add-hook 'company-completion-finished-hook 'company-statistics--finished)) (setq company-transformers (delq 'company-sort-by-statistics company-transformers)) + (remove-hook 'company-completion-started-hook + 'company-statistics--start) (remove-hook 'company-completion-finished-hook 'company-statistics--finished)))