bug#19338: [PATCH 2/3] descr-text: add `describe-char-eldoc' describing character at point

[Michal Nazarewicz <mpn@google.com>]

From: Michal Nazarewicz <mina86@mina86.com>

* lisp/descr-text.el (describe-char-eldoc): New function returning
basic Unicode codepoint information (e.g. name) about character
at point.  It is meant to be used as a default value of the
`eldoc-documentation-function' variable.
(describe-char-eldoc--format, describe-char-eldoc--truncate):
New helper functions for `describe-char-eldoc' function.

* tests/automated/descr-text-test.el: New file with tests for
`describe-char-eldoc--truncate', `describe-char-eldoc--format',
and `describe-char-eldoc'.
---
 etc/NEWS                          |  4 ++
 lisp/descr-text.el                | 96 +++++++++++++++++++++++++++++++++++++++
 test/automated/descr-text-test.el | 94 ++++++++++++++++++++++++++++++++++++++
 3 files changed, 194 insertions(+)
 create mode 100644 test/automated/descr-text-test.el

diff --git a/etc/NEWS b/etc/NEWS
index 50338cf..77a2f9b 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -203,6 +203,10 @@ result of the calculation into the current buffer.
 *** `eldoc-documentation-function' now defaults to nil
 *** Default value of `eldoc-documentation-function now' is consulted if
 local function does not return any documentation.
+*** `describe-char-eldoc' displays information about character at point,
+and can be used as a default value of `eldoc-documentation-function'.  It is
+useful when, for example, one needs to distinguish various spaces (e.g. ] [,
+] [, ] [, etc.) while using mono-spaced font.
 
 ** eww
 
diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index 1dc43e9..d435fe6 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -825,6 +825,102 @@ relevant to POS."
 
 (define-obsolete-function-alias 'describe-char-after 'describe-char "22.1")
 
+;;; Describe-Char-ElDoc
+
+(defun describe-char-eldoc--truncate (name width)
+  "Truncate NAME at white spaces such that it is no longer than WIDTH.
+
+If NAME consists of white space only, return an empty string.
+
+Otherwise, if NAME consists of a single word (where word is defined as sequence
+of non-white space characters), return that word even if it's longer than WIDTH.
+
+Otherwise, if first word in NAME is longer or equal WIDTH, return that word with
+ellipsis character (\"…\") appended; this results in a string longer than WIDTH.
+
+Otherwise, take as many words from NAME as possible, separating them with
+a single space character, while not exceeding WIDTH characters length limit.  If
+not all words fit, append ellipsis character (\"…\") at the end; the ellipsis is
+counted towards WIDTH."
+  (let ((words (split-string name)))
+    (if words
+        (let ((last words))
+          (setq width (- width (length (car words))))
+          (while (and (cdr last)
+                      (<= (+ (length (cadr last)) (if (cddr last) 2 1)) width))
+            (setq last (cdr last))
+            (setq width (- width (length (car last)) 1)))
+          (let ((ellipsis (and (cdr last) "…")))
+            (setcdr last nil)
+            (concat (mapconcat 'identity words " ") ellipsis)))
+      "")))
+
+(defun describe-char-eldoc--format (ch &optional width)
+  "Format a description for character CH which is no more than WIDTH characters.
+
+Full description message has a \"U+<hex>: <name> (<gc>: <general category>)\"
+format where:
+- <hex> is a hexadecimal codepoint of the character (zero-padded to at least
+  four digits),
+- <name> is name of the character.
+- <gc> is a two-letter abbreviation of the general-category of the character,
+  and
+- <general category> is full name of the general-category of the character.
+
+If WIDTH is non-nil some elements of the description may be omitted to
+accommodate the length restriction.  Under certain condition, the function may
+return string longer than WIDTH, see `describe-char-eldoc--truncate'."
+  (let ((name (get-char-code-property ch 'name)))
+    (when name
+      (let* ((code (propertize (format "U+%04X" ch)
+                               'face 'font-lock-constant-face))
+             (gc (get-char-code-property ch 'general-category))
+             (gc-desc (char-code-property-description 'general-category gc)))
+
+        (unless (or (not width) (<= (length name) width))
+          (setq name (describe-char-eldoc--truncate name width)))
+        (setq name (concat (substring name 0 1) (downcase (substring name 1))))
+        (setq name (propertize name 'face 'font-lock-variable-name-face))
+
+        (setq gc (propertize (symbol-name gc) 'face 'font-lock-comment-face))
+        (when gc-desc
+          (setq gc-desc (propertize gc-desc 'face 'font-lock-comment-face)))
+
+        (let ((lcode    (length code))
+              (lname    (length name))
+              (lgc      (length gc))
+              (lgc-desc (and gc-desc (length gc-desc))))
+          (cond
+           ((and gc-desc
+                 (or (not width) (<= (+ lcode lname lgc lgc-desc 7) width)))
+            (concat code ": " name " (" gc ": " gc-desc ")"))
+           ((and gc-desc (<= (+ lcode lname lgc-desc 5) width))
+            (concat code ": " name " (" gc-desc ")"))
+           ((or (not width) (<= (+ lcode lname lgc 5) width))
+            (concat code ": " name " (" gc ")"))
+           ((<= (+ lname lgc 3) width)
+            (concat name " (" gc ")"))
+           (t name)))))))
+
+;;;###autoload
+(defun describe-char-eldoc ()
+  "Returns a description of character at point for use by ElDoc mode.
+
+If character at point is a printable ASCII character (i.e. codepoint between 32
+and 127 inclusively), nil is returned.  Otherwise a description formatted by
+`describe-char-eldoc--format' function is returned taking into account value
+of `eldoc-echo-area-use-multiline-p' variable and width of minibuffer window for
+width limit.
+
+This function is meant to be used as a value of `eldoc-documentation-function'
+variable."
+  (let ((ch (following-char)))
+    (when (and (not (zerop ch)) (or (< ch 32) (> ch 127)))
+      (describe-char-eldoc--format
+       ch
+       (unless (eq eldoc-echo-area-use-multiline-p t)
+         (1- (window-width (minibuffer-window))))))))
+
 (provide 'descr-text)
 
 ;;; descr-text.el ends here
diff --git a/test/automated/descr-text-test.el b/test/automated/descr-text-test.el
new file mode 100644
index 0000000..81a4375
--- /dev/null
+++ b/test/automated/descr-text-test.el
@@ -0,0 +1,94 @@
+;;; descr-text-test.el --- ERT tests for descr-text.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+
+;; Author:     Michal Nazarewicz <mina86@mina86.com>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package defines regression tests for the descr-text package.
+
+;;; Code:
+
+(require 'ert)
+(require 'descr-text)
+
+
+(ert-deftest descr-text-test-truncate ()
+  "Tests describe-char-eldoc--truncate function."
+  (should (equal ""
+                 (describe-char-eldoc--truncate " \t \n" 100)))
+  (should (equal "foo"
+                 (describe-char-eldoc--truncate "foo" 1)))
+  (should (equal "foo…"
+                 (describe-char-eldoc--truncate "foo wilma fred" 0)))
+  (should (equal "foo…"
+                 (describe-char-eldoc--truncate
+                  "foo wilma fred" (length "foo wilma"))))
+  (should (equal "foo wilma…"
+                 (describe-char-eldoc--truncate
+                  "foo wilma fred" (1+ (length "foo wilma")))))
+  (should (equal "foo wilma…"
+                 (describe-char-eldoc--truncate
+                  "foo wilma fred" (1- (length "foo wilma fred")))))
+  (should (equal "foo wilma fred"
+                 (describe-char-eldoc--truncate
+                  "foo wilma fred" (length "foo wilma fred"))))
+  (should (equal "foo wilma fred"
+                 (describe-char-eldoc--truncate
+                  "  foo\t wilma \nfred\t " (length "foo wilma fred")))))
+
+(ert-deftest descr-text-test-format-desc ()
+  "Tests describe-char-eldoc--format function."
+  (should (equal "U+2026: Horizontal ellipsis (Po: Punctuation, Other)"
+                 (describe-char-eldoc--format ?…)))
+  (should (equal "U+2026: Horizontal ellipsis (Punctuation, Other)"
+                 (describe-char-eldoc--format ?… 51)))
+  (should (equal "U+2026: Horizontal ellipsis (Po)"
+                 (describe-char-eldoc--format ?… 40)))
+  (should (equal "Horizontal ellipsis (Po)"
+                 (describe-char-eldoc--format ?… 30)))
+  (should (equal "Horizontal ellipsis"
+                 (describe-char-eldoc--format ?… 20)))
+  (should (equal "Horizontal…"
+                 (describe-char-eldoc--format ?… 10))))
+
+(ert-deftest descr-text-test-desc ()
+  "Tests describe-char-eldoc function."
+  (with-temp-buffer
+    (insert "a…")
+    (goto-char (point-min))
+    (should (eq ?a (following-char))) ; make sure we are where we think we are
+    ;; Function should return nil for an ASCII character.
+    (should (not (describe-char-eldoc)))
+
+    (goto-char (1+ (point)))
+    (should (eq ?… (following-char)))
+    (let ((eldoc-echo-area-use-multiline-p t))
+      ;; Function should return description of an Unicode character.
+      (should (equal "U+2026: Horizontal ellipsis (Po: Punctuation, Other)"
+                     (describe-char-eldoc))))
+
+    (goto-char (point-max))
+    ;; At the end of the buffer, function should return nil and not blow up.
+    (should (not (describe-char-eldoc)))))
+
+
+(provide 'descr-text-test)
+
+;;; descr-text-test.el ends here
-- 
2.2.0.rc0.207.ga3a616c