[nongnu] elpa/telephone-line 426a598c4a 056/195: Start work on memoize replacement

[ELPA Syncer]

branch: elpa/telephone-line
commit 426a598c4abdbdc9cf702f383f6b9ea7c6d084c1
Author: Daniel Bordak <dbordak@fastmail.fm>
Commit: Daniel Bordak <dbordak@fastmail.fm>

    Start work on memoize replacement
---
 telephone-line-separators.el | 28 +++++++++-------
 telephone-line-utils.el      | 76 ++++++++++++++++++++++++++++++++++++--------
 telephone-line.el            | 18 +++++------
 3 files changed, 88 insertions(+), 34 deletions(-)

diff --git a/telephone-line-separators.el b/telephone-line-separators.el
index ddada6b970..b786973c76 100644
--- a/telephone-line-separators.el
+++ b/telephone-line-separators.el
@@ -31,18 +31,22 @@
             (/ num (float width)))
           (number-sequence 1 width)))
 
-(telephone-line-defseparator telephone-line-abs-right
-  #'abs #'telephone-line-row-pattern
-  #xe0b2)
-(telephone-line-defseparator telephone-line-abs-left
-  (telephone-line-complement abs) #'telephone-line-row-pattern
-  #xe0b0)
-(telephone-line-defsubseparator telephone-line-abs-hollow-right
-  #'abs #'telephone-line-row-pattern-hollow
-  #xe0b3)
-(telephone-line-defsubseparator telephone-line-abs-hollow-left
-  (telephone-line-complement abs) #'telephone-line-row-pattern-hollow
-  #xe0b1)
+(defvar telephone-line-abs-right
+  (telephone-line-separator "abs-right"
+              :axis-func #'abs
+              :alt-char #xe0b2))
+(defvar telephone-line-abs-left
+  (telephone-line-separator "abs-left"
+              :axis-func (telephone-line-complement abs)
+              :alt-char #xe0b2))
+(defvar telephone-line-abs-hollow-right
+  (telephone-line-subseparator "abs-hollow-right"
+                 :axis-func #'abs
+                 :alt-char #xe0b2))
+(defvar telephone-line-abs-hollow-left
+  (telephone-line-subseparator "abs-hollow-left"
+                 :axis-func (telephone-line-complement abs)
+                 :alt-char #xe0b2))
 
 (telephone-line-defseparator telephone-line-cubed-right
   (lambda (x) (expt x 3)) #'telephone-line-row-pattern)
diff --git a/telephone-line-utils.el b/telephone-line-utils.el
index 9a2457f6dd..e57b51bdd7 100644
--- a/telephone-line-utils.el
+++ b/telephone-line-utils.el
@@ -21,6 +21,7 @@
 
 (require 'cl-lib)
 (require 'color)
+(require 'eieio)
 
 (require 'memoize)
 (require 's)
@@ -140,7 +141,7 @@ color1 and color2."
        (cons (- 1 rem)  ;Right AA pixel
              (make-list (- total intpadding 2) 1)))))) ;Right gap
 
-(defun telephone-line-create-body (width height axis-func pattern-func)
+(defun telephone-line--create-body (width height axis-func pattern-func)
   "Create a bytestring of a PBM image body of dimensions WIDTH and HEIGHT, and 
shape created from AXIS-FUNC and PATTERN-FUNC."
   (let* ((normalized-axis (telephone-line--normalize-axis
                            (mapcar axis-func (telephone-line-create-axis 
height))))
@@ -175,17 +176,6 @@ color1 and color2."
                            :background bg-color
                            :inverse-video t))))))
 
-(defmacro telephone-line-defseparator (name axis-func pattern-func &optional 
alt-char forced-width)
-  "Define a separator named NAME, using AXIS-FUNC and PATTERN-FUNC to create 
the shape, optionally forcing FORCED-WIDTH.
-
-NOTE: Forced-width primary separators are not currently supported."
-  (declare (indent defun))
-  `(telephone-line--defseparator-internal ,name
-     (let ((height (telephone-line-separator-height))
-           (width (or ,forced-width (telephone-line-separator-width))))
-       (telephone-line-create-body width height ,axis-func ,pattern-func))
-     (char-to-string ,alt-char)))
-
 (defun telephone-line--pad-body (body char-width)
   "Pad 2d byte-list BODY to a width of CHAR-WIDTH, given as a number of 
characters."
   (let* ((body-width (length (car body)))
@@ -196,6 +186,17 @@ NOTE: Forced-width primary separators are not currently 
supported."
               (append left-padding row right-padding))
             body)))
 
+(defmacro telephone-line-defseparator (name axis-func pattern-func &optional 
alt-char forced-width)
+  "Define a separator named NAME, using AXIS-FUNC and PATTERN-FUNC to create 
the shape, optionally forcing FORCED-WIDTH.
+
+NOTE: Forced-width primary separators are not currently supported."
+  (declare (indent defun))
+  `(telephone-line--defseparator-internal ,name
+     (let ((height (telephone-line-separator-height))
+           (width (or ,forced-width (telephone-line-separator-width))))
+       (telephone-line--create-body width height ,axis-func ,pattern-func))
+     (char-to-string ,alt-char)))
+
 (defmacro telephone-line-defsubseparator (name axis-func pattern-func 
&optional alt-char forced-width)
   "Define a subseparator named NAME, using AXIS-FUNC and PATTERN-FUNC to 
create the shape, optionally forcing FORCED-WIDTH."
   (declare (indent defun))
@@ -205,7 +206,7 @@ NOTE: Forced-width primary separators are not currently 
supported."
             (char-width (+ (ceiling width (frame-char-width))
                            telephone-line-separator-extra-padding)))
         (telephone-line--pad-body
-         (telephone-line-create-body width height ,axis-func ,pattern-func)
+         (telephone-line--create-body width height ,axis-func ,pattern-func)
          char-width))
      (string ?  ,alt-char ? )))
 
@@ -243,6 +244,55 @@ Return nil for blank/empty strings."
           (replace-regexp-in-string "%" "%%" trimmed-str)
         str))))
 
+(defclass telephone-line-separator ()
+  ((axis-func :initarg :axis-func)
+   (pattern-func :initarg :pattern-func :initform #'telephone-line-row-pattern)
+   (alt-char :initarg :alt-char)
+   (image-cache :initform (make-hash-table :test 'equal))))
+
+(defclass telephone-line-subseparator (telephone-line-separator)
+  ((pattern-func :initarg :pattern-func :initform 
#'telephone-line-row-pattern-hollow)))
+
+(defmethod telephone-line-separator-create-body ((obj 
telephone-line-separator) &optional forced-width)
+  (telephone-line--create-body (telephone-line-separator-width)
+                (telephone-line-separator-height)
+                (oref obj axis-func)
+                (oref obj pattern-func)))
+
+(defmethod telephone-line-separator-create-body ((obj 
telephone-line-subseparator) &optional forced-width)
+  (let* ((height (telephone-line-separator-height))
+         (width (or forced-width (telephone-line-separator-width)))
+         (char-width (+ (ceiling width (frame-char-width))
+                        telephone-line-separator-extra-padding)))
+    (telephone-line--pad-body
+     (telephone-line--create-body width height
+                   (oref obj axis-func)
+                   (oref obj pattern-func))
+     char-width)))
+
+(defmethod telephone-line-separator-render ((obj telephone-line-separator) 
foreground background)
+  (let* ((bg-color (telephone-line--separator-arg-handler background))
+         (fg-color (telephone-line--separator-arg-handler foreground))
+         (hash-key (concat bg-color "_" fg-color)))
+    (if window-system
+        ;; Return cached image if we have it.
+        (or (gethash hash-key (oref obj image-cache))
+            (let ((height (telephone-line-separator-height))
+                  (width (telephone-line-separator-width)))
+              (puthash hash-key
+                       (telephone-line-propertize-image
+                        (telephone-line--create-pbm-image 
(telephone-line-separator-create-body obj)
+                                            bg-color fg-color))
+                       (oref obj image-cache))))
+
+      (list :propertize (char-to-string (oref obj alt-char))
+            'face (list :foreground fg-color
+                        :background bg-color
+                        :inverse-video t)))))
+
+(defmethod telephone-line-separator-clear-cache ((obj 
telephone-line-separator))
+  (clrhash (oref obj image-cache)))
+
 ;;Stole this bit from seq.el
 (defun telephone-line--activate-font-lock-keywords ()
   "Activate font-lock keywords for some symbols defined in telephone-line."
diff --git a/telephone-line.el b/telephone-line.el
index 5ae382d32f..08de3cc5c8 100644
--- a/telephone-line.el
+++ b/telephone-line.el
@@ -82,33 +82,33 @@
   :group 'telephone-line-evil)
 
 (defface telephone-line-evil-operator
-  '((t (:background "sky blue" :inherit telephone-line-evil)))
+  '((t (:background "violet" :inherit telephone-line-evil)))
   "Face used in evil color-coded segments when in Operator state."
   :group 'telephone-line-evil)
 
 (defface telephone-line-evil-emacs
-  '((t (:background "blue violet" :inherit telephone-line-evil)))
+  '((t (:background "dark violet" :inherit telephone-line-evil)))
   "Face used in evil color-coded segments when in Emacs state."
   :group 'telephone-line-evil)
 
-(defcustom telephone-line-primary-left-separator #'telephone-line-abs-left
+(defcustom telephone-line-primary-left-separator 'telephone-line-abs-left
   "The primary separator to use on the left-hand side."
   :group 'telephone-line
   :type 'function)
 
-(defcustom telephone-line-primary-right-separator #'telephone-line-abs-right
+(defcustom telephone-line-primary-right-separator 'telephone-line-abs-right
   "The primary separator to use on the right-hand side."
   :group 'telephone-line
   :type 'function)
 
-(defcustom telephone-line-secondary-left-separator 
#'telephone-line-abs-hollow-left
+(defcustom telephone-line-secondary-left-separator 
'telephone-line-abs-hollow-left
   "The secondary separator to use on the left-hand side.
 
 Secondary separators do not incur a background color change."
   :group 'telephone-line
   :type 'function)
 
-(defcustom telephone-line-secondary-right-separator 
#'telephone-line-abs-hollow-right
+(defcustom telephone-line-secondary-right-separator 
'telephone-line-abs-hollow-right
   "The secondary separator to use on the right-hand side.
 
 Secondary separators do not incur a background color change."
@@ -177,7 +177,7 @@ Secondary separators do not incur a background color 
change."
            (cl-list*
             cur-subsegments ;New segment
             ;; Separator
-            `(:eval (funcall #',primary-sep
+            `(:eval (telephone-line-separator-render ,primary-sep
                              (telephone-line-face-map ',prev-color-sym)
                              (telephone-line-face-map ',cur-color-sym)))
             accumulated-segments) ;Old segments
@@ -195,7 +195,7 @@ Secondary separators do not incur a background color 
change."
   (let* ((cur-face (telephone-line-face-map color-sym))
          (opposite-face (telephone-line-face-map
                          (telephone-line-opposite-face-sym color-sym)))
-         (subseparator (funcall sep-func cur-face opposite-face)))
+         (subseparator (telephone-line-separator-render sep-func cur-face 
opposite-face)))
     (telephone-line-propertize-segment
      color-sym cur-face
      (cdr (seq-mapcat
@@ -218,7 +218,7 @@ separators, as they are conditional, are evaluated 
on-the-fly."
                     (cons color-sym
                           `(:eval
                             (telephone-line-add-subseparators
-                             ',subsegments #',secondary-sep ',color-sym)))))
+                             ',subsegments ,secondary-sep ',color-sym)))))
                 (seq-reverse segments))
         '(nil . nil))))