switch single-header to be per frame and memoize with a macro

1 files changed, 92 insertions, 49 deletions

diff --git a/emacs/site-lisp/single-header.el b/emacs/site-lisp/single-header.el
index e9cce2a..1378384 100755
--- a/emacs/site-lisp/single-header.el
+++ b/emacs/site-lisp/single-header.el
@@ -25,18 +25,48 @@
   "Custom variables for the single header package."
   :prefix "single-header"
   :group 'emacs)
-
-(defface single-header-face '((default . (:background "#000000" :family "Source Code Pro")))
+(defface single-header-face
+  '((default . (:background "#000000" :family "Source Code Pro")))
   "Base face for the header line."
   :group 'single-header)
-
-(defcustom single-header-update-increment 10
+(defcustom single-header-update-increment
+  3
   "Number of seconds before updating the header again."
   :type 'natnum
   :group 'single-header)
-(defvar single-header--current-header-buffer nil)
 (defvar single-header--active-notifs nil)
-(defvar single-header--last-update-time 0)
+
+(defmacro single-header--time-memo (force frame function &rest args)
+  "Call FUNCTION on ARGS like with `funcall', but only evaluate FUNCTION
+once per `single-header-update-increment', returning the last result on
+more frequent calls.  Caching and time checking is per-frame.  Skip the
+frequency check and write update the cache regardless if FORCE evaluates
+to non-nil.  The last update time is in a frame parameter
+`function--last-time' of FRAME, and the cached value is in
+`function--cache'."
+  (let ((name (if (symbolp function)
+                  (symbol-name function)
+                (error "Function wasn't a symbol"))))
+    (let* ((last-t-str (concat name "--last-time"))
+           (cache-str (concat name "--cache"))
+           (last-t (or (intern-soft last-t-str) (make-symbol last-t-str)))
+           (cache (or (intern-soft cache-str) (make-symbol cache-str))))
+      ;; cache contains the symol of the cache variable
+      ;; last-t contains the symbol of the last time it was evaluated
+      `(if force
+           (let ((v (funcall ',function ,@args)))
+             (set-frame-parameter ,frame (quote ,cache) v)
+             (set-frame-parameter ,frame (quote ,last-t) (time-convert (current-time) 'integer))
+             v)
+         (let ((cur-time (time-convert (current-time) 'integer))
+               (next-time (time-add (or (frame-parameter ,frame (quote ,last-t)) 0)
+                                    single-header-update-increment)))
+           (if (time-less-p next-time cur-time)
+               (let ((v (funcall ',function ,@args)))
+                 (set-frame-parameter ,frame (quote ,cache) v)
+                 (set-frame-parameter ,frame (quote ,last-t) cur-time)
+                 v)
+             (frame-parameter ,frame (quote ,cache))))))))
 
 (defun single-header--with-face (str &rest face-plist)
   "Convenience wrapper for `add-face-text-property'."
@@ -76,23 +106,6 @@ arg, dismiss all the notifications."
              (ednc-dismiss-notification (car notifs))))))
   (single-header-update))
 
-(defun single-header-format ()
-  "Evaluated in the header buffer when empty to fill the buffer."
-  (let* ((win (get-buffer-window (current-buffer)))
-         (win-width (window-max-chars-per-line win 'single-header))
-         (info (single-header--make-header-info-string))
-         (info-width (string-width info))
-         (notifs (s-truncate (- win-width info-width 2)
-                             (single-header--make-notif-string)))
-         (notifs-width (string-width notifs))
-         (filled (min win-width (+ info-width notifs-width)))
-         (padding-width (- win-width filled))
-         (padding (make-string padding-width ? )))
-    (setq notifs (single-header--with-face notifs 'single-header-face))
-    (setq padding (single-header--with-face padding 'single-header-face))
-    (setq info (single-header--with-face info 'single-header-face))
-    (insert notifs padding info)))
-
 (defun single-header--make-header-info-string ()
   "Generates the mode line string that contains all the info to the right."
   (let ((str (concat
@@ -113,7 +126,7 @@ arg, dismiss all the notifications."
               )))
     (single-header--with-face str 'single-header-face)))
 
-(defun single-header-init-buffer (buf)
+(defun single-header--init-buffer (buf)
   (with-current-buffer buf
     (insert "header test")
     (jit-lock-mode nil)
@@ -127,7 +140,7 @@ arg, dismiss all the notifications."
     (setq-local word-wrap nil)
     (setq-local show-trailing-whitespace nil)))
 
-(defun single-header-init-window (win)
+(defun single-header--init-window (win)
   (with-selected-window win
     (set-window-dedicated-p win t)
     (set-window-parameter win 'no-other-window t)
@@ -145,13 +158,16 @@ arg, dismiss all the notifications."
        (fboundp 'window-preserve-size)
       (window-preserve-size win nil t))))
 
-(defun single-header-show (buf)
-  "Show the header, making it if necessary."
-  (if (buffer-live-p buf)
-      (let ((win (display-buffer-in-side-window buf '((side . top)
-                                                  (slot . -100)))))
-        (single-header-init-window win))
-    (single-header-make)))
+(defun single-header--init-frame (&optional frame)
+  (setq frame (or frame (selected-frame)))
+  (with-selected-frame frame
+    (let* ((buf (generate-new-buffer "*header*"))
+           (win (display-buffer-in-side-window buf '((side . top)
+                                                     (slot . -100)))))
+      (single-header--init-buffer buf)
+      (single-header--init-window win)
+      (set-frame-parameter frame 'single-header-buf buf)
+      (set-frame-parameter frame 'single-header-win win))))
 
 (defun single-header-make ()
   "Create the header and show it."
@@ -167,11 +183,12 @@ arg, dismiss all the notifications."
                   ednc-notification-presentation-functions)
           (list 'single-header--register-notif-change
                 ednc-notification-presentation-functions))))
-  (unless (buffer-live-p single-header--current-header-buffer)
-    (let ((buf (generate-new-buffer "*header*")))
-      (single-header-init-buffer buf)
-      (setq single-header--current-header-buffer buf)
-      (single-header-show buf)))
+  (mapc (lambda (f)
+          (when (frame-live-p f)
+            (single-header--init-frame f)))
+        (frame-list))
+  ;; TODO frame creation hook
+  (add-hook 'after-make-frame-functions #'single-header--init-frame)
   (add-hook 'post-command-hook #'single-header-update))
 
 (defun single-header-delete ()
@@ -188,20 +205,46 @@ arg, dismiss all the notifications."
       (setq ednc-notification-presentation-functions
             'ednc--update-log-buffer)))
   (remove-hook 'post-command-hook 'single-header-update)
-  (when (buffer-live-p single-header--current-header-buffer)
-    (kill-buffer single-header--current-header-buffer)))
+  (remove-hook 'after-make-frame-functions 'single-header--init-frame)
+  ;; TODO frame creation hook
+  (mapc (lambda (f)
+          (delete-window (frame-parameter f 'single-header-win))
+          (kill-buffer (frame-parameter f 'single-header-buf))
+          (set-frame-parameter f 'single-header-buf nil)
+          (set-frame-parameter f 'single-header-win nil))
+       (frame-list)))
 
 (defun single-header-update (&optional force)
-  "Update the contents of the header line by calling `single-header-format'
-with the header buffer current and empty."
-  (let ((cur-time (time-convert (current-time) 'integer))
-        (next-time (time-add single-header--last-update-time
-                             single-header-update-increment)))
-    (when (or force (time-less-p next-time cur-time))
-      (with-current-buffer single-header--current-header-buffer
-        (erase-buffer)
-        (single-header-format))
-      (setq single-header--last-update-time cur-time))))
+  ""
+  (mapc (lambda (f) (single-header-update-frame f force))
+        (visible-frame-list)))
+
+(defun single-header-format (frame win buf)
+  "Evaluated in the header buffer when empty to fill the buffer."
+  (let* ((win-width (window-max-chars-per-line win 'single-header-face))
+         (info (single-header--make-header-info-string))
+         (info-width (string-width info))
+         (notifs (s-truncate (- win-width info-width 2)
+                             (single-header--make-notif-string)))
+         (notifs-width (string-width notifs))
+         (filled (min win-width (+ info-width notifs-width)))
+         (padding-width (- win-width filled))
+         (padding (make-string padding-width ? )))
+    (setq notifs (single-header--with-face notifs 'single-header-face))
+    (setq padding (single-header--with-face padding 'single-header-face))
+    (setq info (single-header--with-face info 'single-header-face))
+    (concat notifs padding info)))
+
+(defun single-header-update-frame (frame &optional force)
+  ""
+  (with-selected-frame frame
+    (let ((buf (frame-parameter frame 'single-header-buf))
+          (win (frame-parameter frame 'single-header-win)))
+      (when (and buf win)
+        (with-current-buffer buf
+          (let ((str (single-header--time-memo force frame
+                                               single-header-format frame win buf)))
+            (replace-region-contents (point-min) (point-max) str)))))))
 
 (define-minor-mode single-header-mode
   "Global minor mode to enable a single info line at the top of each frame."