akib
/
emacs-popon
1
3
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
"Pop" floating text "on" a window
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
32 Commits
2 Branches
0 Tags
634 KiB
 
Branch: master
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'master'
${ noResults }
emacs-popon/popon.el

562 lines
24 KiB
Raw Permalink Blame History

;;; popon.el --- "Pop" floating text "on" a window -*- lexical-binding: t -*-
;; Copyright (C) 2022 Akib Azmain Turja.
;; Author: Akib Azmain Turja <akib@disroot.org>
;; Created: 2022-04-11
;; Version: 0.7
;; Package-Requires: ((emacs "25.1"))
;; Keywords: lisp extensions frames
;; Homepage: https://codeberg.org/akib/emacs-popon
;; This file is not part of GNU Emacs.
;; This file 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, 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.
;; For a full copy of the GNU General Public License
;; see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Popon allows you to pop text on a window, what we call a popon. Popons
;; are window-local and sticky, they don't move while scrolling, and they
;; even don't go away when switching buffer, but you can bind a popon to a
;; specific buffer to only show on that buffer.
;; If some popons are annoying you and you can't kill them, do M-x
;; popon-kill-all to kill all popons.
;;; Code:
(require 'subr-x)
(require 'cl-lib)
(defun popon--render-lines (framebuffer x y lines width)
"Place LINES on top of FRAMEBUFFER.
Place LINES on top of text at line X and column Y on FRAMEBUFFER and return
FRAMEBUFFER. LINES is a list of list as string. FRAMEBUFFER is a list,
each element is of form: (LINE MODIFIED EXTENDED OTHERS...), where LINE is
as string, MODIFIED is t when LINE is modified and EXTENDED is t when the
line has been extended. OTHERS is not modified in any way. Each line in
LINES is assumed to occupy WIDTH character. FRAMEBUFFER and LINES
shouldn't contain newlines. Example:
\(`popon--render-lines'
'((\"GNU Emacs is “free software”; this means\" nil nil)
(\"that everyone is free to use it and free\" nil nil)
(\"to redistribute it under certain\" nil nil)
(\"conditions. GNU Emacs is not in the\" nil nil)
(\"public domain; it is copyrighted and\" nil nil)
(\"there are restrictions on its\" nil nil)
(\"distribution, but these restrictions are\" nil nil)
(\"designed to permit everything that a\" nil nil foo)
(\"good cooperating citizen would want to\" nil nil bar)
(\"do. What is not allowed is to try to\" nil nil)
(\"prevent others from further sharing any\" nil nil)
(\"version of GNU Emacs that they might get\" nil nil)
(\"from you. The precise conditions are\" nil nil)
(\"found in the GNU General Public License\" nil nil)
(\"that comes with Emacs and also appears\" nil nil)
(\"in this manual(1). See Copying.\" t nil))
11 1 '(\"+--^^^^^^^^^^^^^-------------------------+\"
\"|Free software is a type of software that|\"
\"|respects user freedom. Think free as in|\"
\"|free speech, not as in free beer. |\"
\"+----------------------------------------+\")
42)
=> ((\"GNU Emacs is “free software”; this means\" nil nil)
(\"that everyo+--^^^^^^^^^^^^^-------------------------+\" t t)
(\"to redistri|Free software is a type of software that|\" t t)
(\"conditions.|respects user freedom. Think free as in|\" t t)
(\"public doma|free speech, not as in free beer. |\" t t)
(\"there are r+----------------------------------------+\" t t)
(\"distribution, but these restrictions are\" nil nil)
(\"designed to permit everything that a\" nil nil foo)
(\"good cooperating citizen would want to\" nil nil bar)
(\"do. What is not allowed is to try to\" nil nil)
(\"prevent others from further sharing any\" nil nil)
(\"version of GNU Emacs that they might get\" nil nil)
(\"from you. The precise conditions are\" nil nil)
(\"found in the GNU General Public License\" nil nil)
(\"that comes with Emacs and also appears\" nil nil)
(\"in this manual(1). See Copying.\" t nil))"
(let ((tab-size tab-width)
(inhibit-read-only t)) ; The text might have `read-only' property.
(with-temp-buffer
(setq-local tab-width tab-size) ; Preseve tab width.
(dotimes (i (length lines))
(when (< (+ y i) (length framebuffer))
(erase-buffer)
(insert (car (nth (+ y i) framebuffer)))
(goto-char (point-min))
(let ((end (line-end-position)))
(move-to-column x t)
(let ((mark (point)))
(move-to-column (+ x width) t)
(setf (car (nth (+ y i) framebuffer))
(concat (buffer-substring (point-min) mark)
(nth i lines)
(buffer-substring (point) (point-max))))
(setf (cadr (nth (+ y i) framebuffer)) t)
(when (< end (point-max))
(setf (cadr (cdr (nth (+ y i) framebuffer))) t))))))
framebuffer)))
;;;###autoload
(defun poponp (object)
"Return t if OBJECT is a popon."
(and (listp object)
(eq (car-safe object) 'popon)))
;;;###autoload
(defun popon-live-p (object)
"Return t if OBJECT is a popon and not killed."
(and (poponp object)
(plist-get (cdr object) :live)
(and (plist-get (cdr object) :window)
(window-live-p (plist-get (cdr object) :window)))
(or (not (plist-get (cdr object) :buffer))
(buffer-live-p (plist-get (cdr object) :buffer)))
t))
;;;###autoload
(defun popon-get (popon prop)
"Get the PROP property of popon POPON."
(plist-get (plist-get (cdr popon) :plist) prop))
;;;###autoload
(defun popon-put (popon prop value)
"Set the PROP property of popon POPON to VALUE."
(setcdr popon (plist-put (cdr popon)
:plist (plist-put (plist-get (cdr popon) :plist)
prop value))))
;;;###autoload
(defun popon-properties (popon)
"Return a copy the property list of popon POPON."
(copy-sequence (plist-get (cdr popon) :plist)))
;;;###autoload
(defun popon-position (popon)
"Return the position of popon POPON as a cons (X, Y).
When popon POPON is killed, return nil."
(when (popon-live-p popon)
(cons (plist-get (cdr popon) :x)
(plist-get (cdr popon) :y))))
;;;###autoload
(defun popon-size (popon)
"Return the size of popon POPON as a cons (WIDTH . HEIGHT).
When popon POPON is killed, return nil."
(when (popon-live-p popon)
(cons (plist-get (cdr popon) :width)
(length (plist-get (cdr popon) :lines)))))
;;;###autoload
(defun popon-window (popon)
"Return the window popon POPON belongs to.
Return nil if popon POPON is killed."
(when (popon-live-p popon)
(plist-get (cdr popon) :window)))
;;;###autoload
(defun popon-buffer (popon)
"Return the buffer popon POPON belongs to.
Return nil if popon POPON is killed."
(when (popon-live-p popon)
(plist-get (cdr popon) :buffer)))
;;;###autaload
(defun popon-priority (popon)
"Return the priority of popon POPON.
Return nil if popon POPON is killed."
(when (popon-live-p popon)
(plist-get (cdr popon) :priority)))
;;;###autoload
(defun popon-text (popon)
"Return the text popon POPON is displaying.
POPON may be a killed popon. Return nil if POPON isn't a popon at all."
(when (poponp popon)
(mapconcat #'identity (plist-get (cdr popon) :lines) "\n")))
(defun popon--render (popon framebuffer offset)
"Render POPON in FRAMEBUFFER at vertical offset OFFSET."
(popon--render-lines framebuffer
(+ (plist-get (cdr popon) :x) offset)
(plist-get (cdr popon) :y)
(plist-get (cdr popon) :lines)
(plist-get (cdr popon) :width)))
;;;###autoload
(defun popon-create (text pos &optional window buffer priority)
"Create a popon showing TEXT at POS of WINDOW.
Display popon only if WINDOW is displaying BUFFER.
POS is a cons (X, Y), where X is column and Y is line in WINDOW. TEXT
should be a string or a cons cell of form (STR . WIDTH). When TEXT is a
string, each line of it should be of same length (i.e `string-width' should
return the same length for every line). When TEXT is a cons cell, STR is
used as the text to display and each line of it should be of visual length
width.
PRIORITY is a number (integer or float) between -100 and 100. Popons with
larger priority values are rendered first."
(when (not (or (consp text) (stringp text)))
(signal 'wrong-type-argument
`((or (consp text) (stringp text)) ,text)))
(when (not (consp pos))
(signal 'wrong-type-argument `(consp ,pos)))
(when (and window (not (windowp window)))
(signal 'wrong-type-argument `(windowp ,window)))
(when (and buffer (not (bufferp buffer)))
(signal 'wrong-type-argument `(bufferp ,buffer)))
(when (and priority (not (numberp priority)))
(signal 'wrong-type-argument `(numberp ,priority)))
(let* ((lines (split-string (if (consp text) (car text) text) "\n"))
(popon `(popon :live t
:x ,(car pos)
:y ,(cdr pos)
:lines ,lines
:width ,(or (and (consp text) (cdr text))
(string-width (car lines)))
:window ,(or window (selected-window))
:buffer ,buffer
:priority ,(or priority 0)
:plist nil)))
(push popon (window-parameter window 'popon-list))
(popon-update)
popon))
;;;###autoload
(defun popon-kill (popon)
"Kill popon POPON.
Do nothing if POPON isn't a live popon. Return nil."
(when (popon-live-p popon)
(let ((window (popon-window popon)))
(setf (window-parameter window 'popon-list)
(delete popon (window-parameter window 'popon-list))))
(setcdr popon (plist-put (cdr popon) :live nil))
(popon-update)
nil))
(defvar-local popon--line-beginnings nil
"List of line beginning of current buffer.
The value is of form (TICK . LINE-BEGINNINGS), where LINE-BEGINNINGS is the
sorted list of beginning of lines and TICK is the value of tick counter
when LINE-BEGINNINGS was calculated.")
(defun popon--buffer-visible-substring (start end)
"Return the visible contents of part of the current buffer as a string.
Take the `invisible' text property into account.
START and END specifies which part to return. They can be in any order."
(when (> start end)
(let ((tmp end))
(setq end start)
(setq start tmp)))
(let ((str ""))
(save-excursion
(goto-char start)
(while (< (point) end)
(let ((prop (get-char-property (point) 'invisible))
(next-change (next-single-char-property-change
(point) 'invisible nil end)))
(cond
((null prop)
(setq str (concat str (buffer-substring (point) next-change))))
((and (consp buffer-invisibility-spec)
(member (cons prop t) buffer-invisibility-spec))
(setq str (concat str (apply #'propertize "..." 'invisible nil
(text-properties-at (point)))))))
(goto-char next-change))))
str))
(defun popon--make-framebuffer ()
"Create a framebuffer for current window and buffer."
(let ((framebuffer nil)
(line-boundaries (let ((pair popon--line-beginnings)
(boundaries nil))
(when (eq (car pair) (buffer-modified-tick))
(setq pair (cdr pair))
(while pair
(when (and (integerp (car pair))
(integerp (cadr pair)))
(push (cons (car pair) (cadr pair))
boundaries))
(setq pair (cdr pair))))
boundaries)))
(save-excursion
(goto-char (window-start))
(let ((mark (point))
(point-to-line nil)
(next-invisible
(if (get-char-property (point) 'invisible)
(point)
(next-single-char-property-change (point) 'invisible nil
(window-end)))))
(dotimes (i (floor (window-screen-lines)))
(if-let ((next (alist-get (point) line-boundaries)))
(goto-char next)
(if truncate-lines
(forward-line 1)
(vertical-motion 1))
(when (< next-invisible (point))
(let ((next-visible
(let ((pos next-invisible))
(while (get-char-property pos 'invisible)
(setq pos (next-single-char-property-change
pos 'invisible nil (window-end))))
pos)))
(setq next-invisible (next-single-char-property-change
next-visible 'invisible nil
(window-end)))
(while (> next-visible (point))
(if truncate-lines
(forward-line 1)
(vertical-motion 1))))))
(let ((line (alist-get mark point-to-line)))
(unless line
(setq line i)
(setf (alist-get mark point-to-line) line))
(let* ((str (popon--buffer-visible-substring mark (point)))
(disp-str (if (>= emacs-major-version 26)
(string-trim-right str "\n")
(let ((i (string-match-p
(concat "\\(?:\n\\)\\'") str)))
(if i (substring str 0 i) str)))))
(push (list disp-str nil nil line mark
(if (equal str disp-str) (point) (1- (point))))
framebuffer)))
(push (cons mark (point)) line-boundaries)
(setq mark (point)))))
(let ((line-beginnings nil))
(dolist (pair (sort (delete-dups line-boundaries)
#'car-less-than-car))
(unless (eq (car line-beginnings) (car pair))
(when (car line-beginnings)
(push nil line-beginnings))
(push (car pair) line-beginnings))
(push (cdr pair) line-beginnings))
(push nil line-beginnings)
(setq popon--line-beginnings (cons (buffer-modified-tick)
(nreverse line-beginnings))))
(nreverse framebuffer)))
(defun popon--make-overlays (framebuffer)
"Make overlays to display FRAMEBUFFER on window."
(let ((line-map nil))
(let ((i 0)
(lines-left framebuffer))
(while lines-left
(let ((line (pop lines-left)))
(when (nth 1 line)
(when (and (< (point-min) (nth 4 line) (point-max))
(not (eq (char-before (nth 4 line)) ?\n)))
(let ((ov (make-overlay (nth 4 line) (nth 4 line))))
(push ov (window-parameter nil 'popon-overlays))
(overlay-put ov 'window (selected-window))
(overlay-put ov 'after-string "\n")))
(let* ((key (cons (nth 4 line) (nth 5 line)))
(pair (assoc key line-map)))
(unless pair
(setq pair (list key nil nil))
(push pair line-map))
(setf (cadr pair) (or (cadr pair) (nth 2 line)))
(push (cons (- i (nth 3 line)) (car line))
(cadr (cdr pair))))))
(setq i (1+ i))))
(dolist (block line-map)
(let ((ov (make-overlay (caar block) (cdar block))))
(push ov (window-parameter nil 'popon-overlays))
(overlay-put ov 'window (selected-window))
(overlay-put ov 'display (copy-sequence '(space :width (0))))
(overlay-put
ov 'before-string
(let ((text "")
(current-offset 0))
(when (and (= (caar block) (cdar block) (point-max))
(not (equal (buffer-substring-no-properties
(1- (caar block)) (caar block))
"\n")))
(setq text "\n"))
(dolist (line (sort (cadr (cdr block)) #'car-less-than-car))
(setq text (concat text
(make-string (- (car line)
current-offset)
?\n)
(cdr line)))
(setq current-offset (car line)))
(add-face-text-property 0 (length text) 'default 'append text)
;; Pay attention to the `font-lock-face' property.
(when font-lock-mode
(let ((pos 0))
(while (< pos (length text))
(let ((next-pos (or (next-single-property-change
pos 'font-lock-face text)
(length text))))
(when-let ((face (get-pos-property pos 'font-lock-face
text)))
(add-face-text-property pos next-pos face nil text))
(setq pos next-pos)))))
text)))
(when (and (cadr block)
(< (cdar block) (point-max))
(not (let* ((extend-attr
(lambda (face)
(if (facep face)
(when (>= emacs-major-version 27)
(face-attribute face :extend))
(if-let (val (plist-member face :extend))
(cadr val)
'unspecified))))
(extend 'unspecified))
(let ((faceprop (get-char-property (cdar block)
'face)))
(catch 'done
(if (face-list-p faceprop)
(dolist (face faceprop)
(setq extend (funcall extend-attr face))
(when (booleanp extend)
(throw 'done extend)))
(setq extend (funcall extend-attr faceprop))
(when (booleanp extend)
(throw 'done extend)))
(funcall extend-attr 'default))))))
(let ((ov (make-overlay (cdar block) (1+ (cdar block)))))
(push ov (window-parameter nil 'popon-overlays))
(overlay-put ov 'window (selected-window))
(overlay-put ov 'face 'default))))))
(defun popon--redisplay-1 (force)
"Redisplay popon overlays.
When FORCE is non-nil, update all overlays."
(let ((popon-available-p nil)
(any-popon-visible-p nil))
(dolist (frame (frame-list))
(dolist (window (window-list frame))
(set-window-parameter
window 'popon-list
(cl-remove-if-not #'popon-live-p
(window-parameter window 'popon-list)))
(when (window-parameter window 'popon-list)
(setq popon-available-p t))
(let ((popons
(cl-remove-if-not
(lambda (popon)
(and (or (null (popon-buffer popon))
(eq (popon-buffer popon) (window-buffer)))
(< (cdr (popon-position popon))
(with-selected-window window
(floor (window-screen-lines))))
(< (car (popon-position popon))
(- (window-width window)
(if (fboundp 'line-number-display-width)
(with-selected-window window
(line-number-display-width))
0)
(if (display-graphic-p)
(let ((fringes (window-fringes window)))
(/ (+ (car fringes) (cadr fringes))
(frame-char-width frame)))
(if (zerop (window-hscroll)) 0 1))))))
(copy-sequence (window-parameter window 'popon-list)))))
(when (or force
(not
(and
(eq (window-parameter window 'popon-window-start)
(window-start window))
(eq (window-parameter window 'popon-window-hscroll)
(window-hscroll window))
(eq (window-parameter window 'popon-window-buffer)
(window-buffer window))
(null (cl-set-exclusive-or
popons
(window-parameter window
'popon-visible-popons))))))
(while (window-parameter window 'popon-overlays)
(delete-overlay
(pop (window-parameter window 'popon-overlays))))
(when popons
(setq popons (sort popons (lambda (a b)
(< (popon-priority a)
(popon-priority b)))))
(with-selected-window window
(let* ((framebuffer (popon--make-framebuffer)))
(dolist (popon popons)
(popon--render popon framebuffer (window-hscroll)))
(popon--make-overlays framebuffer))))
(set-window-parameter window 'popon-visible-popons popons)
(set-window-parameter window 'popon-window-start
(window-start window))
(set-window-parameter window 'popon-window-hscroll
(window-hscroll window))
(set-window-parameter window 'popon-window-buffer
(window-buffer window))))
(when (window-parameter window 'popon-visible-popons)
(setq any-popon-visible-p t))))
(if any-popon-visible-p
(add-hook 'pre-redisplay-functions #'popon--pre-redisplay)
(remove-hook 'pre-redisplay-functions #'popon--pre-redisplay))
(if popon-available-p
(add-hook 'window-configuration-change-hook #'popon-update)
(remove-hook 'window-configuration-change-hook #'popon-update))))
;;;###autoload
(defun popon-redisplay ()
"Redisplay popon overlays."
(popon--redisplay-1 t))
;;;###autoload
(defun popon-update ()
"Update popons if needed."
(popon--redisplay-1 nil))
(defun popon--pre-redisplay (_)
"Update popons."
(popon-update))
;;;###autoload
(defun popon-x-y-at-pos (point)
"Return the (X, Y) coodinate of POINT in selected window as a cons cell.
Return nil if POINT is not in visible text area.
NOTE: This uses `posn-at-point', which is slow. So try to minimize calls
to this function."
(let ((window-start-x-y (posn-col-row (posn-at-point (window-start))))
(point-x-y (posn-col-row (posn-at-point point))))
(cons (- (car point-x-y) (car window-start-x-y))
(- (cdr point-x-y) (cdr window-start-x-y)))))
;;;###autoload
(defun popon-kill-all ()
"Kill all popons."
(interactive)
(dolist (frame (frame-list))
(dolist (window (window-list frame))
(while (window-parameter window 'popon-list)
(popon-kill (pop (window-parameter window 'popon-list)))))))
(provide 'popon)
;;; popon.el ends here