Merge commit '899a1f2bad8795a29c0df09c1bd28b3a3b7e48f8'

[gnu-emacs-elpa] / packages / company-statistics / company-statistics.el

diff --git a/packages/company-statistics/company-statistics.el b/packages/company-statistics/company-statistics.el
index bf6a50f1a69697b8db485e3e3b88a1b6e6570095..62c3c1d182fa9c0d2563db2691f10c9221a827e0 100644 (file)
--- 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 <i.lohmar@gmail.com>
 ;; URL: https://github.com/company-mode/company-statistics
 
 ;; Copyright (C) 2014-2015  Free Software Foundation, Inc.
 
 ;; Author: Ingo Lohmar <i.lohmar@gmail.com>
 ;; 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"))
 
 ;; Keywords: abbrev, convenience, matching
 ;; Package-Requires: ((emacs "24.3") (company "0.8.5"))
 


@@ -27,7 +27,7 @@
 ;;
 ;; Package installed from elpa.gnu.org:
 ;;
 ;;
 ;; 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
 ;;
 ;;
 ;; 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
 ;;
 ;; 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:
 
 
 ;;; 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
   "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
   :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)
 
 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)
 
   "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)."
   "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
 (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))
 
   (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))
   (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
 
 
 ;; 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)))
   (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)
     (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
       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--alist-update
             (gethash cand company-statistics--scores)
             score-updates

-            '+)
+            #'+)

            company-statistics--scores))
 
 (defun company-statistics--log-revert (&optional index)
            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
               (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))))))
         (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
 
 
 ;; 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))
 (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)
             (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))
         (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)))
 
     (remove-hook 'company-completion-finished-hook
                  'company-statistics--finished)))