notibox/notibox.el

;;; notibox.el --- PosFrame-based notification UI  -*- lexical-binding: t; -*-

;; Copyright (C) 2023  mir

;; Author: mir <mirmarq428@gmail.com>
;; Keywords:frames,convenience,help
;; Package-Requires: ((posframe) (alert) (dash))

;; This file is NOT part of GNU Emacs.

;; This program 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.

;; This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This package shows a temporary child frame which mirrors the contents of the
;; echo area.  It was designed to be used with configurations that hide the echo
;; area by splitting it into a `minibuffer-frame'.

;; it even shows multiple notifications in a stack!

;;; Code:

;; imports
(require 'posframe)
(require 'alert)
(require 'dash)
(if (not (fboundp #'string-pixel-width))
    (progn
      (require 'shr) ;for `shr-string-pixel-width'
      (defalias #'string-pixel-width #'shr-string-pixel-width)))

;; variables / customizations
(defvar notibox-width 40) ; characters
(defvar notibox-height 4) ; characters
(defvar notibox-border-color "#808080") ; just a global default
(defvar notibox-current-posframes nil)
(defvar last-message nil
  "Previous value of `current-message', stored for notibox.")
(defvar mir/framove-update-interval 0.05
  "How many seconds to wait before updating incremental frame positions.")
(defgroup notibox nil
  "The notification box.")
(defcustom notibox-corner 'bottomright
  "Corner in which to show the NotiBox."
  :type '(choice
	  (const :tag "Top Left" 'topleft)
	  (const :tag "Bottom Left" 'bottomleft)
	  (const :tag "Top Right" 'topright)
	  (const :tag "Bottom Right" 'bottomright)))
(defvar notibox-padding 30)
(defvar alert-fade-time 5); seconds, also provided by `alert' package
(defvar notibox--refresh-delay 0.1) ; seconds. Probably don't change this one.

;; functions - static frame ----------------------------------------------------
(defun notibox--get-position (&optional stackdepth)
  "Return the starting coordinate at which to place the next notibox, as cons.

If STACKDEPTH is non-nil and nonzero, return a position that far down."
  (let* (
	 ;; need to not overlap the gtk scrollbar
	 (scrollbar-width (or (if (eq x-toolkit-scroll-bars 'gtk)
				  30)	; educated guess...
			      0))
	 ;; (stackdepth (or stackdepth 0))
	 (stackdepth 0)			; we do not care actually
	 (parent-width (frame-pixel-width))
	 (child-width (* notibox-width (string-pixel-width " ")))
	 (parent-height (frame-pixel-height))
	 (child-height (* notibox-height (line-pixel-height)))
	 (padded-height (+ child-height notibox-padding))
	 (x-justify (pcase notibox-corner
		      ((or 'topleft 'bottomleft) notibox-padding)
		      ((or 'topright 'bottomright)
		       (- (- parent-width scrollbar-width)
			  (+ child-width notibox-padding)))))
	 (y-justify (pcase notibox-corner
		      ((or 'topleft 'topright) notibox-padding)
		      ((or 'bottomleft 'bottomright)
		       (- parent-height (+ child-height notibox-padding)))))
	 (y-direction (pcase notibox-corner
			((or 'topleft 'topright) #'+)
			((or 'bottomleft 'bottomright) #'-)))
	 (y-coord (funcall y-direction y-justify (* stackdepth padded-height)))
	 )
    (cons x-justify y-coord)))
(cl-defun notibox--show (&key timeout &key depth &key buf)
  "Show the notibox currently prepared, with optional TIMEOUT, at DEPTH, in BUF."
  (let ((this-notibox
	 (let ((buffer (get-buffer-create (or buf "*notibox*"))))
	   (posframe-show buffer
			  :position (notibox--get-position depth)
			  :left-fringe 0
			  :right-fringe 0
			  :max-width notibox-width
			  :max-height notibox-height
			  :min-width notibox-width
			  :min-height notibox-height
			  :border-width 2
			  :border-color notibox-border-color
			  ;; :timeout timeout
			  ))
	 ))
    (run-with-timer timeout nil #'notibox-delete this-notibox)
    (mir/push-notibox this-notibox)
    ;; (add-to-list 'notibox-current-posframes
    ;; 		 this-notibox)
    )
  nil)
(defun notibox-alert (info)
  "Show a notibox corresponding with INFO.  Can* be used as a backend for `alert'."
  (let* ((message (plist-get info :message))
	 (title   (plist-get info :title))
	 (timeout (plist-get info :persistent))
	 (depth   (plist-get info :depth)))
    ;; gotta make it move the others down...
    (notibox--show :timeout (unless timeout alert-fade-time)
		   ;; :depth (or depth (- (length notibox-current-posframes) 1))
		   :buf (notibox--prepare-buffer title message))))
(defun notibox--resolve-frame (object)
  "Return the /frame reference/ signified by OBJECT, whatever it may be."
  (cond
   ((framep object) object) ;this is the easy one
   ((windowp object) (window-frame object))
   ((bufferp object) (window-frame (get-window-buffer object)))
   ((stringp object)
    (window-frame (get-buffer-window (get-buffer object))))
   ((symbolp object)
    (window-frame (get-buffer-window (get-buffer (format "%s" object)))))
   ))
;; (notibox--resolve-frame "*notibox*")

(defun notibox--hide (frame)
  "Stop showing FRAME."
  (if (frame-live-p frame)
      (posframe-delete (window-buffer (frame-selected-window frame)))))

(defun notibox-delete (frame)
  "Delete the notibox FRAME.

If FRAME is the root Emacs window, or some other symbol, hide all notiboxes."
  (let ((frame (notibox--resolve-frame frame)))
    (if frame
	(notibox--hide frame)
      (notibox--hide (car notibox-current-posframes))
      ))
  
  (pop notibox-current-posframes))
(defun notibox/setup-timer ()
  "Start running notibox."
  (interactive)
  (run-with-timer notibox--refresh-delay notibox--refresh-delay #'notibox--tail-echoarea))
(defun notibox-test-alert ()
  "Show a sample notibox to prove we can."
  (interactive)
  (notibox-alert `(:title ,(random 8096) :message "test of notibox")))
(defun notibox-test-message ()
  "Send a message and see if it gets picked up by notibox."
  (message "test message %s: %s is a number" (random 40) (random 500)))


;; functions - frame moving ----------------------------------------------------
(defun mir/move-frame (frame pos)
  "Move FRAME to POS, a cons of (top . left)."
  (if (frame-live-p frame)
      (modify-frame-parameters frame
			       `(
				 (top . ,(car pos))
				 (left . ,(cdr pos))
				 ))))
(defun mir/framove-gradual (frame newpos duration)
  "Move FRAME to NEWPOS ( a cons of top and left) over DURATION.

intermediate positions are calculated via `mir/framove-update-interval'."
  (let* (
	 (how-many-steps (/ duration mir/framove-update-interval))
	 (updates-num-seq (number-sequence 1 how-many-steps))
	 (timestamps (--map (* mir/framove-update-interval it) updates-num-seq))
	 (beg-top (frame-parameter frame 'top))
	 (beg-left (frame-parameter frame 'left))
	 (end-top (car newpos))
	 (end-left (cdr newpos))
	 (top-diff (/ (- end-top beg-top) (float how-many-steps)))
	 (left-diff (/ (- end-left beg-left) (float how-many-steps)))
	 (tops (or (number-sequence beg-top end-top top-diff) 0))
	 (lefts (or (number-sequence beg-left end-left left-diff) 0))
	 (uhm
	  (--map (list
		  (or (elt timestamps it) duration)
		  (or (elt tops it) beg-top)
		  (or (elt lefts it) beg-left)
		  )
		 updates-num-seq
		 ))
	 (timerfun (lambda (threelist)
		     (let ((timestamp (-first-item threelist))
			   (top (-second-item threelist))
			   (left (-third-item threelist)))
		       (if (and top left)
			   (run-with-timer timestamp nil ;no repeat
					   #'mir/move-frame
					   frame
					   (cons (round top) (round left))
					   )
			 ;; (message "%s" threelist)
			 ))))
	 )
    (mapcar timerfun uhm)
    )
  nil
  )

(defun mir/notibox-down-one (frame)
  "Move FRAME down by `notibox-padding'."
  (if (frame-live-p frame)
      (let* ((parms (frame-parameters frame))
	     (old-y (alist-get 'top parms))
	     (old-x (alist-get 'left parms)))
	(mir/framove-gradual frame (cons
				    (+ old-y ;; (- (* notibox-height
					     ;; 	   (window-text-height))
					     ;; 	notibox-padding)
				       (/
					(+ (* (window-text-height) notibox-height)
					   notibox-padding)
					2))
				    old-x
				    ) 0.125))))
;; (notibox-test-alert)
;; (notibox-test-message)

(defun mir/push-notibox (frame)
  "Push FRAME onto `notibox-current-posframes' and display it at the top of the stack."
  (--map (mir/notibox-down-one it)		     ; move each by the interval - need more infra first
	 (reverse notibox-current-posframes))
  (push frame notibox-current-posframes)
  )

;; functions - message parsing -------------------------------------------------
(defun notibox--prepare-buffer (title body &optional buffer)
  "Return the notibox buffer containing TITLE and BODY, properly formatted"
  (let ((buf (get-buffer-create (format " *notibox-- %s: %s *" title body))))
    (with-current-buffer buf
      (let ((inhibit-read-only t))
	(erase-buffer)
	(insert (format "%s\n%s\n%s" ;; (buttonize title #'view-echo-area-messages)
			title
			(propertize (make-string notibox-width ?─)
				    'face `((:foreground ,notibox-border-color)))
			body))))
    buf))
(defun notibox--parse-message (msg)
  "Given string MSG, return a cons of source and contents.
If the source is not obvious, use `current-buffer'."
  (let* (source
	 contents
	 (splooted (split-string msg ": ")))
    (pcase (length splooted)
      ;; problem: the echo area shows only cdr, whereas messages buffer shows the source fn we want..
      (1 (progn
	   (setq source
		 (format "%s"
			 (current-buffer)))
	   (setq contents
		 (car splooted))))
      (2 (progn
	   (setq source (car splooted))
	   (setq contents (cadr splooted))))
      (3 (progn
	   (setq source (car splooted))
	   (setq contents (format "%s: %s" (cadr splooted) (caddr splooted)))))
      )
    (cons source contents)))
(defun buflast (buffer)
  "Return the last line of BUFFER as a string, without linebreaks."
  (with-current-buffer buffer
    (save-excursion
      (goto-char (- (point-max) 1)) ; there is a \n at the end of every buffer
      (buffer-substring-no-properties (point-at-bol) (point-max)))))
(defun notibox--tail-echoarea ()
  "Show `current-message' in the notibox.  If that does not exist, probably hide it."
  (if (current-message)
      (unless (string= last-message (current-message))
	(let* ((notibox-border-color "#0faa0f") ; hacky, can we set it elsewhere?
	       (parsed-msg
		(notibox--parse-message
		 ;; (current-message)
		 (buflast (get-buffer "*Messages*")) ; workaround for abbreviated stuff
		 ))
	       (title (car parsed-msg))
	       (contents (cdr parsed-msg)))
	  (notibox-alert `( :title ,title
			    :message ,contents
			    )))
	(setq last-message (current-message)))
    ;; (if notibox-current-posframes
    ;; 	(notibox-delete (car notibox-current-posframes)))
    )
  )




;; (add-variable-watcher 'notibox-current-posframes
;; 		      (lambda (symbol newval operation where)
;; 			"Display the variable in *watched* buffer."
;; 			(with-current-buffer (get-buffer-create "*watched*")
;; 			  (goto-char (point-max))
;; 			  (insert
;; 			   (format "\n%s:\n  was: %s\n  now: %s"
;; 				   symbol
;; 				   (eval symbol)
;; 				   newval)))
;; 			))
;; (--map (remove-variable-watcher 'notibox-current-posframes it)
;;        (get-variable-watchers 'notibox-current-posframes))


(provide 'notibox)
;;; notibox.el ends here