branch: externals/listen
commit 83669a4574b0475f31f2808c348e4ea29462df66
Merge: 82386aa8b9 455a60c255
Author: Adam Porter <[email protected]>
Commit: Adam Porter <[email protected]>
Merge: Workaround for vtable on Emacs < 30.1
---
listen-queue.el | 171 ++++++++++++++++++++++++++++++++++++++------------------
1 file changed, 116 insertions(+), 55 deletions(-)
diff --git a/listen-queue.el b/listen-queue.el
index 3d8c236eda..a7b74d9a7a 100644
--- a/listen-queue.el
+++ b/listen-queue.el
@@ -139,7 +139,7 @@ Useful for when `save-excursion' does not preserve point."
(setf listen-queue queue)
(erase-buffer)
(when (listen-queue-tracks listen-queue)
- (make-vtable
+ (listen-make-vtable
:columns
(list (list :name "▶" :primary 'descend
:getter
@@ -313,7 +313,7 @@ If BACKWARDP, move it backward."
(list track)
(seq-subseq (listen-queue-tracks queue) position)))
(vtable-insert-object (vtable-current-table) track previous-track)
- (vtable-update-object (vtable-current-table) previous-track
previous-track)))
+ (listen-queue--vtable-update-object (vtable-current-table) previous-track
previous-track)))
(defun listen-queue--update-buffer (queue)
"Update QUEUE's buffer, if any."
@@ -326,56 +326,6 @@ If BACKWARDP, move it backward."
(listen-queue--annotate-buffer))
(listen-queue-goto-current queue)))
-(defun listen-queue-update-track (track queue)
- "Update TRACK in QUEUE.
-Reverts TRACK's metadata from the file and updates it in QUEUE,
-including QUEUE's buffer, if any."
- ;; TODO: Use where appropriate.
- (listen-queue-revert-track track)
- (listen-queue-with-buffer queue
- (listen-save-position
- (goto-char (point-min))
- (vtable-update-object (vtable-current-table) track track))))
-
-(declare-function listen-mode "listen")
-(declare-function listen-play "listen")
-;;;###autoload
-(cl-defun listen-queue-play (queue &optional (track (car (listen-queue-tracks
queue))))
- "Play QUEUE and optionally TRACK in it.
-Interactively, selected queue with completion; and with prefix,
-select track as well."
- (interactive
- (let* ((queue (listen-queue-complete))
- (track (if current-prefix-arg
- (listen-queue-complete-track queue)
- (car (listen-queue-tracks queue)))))
- (list queue track)))
- (let ((player (listen-current-player)))
- (listen-play player (listen-track-filename track))
- ;; Remember queue position of track so if it gets removed, we can still go
to the next track.
- (setf (map-elt (listen-queue-etc queue) :track-number)
- (seq-position (listen-queue-tracks queue) track))
- (let ((previous-track (listen-queue-current queue)))
- (setf (listen-queue-current queue) track
- (map-elt (listen-player-etc player) :queue) queue)
- (listen-queue-with-buffer queue
- ;; HACK: Only update the vtable if its buffer is visible.
- (when-let ((buffer-window (get-buffer-window (current-buffer))))
- (with-selected-window buffer-window
- (listen-save-position
- (goto-char (point-min))
- (ignore-errors
- ;; HACK: Ignore errors, because if the window size has
changed, the vtable's cache
- ;; will miss and it will signal an error.
- (when previous-track
- (listen-queue--vtable-update-object (vtable-current-table)
- previous-track
previous-track))
- (listen-queue--vtable-update-object (vtable-current-table)
track track)))
- (listen-queue--highlight-current))))))
- (unless listen-mode
- (listen-mode))
- queue)
-
(defun listen-queue-goto-current (queue)
"Jump to current track."
(interactive (list (listen-queue-complete)))
@@ -772,7 +722,7 @@ tracks in the queue unchanged)."
(cl-labels ((get (slot)
(cons (capitalize (symbol-name slot))
(cl-struct-slot-value 'listen-track slot track))))
- (make-vtable
+ (listen-make-vtable
:columns
(list (list :name "Key" :getter (lambda (row _table) (car row)))
(list :name "Value" :getter (lambda (row _table) (cdr row))))
@@ -944,7 +894,7 @@ Delay according to `listen-queue-delay-time-range', which
see."
(toggle-truncate-lines 1)
(setq-local bookmark-make-record-function
#'listen-queue-list--bookmark-make-record)
(when listen-queues
- (make-vtable
+ (listen-make-vtable
:columns
(list (list :name "▶" :primary 'descend
:getter (lambda (queue _table)
@@ -990,7 +940,38 @@ Delay according to `listen-queue-delay-time-range', which
see."
;; `listen-queue--bookmark-handler' works correctly.
(pop-to-buffer buffer)))
-;;;; Compatibility
+;;;; Vtable
+
+(require 'vtable)
+
+(cl-defmacro listen-with-vtable-at (position &rest body)
+ "FIXME: Docstring."
+ (declare (indent defun))
+ (let ((positionᵥ (gensym)))
+ `(let ((,positionᵥ ,position))
+ (save-excursion
+ (goto-char ,positionᵥ)
+ (cl-letf* (((symbol-function 'frame-terminal)
+ (lambda (&optional _)
+ listen-vtable-frame-terminal))
+ ((symbol-function 'window-width)
+ (lambda (&optional _ _)
+ listen-vtable-window-width))
+ (table (vtable-current-table))
+ ((symbol-function 'vtable-current-table)
+ (lambda ()
+ table))
+ ((symbol-function 'vtable--recompute-numerical)
+ #'listen-queue--vtable--recompute-numerical))
+ ,@body)))))
+
+(defvar-local listen-vtable-frame-terminal nil)
+(defvar-local listen-vtable-window-width nil)
+
+(defun listen-make-vtable (&rest args)
+ (apply #'make-vtable args)
+ (setq-local listen-vtable-frame-terminal (frame-terminal)
+ listen-vtable-window-width (window-width)))
(defalias 'listen-queue--vtable-update-object
(if (version<= emacs-version "30")
@@ -1040,6 +1021,86 @@ Delay according to `listen-queue-delay-time-range',
which see."
(error "Can't find cached object in vtable"))))
#'vtable-update-object))
+;;;;; Functions using these vtable workarounds
+
+(defun listen-queue-update-track (track queue)
+ "Update TRACK in QUEUE.
+Reverts TRACK's metadata from the file and updates it in QUEUE,
+including QUEUE's buffer, if any."
+ ;; TODO: Use where appropriate.
+ (listen-queue-revert-track track)
+ (listen-queue-with-buffer queue
+ (listen-save-position
+ (listen-with-vtable-at (point-min)
+ (listen-queue--vtable-update-object table track track)))))
+
+;;;###autoload
+(cl-defun listen-queue-play (queue &optional (track (car (listen-queue-tracks
queue))))
+ "Play QUEUE and optionally TRACK in it.
+Interactively, selected queue with completion; and with prefix,
+select track as well."
+ (interactive
+ (let* ((queue (listen-queue-complete))
+ (track (if current-prefix-arg
+ (listen-queue-complete-track queue)
+ (car (listen-queue-tracks queue)))))
+ (list queue track)))
+ (declare-function listen-mode "listen")
+ (declare-function listen-play "listen")
+ (let ((player (listen-current-player)))
+ (listen-play player (listen-track-filename track))
+ ;; Remember queue position of track so if it gets removed, we can still go
to the next track.
+ (setf (map-elt (listen-queue-etc queue) :track-number)
+ (seq-position (listen-queue-tracks queue) track))
+ (let ((previous-track (listen-queue-current queue)))
+ (setf (listen-queue-current queue) track
+ (map-elt (listen-player-etc player) :queue) queue)
+ (listen-queue-with-buffer queue
+ (listen-save-position
+ (listen-with-vtable-at (point-min)
+ (when previous-track
+ (listen-queue--vtable-update-object table previous-track
previous-track))
+ (listen-queue--vtable-update-object table track track)))
+ (listen-queue--highlight-current))))
+ (unless listen-mode
+ (listen-mode))
+ queue)
+
+(defalias 'listen-queue--vtable--recompute-numerical
+ ;; TODO: Remove this when requiring Emacs 30+.
+ ;; See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=69927>.
+ (if (version< emacs-version "30.1")
+ (lambda (table line)
+ "Recompute numericalness of columns if necessary."
+ (let ((columns (vtable-columns table))
+ (recompute nil))
+ (seq-do-indexed
+ (lambda (elem index)
+ (when (and (vtable-column--numerical (elt columns index))
+ (not (numberp (car elem))))
+ (setq recompute t)))
+ line)
+ (when recompute
+ (vtable--compute-columns table))))
+ ;; HACK: This is unique, one the likes of which I've never quite seen
before. This is to work
+ ;; around errors like "(cyclic-function-indirection
vtable--recompute-numerical)" and "Symbol’s
+ ;; chain of function indirections contains a loop:
vtable--recompute-numerical". Because we
+ ;; also, in the macro `listen-with-vtable-at', dynamically rebind the
function
+ ;; `vtable--recompute-numerical' with `cl-letf*', which normally creates a
loop, we use
+ ;; `cl-letf' here also, to save a reference to the original function
definition, which we make
+ ;; our own alias to. Then when the expansion of `cl-letf*' in
`listen-with-vtable-at' rebinds
+ ;; the function slot of `vtable--recompute-numerical', it binds it to the
original function,
+ ;; rather than to the symbol (which would cause the cyclic
indirection/loop).
+
+ ;; Now, you may think this is ugly or ridiculous, but it has a legitimate
purpose: to provide a
+ ;; fix for users of older Emacs versions, while also being compatible with
the Emacs version
+ ;; that has the fix included. And how many other languages and platforms
would even allow this?
+ ;; (Remember that `cl-letf' rebinds the symbol's function slot, so that
while the macro's
+ ;; expansion is on the stack, anything else--in the whole system--that
calls the rebound
+ ;; function calls our replacement for it--not just where we, ourselves,
directly reference it.)
+ (cl-letf ((orig-fn (symbol-function 'vtable--recompute-numerical)))
+ orig-fn)))
+
;;;; Footer
(provide 'listen-queue)
