[elpa] externals/company b1b51b5 6/6: Merge pull request #1099 from mohkale/color-text-icons

[ELPA Syncer]

branch: externals/company
commit b1b51b5f0e4df12f427bb0ef6ff99bec059f0979
Merge: 9074b71 59bbbbc
Author: Dmitry Gutov <dgutov@yandex.ru>
Commit: GitHub <noreply@github.com>

    Merge pull request #1099 from mohkale/color-text-icons
    
    company-text-icons-mapping: Merge faces/colors into its format
---
 company.el | 195 ++++++++++++++++++++++++++++++++-----------------------------
 1 file changed, 102 insertions(+), 93 deletions(-)

diff --git a/company.el b/company.el
index 1792770..6a7c57c 100644
--- a/company.el
+++ b/company.el
@@ -1483,70 +1483,49 @@ end of the match."
                                 selected))
 
 (defcustom company-text-icons-mapping
-  '((array . "a")
-    (boolean . "b")
-    (class . "c")
-    (color . "#")
-    (constant . "c")
-    (enum-member . "e")
-    (enum . "e")
-    (field . "f")
-    (file . "f")
-    (folder . "d")
-    (interface . "i")
-    (keyword . "k")
-    (method . "m")
-    (function . "f")
-    (module . "{")
-    (numeric . "n")
-    (operator . "o")
-    (parameter . "p")
-    (property . "p")
-    (ruler . "r")
-    (snippet . "S")
-    (string . "s")
-    (struct . "s")
-    (text . "t")
-    (value . "v")
-    (variable . "v")
-    (t . "."))
-  "Mapping of the text icons."
+  '((array "a" font-lock-type-face)
+    (boolean "b" font-lock-builtin-face)
+    (class "c" font-lock-type-face)
+    (color "#" success)
+    (constant "c" font-lock-constant-face)
+    (enum-member "e" font-lock-builtin-face)
+    (enum "e" font-lock-builtin-face)
+    (field "f" font-lock-variable-name-face)
+    (file "f" font-lock-string-face)
+    (folder "d" font-lock-doc-face)
+    (interface "i" font-lock-type-face)
+    (keyword "k" font-lock-keyword-face)
+    (method "m" font-lock-function-name-face)
+    (function "f" font-lock-function-name-face)
+    (module "{" font-lock-type-face)
+    (numeric "n" font-lock-builtin-face)
+    (operator "o" font-lock-comment-delimiter-face)
+    (parameter "p" font-lock-builtin-face)
+    (property "p" font-lock-variable-name-face)
+    (ruler "r" shadow)
+    (snippet "S" font-lock-string-face)
+    (string "s" font-lock-string-face)
+    (struct "s" font-lock-variable-name-face)
+    (text "t" shadow)
+    (value "v" font-lock-builtin-face)
+    (variable "v" font-lock-variable-name-face)
+    (t "." shadow))
+  "Mapping of the text icons.
+The format should be an alist of (KIND . CONF) where CONF is a list of the
+form (ICON FG BG) which is used to propertize the icon to be shown for a
+candidate of kind KIND. FG can either be color string or a face from which
+we can get a color string (using the :foreground face-property). BG must be
+of the same form as FG or a cons cell of (BG . BG-WHEN-SELECTED) which each
+should be of the same form as FG.
+
+The only mandatory element in CONF is ICON, you can omit both the FG and BG
+fields without issue.
+
+When BG is omitted and `company-text-icons-add-background' is non-nil, a BG
+color will be generated using a gradient between the active tooltip color and
+the FG color."
   :type 'list)
 
-(defcustom company-text-kind-face-mapping
-  '((array . font-lock-type-face)
-    (boolean . font-lock-builtin-face)
-    (class . font-lock-type-face)
-    (color . success)
-    (constant . font-lock-constant-face)
-    (enum-member . font-lock-builtin-face)
-    (enum . font-lock-builtin-face)
-    (field . font-lock-variable-name-face)
-    (file . font-lock-string-face)
-    (folder . font-lock-doc-face)
-    (interface . font-lock-type-face)
-    (keyword . font-lock-keyword-face)
-    (method . font-lock-function-name-face)
-    (function . font-lock-function-name-face)
-    (module . font-lock-type-face)
-    (numeric . font-lock-builtin-face)
-    (operator . font-lock-comment-delimiter-face)
-    (parameter . font-lock-builtin-face)
-    (property . font-lock-variable-name-face)
-    ;; (ruler . nil)
-    (snippet . font-lock-string-face)
-    (string . font-lock-string-face)
-    (struct . font-lock-variable-name-face)
-    ;; (text . nil)
-    (value . font-lock-builtin-face)
-    (variable . font-lock-variable-name-face)
-    (t . shadow))
-  "Faces mapping for `company-text-icons-margin' and 
`company-dot-icons-margin'.
-Only their values of :foreground attribute will be used."
-  :type '(repeat
-          (cons (symbol :tag "Kind name")
-                (face :tag "Face to use for it"))))
-
 (defcustom company-text-face-extra-attributes '(:weight bold)
   "Additional attributes to add to text icons' faces.
 If non-nil, an anonymous face will be generated.
@@ -1558,54 +1537,84 @@ Only affects `company-text-icons-margin'."
   :type 'string)
 
 (defcustom company-text-icons-add-background nil
-  "When non-nil, add special background to the characters."
+  "When non-nil, generate a background color for text icons when none is given.
+See `company-text-icons-mapping'."
   :type 'boolean)
 
 (defun company-text-icons-margin (candidate selected)
   "Margin function which returns unicode icons."
   (when-let ((candidate candidate)
              (kind (company-call-backend 'kind candidate))
-             (icon (or (alist-get kind company-text-icons-mapping)
-                       (alist-get t company-text-icons-mapping)))
-             (face (or (assoc-default kind
-                                      company-text-kind-face-mapping)
-                       (assoc-default t company-text-kind-face-mapping))))
-    (propertize
-     (format company-text-icons-format icon)
-     'face
-     `(,@company-text-face-extra-attributes
-       ,@(when company-text-icons-add-background
-           (list :background
-                 (company-text-icons--background face selected)))
-       :foreground ,(face-attribute face :foreground)))))
+             (conf (or (alist-get kind company-text-icons-mapping)
+                       (alist-get t company-text-icons-mapping))))
+    (cl-destructuring-bind (icon &optional fg bg) conf
+      (propertize
+       (format company-text-icons-format icon)
+       'face
+       (company-text-icons--face fg bg selected)))))
 
 (declare-function color-rgb-to-hex "color")
 (declare-function color-gradient "color")
 
-(defun company-text-icons--background (face selected)
-  (apply #'color-rgb-to-hex
-         (nth 0 (color-gradient
-                 (color-name-to-rgb
-                  (face-attribute
-                   (if selected
-                       'company-tooltip-selection
-                     'company-tooltip)
-                   :background))
-                 (color-name-to-rgb
-                  (face-attribute face :foreground))
-                 10))))
+(cl-defsubst company-text-icons--extract-property (face property)
+  "Try to extract PROPERTY from FACE.
+If FACE isn't a valid face return FACE as is. If FACE doesn't have
+PROPERTY return nil."
+  (if (facep face)
+      (let ((value (face-attribute face property)))
+        (unless (eq value 'unspecified)
+          value))
+    face))
+
+(defun company-text-icons--face (fg bg selected)
+  (let ((fg-color (company-text-icons--extract-property fg :foreground)))
+    `(,@company-text-face-extra-attributes
+      ,@(and fg-color
+             (list :foreground fg-color))
+      ,@(let* ((bg-is-cons (consp bg))
+               (bg (if bg-is-cons (if selected (cdr bg) (car bg)) bg))
+               (bg-color (company-text-icons--extract-property bg :background))
+               (tooltip-bg-color (company-text-icons--extract-property
+                                  (if selected
+                                      'company-tooltip-selection
+                                    'company-tooltip)
+                                  :background)))
+          (cond
+           ((and company-text-icons-add-background selected
+                 (not bg-is-cons) bg-color tooltip-bg-color)
+            ;; Adjust the coloring of the background when *selected* but user 
hasn't
+            ;; specified an alternate background color for selected item icons.
+            (list :background
+                  (apply #'color-rgb-to-hex
+                         (nth 0 (color-gradient (color-name-to-rgb 
tooltip-bg-color)
+                                                (color-name-to-rgb bg-color)
+                                                2)))))
+           (bg
+            ;; When background is configured we use it as is, even if it 
doesn't
+            ;; constrast well with other candidates when selected.
+            (and bg-color
+                 (list :background bg-color)))
+           ((and company-text-icons-add-background fg-color tooltip-bg-color)
+            ;; Lastly attempt to generate a background from the foreground.
+            (list :background
+                  (apply #'color-rgb-to-hex
+                         (nth 0 (color-gradient (color-name-to-rgb 
tooltip-bg-color)
+                                                (color-name-to-rgb fg-color)
+                                                10))))))))))
 
 (defcustom company-dot-icons-format "●"
   "Format string for `company-dot-icons-margin'."
   :type 'string)
 
-(defun company-dot-icons-margin (candidate _selected)
+(defun company-dot-icons-margin (candidate selected)
   "Margin function that uses a colored dot to display completion kind."
   (when-let ((kind (company-call-backend 'kind candidate))
-             (face (or (assoc-default kind
-                                      company-text-kind-face-mapping)
-                       (assoc-default t company-text-kind-face-mapping))))
-    (propertize company-dot-icons-format 'face face)))
+             (conf (or (assoc-default kind company-text-icons-mapping)
+                       (assoc-default t company-text-icons-mapping))))
+    (cl-destructuring-bind (_icon &optional fg bg) conf
+      (propertize company-dot-icons-format
+                  'face
+                  (company-text-icons--face fg bg selected)))))
 
 (defun company-detect-icons-margin (candidate selected)
   "Margin function which picks the appropriate icon set automatically."