917 lines
41 KiB
EmacsLisp
917 lines
41 KiB
EmacsLisp
;;; ement-room-list.el --- List Ement rooms -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
|
|
|
|
;; Author: Adam Porter <adam@alphapapa.net>
|
|
;; Maintainer: Adam Porter <adam@alphapapa.net>
|
|
|
|
;; 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 library implements a room list view using `taxy' and `taxy-magit-section' for
|
|
;; dynamic, programmable grouping.
|
|
|
|
;;; Code:
|
|
|
|
(require 'button)
|
|
(require 'rx)
|
|
|
|
(require 'persist)
|
|
(require 'svg-lib)
|
|
(require 'taxy)
|
|
(require 'taxy-magit-section)
|
|
|
|
(require 'ement-lib)
|
|
|
|
;;;; Mouse commands
|
|
|
|
;; Since mouse-activated commands must handle mouse events, we define a simple macro to
|
|
;; wrap a command into a mouse-event-accepting one.
|
|
|
|
(defmacro ement-room-list-define-mouse-command (command)
|
|
"Define a command that calls COMMAND interactively with point at mouse event.
|
|
COMMAND should be a form that evaluates to a function symbol; if
|
|
a symbol, it should be unquoted.."
|
|
(let ((docstring (format "Call command `%s' interactively with point at EVENT." command))
|
|
(name (intern (format "ement-room-list-mouse-%s" command))))
|
|
`(defun ,name (event)
|
|
,docstring
|
|
(interactive "e")
|
|
(mouse-set-point event)
|
|
(call-interactively #',command))))
|
|
|
|
;;;; Types
|
|
|
|
(defclass ement-room-list-section (magit-section)
|
|
;; We define this class so we can use it as the type of section we insert, so we can
|
|
;; define a method to return identifiers for our section type, so section visibility can
|
|
;; be cached concisely (i.e. without storing room event data in the values, which can
|
|
;; serialize to hundreds of megabytes after receiving many events).
|
|
nil)
|
|
|
|
(cl-defmethod magit-section-ident-value ((section ement-room-list-section))
|
|
"Return ident value for `ement-room-list-section' SECTION.
|
|
Used for caching section visibility."
|
|
;; FIXME: The name of each taxy could be ambiguous. Best would be to use the
|
|
;; hierarchical path, but since the taxys aren't doubly linked, that isn't easily done.
|
|
;; Could probably be worked around by binding a special variable around the creation of
|
|
;; the taxy hierarchy that would allow the path to be saved into each taxy.
|
|
(pcase-exhaustive (oref section value)
|
|
;; FIXME(emacs-28): Use `(cl-type taxy-magit-section)' and `(cl-type ement-room)', et
|
|
;; al. when requiring Emacs 28. See
|
|
;; <https://github.com/alphapapa/ement.el/issues/272>.
|
|
((and (pred taxy-magit-section-p) it)
|
|
(taxy-name it))
|
|
(`[,(and (pred ement-room-p) room)
|
|
,(and (pred ement-session-p) session)]
|
|
(vector (ement-user-id (ement-session-user session))
|
|
(ement-room-id room)))
|
|
((pred null) nil)))
|
|
|
|
;;;; Variables
|
|
|
|
(declare-function ement-room-toggle-space "ement-room")
|
|
|
|
(defvar ement-room-list-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map (kbd "RET") #'ement-room-list-RET)
|
|
(define-key map (kbd "SPC") #'ement-room-list-next-unread)
|
|
(define-key map [tab] #'ement-room-list-section-toggle)
|
|
(define-key map [mouse-1] (ement-room-list-define-mouse-command ement-room-list-RET))
|
|
(define-key map [mouse-2] (ement-room-list-define-mouse-command ement-room-list-kill-buffer))
|
|
(define-key map (kbd "k") #'ement-room-list-kill-buffer)
|
|
(define-key map (kbd "s") #'ement-room-toggle-space)
|
|
map)
|
|
"Keymap for `ement-room-list' buffers.
|
|
See also `ement-room-list-button-map'.")
|
|
|
|
(defvar ement-room-list-button-map
|
|
;; This map is needed because some columns are propertized as buttons, which override
|
|
;; the main keymap.
|
|
;; TODO: Is it possible to adjust the button properties to obviate this map?
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map [mouse-1] (ement-room-list-define-mouse-command ement-room-list-RET))
|
|
(define-key map [mouse-2] (ement-room-list-define-mouse-command ement-room-list-kill-buffer))
|
|
map)
|
|
"Keymap for buttonized text in `ement-room-list' buffers.")
|
|
|
|
(defvar ement-room-list-timestamp-colors nil
|
|
"List of colors used for timestamps.
|
|
Set automatically when `ement-room-list-mode' is activated.")
|
|
|
|
(defvar ement-room)
|
|
(defvar ement-session)
|
|
(defvar ement-sessions)
|
|
(defvar ement-room-prism-minimum-contrast)
|
|
|
|
;;;;; Persistent variables
|
|
|
|
(persist-defvar ement-room-list-visibility-cache nil
|
|
"Applied to `magit-section-visibility-cache', which see.")
|
|
|
|
;;;; Customization
|
|
|
|
(defgroup ement-room-list-faces nil
|
|
"Faces for room list buffers."
|
|
:group 'ement-room-list
|
|
:group 'ement-faces)
|
|
|
|
(defgroup ement-room-list nil
|
|
"Options for room list buffers."
|
|
:group 'ement)
|
|
|
|
(defcustom ement-room-list-auto-update t
|
|
"Automatically update the taxy-based room list buffer."
|
|
:type 'boolean)
|
|
|
|
(defcustom ement-room-list-avatars (display-images-p)
|
|
"Show room avatars in the room list."
|
|
:type 'boolean)
|
|
|
|
(defcustom ement-room-list-avatar-generation (image-type-available-p 'svg)
|
|
"Generate SVG-based avatars for rooms that have none."
|
|
:type 'boolean)
|
|
|
|
(defcustom ement-room-list-space-prefix "Space: "
|
|
"Prefix applied to space names."
|
|
:type 'string)
|
|
|
|
;;;;; Faces
|
|
|
|
;; TODO: Inherit from a single face to allow certain attributes to be disabled
|
|
;; (e.g. underline), in case a face inherited from has such attributes.
|
|
|
|
(defface ement-room-list-direct
|
|
;; We want to use `font-lock-constant-face' as the base face (because it seems to look
|
|
;; nice with most themes), but that face sometimes is defined as bold, which interferes
|
|
;; with our ability to use boldness to indicate unread rooms. But if we override the
|
|
;; weight to be normal, even the "People" heading in the room list will not be bold,
|
|
;; which group headings should be. So we make a copy of the face, unset its weight, and
|
|
;; inherit from that.
|
|
(progn
|
|
(copy-face 'font-lock-constant-face 'ement--font-lock-constant-face)
|
|
(set-face-attribute 'ement--font-lock-constant-face nil :weight 'unspecified)
|
|
'((t (:inherit (ement--font-lock-constant-face ement-room-list-name) :underline nil))))
|
|
"Direct rooms."
|
|
:group 'ement-room-list-faces)
|
|
|
|
(defface ement-room-list-favourite '((t (:inherit (font-lock-doc-face ement-room-list-name))))
|
|
"Favourite rooms."
|
|
:group 'ement-room-list-faces)
|
|
|
|
(defface ement-room-list-invited
|
|
'((t (:inherit (italic ement-room-list-name))))
|
|
"Invited rooms."
|
|
:group 'ement-room-list-faces)
|
|
|
|
(defface ement-room-list-left
|
|
'((t (:strike-through t :inherit ement-room-list-name)))
|
|
"Left rooms."
|
|
:group 'ement-room-list-faces)
|
|
|
|
(defface ement-room-list-low-priority '((t (:inherit (font-lock-comment-face ement-room-list-name))))
|
|
"Low-priority rooms."
|
|
:group 'ement-room-list-faces)
|
|
|
|
(defface ement-room-list-name
|
|
'((t (:inherit (font-lock-function-name-face button) :underline nil)))
|
|
"Non-direct rooms."
|
|
:group 'ement-room-list-faces)
|
|
|
|
(defface ement-room-list-space '((t (:inherit (font-lock-regexp-grouping-backslash ement-room-list-name))))
|
|
"Space rooms."
|
|
:group 'ement-room-list-faces)
|
|
|
|
(defface ement-room-list-unread
|
|
'((t (:inherit (bold ement-room-list-name))))
|
|
"Unread rooms."
|
|
:group 'ement-room-list-faces)
|
|
|
|
(defface ement-room-list-recent '((t (:inherit font-lock-warning-face)))
|
|
"Latest timestamp of recently updated rooms.
|
|
The foreground color is used to generate a gradient of colors
|
|
from recent to non-recent for rooms updated in the past 24
|
|
hours but at least one hour ago."
|
|
:group 'ement-room-list-faces)
|
|
|
|
(defface ement-room-list-very-recent '((t (:inherit error)))
|
|
"Latest timestamp of very recently updated rooms.
|
|
The foreground color is used to generate a gradient of colors
|
|
from recent to non-recent for rooms updated in the past hour."
|
|
:group 'ement-room-list-faces)
|
|
|
|
;;;; Keys
|
|
|
|
;; Since some of these keys need access to the session, and room
|
|
;; structs don't include the session, we use a two-element vector in
|
|
;; which the session is the second element.
|
|
|
|
(eval-and-compile
|
|
(taxy-define-key-definer ement-room-list-define-key
|
|
ement-room-list-keys "ement-room-list-key" "FIXME: Docstring."))
|
|
|
|
(ement-room-list-define-key membership (&key name status)
|
|
;; FIXME: Docstring: status should be a symbol of either `invite', `join', `leave'.
|
|
(cl-labels ((format-membership (membership)
|
|
(pcase membership
|
|
('join "Joined")
|
|
('invite "Invited")
|
|
('leave "[Left]"))))
|
|
(pcase-let ((`[,(cl-struct ement-room (status membership)) ,_session] item))
|
|
(if status
|
|
(when (equal status membership)
|
|
(or name (format-membership membership)))
|
|
(format-membership membership)))))
|
|
|
|
(ement-room-list-define-key alias (&key name regexp)
|
|
(pcase-let ((`[,(cl-struct ement-room canonical-alias) ,_session] item))
|
|
(when canonical-alias
|
|
(when (string-match-p regexp canonical-alias)
|
|
name))))
|
|
|
|
(ement-room-list-define-key buffer ()
|
|
(pcase-let ((`[,(cl-struct ement-room (local (map buffer))) ,_session] item))
|
|
(when buffer
|
|
#("Buffers" 0 7 (help-echo "Rooms with open buffers")))))
|
|
|
|
(ement-room-list-define-key direct ()
|
|
(pcase-let ((`[,room ,session] item))
|
|
(when (ement--room-direct-p room session)
|
|
"Direct")))
|
|
|
|
(ement-room-list-define-key people ()
|
|
(pcase-let ((`[,room ,session] item))
|
|
(when (ement--room-direct-p room session)
|
|
(ement-propertize "People" 'face 'ement-room-list-direct))))
|
|
|
|
(ement-room-list-define-key space (&key name id)
|
|
(pcase-let* ((`[,room ,session] item)
|
|
((cl-struct ement-session rooms) session)
|
|
((cl-struct ement-room type (local (map parents))) room))
|
|
(cl-labels ((format-space (id)
|
|
(let* ((parent-room (cl-find id rooms :key #'ement-room-id :test #'equal))
|
|
(space-name (if parent-room
|
|
(ement-room-display-name parent-room)
|
|
id)))
|
|
(concat ement-room-list-space-prefix space-name))))
|
|
(when-let ((key (if id
|
|
;; ID specified.
|
|
(cond ((or (member id parents)
|
|
(equal id (ement-room-id room)))
|
|
;; Room is in specified space.
|
|
(or name (format-space id)))
|
|
((and (equal type "m.space")
|
|
(equal id (ement-room-id room)))
|
|
;; Room is a specified space.
|
|
(or name (concat ement-room-list-space-prefix (ement-room-display-name room)))))
|
|
;; ID not specified.
|
|
(pcase (length parents)
|
|
(0 nil)
|
|
(1
|
|
;; TODO: Make the rooms list a hash table to avoid this lookup.
|
|
(format-space (car parents)))
|
|
(_
|
|
;; TODO: How to handle this better? (though it should be very rare)
|
|
(string-join (mapcar #'format-space parents) ", "))))))
|
|
(ement-propertize key 'face 'ement-room-list-space)))))
|
|
|
|
(ement-room-list-define-key space-p ()
|
|
"Groups rooms that are themselves spaces."
|
|
(pcase-let* ((`[,room ,_session] item)
|
|
((cl-struct ement-room type) room))
|
|
(when (equal "m.space" type)
|
|
"Spaces")))
|
|
|
|
(ement-room-list-define-key name (&key name regexp)
|
|
(pcase-let* ((`[,room ,_session] item)
|
|
(display-name (ement--room-display-name room)))
|
|
(when display-name
|
|
(when (string-match-p regexp display-name)
|
|
(or name regexp)))))
|
|
|
|
(ement-room-list-define-key latest (&key name newer-than older-than)
|
|
(pcase-let* ((`[,room ,_session] item)
|
|
((cl-struct ement-room latest-ts) room)
|
|
(age))
|
|
(when latest-ts
|
|
(setf age (- (time-convert nil 'integer) (/ latest-ts 1000)))
|
|
(cond (newer-than
|
|
(when (<= age newer-than)
|
|
(or name (format "Newer than %s seconds" newer-than))))
|
|
(older-than
|
|
(when (>= age older-than)
|
|
(or name (format "Older than %s seconds" newer-than))))
|
|
(t
|
|
;; Default to rooms with traffic in the last day.
|
|
(if (<= age 86400)
|
|
"Last 24 hours"
|
|
"Older than 24 hours"))))))
|
|
|
|
(ement-room-list-define-key freshness
|
|
(&key (intervals '((86400 . "Past 24h")
|
|
(604800 . "Past week")
|
|
(2419200 . "Past month")
|
|
(31536000 . "Past year"))))
|
|
(pcase-let* ((`[,room ,_session] item)
|
|
((cl-struct ement-room latest-ts) room)
|
|
(age))
|
|
(when latest-ts
|
|
(setf age (- (time-convert nil 'integer) (/ latest-ts 1000)))
|
|
(or (alist-get age intervals nil nil #'>)
|
|
"Older than a year"))))
|
|
|
|
(ement-room-list-define-key session (&optional user-id)
|
|
(pcase-let ((`[,_room ,(cl-struct ement-session
|
|
(user (cl-struct ement-user id)))]
|
|
item))
|
|
(pcase user-id
|
|
(`nil id)
|
|
(_ (when (equal user-id id)
|
|
user-id)))))
|
|
|
|
(ement-room-list-define-key topic (&key name regexp)
|
|
(pcase-let ((`[,(cl-struct ement-room topic) ,_session] item))
|
|
(when (and topic (string-match-p regexp topic))
|
|
name)))
|
|
|
|
(ement-room-list-define-key unread ()
|
|
(pcase-let ((`[,room ,session] item))
|
|
(when (ement--room-unread-p room session)
|
|
"Unread")))
|
|
|
|
(ement-room-list-define-key favourite ()
|
|
:then #'identity
|
|
(pcase-let ((`[,room ,_session] item))
|
|
(when (ement--room-favourite-p room)
|
|
(ement-propertize "Favourite" 'face 'ement-room-list-favourite))))
|
|
|
|
(ement-room-list-define-key low-priority ()
|
|
:then #'identity
|
|
(pcase-let ((`[,room ,_session] item))
|
|
(when (ement--room-low-priority-p room)
|
|
"Low-priority")))
|
|
|
|
(defcustom ement-room-list-default-keys
|
|
'(;; First, group all invitations (this group will appear first since the rooms are
|
|
;; already sorted first).
|
|
((membership :status 'invite))
|
|
;; Group all left rooms (this group will appear last, because the rooms are already
|
|
;; sorted last).
|
|
((membership :status 'leave))
|
|
;; Group all favorite rooms, which are already sorted first.
|
|
(favourite)
|
|
;; Group other rooms which are opened in a buffer.
|
|
(buffer)
|
|
;; Group other rooms which are unread.
|
|
(unread)
|
|
;; Group all low-priority rooms, which are already sorted last, and within that group,
|
|
;; group them by their space, if any.
|
|
(low-priority space)
|
|
;; Group other non-direct rooms which are in a space by freshness, then by space.
|
|
((and :name "Spaced"
|
|
:keys ((not space-p)
|
|
(not people)
|
|
space))
|
|
freshness space)
|
|
;; Group spaces themselves by their parent space (since space headers can't also be
|
|
;; items, we have to handle them separately; a bit of a hack, but not too bad).
|
|
((and :name "Spaces" :keys (space-p))
|
|
space)
|
|
;; Group rooms which aren't in spaces by their freshness.
|
|
((and :name "Unspaced"
|
|
:keys ((not space)
|
|
(not people)))
|
|
freshness)
|
|
;; Group direct rooms by freshness and space.
|
|
(people freshness space))
|
|
"Default keys."
|
|
:type 'sexp)
|
|
|
|
;;;; Columns
|
|
|
|
(eval-and-compile
|
|
(taxy-magit-section-define-column-definer "ement-room-list"))
|
|
|
|
(ement-room-list-define-column #("🐱" 0 1 (help-echo "Avatar")) (:align 'right)
|
|
(pcase-let* ((`[,room ,_session] item)
|
|
((cl-struct ement-room avatar display-name
|
|
(local (map room-list-avatar)))
|
|
room))
|
|
(if ement-room-list-avatars
|
|
(or room-list-avatar
|
|
(let ((new-avatar
|
|
(if avatar
|
|
;; NOTE: We resize every avatar to be suitable for this buffer, rather than using
|
|
;; the one cached in the room's struct. If the buffer's faces change height, this
|
|
;; will need refreshing, but it should be worth it to avoid resizing the images on
|
|
;; every update.
|
|
(propertize " " 'display
|
|
(ement--resize-image (get-text-property 0 'display avatar)
|
|
nil (frame-char-height)))
|
|
;; Room has no avatar.
|
|
(if ement-room-list-avatar-generation
|
|
(let* ((string (or display-name (ement--room-display-name room)))
|
|
(ement-room-prism-minimum-contrast 1)
|
|
(color (ement--prism-color string :contrast-with "white")))
|
|
(when (string-match (rx bos (or "#" "!" "@")) string)
|
|
(setf string (substring string 1)))
|
|
(propertize " " 'display (svg-lib-tag (substring string 0 1) nil
|
|
:background color :foreground "white"
|
|
:stroke 0)))
|
|
;; Avatar generation disabled: use a two-space string.
|
|
" "))))
|
|
(setf (alist-get 'room-list-avatar (ement-room-local room)) new-avatar)))
|
|
;; Avatars disabled: use a two-space string.
|
|
" ")))
|
|
|
|
(ement-room-list-define-column "Name" (:max-width 25)
|
|
(pcase-let* ((`[,room ,session] item)
|
|
((cl-struct ement-room type) room)
|
|
(display-name (ement--room-display-name room))
|
|
(face))
|
|
(or (when display-name
|
|
;; TODO: Use code from ement-room-list and put in a dedicated function.
|
|
(setf face (cl-copy-list '(:inherit (ement-room-list-name))))
|
|
;; In concert with the "Unread" column, this is roughly equivalent to the
|
|
;; "red/gray/bold/idle" states listed in <https://github.com/matrix-org/matrix-react-sdk/blob/b0af163002e8252d99b6d7075c83aadd91866735/docs/room-list-store.md#list-ordering-algorithm-importance>.
|
|
(when (ement--room-unread-p room session)
|
|
;; For some reason, `push' doesn't work with `map-elt'...or does it?
|
|
(push 'ement-room-list-unread (map-elt face :inherit)))
|
|
(when (equal "m.space" type)
|
|
(push 'ement-room-list-space (map-elt face :inherit)))
|
|
(when (ement--room-direct-p room session)
|
|
(push 'ement-room-list-direct (map-elt face :inherit)))
|
|
(when (ement--room-favourite-p room)
|
|
(push 'ement-room-list-favourite (map-elt face :inherit)))
|
|
(when (ement--room-low-priority-p room)
|
|
(push 'ement-room-list-low-priority (map-elt face :inherit)))
|
|
(pcase (ement-room-status room)
|
|
('invite
|
|
(push 'ement-room-list-invited (map-elt face :inherit)))
|
|
('leave
|
|
(push 'ement-room-list-left (map-elt face :inherit))))
|
|
(ement-propertize display-name
|
|
'face face
|
|
'mouse-face 'highlight
|
|
'keymap ement-room-list-button-map))
|
|
"")))
|
|
|
|
(ement-room-list-define-column #("Unread" 0 6 (help-echo "Unread events (Notifications:Highlights)")) (:align 'right)
|
|
(pcase-let* ((`[,(cl-struct ement-room unread-notifications) ,_session] item)
|
|
((map notification_count highlight_count) unread-notifications))
|
|
(if (or (not unread-notifications)
|
|
(and (equal 0 notification_count)
|
|
(equal 0 highlight_count)))
|
|
""
|
|
(concat (ement-propertize (number-to-string notification_count)
|
|
'face (if (zerop highlight_count)
|
|
'default
|
|
'ement-room-mention))
|
|
":"
|
|
(ement-propertize (number-to-string highlight_count)
|
|
'face 'highlight)))))
|
|
|
|
(ement-room-list-define-column "Latest" ()
|
|
(pcase-let ((`[,(cl-struct ement-room latest-ts) ,_session] item))
|
|
(if latest-ts
|
|
(let* ((difference-seconds (- (float-time) (/ latest-ts 1000)))
|
|
(n (cl-typecase difference-seconds
|
|
((number 0 3599) ;; <1 hour: 10-minute periods.
|
|
(truncate (/ difference-seconds 600)))
|
|
((number 3600 86400) ;; 1 hour to 1 day: 24 1-hour periods.
|
|
(+ 6 (truncate (/ difference-seconds 3600))))
|
|
(otherwise ;; Difference in weeks.
|
|
(min (/ (length ement-room-list-timestamp-colors) 2)
|
|
(+ 24 (truncate (/ difference-seconds 86400 7)))))))
|
|
(face (list :foreground (elt ement-room-list-timestamp-colors n)))
|
|
(formatted-ts (ement--human-format-duration difference-seconds 'abbreviate)))
|
|
(string-match (rx (1+ digit) (repeat 1 alpha)) formatted-ts)
|
|
(ement-propertize (match-string 0 formatted-ts)
|
|
'face face
|
|
'help-echo formatted-ts))
|
|
"")))
|
|
|
|
(ement-room-list-define-column "Topic" (:max-width 35)
|
|
(pcase-let ((`[,(cl-struct ement-room topic status) ,_session] item))
|
|
;; FIXME: Can the status and type unified, or is this inherent to the spec?
|
|
(when topic
|
|
(setf topic (replace-regexp-in-string "\n" " " topic 'fixedcase 'literal)))
|
|
(pcase status
|
|
('invite (concat (ement-propertize "[invited]"
|
|
'face 'ement-room-list-invited)
|
|
" " topic))
|
|
('leave (concat (ement-propertize "[left]"
|
|
'face 'ement-room-list-left)
|
|
" " topic))
|
|
(_ (or topic "")))))
|
|
|
|
(ement-room-list-define-column "Members" (:align 'right)
|
|
(pcase-let ((`[,(cl-struct ement-room
|
|
(summary (map ('m.joined_member_count member-count))))
|
|
,_session]
|
|
item))
|
|
(if member-count
|
|
(number-to-string member-count)
|
|
"")))
|
|
|
|
(ement-room-list-define-column #("Notifications" 0 5 (help-echo "Notification state")) ()
|
|
(pcase-let* ((`[,room ,session] item))
|
|
(pcase (ement-room-notification-state room session)
|
|
('nil "default")
|
|
('all-loud "all (loud)")
|
|
('all "all")
|
|
('mentions-and-keywords "mentions")
|
|
('none "none"))))
|
|
|
|
(ement-room-list-define-column #("B" 0 1 (help-echo "Buffer exists for room")) ()
|
|
(pcase-let ((`[,(cl-struct ement-room (local (map buffer))) ,_session] item))
|
|
(if buffer
|
|
#("B" 0 1 (help-echo "Buffer exists for room"))
|
|
" ")))
|
|
|
|
(ement-room-list-define-column "Session" ()
|
|
(pcase-let ((`[,_room ,(cl-struct ement-session (user (cl-struct ement-user id)))] item))
|
|
id))
|
|
|
|
(unless ement-room-list-columns
|
|
;; TODO: Automate this or document it
|
|
(setq-default ement-room-list-columns
|
|
(get 'ement-room-list-columns 'standard-value)))
|
|
|
|
;;;; Bookmark support
|
|
|
|
;; Especially useful with Burly: <https://github.com/alphapapa/burly.el>
|
|
|
|
(require 'bookmark)
|
|
|
|
(defun ement-room-list-bookmark-make-record ()
|
|
"Return a bookmark record for the `ement-room-list' buffer."
|
|
(list "*Ement Room List*"
|
|
(cons 'handler #'ement-room-list-bookmark-handler)))
|
|
|
|
(defun ement-room-list-bookmark-handler (bookmark)
|
|
"Show `ement-room-list' room list buffer for BOOKMARK."
|
|
(pcase-let* ((`(,_bookmark-name . ,_) bookmark))
|
|
(unless ement-sessions
|
|
;; MAYBE: Automatically connect.
|
|
(user-error "No sessions connected: call `ement-connect' first"))
|
|
(ement-room-list)))
|
|
|
|
;;;; Commands
|
|
|
|
(defun ement-room-list-section-toggle ()
|
|
"Toggle the section at point."
|
|
;; HACK: For some reason, when a section's body is hidden, then the buffer is refreshed,
|
|
;; and then the section's body is shown again, the body is empty--but then, refreshing
|
|
;; the buffer shows its body. So we work around that by refreshing the buffer when a
|
|
;; section is toggled. In a way, it makes sense to do this anyway, so the user has the
|
|
;; most up-to-date information in the buffer. This hack also works around a minor
|
|
;; visual bug that sometimes causes room avatars to be displayed in a section heading
|
|
;; when a section is hidden.
|
|
(interactive)
|
|
(ignore-errors
|
|
;; Ignore an error in case point is past the top-level section.
|
|
(cl-typecase (aref (oref (magit-current-section) value) 0)
|
|
(ement-room
|
|
;; HACK: Don't hide rooms themselves (they end up permanently hidden).
|
|
nil)
|
|
(otherwise
|
|
(call-interactively #'magit-section-toggle)
|
|
(revert-buffer)))))
|
|
|
|
;;;###autoload
|
|
(defun ement-room-list--after-initial-sync (&rest _ignore)
|
|
"Call `ement-room-list', ignoring arguments.
|
|
To be called from `ement-after-initial-sync-hook'."
|
|
(ement-room-list))
|
|
|
|
;;;###autoload
|
|
(defalias 'ement-list-rooms 'ement-room-list)
|
|
|
|
;;;###autoload
|
|
(cl-defun ement-room-list (&key (buffer-name "*Ement Room List*")
|
|
(keys ement-room-list-default-keys)
|
|
(display-buffer-action '((display-buffer-reuse-window display-buffer-same-window)))
|
|
;; visibility-fn
|
|
)
|
|
"Show a buffer listing Ement rooms, grouped with Taxy KEYS.
|
|
After showing it, its window is selected. The buffer is named
|
|
BUFFER-NAME and is shown with DISPLAY-BUFFER-ACTION; or if
|
|
DISPLAY-BUFFER-ACTION is nil, the buffer is not displayed."
|
|
(interactive)
|
|
(let ((window-start 0) (window-point 0)
|
|
format-table column-sizes)
|
|
(cl-labels (;; (heading-face
|
|
;; (depth) (list :inherit (list 'bufler-group (bufler-level-face depth))))
|
|
(format-item (item) (gethash item format-table))
|
|
;; NOTE: Since these functions take an "item" (which is a [room session]
|
|
;; vector), they're prefixed "item-" rather than "room-".
|
|
(item-latest-ts (item)
|
|
(or (ement-room-latest-ts (elt item 0))
|
|
;; Room has no latest timestamp. FIXME: This shouldn't
|
|
;; happen, but it can, maybe due to oversights elsewhere.
|
|
0))
|
|
(item-unread-p (item)
|
|
(pcase-let ((`[,room ,session] item))
|
|
(ement--room-unread-p room session)))
|
|
(item-left-p (item)
|
|
(pcase-let ((`[,(cl-struct ement-room status) ,_session] item))
|
|
(equal 'leave status)))
|
|
(item-buffer-p (item)
|
|
(pcase-let ((`[,(cl-struct ement-room (local (map buffer))) ,_session] item))
|
|
(buffer-live-p buffer)))
|
|
(taxy-unread-p (taxy)
|
|
(or (cl-some #'item-unread-p (taxy-items taxy))
|
|
(cl-some #'taxy-unread-p (taxy-taxys taxy))))
|
|
(item-space-p (item)
|
|
(pcase-let ((`[,(cl-struct ement-room type) ,_session] item))
|
|
(equal "m.space" type)))
|
|
(item-favourite-p (item)
|
|
(pcase-let ((`[,room ,_session] item))
|
|
(ement--room-favourite-p room)))
|
|
(item-low-priority-p (item)
|
|
(pcase-let ((`[,room ,_session] item))
|
|
(ement--room-low-priority-p room)))
|
|
(visible-p (section)
|
|
;; This is very confusing and doesn't currently work.
|
|
(let ((value (oref section value)))
|
|
(if (cl-typecase value
|
|
(taxy-magit-section (item-unread-p value))
|
|
(ement-room nil))
|
|
'show
|
|
'hide)))
|
|
(item-invited-p (item)
|
|
(pcase-let ((`[,(cl-struct ement-room status) ,_session] item))
|
|
(equal 'invite status)))
|
|
(taxy-latest-ts (taxy)
|
|
(apply #'max most-negative-fixnum
|
|
(delq nil
|
|
(list
|
|
(when (taxy-items taxy)
|
|
(item-latest-ts (car (taxy-items taxy))))
|
|
(when (taxy-taxys taxy)
|
|
(cl-loop for sub-taxy in (taxy-taxys taxy)
|
|
maximizing (taxy-latest-ts sub-taxy)))))))
|
|
(t<nil (a b) (and a (not b)))
|
|
(t>nil (a b) (and (not a) b))
|
|
(make-fn (&rest args)
|
|
(apply #'make-taxy-magit-section
|
|
:make #'make-fn
|
|
:format-fn #'format-item
|
|
:level-indent ement-room-list-level-indent
|
|
;; :visibility-fn #'visible-p
|
|
;; :heading-indent 2
|
|
:item-indent 2
|
|
;; :heading-face-fn #'heading-face
|
|
args)))
|
|
;; (when (get-buffer buffer-name)
|
|
;; (kill-buffer buffer-name))
|
|
(unless ement-sessions
|
|
(error "Ement: Not connected. Use `ement-connect' to connect"))
|
|
(if (not (cl-loop for (_id . session) in ement-sessions
|
|
thereis (ement-session-rooms session)))
|
|
(ement-message "No rooms have been joined")
|
|
(with-current-buffer (get-buffer-create buffer-name)
|
|
(unless (eq 'ement-room-list-mode major-mode)
|
|
(ement-room-list-mode))
|
|
(let* ((room-session-vectors
|
|
(cl-loop for (_id . session) in ement-sessions
|
|
append (cl-loop for room in (ement-session-rooms session)
|
|
collect (vector room session))))
|
|
(taxy (cl-macrolet ((first-item
|
|
(pred) `(lambda (taxy)
|
|
(when (taxy-items taxy)
|
|
(,pred (car (taxy-items taxy))))))
|
|
(name= (name) `(lambda (taxy)
|
|
(equal ,name (taxy-name taxy)))))
|
|
(thread-last
|
|
(make-fn
|
|
:name "Ement Rooms"
|
|
:take (taxy-make-take-function keys ement-room-list-keys))
|
|
(taxy-fill room-session-vectors)
|
|
(taxy-sort #'> #'item-latest-ts)
|
|
(taxy-sort #'t<nil #'item-invited-p)
|
|
(taxy-sort #'t<nil #'item-favourite-p)
|
|
(taxy-sort #'t>nil #'item-low-priority-p)
|
|
(taxy-sort #'t<nil #'item-unread-p)
|
|
(taxy-sort #'t<nil #'item-space-p)
|
|
;; Within each taxy, left rooms should be sorted last so that one
|
|
;; can never be the first room in the taxy (unless it's the taxy
|
|
;; of left rooms), which would cause the taxy to be incorrectly
|
|
;; sorted last.
|
|
(taxy-sort #'t>nil #'item-left-p)
|
|
(taxy-sort* #'string< #'taxy-name)
|
|
(taxy-sort* #'> #'taxy-latest-ts)
|
|
(taxy-sort* #'t<nil (name= "Buffers"))
|
|
(taxy-sort* #'t<nil (first-item item-unread-p))
|
|
(taxy-sort* #'t<nil (first-item item-favourite-p))
|
|
(taxy-sort* #'t<nil (first-item item-invited-p))
|
|
(taxy-sort* #'t>nil (first-item item-space-p))
|
|
(taxy-sort* #'t>nil (name= "Low-priority"))
|
|
(taxy-sort* #'t>nil (first-item item-left-p)))))
|
|
(taxy-magit-section-insert-indent-items nil)
|
|
(inhibit-read-only t)
|
|
(format-cons (taxy-magit-section-format-items
|
|
ement-room-list-columns ement-room-list-column-formatters taxy))
|
|
(pos (point))
|
|
(section-ident (when (magit-current-section)
|
|
(magit-section-ident (magit-current-section)))))
|
|
(setf format-table (car format-cons)
|
|
column-sizes (cdr format-cons)
|
|
header-line-format (taxy-magit-section-format-header
|
|
column-sizes ement-room-list-column-formatters))
|
|
(when-let ((window (get-buffer-window (current-buffer))))
|
|
(setf window-point (window-point window)
|
|
window-start (window-start window)))
|
|
(when ement-room-list-visibility-cache
|
|
(setf magit-section-visibility-cache ement-room-list-visibility-cache))
|
|
(add-hook 'kill-buffer-hook #'ement-room-list--cache-visibility nil 'local)
|
|
;; Before this point, no changes have been made to the buffer's contents.
|
|
(delete-all-overlays)
|
|
(erase-buffer)
|
|
(save-excursion
|
|
(taxy-magit-section-insert taxy :items 'first
|
|
;; :blank-between-depth bufler-taxy-blank-between-depth
|
|
:initial-depth 0 :section-class 'ement-room-list-section))
|
|
(if-let* ((section-ident)
|
|
(section (magit-get-section section-ident)))
|
|
(goto-char (oref section start))
|
|
(goto-char pos))))
|
|
(when display-buffer-action
|
|
(when-let ((window (display-buffer buffer-name display-buffer-action)))
|
|
(select-window window)))
|
|
(when-let ((window (get-buffer-window buffer-name)))
|
|
(set-window-start window window-start)
|
|
(set-window-point window window-point))
|
|
;; FIXME: Despite all this code to save and restore point and window point and
|
|
;; window start, when I send a message from the minibuffer, or when I abort
|
|
;; sending a message from the minibuffer, point is moved to the beginning of the
|
|
;; buffer. While the minibuffer is open (and the typing messages are being sent
|
|
;; to the server, causing it to repeatedly sync), the point stays in the correct
|
|
;; place. I can't find any reason why this happens. It makes no sense. And
|
|
;; while trying to debug the problem, somehow Emacs got put into an unbreakable,
|
|
;; infinite loop twice; even C-g and SIGUSR2 didn't stop it.
|
|
|
|
;; NOTE: In order for `bookmark--jump-via' to work properly, the restored buffer
|
|
;; must be set as the current buffer, so we have to do this explicitly here.
|
|
(set-buffer buffer-name)))))
|
|
|
|
(cl-defun ement-room-list-side-window (&key (side 'left))
|
|
"Show room list in side window on SIDE.
|
|
Interactively, with prefix, show on right side; otherwise, on
|
|
left."
|
|
(interactive (when current-prefix-arg
|
|
(list :side 'right)))
|
|
(let ((display-buffer-mark-dedicated t))
|
|
;; Not sure if binding `display-buffer-mark-dedicated' is still necessary.
|
|
(ement-room-list
|
|
:display-buffer-action `(display-buffer-in-side-window
|
|
(dedicated . t)
|
|
(side . ,side)
|
|
(window-parameters
|
|
(no-delete-other-windows . t))))))
|
|
|
|
(defun ement-room-list-revert (&optional _ignore-auto _noconfirm)
|
|
"Revert current Ement-Room-List buffer."
|
|
(interactive)
|
|
(with-current-buffer "*Ement Room List*"
|
|
;; FIXME: This caching of the visibility only supports the main buffer with the
|
|
;; default name, not any special ones with different names.
|
|
(setf ement-room-list-visibility-cache magit-section-visibility-cache))
|
|
(ement-room-list :display-buffer-action nil))
|
|
|
|
(defun ement-room-list-kill-buffer (room)
|
|
"Kill ROOM's buffer."
|
|
(interactive
|
|
(ement-with-room-and-session
|
|
(ignore ement-session)
|
|
(list ement-room)))
|
|
(pcase-let (((cl-struct ement-room (local (map buffer))) room)
|
|
(kill-buffer-query-functions))
|
|
(when (buffer-live-p buffer)
|
|
(kill-buffer buffer)
|
|
(ement-room-list-revert))))
|
|
|
|
(declare-function ement-view-room "ement-room")
|
|
(defun ement-room-list-RET ()
|
|
"View room at point, or cycle section at point."
|
|
(declare (function ement-view-space "ement-room"))
|
|
(interactive)
|
|
(cl-etypecase (oref (magit-current-section) value)
|
|
(vector (pcase-let ((`[,room ,session] (oref (magit-current-section) value)))
|
|
(if (ement--space-p room)
|
|
(ement-view-space room session)
|
|
(ement-view-room room session))))
|
|
(taxy-magit-section (call-interactively #'ement-room-list-section-toggle))
|
|
(null nil)))
|
|
|
|
(declare-function ement-room-goto-fully-read-marker "ement-room")
|
|
(defun ement-room-list-next-unread ()
|
|
"Show next unread room."
|
|
(interactive)
|
|
(when (eobp)
|
|
(goto-char (point-min)))
|
|
(unless (cl-loop with starting-line = (line-number-at-pos)
|
|
for value = (oref (magit-current-section) value)
|
|
if (and (vectorp value)
|
|
(ement--room-unread-p (elt value 0) (elt value 1)))
|
|
do (progn
|
|
(ement-view-room (elt value 0) (elt value 1))
|
|
(ement-room-goto-fully-read-marker)
|
|
(cl-return t))
|
|
else do (forward-line 1)
|
|
while (and (not (eobp))
|
|
(> (line-number-at-pos) starting-line)))
|
|
;; No more unread rooms.
|
|
(message "No more unread rooms")))
|
|
|
|
(define-derived-mode ement-room-list-mode magit-section-mode "Ement-Room-List"
|
|
:global nil
|
|
(setq-local bookmark-make-record-function #'ement-room-list-bookmark-make-record
|
|
revert-buffer-function #'ement-room-list-revert
|
|
ement-room-list-timestamp-colors (ement-room-list--timestamp-colors)))
|
|
|
|
;;;; Functions
|
|
|
|
(defun ement-room-list--cache-visibility ()
|
|
"Save visibility cache.
|
|
Sets `ement-room-list-visibility-cache' to the value of
|
|
`magit-section-visibility-cache'. To be called in
|
|
`kill-buffer-hook'."
|
|
(ignore-errors
|
|
(when magit-section-visibility-cache
|
|
(setf ement-room-list-visibility-cache magit-section-visibility-cache))))
|
|
|
|
;;;###autoload
|
|
(defun ement-room-list-auto-update (_session)
|
|
"Automatically update the Taxy room list buffer.
|
|
+Does so when variable `ement-room-list-auto-update' is non-nil.
|
|
+To be called in `ement-sync-callback-hook'."
|
|
(when (and ement-room-list-auto-update
|
|
(buffer-live-p (get-buffer "*Ement Room List*")))
|
|
(with-current-buffer (get-buffer "*Ement Room List*")
|
|
(unless (region-active-p)
|
|
;; Don't refresh the list if the region is active (e.g. if the user is trying to
|
|
;; operate on multiple rooms).
|
|
(revert-buffer)))))
|
|
|
|
(defun ement-room-list--timestamp-colors ()
|
|
"Return a vector of generated latest-timestamp colors for rooms.
|
|
Used in `ement-tabulated-room-list' and `ement-room-list'."
|
|
(if (or (equal "unspecified-fg" (face-foreground 'default nil 'default))
|
|
(equal "unspecified-bg" (face-background 'default nil 'default)))
|
|
;; NOTE: On a TTY, the default face's foreground and background colors may be the
|
|
;; special values "unspecified-fg"/"unspecified-bg", in which case we can't generate
|
|
;; gradients, so we just return a vector of "unspecified-fg". See
|
|
;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=55623>.
|
|
(make-vector 134 "unspecified-fg")
|
|
(cl-coerce
|
|
(append (mapcar
|
|
;; One face per 10-minute period, from "recent" to 1-hour.
|
|
(lambda (rgb)
|
|
(pcase-let ((`(,r ,g ,b) rgb))
|
|
(color-rgb-to-hex r g b 2)))
|
|
(color-gradient (color-name-to-rgb (face-foreground 'ement-room-list-very-recent
|
|
nil 'default))
|
|
(color-name-to-rgb (face-foreground 'ement-room-list-recent
|
|
nil 'default))
|
|
6))
|
|
(mapcar
|
|
;; One face per hour, from "recent" to default.
|
|
(lambda (rgb)
|
|
(pcase-let ((`(,r ,g ,b) rgb))
|
|
(color-rgb-to-hex r g b 2)))
|
|
(color-gradient (color-name-to-rgb (face-foreground 'ement-room-list-recent
|
|
nil 'default))
|
|
(color-name-to-rgb (face-foreground 'default nil 'default))
|
|
24))
|
|
(mapcar
|
|
;; One face per week for the last year (actually we
|
|
;; generate colors for the past two years' worth so
|
|
;; that the face for one-year-ago is halfway to
|
|
;; invisible, and we don't use colors past that point).
|
|
(lambda (rgb)
|
|
(pcase-let ((`(,r ,g ,b) rgb))
|
|
(color-rgb-to-hex r g b 2)))
|
|
(color-gradient (color-name-to-rgb (face-foreground 'default nil 'default))
|
|
(color-name-to-rgb (face-background 'default nil 'default))
|
|
104)))
|
|
'vector)))
|
|
|
|
;;;; Footer
|
|
|
|
(provide 'ement-room-list)
|
|
|
|
;;; ement-room-list.el ends here
|