[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals-release/ement 4120ad90ca 3/3: Merge: v0.12
|
From: |
ELPA Syncer |
|
Subject: |
[elpa] externals-release/ement 4120ad90ca 3/3: Merge: v0.12 |
|
Date: |
Thu, 14 Sep 2023 21:57:47 -0400 (EDT) |
branch: externals-release/ement
commit 4120ad90cafe0d6cd1be5d28c63952985bba1d9b
Merge: d2b7a84840 a4fc3d1ab6
Author: Adam Porter <adam@alphapapa.net>
Commit: Adam Porter <adam@alphapapa.net>
Merge: v0.12
---
.github/ISSUE_TEMPLATE/bug_report.yml | 71 +++++
.github/ISSUE_TEMPLATE/config.yml | 1 +
README.org | 29 +-
ement-api.el | 2 +-
ement-directory.el | 42 +--
ement-lib.el | 487 ++++++++++++++++--------------
ement-macros.el | 2 +-
ement-notifications.el | 272 +++++++++++++++++
ement-notify.el | 100 ++-----
ement-room-list.el | 138 ++++-----
ement-room.el | 539 +++++++++++++++++++---------------
ement-structs.el | 2 +-
ement-tabulated-room-list.el | 2 +-
ement.el | 328 +++++++++++----------
14 files changed, 1220 insertions(+), 795 deletions(-)
diff --git a/.github/ISSUE_TEMPLATE/bug_report.yml
b/.github/ISSUE_TEMPLATE/bug_report.yml
new file mode 100644
index 0000000000..f9d9462444
--- /dev/null
+++ b/.github/ISSUE_TEMPLATE/bug_report.yml
@@ -0,0 +1,71 @@
+name: Bug Report
+description: File a bug report
+labels: ["bug"]
+assignees:
+ - alphapapa
+body:
+ - type: markdown
+ attributes:
+ value: |
+ Thanks for taking the time to fill out this bug report!
+ - type: input
+ id: os-platform
+ attributes:
+ label: OS/platform
+ description: What operating system or platform are you running Emacs on?
+ validations:
+ required: true
+ - type: textarea
+ id: emacs-provenance
+ attributes:
+ label: Emacs version and provenance
+ description: What version of Emacs are you using, where did you acquire
it, and how did you install it?
+ validations:
+ required: true
+ - type: input
+ id: emacs-command
+ attributes:
+ label: Emacs command
+ description: By what method did you run Emacs? (i.e. what command did
you run?)
+ validations:
+ required: true
+ - type: input
+ id: emacs-frame
+ attributes:
+ label: Emacs frame type
+ description: Did the problem happen on a GUI or tty Emacs frame?
+ validations:
+ required: true
+ - type: textarea
+ id: actions
+ attributes:
+ label: Actions taken
+ description: What actions did you take, step-by-step, in order, before
the problem was noticed?
+ validations:
+ required: true
+ - type: textarea
+ id: results
+ attributes:
+ label: Results
+ description: What behavior did you observe that seemed wrong?
+ validations:
+ required: true
+ - type: textarea
+ id: expected
+ attributes:
+ label: Expected results
+ description: What behavior did you expect to observe?
+ validations:
+ required: true
+ - type: textarea
+ id: backtrace
+ attributes:
+ label: Backtrace
+ description: If an error was signaled, please use `M-x
toggle-debug-on-error RET` and cause the error to happen again, then paste the
contents of the `*Backtrace*` buffer here.
+ render: elisp
+ - type: textarea
+ id: etc
+ attributes:
+ label: Etc.
+ description: Any other information that seems relevant
+
diff --git a/.github/ISSUE_TEMPLATE/config.yml
b/.github/ISSUE_TEMPLATE/config.yml
new file mode 100644
index 0000000000..0086358db1
--- /dev/null
+++ b/.github/ISSUE_TEMPLATE/config.yml
@@ -0,0 +1 @@
+blank_issues_enabled: true
diff --git a/README.org b/README.org
index f8c3b2d2ca..d701d948ff 100644
--- a/README.org
+++ b/README.org
@@ -168,11 +168,11 @@ These bindings are common to all of the following buffer
types:
*Movement*
-+ Next event: ~TAB~
-+ Previous event: ~<backtab>~
++ Next event: ~n~
++ Previous event: ~p~
+ Scroll up and mark read: ~SPC~
+ Scroll down: ~S-SPC~
-+ Jump to fully-read marker: ~M-SPC~
++ Jump to fully-read marker: ~M-g M-p~
+ Move read markers to point: ~m~
+ Load older messages: at top of buffer, scroll contents up (i.e. ~S-SPC~,
~M-v~ or ~mwheel-scroll~)
@@ -292,6 +292,29 @@ Ement.el doesn't support encrypted rooms natively, but it
can be used transparen
:TOC: :depth 0
:END:
+** 0.12
+
+*Additions*
+
++ Command ~ement-notifications~ shows recent notifications, similar to the
pane in the Element client. (This new command fetches recent notifications
from the server and allows scrolling up to retrieve older ones. Newly received
notifications, as configured in the ~ement-notify~ options, are displayed in
the same buffer. This functionality will be consolidated in the future.)
++ Face ~ement-room-quote~, applied to quoted parts of replies.
+
+*Changes*
++ Commands ~ement-room-goto-next~ and ~ement-room-goto-prev~ work more
usefully at the end of a room buffer. (Now pressing ~n~ on the last event
moves point to the end of the buffer so it will scroll automatically for new
messages, and then pressing ~p~ skips over any read marker to the last event.)
++ Room buffer bindings:
+ + ~ement-room-goto-next~ and ~ement-room-goto-prev~ are bound to ~n~ and
~p~, respectively.
+ + ~ement-room-goto-fully-read-marker~ is bound to ~M-g M-p~ (the mnemonic
being "go to previously read").
++ The quoted part of a reply now omits the face applied to the rest of the
message, helping to distinguish them.
++ Commands that read a string from the minibuffer in ~ement-room~ buffers and
~ement-connect~ user ID prompts use separate history list variables.
++ Use Emacs's Jansson-based JSON-parsing functions when available. (This
results in a 3-5x speed improvement for parsing JSON responses, which can be
significant for large initial sync responses. Thanks to
[[https://github.com/rrix/][Ryan Rix]] for discovering this!)
+
+*Fixes*
+
++ File event formatter assumed that file size metadata would be present (a
malformed, e.g. spam, event might not have it).
++ Send correct file size when sending files/images.
++ Underscores are no longer interpreted as denoting subscripts when sending
messages in Org format. (Thanks to [[https://github.com/phil-s][Phil Sainty]].)
++ Add workaround for ~savehist-mode~'s serializing of the ~command-history~
variable's arguments. (For ~ement-~ commands, that may include large data
structures, like ~ement-session~ structs, which should never be serialized or
reused, and ~savehist~'s doing so could cause noticeable delays for users who
enabled it). (See [[https://github.com/alphapapa/ement.el/issues/216][#216]].
Thanks to [[https://github.com/phil-s][Phil Sainty]] and other users who helped
to discover this problem.)
+
** 0.11
*Additions*
diff --git a/ement-api.el b/ement-api.el
index db2f66fe62..ff8054c2ef 100644
--- a/ement-api.el
+++ b/ement-api.el
@@ -1,6 +1,6 @@
;;; ement-api.el --- Matrix API library -*- lexical-binding: t;
-*-
-;; Copyright (C) 2022 Free Software Foundation, Inc.
+;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
;; Author: Adam Porter <adam@alphapapa.net>
;; Maintainer: Adam Porter <adam@alphapapa.net>
diff --git a/ement-directory.el b/ement-directory.el
index 197ae49078..5a7b5968be 100644
--- a/ement-directory.el
+++ b/ement-directory.el
@@ -1,6 +1,6 @@
;;; ement-directory.el --- Public room directory support
-*- lexical-binding: t; -*-
-;; Copyright (C) 2022 Free Software Foundation, Inc.
+;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
;; Author: Adam Porter <adam@alphapapa.net>
;; Maintainer: Adam Porter <adam@alphapapa.net>
@@ -296,31 +296,31 @@ APPEND-P, add ROOMS to buffer rather than replacing
existing
contents. To be called by `ement-directory-search'."
(declare (indent defun))
(let (column-sizes window-start)
- (cl-labels ((format-item
- ;; NOTE: We use the buffer-local variable
`ement-directory-etc' rather
- ;; than a closure variable because the taxy-magit-section
struct's format
- ;; table is not stored in it, and we can't reuse closures'
variables.
- ;; (It would be good to store the format table in the
taxy-magit-section
- ;; in the future, to make this cleaner.)
- (item) (gethash item (alist-get 'format-table
ement-directory-etc)))
+ (cl-labels ((format-item (item)
+ ;; NOTE: We use the buffer-local variable
`ement-directory-etc' rather
+ ;; than a closure variable because the taxy-magit-section
struct's format
+ ;; table is not stored in it, and we can't reuse closures'
variables.
+ ;; (It would be good to store the format table in the
taxy-magit-section
+ ;; in the future, to make this cleaner.)
+ (gethash item (alist-get 'format-table ement-directory-etc)))
;; NOTE: Since these functions take an "item" (which is a
[room session]
;; vector), they're prefixed "item-" rather than "room-".
- (size
- (item) (pcase-let (((map ('num_joined_members size)) item))
- size))
+ (size (item)
+ (pcase-let (((map ('num_joined_members size)) item))
+ size))
(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
- ;; FIXME: Should we reuse
`ement-room-list-level-indent' here?
- :level-indent ement-room-list-level-indent
- ;; :visibility-fn #'visible-p
- ;; :heading-indent 2
- :item-indent 2
- ;; :heading-face-fn #'heading-face
- args)))
+ (apply #'make-taxy-magit-section
+ :make #'make-fn
+ :format-fn #'format-item
+ ;; FIXME: Should we reuse
`ement-room-list-level-indent' here?
+ :level-indent ement-room-list-level-indent
+ ;; :visibility-fn #'visible-p
+ ;; :heading-indent 2
+ :item-indent 2
+ ;; :heading-face-fn #'heading-face
+ args)))
(with-current-buffer (get-buffer-create buffer-name)
(unless (eq 'ement-directory-mode major-mode)
;; Don't obliterate buffer-local variables.
diff --git a/ement-lib.el b/ement-lib.el
index ad75bf79d3..bf9d7b733b 100644
--- a/ement-lib.el
+++ b/ement-lib.el
@@ -1,6 +1,6 @@
;;; ement-lib.el --- Library of Ement functions -*- lexical-binding: t;
-*-
-;; Copyright (C) 2022 Free Software Foundation, Inc.
+;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
;; Author: Adam Porter <adam@alphapapa.net>
;; Maintainer: Adam Porter <adam@alphapapa.net>
@@ -92,6 +92,23 @@ that stray such forms don't remain if the function is
removed."
;; These workarounds should be removed when they aren't needed.
+(defalias 'ement--json-parse-buffer
+ ;; For non-libjansson builds (those that do have libjansson will see a 4-5x
improvement
+ ;; in the time needed to parse JSON responses).
+
+ ;; TODO: Suggest mentioning in manual and docstrings that `json-read', et al
do not use
+ ;; libjansson, while `json-parse-buffer', et al do.
+ (if (fboundp 'json-parse-buffer)
+ (lambda ()
+ (condition-case err
+ (json-parse-buffer :object-type 'alist :null-object nil
:false-object :json-false)
+ (json-parse-error
+ (ement-message "`json-parse-buffer' signaled `json-parse-error';
falling back to `json-read'... (%S)"
+ (error-message-string err))
+ (goto-char (point-min))
+ (json-read))))
+ 'json-read))
+
;;;;; Emacs 28 color features.
;; Copied from Emacs 28. See
<https://github.com/alphapapa/ement.el/issues/99>.
@@ -155,8 +172,7 @@ include with the request (see Matrix spec)."
:alias (read-string "New room alias (e.g. \"foo\" for
\"#foo:matrix.org\"): ")
:topic (read-string "New room topic: ")
:visibility (completing-read "New room visibility: "
'(private public))))
- (cl-labels ((given-p
- (var) (and var (not (string-empty-p var)))))
+ (cl-labels ((given-p (var) (and var (not (string-empty-p var)))))
(pcase-let* ((endpoint "createRoom")
(data (ement-aprog1
(ement-alist "visibility" visibility)
@@ -402,14 +418,14 @@ new one automatically if necessary."
(ement-with-room-and-session
(let* ((prompt (format "Toggle tag (%s): " (ement--format-room
ement-room)))
(default-tags
- (ement-alist (propertize "Favourite"
- 'face (when (ement--room-tagged-p
"m.favourite" ement-room)
- 'transient-value))
- "m.favourite"
- (propertize "Low-priority"
- 'face (when (ement--room-tagged-p
"m.lowpriority" ement-room)
- 'transient-value))
- "m.lowpriority"))
+ (ement-alist (propertize "Favourite"
+ 'face (when (ement--room-tagged-p
"m.favourite" ement-room)
+ 'transient-value))
+ "m.favourite"
+ (propertize "Low-priority"
+ 'face (when (ement--room-tagged-p
"m.lowpriority" ement-room)
+ 'transient-value))
+ "m.lowpriority"))
(input (completing-read prompt default-tags))
(tag (alist-get input default-tags (concat "u." input) nil
#'string=)))
(list tag ement-room ement-session))))
@@ -493,11 +509,11 @@ Interactively, with prefix, prompt for room and session,
otherwise use current room."
(interactive (ement-with-room-and-session (list ement-room ement-session)))
(cl-labels ((heading (string)
- (propertize (or string "") 'face
'font-lock-builtin-face))
+ (propertize (or string "") 'face 'font-lock-builtin-face))
(id (string)
- (propertize (or string "") 'face 'font-lock-constant-face))
+ (propertize (or string "") 'face 'font-lock-constant-face))
(member<
- (a b) (string-collate-lessp (car a) (car b) nil t)))
+ (a b) (string-collate-lessp (car a) (car b) nil t)))
(pcase-let* (((cl-struct ement-room (id room-id) avatar display-name
canonical-alias members timeline status topic
(local (map fetched-members-p)))
room)
@@ -584,31 +600,31 @@ Returns one of nil (meaning default rules are used),
`all-loud',
(let ((push-rules (cl-find-if (lambda (alist)
(equal "m.push_rules" (alist-get 'type
alist)))
(ement-session-account-data session))))
- (cl-labels ((override-mute-rule-for-room-p
- ;; Following findOverrideMuteRule() in RoomNotifs.ts.
- (room) (when-let ((overrides (map-nested-elt push-rules
'(content global override))))
- (cl-loop for rule in overrides
- when (and (alist-get 'enabled rule)
- (rule-for-room-p rule room))
- return rule)))
- (rule-for-room-p
- ;; Following isRuleForRoom() in RoomNotifs.ts.
- (rule room) (and (/= 1 (length (alist-get 'conditions rule)))
- (pcase-let* ((condition (elt (alist-get
'conditions rule) 0))
- ((map kind key pattern)
condition))
- (and (equal "event_match" kind)
- (equal "room_id" key)
- (equal (ement-room-id room)
pattern)))))
- (mute-rule-p
- (rule) (when-let ((actions (alist-get 'actions rule)))
- (seq-contains-p actions "dont_notify")))
- ;; NOTE: Although v1.7 of the spec says that "dont_notify" is
- ;; obsolete, the latest revision of matrix-react-sdk
(released last week
- ;; as v3.77.1) still works as modeled here.
- (tweak-rule-p
- (type rule) (when-let ((actions (alist-get 'actions rule)))
- (and (seq-contains-p actions "notify")
- (seq-contains-p actions `(set_tweak .
,type) 'seq-contains-p)))))
+ (cl-labels ((override-mute-rule-for-room-p (room)
+ ;; Following findOverrideMuteRule() in RoomNotifs.ts.
+ (when-let ((overrides (map-nested-elt push-rules '(content
global override))))
+ (cl-loop for rule in overrides
+ when (and (alist-get 'enabled rule)
+ (rule-for-room-p rule room))
+ return rule)))
+ (rule-for-room-p (rule room)
+ ;; Following isRuleForRoom() in RoomNotifs.ts.
+ (and (/= 1 (length (alist-get 'conditions rule)))
+ (pcase-let* ((condition (elt (alist-get 'conditions
rule) 0))
+ ((map kind key pattern) condition))
+ (and (equal "event_match" kind)
+ (equal "room_id" key)
+ (equal (ement-room-id room) pattern)))))
+ (mute-rule-p (rule)
+ (when-let ((actions (alist-get 'actions rule)))
+ (seq-contains-p actions "dont_notify")))
+ ;; NOTE: Although v1.7 of the spec says that "dont_notify" is
+ ;; obsolete, the latest revision of matrix-react-sdk (released
last week
+ ;; as v3.77.1) still works as modeled here.
+ (tweak-rule-p (type rule)
+ (when-let ((actions (alist-get 'actions rule)))
+ (and (seq-contains-p actions "notify")
+ (seq-contains-p actions `(set_tweak . ,type)
'seq-contains-p)))))
;; If none of these match, nil is returned, meaning that the default
rule is used
;; for the room.
(if (override-mute-rule-for-room-p room)
@@ -658,34 +674,34 @@ default, `all', `mentions-and-keywords', or `none'."
(state (alist-get selected-rule available-states nil nil #'equal)))
(list state ement-room ement-session))))
(cl-labels ((set-rule (kind rule queue message-fn)
- (pcase-let* (((cl-struct ement-room (id room-id)) room)
- (rule-id (url-hexify-string room-id))
- (endpoint (format
"pushrules/global/%s/%s" kind rule-id))
- (method (if rule 'put 'delete))
- (then (if rule
- ;; Setting rules requires
PUTting the rules, then making a second
- ;; request to enable them.
- (lambda (_data)
- (ement-api session (concat
endpoint "/enabled") :queue queue :version "r0"
- :method 'put :data
(json-encode (ement-alist 'enabled t))
- :then message-fn))
- message-fn)))
- (ement-api session endpoint :queue queue :method
method :version "r0"
- :data (json-encode rule)
- :then then
- :else (lambda (plz-error)
- (pcase-let* (((cl-struct plz-error
response) plz-error)
- ((cl-struct plz-response
status) response))
- (pcase status
- (404 (pcase rule
- (`nil
- ;; Room already had no rules,
so none being found is not an
- ;; error.
- nil)
- (_ ;; Unexpected error:
re-signal.
- (ement-api-error plz-error))))
- (_ ;; Unexpected error: re-signal.
- (ement-api-error plz-error)))))))))
+ (pcase-let* (((cl-struct ement-room (id room-id)) room)
+ (rule-id (url-hexify-string room-id))
+ (endpoint (format "pushrules/global/%s/%s" kind
rule-id))
+ (method (if rule 'put 'delete))
+ (then (if rule
+ ;; Setting rules requires PUTting the
rules, then making a second
+ ;; request to enable them.
+ (lambda (_data)
+ (ement-api session (concat endpoint
"/enabled") :queue queue :version "r0"
+ :method 'put :data (json-encode
(ement-alist 'enabled t))
+ :then message-fn))
+ message-fn)))
+ (ement-api session endpoint :queue queue :method method
:version "r0"
+ :data (json-encode rule)
+ :then then
+ :else (lambda (plz-error)
+ (pcase-let* (((cl-struct plz-error response)
plz-error)
+ ((cl-struct plz-response status)
response))
+ (pcase status
+ (404 (pcase rule
+ (`nil
+ ;; Room already had no rules, so none
being found is not an
+ ;; error.
+ nil)
+ (_ ;; Unexpected error: re-signal.
+ (ement-api-error plz-error))))
+ (_ ;; Unexpected error: re-signal.
+ (ement-api-error plz-error)))))))))
(pcase-let* ((available-states
(ement-alist
nil (ement-alist
@@ -772,13 +788,13 @@ Selects from seen users on all sessions. If point is on
an
event, suggests the event's sender as initial input. Allows
unseen user IDs to be input as well."
(cl-labels ((format-user (user)
- ;; FIXME: Per-room displaynames are now stored in
room structs
- ;; rather than user structs, so to be complete,
this needs to
- ;; iterate over all known rooms, looking for the
user's
- ;; displayname in that room.
- (format "%s <%s>"
- (ement-user-displayname user)
- (ement-user-id user))))
+ ;; FIXME: Per-room displaynames are now stored in room structs
+ ;; rather than user structs, so to be complete, this needs to
+ ;; iterate over all known rooms, looking for the user's
+ ;; displayname in that room.
+ (format "%s <%s>"
+ (ement-user-displayname user)
+ (ement-user-id user))))
(let* ((display-to-id
(cl-loop for key being the hash-keys of ement-users
using (hash-values value)
@@ -904,31 +920,30 @@ avatars, etc."
;; string as argument.)
;; TODO: Try using HSV somehow so we could avoid having so many strings
return a
;; nearly-black color.
- (cl-labels ((relative-luminance
- ;; Copy of `modus-themes-wcag-formula', an elegant
- ;; implementation by Protesilaos Stavrou. Also see
- ;; <https://en.wikipedia.org/wiki/Relative_luminance> and
- ;; <https://www.w3.org/TR/WCAG20/#relativeluminancedef>.
- (rgb) (cl-loop for k in '(0.2126 0.7152 0.0722)
- for x in rgb
- sum (* k (if (<= x 0.03928)
- (/ x 12.92)
- (expt (/ (+ x 0.055) 1.055) 2.4)))))
- (contrast-ratio
- ;; Copy of `modus-themes-contrast'; see above.
- (a b) (let ((ct (/ (+ (relative-luminance a) 0.05)
- (+ (relative-luminance b) 0.05))))
- (max ct (/ ct))))
- (increase-contrast
- (color against target toward)
- (let ((gradient (cdr (color-gradient color toward 20)))
- new-color)
- (cl-loop do (setf new-color (pop gradient))
- while new-color
- until (>= (contrast-ratio new-color against) target)
- ;; Avoid infinite loop in case of weirdness
- ;; by returning color as a fallback.
- finally return (or new-color color)))))
+ (cl-labels ((relative-luminance (rgb)
+ ;; Copy of `modus-themes-wcag-formula', an elegant
+ ;; implementation by Protesilaos Stavrou. Also see
+ ;; <https://en.wikipedia.org/wiki/Relative_luminance> and
+ ;; <https://www.w3.org/TR/WCAG20/#relativeluminancedef>.
+ (cl-loop for k in '(0.2126 0.7152 0.0722)
+ for x in rgb
+ sum (* k (if (<= x 0.03928)
+ (/ x 12.92)
+ (expt (/ (+ x 0.055) 1.055) 2.4)))))
+ (contrast-ratio (a b)
+ ;; Copy of `modus-themes-contrast'; see above.
+ (let ((ct (/ (+ (relative-luminance a) 0.05)
+ (+ (relative-luminance b) 0.05))))
+ (max ct (/ ct))))
+ (increase-contrast (color against target toward)
+ (let ((gradient (cdr (color-gradient color toward 20)))
+ new-color)
+ (cl-loop do (setf new-color (pop gradient))
+ while new-color
+ until (>= (contrast-ratio new-color against) target)
+ ;; Avoid infinite loop in case of weirdness
+ ;; by returning color as a fallback.
+ finally return (or new-color color)))))
(let* ((id string)
(id-hash (float (+ (abs (sxhash id))
ement-room-prism-color-adjustment)))
;; TODO: Wrap-around the value to get the color I want.
@@ -1007,12 +1022,12 @@ period, anywhere in the body."
;; "@foo and @bar:matrix.org: hi"
;; "foo: how about you and @bar ..."
(declare (indent defun))
- (cl-labels ((members-having-displayname
- ;; Iterating over the hash table values isn't as efficient as a
hash
- ;; lookup, but in most rooms it shouldn't be a problem.
- (name members) (cl-loop for user being the hash-values of
members
- when (equal name
(ement--user-displayname-in room user))
- collect user)))
+ (cl-labels ((members-having-displayname (name members)
+ ;; Iterating over the hash table values isn't as efficient as
a hash
+ ;; lookup, but in most rooms it shouldn't be a problem.
+ (cl-loop for user being the hash-values of members
+ when (equal name (ement--user-displayname-in room
user))
+ collect user)))
(pcase-let* (((cl-struct ement-room members) room)
(regexp (rx (or bos bow (1+ blank))
(or (seq (group
@@ -1199,35 +1214,34 @@ DATA is an unsent message event's data alist."
(defun ement--direct-room-for-user (user session)
"Return last-modified direct room with USER on SESSION, if one exists."
;; Loosely modeled on the Element function findDMForUser in createRoom.ts.
- (cl-labels ((membership-event-for-p
- (event user) (and (equal "m.room.member" (ement-event-type
event))
- (equal (ement-user-id user)
(ement-event-state-key event))))
- (latest-membership-for
- (user room)
- (when-let ((latest-membership-event
- (car
- (cl-sort
- ;; I guess we need to check both state and
timeline events.
- (append (cl-remove-if-not (lambda (event)
-
(membership-event-for-p event user))
- (ement-room-state room))
- (cl-remove-if-not (lambda (event)
-
(membership-event-for-p event user))
- (ement-room-timeline
room)))
- (lambda (a b)
- ;; Sort latest first so we can use the car.
- (> (ement-event-origin-server-ts a)
- (ement-event-origin-server-ts b)))))))
- (alist-get 'membership (ement-event-content
latest-membership-event))))
- (latest-event-in
- (room) (car
- (cl-sort
- (append (ement-room-state room)
- (ement-room-timeline room))
- (lambda (a b)
- ;; Sort latest first so we can use the car.
- (> (ement-event-origin-server-ts a)
- (ement-event-origin-server-ts b)))))))
+ (cl-labels ((membership-event-for-p (event user)
+ (and (equal "m.room.member" (ement-event-type event))
+ (equal (ement-user-id user) (ement-event-state-key
event))))
+ (latest-membership-for (user room)
+ (when-let ((latest-membership-event
+ (car
+ (cl-sort
+ ;; I guess we need to check both state and
timeline events.
+ (append (cl-remove-if-not (lambda (event)
+
(membership-event-for-p event user))
+ (ement-room-state
room))
+ (cl-remove-if-not (lambda (event)
+
(membership-event-for-p event user))
+ (ement-room-timeline
room)))
+ (lambda (a b)
+ ;; Sort latest first so we can use the car.
+ (> (ement-event-origin-server-ts a)
+ (ement-event-origin-server-ts b)))))))
+ (alist-get 'membership (ement-event-content
latest-membership-event))))
+ (latest-event-in (room)
+ (car
+ (cl-sort
+ (append (ement-room-state room)
+ (ement-room-timeline room))
+ (lambda (a b)
+ ;; Sort latest first so we can use the car.
+ (> (ement-event-origin-server-ts a)
+ (ement-event-origin-server-ts b)))))))
(let* ((direct-rooms (cl-remove-if-not
(lambda (room)
(ement--room-direct-p room session))
@@ -1350,6 +1364,24 @@ can cause undesirable underlining."
while next-face-change-pos
do (setf pos next-face-change-pos))))
+(cl-defun ement--text-property-search-forward (property predicate string &key
(start 0))
+ "Return the position at which PROPERTY in STRING matches PREDICATE.
+Return nil if not found. Searches forward from START."
+ (declare (indent defun))
+ (cl-loop for pos = start then (next-single-property-change pos property
string)
+ while pos
+ when (funcall predicate (get-text-property pos property string))
+ return pos))
+
+(cl-defun ement--text-property-search-backward (property predicate string &key
(start 0))
+ "Return the position at which PROPERTY in STRING matches PREDICATE.
+Return nil if not found. Searches backward from START."
+ (declare (indent defun))
+ (cl-loop for pos = start then (previous-single-property-change pos property
string)
+ while (and pos (> pos 1))
+ when (funcall predicate (get-text-property (1- pos) property
string))
+ return pos))
+
(defun ement--resize-image (image max-width max-height)
"Return a copy of IMAGE set to MAX-WIDTH and MAX-HEIGHT.
IMAGE should be one as created by, e.g. `create-image'."
@@ -1395,10 +1427,10 @@ Works in major-modes `ement-room-mode',
(defun ement--room-direct-p (room session)
"Return non-nil if ROOM on SESSION is a direct chat."
- (cl-labels ((content-contains-room-id
- (content room-id) (cl-loop for (_user-id . room-ids) in content
- ;; NOTE: room-ids is a vector.
- thereis (seq-contains-p room-ids
room-id))))
+ (cl-labels ((content-contains-room-id (content room-id)
+ (cl-loop for (_user-id . room-ids) in content
+ ;; NOTE: room-ids is a vector.
+ thereis (seq-contains-p room-ids room-id))))
(pcase-let* (((cl-struct ement-session account-data) session)
((cl-struct ement-room id) room))
(or (cl-loop for event in account-data
@@ -1417,63 +1449,62 @@ Works in major-modes `ement-room-mode',
;; or when to use "m.room.member" events for rooms without heroes (e.g.
invited rooms).
;; TODO: Add SESSION argument and use it to remove local user from names.
(cl-labels ((latest-event (type content-field)
- (or (cl-loop for event in (ement-room-timeline
room)
- when (and (equal type
(ement-event-type event))
- (not (string-empty-p
(alist-get content-field (ement-event-content event)))))
- return (alist-get content-field
(ement-event-content event)))
- (cl-loop for event in (ement-room-state room)
- when (and (equal type
(ement-event-type event))
- (not (string-empty-p
(alist-get content-field (ement-event-content event)))))
- return (alist-get content-field
(ement-event-content event)))))
- (member-events-name
- () (when-let ((member-events (cl-loop for accessor in
'(ement-room-timeline ement-room-state ement-room-invite-state)
- append (cl-remove-if-not
(apply-partially #'equal "m.room.member")
-
(funcall accessor room)
-
:key #'ement-event-type))))
- (string-join (delete-dups
- (mapcar (lambda (event)
- (ement--user-displayname-in room
(ement-event-sender event)))
- member-events))
- ", ")))
- (heroes-name
- () (pcase-let* (((cl-struct ement-room summary) room)
- ((map ('m.heroes hero-ids)
('m.joined_member_count joined-count)
- ('m.invited_member_count invited-count))
- summary))
- ;; TODO: Disambiguate hero display names.
- (when hero-ids
- (cond ((<= (+ joined-count invited-count) 1)
- ;; Empty room.
- (empty-room hero-ids joined-count))
- ((>= (length hero-ids) (1- (+ joined-count
invited-count)))
- ;; Members == heroes.
- (hero-names hero-ids))
- ((and (< (length hero-ids) (1- (+ joined-count
invited-count)))
- (> (+ joined-count invited-count) 1))
- ;; More members than heroes.
- (heroes-and-others hero-ids joined-count))))))
- (hero-names
- (heroes) (string-join (mapcar #'hero-name heroes) ", "))
- (hero-name
- (id) (if-let ((user (gethash id ement-users)))
- (ement--user-displayname-in room user)
- id))
- (heroes-and-others
- (heroes joined)
- (format "%s, and %s others" (hero-names heroes)
- (- joined (length heroes))))
- (name-override
- () (when-let ((event (alist-get
"org.matrix.msc3015.m.room.name.override"
- (ement-room-account-data room)
- nil nil #'equal)))
- (map-nested-elt event '(content name))))
- (empty-room
- (heroes joined) (cl-etypecase (length heroes)
- ((satisfies zerop) "Empty room")
- ((number 1 5) (format "Empty room (was %s)"
- (hero-names heroes)))
- (t (format "Empty room (was %s)"
- (heroes-and-others heroes
joined))))))
+ (or (cl-loop for event in (ement-room-timeline room)
+ when (and (equal type (ement-event-type event))
+ (not (string-empty-p (alist-get
content-field (ement-event-content event)))))
+ return (alist-get content-field
(ement-event-content event)))
+ (cl-loop for event in (ement-room-state room)
+ when (and (equal type (ement-event-type event))
+ (not (string-empty-p (alist-get
content-field (ement-event-content event)))))
+ return (alist-get content-field
(ement-event-content event)))))
+ (member-events-name ()
+ (when-let ((member-events (cl-loop for accessor in
'(ement-room-timeline ement-room-state ement-room-invite-state)
+ append (cl-remove-if-not
(apply-partially #'equal "m.room.member")
+
(funcall accessor room)
+
:key #'ement-event-type))))
+ (string-join (delete-dups
+ (mapcar (lambda (event)
+ (ement--user-displayname-in room
(ement-event-sender event)))
+ member-events))
+ ", ")))
+ (heroes-name ()
+ (pcase-let* (((cl-struct ement-room summary) room)
+ ((map ('m.heroes hero-ids)
('m.joined_member_count joined-count)
+ ('m.invited_member_count invited-count))
+ summary))
+ ;; TODO: Disambiguate hero display names.
+ (when hero-ids
+ (cond ((<= (+ joined-count invited-count) 1)
+ ;; Empty room.
+ (empty-room hero-ids joined-count))
+ ((>= (length hero-ids) (1- (+ joined-count
invited-count)))
+ ;; Members == heroes.
+ (hero-names hero-ids))
+ ((and (< (length hero-ids) (1- (+ joined-count
invited-count)))
+ (> (+ joined-count invited-count) 1))
+ ;; More members than heroes.
+ (heroes-and-others hero-ids joined-count))))))
+ (hero-names (heroes)
+ (string-join (mapcar #'hero-name heroes) ", "))
+ (hero-name (id)
+ (if-let ((user (gethash id ement-users)))
+ (ement--user-displayname-in room user)
+ id))
+ (heroes-and-others (heroes joined)
+ (format "%s, and %s others" (hero-names heroes)
+ (- joined (length heroes))))
+ (name-override ()
+ (when-let ((event (alist-get
"org.matrix.msc3015.m.room.name.override"
+ (ement-room-account-data room)
+ nil nil #'equal)))
+ (map-nested-elt event '(content name))))
+ (empty-room (heroes joined)
+ (cl-etypecase (length heroes)
+ ((satisfies zerop) "Empty room")
+ ((number 1 5) (format "Empty room (was %s)"
+ (hero-names heroes)))
+ (t (format "Empty room (was %s)"
+ (heroes-and-others heroes joined))))))
(or (name-override)
(latest-event "m.room.name" 'name)
(latest-event "m.room.canonical_alias" 'alias)
@@ -1529,19 +1560,19 @@ is not at the latest known message event."
;; A room should rarely, if ever, have a nil timeline, but in case
it does
;; (which apparently can happen, given user reports), it should not
be
;; considered unread.
- (cl-labels ((event-counts-toward-unread-p
- ;; NOTE: We only consider message events, so
membership, reaction,
- ;; etc. events will not mark a room as unread.
Ideally, I think
- ;; that join/leave events should, at least optionally,
mark a room
- ;; as unread (e.g. in a 1:1 room with a friend, if the
other user
- ;; left, one would probably want to know, and marking
the room
- ;; unread would help the user notice), but since
membership events
- ;; have to be processed to understand their meaning,
it's not
- ;; straightforward to know whether one should mark a
room unread.
-
- ;; FIXME: Use code from
`ement-room--format-member-event' to
- ;; distinguish ones that should count.
- (event) (equal "m.room.message" (ement-event-type
event))))
+ (cl-labels ((event-counts-toward-unread-p (event)
+ ;; NOTE: We only consider message events, so
membership, reaction,
+ ;; etc. events will not mark a room as unread.
Ideally, I think
+ ;; that join/leave events should, at least optionally,
mark a room
+ ;; as unread (e.g. in a 1:1 room with a friend, if the
other user
+ ;; left, one would probably want to know, and marking
the room
+ ;; unread would help the user notice), but since
membership events
+ ;; have to be processed to understand their meaning,
it's not
+ ;; straightforward to know whether one should mark a
room unread.
+
+ ;; FIXME: Use code from
`ement-room--format-member-event' to
+ ;; distinguish ones that should count.
+ (equal "m.room.message" (ement-event-type event))))
(let ((our-read-receipt-event-id (car (gethash our-id receipts)))
(first-counting-event (cl-find-if
#'event-counts-toward-unread-p timeline)))
(cond ((equal fully-read-event-id (ement-event-id (car
timeline)))
@@ -1595,11 +1626,11 @@ problems."
(if-let ((cached-name (gethash user (ement-room-displaynames room))))
cached-name
;; Put timeline events before state events, because IIUC they should be
more recent.
- (cl-labels ((join-displayname-event-p
- (event) (and (eq user (ement-event-sender event))
- (equal "m.room.member" (ement-event-type event))
- (equal "join" (alist-get 'membership
(ement-event-content event)))
- (alist-get 'displayname (ement-event-content
event)))))
+ (cl-labels ((join-displayname-event-p (event)
+ (and (eq user (ement-event-sender event))
+ (equal "m.room.member" (ement-event-type event))
+ (equal "join" (alist-get 'membership
(ement-event-content event)))
+ (alist-get 'displayname (ement-event-content event)))))
;; FIXME: Should probably sort the relevant events to get the latest one.
(if-let* ((displayname (or (cl-loop for event in (ement-room-timeline
room)
when (join-displayname-event-p event)
@@ -1698,19 +1729,19 @@ seconds, etc."
(if (< seconds 1)
(if abbreviate "0s" "0 seconds")
(cl-macrolet ((format> (place)
- ;; When PLACE is greater than 0, return formatted
string using its symbol name.
- `(when (> ,place 0)
- (format "%d%s%s" ,place
- (if abbreviate "" " ")
- (if abbreviate
- ,(substring (symbol-name place) 0 1)
- ,(symbol-name place)))))
+ ;; When PLACE is greater than 0, return formatted string
using its symbol name.
+ `(when (> ,place 0)
+ (format "%d%s%s" ,place
+ (if abbreviate "" " ")
+ (if abbreviate
+ ,(substring (symbol-name place) 0 1)
+ ,(symbol-name place)))))
(join-places (&rest places)
- ;; Return string joining the names and values
of PLACES.
- `(string-join (delq nil
- (list ,@(cl-loop for place
in places
- collect
`(format> ,place))))
- (if abbreviate "" ", "))))
+ ;; Return string joining the names and values of PLACES.
+ `(string-join (delq nil
+ (list ,@(cl-loop for place in places
+ collect `(format>
,place))))
+ (if abbreviate "" ", "))))
(pcase-let ((`(,years ,days ,hours ,minutes ,seconds)
(ement--human-duration seconds)))
(join-places years days hours minutes seconds)))))
@@ -1721,9 +1752,9 @@ a simple calculation that does not account for leap
years, leap
seconds, etc."
;; Copied from `ts-human-format-duration' (same author).
(cl-macrolet ((dividef (place divisor)
- ;; Divide PLACE by DIVISOR, set PLACE to the
remainder, and return the quotient.
- `(prog1 (/ ,place ,divisor)
- (setf ,place (% ,place ,divisor)))))
+ ;; Divide PLACE by DIVISOR, set PLACE to the remainder, and
return the quotient.
+ `(prog1 (/ ,place ,divisor)
+ (setf ,place (% ,place ,divisor)))))
(let* ((seconds (floor seconds))
(years (dividef seconds 31536000))
(days (dividef seconds 86400))
diff --git a/ement-macros.el b/ement-macros.el
index 88e9a44d46..9a46077500 100644
--- a/ement-macros.el
+++ b/ement-macros.el
@@ -1,6 +1,6 @@
;;; ement-macros.el --- Ement macros -*- lexical-binding: t;
-*-
-;; Copyright (C) 2022 Free Software Foundation, Inc.
+;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
;; Author: Adam Porter <adam@alphapapa.net>
;; Maintainer: Adam Porter <adam@alphapapa.net>
diff --git a/ement-notifications.el b/ement-notifications.el
new file mode 100644
index 0000000000..40cf7e5bb2
--- /dev/null
+++ b/ement-notifications.el
@@ -0,0 +1,272 @@
+;;; ement-notifications.el --- Notifications support -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 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 support for Matrix notifications. It differs from
+;; `ement-notify', which implements a kind of bespoke notification system for
events
+;; received via sync requests rather than Matrix's own notifications endpoint.
These two
+;; libraries currently integrate somewhat, as newly arriving events are
handled and
+;; notified about by `ement-notify', and old notifications are fetched and
listed by
+;; `ement-notifications' in the same "*Ement Notifications*" buffer.
+
+;; In the future, these libraries will likely be consolidated and enhanced to
more closely
+;; follow the Matrix API's and Element client's examples.
+
+;;; Code:
+
+;;;; Requirements
+
+(require 'cl-lib)
+(require 'map)
+
+(require 'ement-lib)
+(require 'ement-room)
+(require 'ement-notify)
+
+;;;; Structs
+
+(cl-defstruct ement-notification
+ "Represents a Matrix notification."
+ room-id event readp)
+
+(defun ement-notifications--make (notification)
+ "Return an `ement-notification' struct for NOTIFICATION.
+NOTIFICATION is an alist representing a notification returned
+from the \"/notifications\" endpoint. The notification's event
+is passed through `ement--make-event'."
+ (declare (function ement--make-event "ement"))
+ (pcase-let (((map room_id _actions _ts event read) notification))
+ (make-ement-notification :room-id room_id :readp read
+ :event (ement--make-event event))))
+
+;;;; Variables
+
+(declare-function ement-room-list "ement-room-list")
+(defvar ement-notifications-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "S-<return>") #'ement-notify-reply)
+ (define-key map (kbd "M-g M-l") #'ement-room-list)
+ (define-key map (kbd "M-g M-m") #'ement-notify-switch-to-mentions-buffer)
+ (define-key map (kbd "M-g M-n")
#'ement-notify-switch-to-notifications-buffer)
+ (define-key map [remap scroll-down-command]
#'ement-notifications-scroll-down-command)
+ (define-key map [remap mwheel-scroll] #'ement-notifications-mwheel-scroll)
+ (make-composed-keymap (list map button-buffer-map) 'view-mode-map))
+ "Map for Ement notification buffers.")
+
+(defvar ement-notifications-hook '(ement-notifications-log-to-buffer)
+ "Functions called for `ement-notifications' notifications.
+Each function is called with two arguments, the session and the
+`ement-notification' struct.")
+
+(defvar-local ement-notifications-retro-loading nil
+ "Non-nil when earlier messages are being loaded.
+Used to avoid overlapping requests.")
+
+(defvar-local ement-notifications-metadata nil
+ "Metadata for `ement-notifications' buffers.")
+
+;; Variables from other files.
+(defvar ement-ewoc)
+(defvar ement-session)
+(defvar ement-notify-prism-background)
+(defvar ement-room-message-format-spec)
+(defvar ement-room-sender-in-left-margin)
+
+;;;; Commands
+
+;;;###autoload
+(cl-defun ement-notifications
+ (session &key from limit only
+ (then (apply-partially #'ement-notifications-callback session))
else)
+ "Show the notifications buffer for SESSION.
+FROM may be a \"next_token\" token from a previous request.
+LIMIT may be a maximum number of events to return. ONLY may be
+the string \"highlight\" to only return notifications that have
+the highlight tweak set. THEN and ELSE may be callbacks passed
+to `ement-api', which see."
+ (interactive (list (ement-complete-session)
+ :only (when current-prefix-arg
+ "highlight")))
+ (if-let ((buffer (get-buffer "*Ement Notifications*")))
+ (switch-to-buffer buffer)
+ (let ((endpoint "notifications")
+ (params (remq nil
+ (list (when from
+ (list "from" from))
+ (when limit
+ (list "limit" (number-to-string limit)))
+ (when only
+ (list "only" only))))))
+ (ement-api session endpoint :params params :then then :else else)
+ (ement-message "Fetching notifications for <%s>..." (ement-user-id
(ement-session-user session))))))
+
+(cl-defun ement-notifications-callback (session data &key (buffer
(ement-notifications--log-buffer)))
+ "Callback for `ement-notifications' on SESSION which receives DATA."
+ (pcase-let (((map notifications next_token) data))
+ (with-current-buffer buffer
+ (setf (map-elt ement-notifications-metadata :next-token) next_token)
+ (cl-loop for notification across notifications
+ do (run-hook-with-args 'ement-notifications-hook
+ session (ement-notifications--make
notification)))
+ ;; TODO: Pass start/end nodes to `ement-room--insert-ts-headers' if
possible.
+ (ement-room--insert-ts-headers)
+ (switch-to-buffer (current-buffer)))))
+
+(defun ement-notifications-scroll-down-command ()
+ "Scroll down, and load NUMBER earlier messages when at top."
+ (interactive)
+ (condition-case _err
+ (scroll-down nil)
+ (beginning-of-buffer
+ (call-interactively #'ement-notifications-retro))))
+
+(defun ement-notifications-mwheel-scroll (event)
+ "Scroll according to EVENT, loading earlier messages when at top."
+ (interactive "e")
+ (with-selected-window (posn-window (event-start event))
+ (mwheel-scroll event)
+ (when (= (point-min) (window-start))
+ (call-interactively #'ement-notifications-retro))))
+
+(cl-defun ement-notifications-retro (session number)
+ ;; FIXME: Naming things is hard.
+ "Retrieve NUMBER older notifications on SESSION."
+ ;; FIXME: Support multiple sessions.
+ (interactive (list (ement-complete-session)
+ (cl-typecase current-prefix-arg
+ (null 100)
+ (list (read-number "Number of messages: "))
+ (number current-prefix-arg))))
+ (cl-assert (eq 'ement-notifications-mode major-mode))
+ (cl-assert (map-elt ement-notifications-metadata :next-token) nil
+ "No more notifications for %s" (ement-user-id (ement-session-user
ement-session)))
+ (let ((buffer (current-buffer)))
+ (unless ement-notifications-retro-loading
+ (ement-notifications
+ session :limit number
+ :from (map-elt ement-notifications-metadata :next-token)
+ ;; TODO: Use a :finally for resetting
`ement-notifications-retro-loading'?
+ :then (lambda (data)
+ (unwind-protect
+ (ement-notifications-callback session data :buffer buffer)
+ (setf (buffer-local-value 'ement-notifications-retro-loading
buffer) nil)))
+ :else (lambda (plz-error)
+ (setf (buffer-local-value 'ement-notifications-retro-loading
buffer) nil)
+ (ement-api-error plz-error)))
+ (ement-message "Loading %s earlier messages..." number)
+ (setf ement-notifications-retro-loading t))))
+
+;;;; Functions
+
+(cl-defun ement-notifications-log-to-buffer (session notification &key
(buffer-name "*Ement Notifications*"))
+ "Log EVENT in ROOM on SESSION to \"*Ement NOTIFICATIONS*\" buffer."
+ (with-demoted-errors "ement-notifications-log-to-buffer: %S"
+ (with-current-buffer (ement-notifications--log-buffer :name buffer-name)
+ (save-window-excursion
+ (when-let ((buffer-window (get-buffer-window (current-buffer))))
+ ;; Select the buffer's window to avoid EWOC bug. (See #191.)
+ (select-window buffer-window))
+ ;; TODO: Use the :readp slot to mark unread events.
+ (save-mark-and-excursion
+ (pcase-let* (((cl-struct ement-notification room-id event)
notification)
+ (ement-session session)
+ (ement-room (or (cl-find room-id (ement-session-rooms
session)
+ :key #'ement-room-id :test
#'equal)
+ (error
"ement-notifications-log-to-buffer: Can't find room <%s>; discarding
notification" room-id)))
+ (ement-room-sender-in-left-margin nil)
+ (ement-room-message-format-spec "%o%O »%W %S> %B%R%t")
+ (new-node (ement-room--insert-event event))
+ (inhibit-read-only t)
+ (start) (end))
+ (ewoc-goto-node ement-ewoc new-node)
+ (setf start (point))
+ (if-let (next-node (ewoc-next ement-ewoc new-node))
+ (ewoc-goto-node ement-ewoc next-node)
+ (goto-char (point-max)))
+ (setf end (- (point) 2))
+ (add-text-properties start end
+ (list 'button '(t)
+ 'category 'default-button
+ 'action #'ement-notify-button-action
+ 'session session
+ 'room ement-room
+ 'event event))
+ ;; Remove button face property.
+ (alter-text-property start end 'face
+ (lambda (face)
+ (pcase face
+ ('button nil)
+ ((pred listp) (remq 'button face))
+ (_ face))))
+ (when ement-notify-prism-background
+ (add-face-text-property start end (list :background
(ement-notifications--room-background-color ement-room)
+ :extend t)))))))))
+
+(defun ement-notifications--room-background-color (room)
+ "Return a background color on which to display ROOM's messages."
+ (or (alist-get 'notify-background-color (ement-room-local room))
+ (setf (alist-get 'notify-background-color (ement-room-local room))
+ (let ((color (color-desaturate-name
+ (ement--prism-color (ement-room-id room)
:contrast-with (face-foreground 'default))
+ 50)))
+ (if (ement--color-dark-p (color-name-to-rgb (face-background
'default)))
+ (color-darken-name color 25)
+ (color-lighten-name color 25))))))
+
+(cl-defun ement-notifications--log-buffer (&key (name "*Ement Notifications*"))
+ "Return an Ement notifications buffer named NAME."
+ (or (get-buffer name)
+ (with-current-buffer (get-buffer-create name)
+ (ement-notifications-mode)
+ (current-buffer))))
+
+;;;; Mode
+
+(define-derived-mode ement-notifications-mode ement-room-mode "Ement
Notifications"
+ (setf ement-room-sender-in-left-margin nil
+ left-margin-width 0
+ right-margin-width 8)
+ (setq-local ement-room-message-format-spec "[%o%O] %S> %B%R%t"
+ bookmark-make-record-function
#'ement-notifications-bookmark-make-record))
+
+;;;; Bookmark support
+
+(require 'bookmark)
+
+(defun ement-notifications-bookmark-make-record ()
+ "Return a bookmark record for the current `ement-notifications' buffer."
+ (list (buffer-name)
+ ;; It seems silly to have to record the buffer name twice, but the
+ ;; `bookmark-make-record' function seems to override the bookmark name
sometimes,
+ ;; which makes the result useless unless we save the buffer name
separately.
+ (cons 'buffer-name (buffer-name))
+ (cons 'handler #'ement-notifications-bookmark-handler)))
+
+(defun ement-notifications-bookmark-handler (bookmark)
+ "Show `ement-notifications' buffer for BOOKMARK."
+ (pcase-let ((`(,_bookmark-name . ,(map buffer-name)) bookmark))
+ (switch-to-buffer (ement-notifications--log-buffer :name buffer-name))))
+
+;;; Footer
+
+(provide 'ement-notifications)
+
+;;; ement-notifications.el ends here
diff --git a/ement-notify.el b/ement-notify.el
index 1efd147a3a..c341678b40 100644
--- a/ement-notify.el
+++ b/ement-notify.el
@@ -1,6 +1,6 @@
;;; ement-notify.el --- Notifications for Ement events -*- lexical-binding:
t; -*-
-;; Copyright (C) 2022 Free Software Foundation, Inc.
+;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
;; Author: Adam Porter <adam@alphapapa.net>
;; Maintainer: Adam Porter <adam@alphapapa.net>
@@ -169,13 +169,21 @@ margins in Emacs. But it's useful, anyway."
(defun ement-notify-switch-to-notifications-buffer ()
"Switch to \"*Ement Notifications*\" buffer."
+ (declare (function ement-notifications "ement-notifications"))
(interactive)
- (switch-to-buffer (ement-notify--log-buffer "*Ement Notifications*")))
+ (call-interactively #'ement-notifications))
+(defvar ement-notifications-mode-map)
(defun ement-notify-switch-to-mentions-buffer ()
"Switch to \"*Ement Mentions*\" buffer."
+ (declare (function ement-notifications--log-buffer "ement-notifications"))
(interactive)
- (switch-to-buffer (ement-notify--log-buffer "*Ement Mentions*")))
+ (switch-to-buffer (ement-notifications--log-buffer :name "*Ement Mentions*"))
+ ;; HACK: Undo remapping of scroll commands which don't apply in this buffer.
+ (let ((map (copy-keymap ement-notifications-mode-map)))
+ (define-key map [remap scroll-down-command] nil)
+ (define-key map [remap mwheel-scroll] nil)
+ (use-local-map map)))
;;;; Functions
@@ -206,13 +214,13 @@ If ROOM has no existing buffer, do nothing."
(function dbus-get-unique-name "dbusbind.c")
(function x-change-window-property "xfns.c")
(function x-window-property "xfns.c"))
- (cl-labels ((mark-frame-urgent
- (frame) (let* ((prop "WM_HINTS")
- (hints (cl-coerce
- (x-window-property prop frame prop nil
nil t)
- 'list)))
- (setf (car hints) (logior (car hints) 256))
- (x-change-window-property prop hints nil prop 32 t))))
+ (cl-labels ((mark-frame-urgent (frame)
+ (let* ((prop "WM_HINTS")
+ (hints (cl-coerce
+ (x-window-property prop frame prop nil nil t)
+ 'list)))
+ (setf (car hints) (logior (car hints) 256))
+ (x-change-window-property prop hints nil prop 32 t))))
(when-let* ((buffer (alist-get 'buffer (ement-room-local room)))
(frames (cl-loop for frame in (frame-list)
when (eq 'x (framep frame))
@@ -272,73 +280,13 @@ If ROOM has no existing buffer, do nothing."
(delete-file filename)))
filename))
-(define-derived-mode ement-notify-mode ement-room-mode "Ement Notify"
- (setf ement-room-sender-in-left-margin nil
- left-margin-width 0
- right-margin-width 8)
- (setq-local ement-room-message-format-spec "[%o%O] %S> %B%R%t"
- bookmark-make-record-function
#'ement-notify-bookmark-make-record))
-
(cl-defun ement-notify--log-to-buffer (event room session &key (buffer-name
"*Ement Notifications*"))
"Log EVENT in ROOM on SESSION to \"*Ement Notifications*\" buffer."
- (with-demoted-errors "ement-notify--log-to-buffer: %S"
- ;; HACK: We only log "m.room.message" events for now. This shouldn't be
necessary
- ;; since we have `ement-notify--event-message-p' in
`ement-notify-predicates', but
- ;; just to be safe...
- (when (equal "m.room.message" (ement-event-type event))
- (with-current-buffer (ement-notify--log-buffer buffer-name)
- (save-window-excursion
- (when-let ((buffer-window (get-buffer-window (current-buffer))))
- ;; Select the buffer's window to avoid EWOC bug. (See #191.)
- (select-window buffer-window))
- (let* ((ement-session session)
- (ement-room room)
- (ement-room-sender-in-left-margin nil)
- (ement-room-message-format-spec "%o%O »%W %S> %B%R%t")
- (new-node (ement-room--insert-event event))
- (inhibit-read-only t)
- start end)
- (ewoc-goto-node ement-ewoc new-node)
- (setf start (point))
- (if-let (next-node (ewoc-next ement-ewoc new-node))
- (ewoc-goto-node ement-ewoc next-node)
- (goto-char (point-max)))
- (setf end (- (point) 2))
- (add-text-properties start end
- (list 'button '(t)
- 'category 'default-button
- 'action #'ement-notify-button-action
- 'session session
- 'room room
- 'event event))
- ;; Remove button face property.
- (alter-text-property start end 'face
- (lambda (face)
- (pcase face
- ('button nil)
- ((pred listp) (remq 'button face))
- (_ face))))
- (when ement-notify-prism-background
- (add-face-text-property start end (list :background
(ement-notify--room-background-color room)
- :extend t)))))))))
-
-(defun ement-notify--log-buffer (name)
- "Return an Ement notifications buffer named NAME."
- (or (get-buffer name)
- (with-current-buffer (get-buffer-create name)
- (ement-notify-mode)
- (current-buffer))))
-
-(defun ement-notify--room-background-color (room)
- "Return a background color on which to display ROOM's messages."
- (or (alist-get 'notify-background-color (ement-room-local room))
- (setf (alist-get 'notify-background-color (ement-room-local room))
- (let ((color (color-desaturate-name
- (ement--prism-color (ement-room-id room)
:contrast-with (face-foreground 'default))
- 50)))
- (if (ement--color-dark-p (color-name-to-rgb (face-background
'default)))
- (color-darken-name color 25)
- (color-lighten-name color 25))))))
+ (declare (function ement-notifications-log-to-buffer "ement-notifications")
+ (function make-ement-notification "ement-notifications"))
+ (pcase-let* (((cl-struct ement-room (id room-id)) room)
+ (notification (make-ement-notification :room-id room-id :event
event)))
+ (ement-notifications-log-to-buffer session notification :buffer-name
buffer-name)))
;;;;; Predicates
@@ -395,7 +343,7 @@ According to the room's notification configuration on the
server."
(defun ement-notify-bookmark-handler (bookmark)
"Show Ement notifications buffer for BOOKMARK."
(pcase-let ((`(,_bookmark-name . ,(map buffer-name)) bookmark))
- (switch-to-buffer (ement-notify--log-buffer buffer-name))))
+ (switch-to-buffer (ement-notifications--log-buffer :name buffer-name))))
;;;; Footer
diff --git a/ement-room-list.el b/ement-room-list.el
index 117e0097e6..232ef6d2c8 100644
--- a/ement-room-list.el
+++ b/ement-room-list.el
@@ -1,6 +1,6 @@
;;; ement-room-list.el --- List Ement rooms -*- lexical-binding: t; -*-
-;; Copyright (C) 2022 Free Software Foundation, Inc.
+;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
;; Author: Adam Porter <adam@alphapapa.net>
;; Maintainer: Adam Porter <adam@alphapapa.net>
@@ -165,10 +165,10 @@ from recent to non-recent for rooms updated in the past
hour.")
(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 membership
+ ('join "Joined")
+ ('invite "Invited")
+ ('leave "[Left]"))))
(pcase-let ((`[,(cl-struct ement-room (status membership)) ,_session]
item))
(if status
(when (equal status membership)
@@ -200,12 +200,12 @@ from recent to non-recent for rooms updated in the past
hour.")
(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 "Space: " space-name))))
+ (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 "Space: " space-name))))
(when-let ((key (if id
;; ID specified.
(cond ((or (member id parents)
@@ -553,64 +553,64 @@ DISPLAY-BUFFER-ACTION is nil, the buffer is not
displayed."
(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
- ;; This is very confusing and doesn't currently work.
- (section) (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)))))))
+ (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)))
+ (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
@@ -626,9 +626,9 @@ DISPLAY-BUFFER-ACTION is nil, the buffer is not displayed."
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))))))
+ (pred) `(lambda (taxy)
+ (when (taxy-items taxy)
+ (,pred (car (taxy-items
taxy))))))
(name= (name) `(lambda (taxy)
(equal ,name (taxy-name
taxy)))))
(thread-last
diff --git a/ement-room.el b/ement-room.el
index a7eb288db0..1dbf8bf723 100644
--- a/ement-room.el
+++ b/ement-room.el
@@ -1,6 +1,6 @@
;;; ement-room.el --- Ement room buffers -*- lexical-binding: t;
-*-
-;; Copyright (C) 2022 Free Software Foundation, Inc.
+;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
;; Author: Adam Porter <adam@alphapapa.net>
;; Maintainer: Adam Porter <adam@alphapapa.net>
@@ -122,11 +122,11 @@ Used to, e.g. call `ement-room-compose-org'.")
(define-key map (kbd "?") #'ement-room-transient)
;; Movement
- (define-key map (kbd "TAB") #'ement-room-goto-next)
- (define-key map (kbd "<backtab>") #'ement-room-goto-prev)
+ (define-key map (kbd "n") #'ement-room-goto-next)
+ (define-key map (kbd "p") #'ement-room-goto-prev)
(define-key map (kbd "SPC") #'ement-room-scroll-up-mark-read)
(define-key map (kbd "S-SPC") #'ement-room-scroll-down-command)
- (define-key map (kbd "M-SPC") #'ement-room-goto-fully-read-marker)
+ (define-key map (kbd "M-g M-p") #'ement-room-goto-fully-read-marker)
(define-key map (kbd "m") #'ement-room-mark-read)
(define-key map [remap scroll-down-command]
#'ement-room-scroll-down-command)
(define-key map [remap mwheel-scroll] #'ement-room-mwheel-scroll)
@@ -206,6 +206,13 @@ In that case, sender names are aligned to the margin
edge.")
(optional "?" (group (1+ anything))))
"Regexp matching \"matrix.to\" URLs.")
+(defvar ement-room-message-history nil
+ "History list of messages entered with `ement-room' commands.
+Does not include filenames, emotes, etc.")
+
+(defvar ement-room-emote-history nil
+ "History list of emotes entered with `ement-room' commands.")
+
;; Variables from other files.
(defvar ement-sessions)
(defvar ement-syncs)
@@ -277,6 +284,11 @@ normal text.")
'((t (:inherit italic)))
"Emote message bodies.")
+(defface ement-room-quote
+ '((t (:height 0.9 :inherit font-lock-comment-face)))
+ "Quoted parts of messages.
+Anything wrapped by HTML BLOCKQUOTE tag.")
+
(defface ement-room-redacted
'((t (:strike-through t)))
"Redacted messages.")
@@ -293,6 +305,7 @@ this one automatically.")
"Timestamp headers.")
(defface ement-room-mention
+ ;; TODO(30.1): Remove when not supporting Emacs 27 anymore.
(if (version< emacs-version "27.1")
'((t (:inherit hl-line)))
'((t (:inherit hl-line :extend t))))
@@ -398,12 +411,12 @@ received from setting the customization option. If LOCAL
is
non-nil, set the variables buffer-locally (i.e. when called from
`ement-room-set-message-format'."
(cl-macrolet ((set-vars (&rest pairs)
- ;; Set variable-value pairs, locally if LOCAL is
non-nil.
- `(progn
- ,@(cl-loop for (symbol value) on pairs by #'cddr
- collect `(if local
- (set (make-local-variable
',symbol) ,value)
- (set ',symbol ,value))))))
+ ;; Set variable-value pairs, locally if LOCAL is non-nil.
+ `(progn
+ ,@(cl-loop for (symbol value) on pairs by #'cddr
+ collect `(if local
+ (set (make-local-variable
',symbol) ,value)
+ (set ',symbol ,value))))))
(if local
(set (make-local-variable option) value)
(set-default option value))
@@ -779,7 +792,8 @@ room, and the session. See macro
BODY is wrapped in a lambda form that binds `event', `room', and
`session', and the lambda is added to the variable
`ement-room-event-formatters', which see."
- (declare (indent defun))
+ (declare (indent defun)
+ (debug (characterp stringp def-body)))
`(setf (alist-get ,char ement-room-event-formatters nil nil #'equal)
(lambda (event room session)
,docstring
@@ -805,23 +819,55 @@ spec) without requiring all events to use the same margin
width."
(setf ement-room--format-message-wrap-prefix t)
(propertize " " 'wrap-prefix-end t))
+;; FIXME(v0.12): The quote-end may be detected in the wrong position when,
e.g. a link is
+;; in the middle of the quoted part. We need to search backward from the end
to find
+;; where the quote face finally ends.
+
(ement-room-define-event-formatter ?b
"Plain-text body content."
;; NOTE: `save-match-data' is required around calls to
`ement-room--format-message-body'.
- (let ((body (save-match-data
- (ement-room--format-message-body event :formatted-p nil)))
- (face (ement-room--event-body-face event room session)))
- (add-face-text-property 0 (length body) face 'append body)
+ (let* ((body (save-match-data
+ (ement-room--format-message-body event :formatted-p nil)))
+ (body-length (length body))
+ (face (ement-room--event-body-face event room session))
+ (quote-start (ement--text-property-search-forward 'face
+ (lambda (value)
+ (pcase value
+ ('ement-room-quote t)
+ ((pred listp) (member 'ement-room-quote value))))
+ body))
+ (quote-end (when quote-start
+ (ement--text-property-search-backward 'face
+ (lambda (value)
+ (pcase value
+ ('ement-room-quote t)
+ ((pred listp) (member 'ement-room-quote value))))
+ body))))
+ (add-face-text-property (or quote-end 0) body-length face 'append body)
(when ement-room-prism-addressee
(ement-room--add-member-face body room))
body))
(ement-room-define-event-formatter ?B
"Formatted body content (i.e. rendered HTML)."
- (let ((body (save-match-data
- (ement-room--format-message-body event)))
- (face (ement-room--event-body-face event room session)))
- (add-face-text-property 0 (length body) face 'append body)
+ (let* ((body (save-match-data
+ (ement-room--format-message-body event)))
+ (body-length (length body))
+ (face (ement-room--event-body-face event room session))
+ (quote-start (ement--text-property-search-forward 'face
+ (lambda (value)
+ (pcase value
+ ('ement-room-quote t)
+ ((pred listp) (member 'ement-room-quote value))))
+ body))
+ (quote-end (when quote-start
+ (ement--text-property-search-backward 'face
+ (lambda (value)
+ (pcase value
+ ('ement-room-quote t)
+ ((pred listp) (member 'ement-room-quote value))))
+ body :start (length body)))))
+ (add-face-text-property (or quote-end 0) body-length face 'append body)
(when ement-room-prism-addressee
(ement-room--add-member-face body room))
body))
@@ -970,11 +1016,10 @@ Note that, if ROOM has no buffer, STRING is returned
unchanged."
(with-current-buffer buffer
(save-excursion
(goto-char (point-min))
- (cl-labels ((found-sender-p
- (ewoc-data)
- (when (ement-event-p
ewoc-data)
- (equal member-name
- (gethash
(ement-event-sender ewoc-data) (ement-room-displaynames room))))))
+ (cl-labels ((found-sender-p (ewoc-data)
+ (when (ement-event-p
ewoc-data)
+ (equal member-name
+ (gethash
(ement-event-sender ewoc-data) (ement-room-displaynames room))))))
(cl-loop with regexp = (regexp-quote
member-name)
while (re-search-forward regexp
nil t)
;; NOTE: I don't know why, but
sometimes the regexp
@@ -1125,15 +1170,14 @@ are passed to `browse-url'."
(defun ement-room-find-event (event-id)
"Go to EVENT-ID in current buffer."
(interactive)
- (cl-labels ((goto-event
- (event-id) (progn
- (push-mark)
- (goto-char
- (ewoc-location
- (ement-room--ewoc-last-matching ement-ewoc
- (lambda (data)
- (and (ement-event-p data)
- (equal event-id (ement-event-id
data))))))))))
+ (cl-labels ((goto-event (event-id)
+ (push-mark)
+ (goto-char
+ (ewoc-location
+ (ement-room--ewoc-last-matching ement-ewoc
+ (lambda (data)
+ (and (ement-event-p data)
+ (equal event-id (ement-event-id data)))))))))
(if (or (cl-find event-id (ement-room-timeline ement-room)
:key #'ement-event-id :test #'equal)
(cl-find event-id (ement-room-state ement-room)
@@ -1217,8 +1261,9 @@ otherwise use current room."
(ement-room-with-typing
(let* ((file (read-file-name (format "Send file (%s): "
(ement-room-display-name ement-room))
nil nil 'confirm))
- (body (ement-room-read-string (format "Message body (%s): "
(ement-room-display-name ement-room))
- (file-name-nondirectory file) nil
nil 'inherit-input-method)))
+ (body (ement-room-read-string
+ (format "Message body (%s): " (ement-room-display-name
ement-room))
+ (file-name-nondirectory file) 'file-name-history nil
'inherit-input-method)))
(list file body ement-room ement-session)))))
;; NOTE: The typing notification won't be quite right, because it'll be
canceled while waiting
;; for the file to upload. It would be awkward to handle that, so this will
do for now.
@@ -1228,7 +1273,7 @@ otherwise use current room."
(extension (or (file-name-extension file) ""))
(mime-type (mailcap-extension-to-mime extension))
(data `(file ,file))
- (size (length data)))
+ (size (file-attribute-size (file-attributes file))))
(ement-upload session :data data :filename filename :content-type
mime-type
:then (lambda (data)
(message "Uploaded file %S. Sending message..." file)
@@ -1257,8 +1302,9 @@ otherwise use current room."
(ement-room-with-typing
(let* ((file (read-file-name (format "Send image file (%s): "
(ement-room-display-name ement-room))
nil nil 'confirm))
- (body (ement-room-read-string (format "Message body (%s): "
(ement-room-display-name ement-room))
- (file-name-nondirectory file) nil
nil 'inherit-input-method)))
+ (body (ement-room-read-string
+ (format "Message body (%s): " (ement-room-display-name
ement-room))
+ (file-name-nondirectory file) 'file-name-history nil
'inherit-input-method)))
(list file body ement-room ement-session)))))
(ement-room-send-file file body room session :msgtype "m.image"))
@@ -1333,7 +1379,7 @@ buffer). It receives two arguments, the room and the
session."
(if (>= (point) (- (point-max) 2))
;; Point is actually on the last event, but it doesn't appear to be:
move point to
;; the beginning of that event.
- (ewoc-goto-node ement-ewoc (ewoc-locate ement-ewoc))
+ (ewoc-goto-node ement-ewoc (ement-room--ewoc-last-matching ement-ewoc
#'ement-event-p))
;; Go to previous event.
(ement-room-goto-next :next-fn #'ewoc-prev)))
@@ -1345,7 +1391,11 @@ see."
(if-let (node (ement-room--ewoc-next-matching ement-ewoc
(ewoc-locate ement-ewoc) #'ement-event-p next-fn))
(ewoc-goto-node ement-ewoc node)
- (user-error "End of events")))
+ (if (= (point) (point-max))
+ ;; Already at end of buffer: signal error.
+ (user-error "End of events")
+ ;; Go to end-of-buffer so new messages will auto-scroll.
+ (goto-char (point-max)))))
(defun ement-room-scroll-down-command ()
"Scroll down, and load NUMBER earlier messages when at top."
@@ -1513,16 +1563,16 @@ sync requests. Also, update any room list buffers."
EVENT should be an `ement-event' or `ement-room-membership-events' struct."
(interactive (list (ewoc-data (ewoc-locate ement-ewoc))))
(require 'pp)
- (cl-labels ((event-alist
- (event) (ement-alist :id (ement-event-id event)
- :sender (ement-user-id (ement-event-sender
event))
- :content (ement-event-content event)
- :origin-server-ts
(ement-event-origin-server-ts event)
- :type (ement-event-type event)
- :state-key (ement-event-state-key event)
- :unsigned (ement-event-unsigned event)
- :receipts (ement-event-receipts event)
- :local (ement-event-local event))))
+ (cl-labels ((event-alist (event)
+ (ement-alist :id (ement-event-id event)
+ :sender (ement-user-id (ement-event-sender event))
+ :content (ement-event-content event)
+ :origin-server-ts (ement-event-origin-server-ts
event)
+ :type (ement-event-type event)
+ :state-key (ement-event-state-key event)
+ :unsigned (ement-event-unsigned event)
+ :receipts (ement-event-receipts event)
+ :local (ement-event-local event))))
(let* ((buffer-name (format "*Ement event: %s*"
(cl-typecase event
(ement-room-membership-events "[multiple
events]")
@@ -1554,8 +1604,8 @@ the content (e.g. see `ement-room-send-org-filter')."
(ement-with-room-and-session
(let* ((prompt (format "Send message (%s): " (ement-room-display-name
ement-room)))
(body (ement-room-with-typing
- (ement-room-read-string prompt nil nil nil
- 'inherit-input-method))))
+ (ement-room-read-string prompt nil
'ement-room-message-history
+ nil 'inherit-input-method))))
(list ement-room ement-session :body body))))
(ement-send-message room session :body body :formatted-body formatted-body
:replying-to-event replying-to-event :filter ement-room-send-message-filter
@@ -1586,8 +1636,8 @@ the content (e.g. see `ement-room-send-org-filter')."
(ement-with-room-and-session
(let* ((prompt (format "Send emote (%s): " (ement-room-display-name
ement-room)))
(body (ement-room-with-typing
- (ement-room-read-string prompt nil nil nil
- 'inherit-input-method))))
+ (ement-room-read-string prompt nil
'ement-room-emote-history
+ nil 'inherit-input-method))))
(list ement-room ement-session :body body))))
(cl-assert (not (string-empty-p body)))
(pcase-let* (((cl-struct ement-room (id room-id) (local (map buffer))) room)
@@ -1660,8 +1710,8 @@ The message must be one sent by the local user."
(ement-room-with-typing
(let* ((prompt (format "Edit message (%s): "
(ement-room-display-name
ement-room)))
- (body (ement-room-read-string prompt body nil nil
-
'inherit-input-method)))
+ (body (ement-room-read-string prompt body
'ement-room-message-history
+ nil
'inherit-input-method)))
(when (string-empty-p body)
(user-error "To delete a message, use command
`ement-room-delete-message'"))
(when (yes-or-no-p (format "Edit message to: %S? "
body))
@@ -1709,7 +1759,8 @@ The message must be one sent by the local user."
(lambda ()
(setq-local ement-room-replying-to-event event)))
(body (ement-room-with-typing
- (ement-room-read-string prompt nil nil nil
'inherit-input-method))))
+ (ement-room-read-string prompt nil
'ement-room-message-history
+ nil 'inherit-input-method))))
(ement-room-send-message room session :body body :replying-to-event
event))))
(defun ement-room-send-reaction (key position)
@@ -1743,28 +1794,27 @@ reaction string, e.g. \"👍\"."
"Toggle reaction of KEY to EVENT in ROOM on SESSION."
(interactive
(cl-labels
- ((face-at-point-p
- (face) (let ((face-at-point (get-text-property (point) 'face)))
- (or (eq face face-at-point)
- (and (listp face-at-point)
- (member face face-at-point)))))
- (buffer-substring-while
- (beg pred &key (forward-fn #'forward-char))
- "Return substring of current buffer from BEG while PRED is true."
- (save-excursion
- (goto-char beg)
- (cl-loop while (funcall pred)
- do (funcall forward-fn)
- finally return (buffer-substring-no-properties beg
(point)))))
- (key-at
- (pos) (cond ((face-at-point-p 'ement-room-reactions-key)
- (buffer-substring-while
- pos (lambda () (face-at-point-p
'ement-room-reactions-key))))
- ((face-at-point-p 'ement-room-reactions)
- ;; Point is in a reaction button but after the key.
- (buffer-substring-while
- (button-start (button-at pos))
- (lambda () (face-at-point-p
'ement-room-reactions-key)))))))
+ ((face-at-point-p (face)
+ (let ((face-at-point (get-text-property (point) 'face)))
+ (or (eq face face-at-point)
+ (and (listp face-at-point)
+ (member face face-at-point)))))
+ (buffer-substring-while (beg pred &key (forward-fn #'forward-char))
+ "Return substring of current buffer from BEG while PRED is true."
+ (save-excursion
+ (goto-char beg)
+ (cl-loop while (funcall pred)
+ do (funcall forward-fn)
+ finally return (buffer-substring-no-properties beg
(point)))))
+ (key-at (pos)
+ (cond ((face-at-point-p 'ement-room-reactions-key)
+ (buffer-substring-while
+ pos (lambda () (face-at-point-p 'ement-room-reactions-key))))
+ ((face-at-point-p 'ement-room-reactions)
+ ;; Point is in a reaction button but after the key.
+ (buffer-substring-while
+ (button-start (button-at pos))
+ (lambda () (face-at-point-p 'ement-room-reactions-key)))))))
(list (or (key-at (point))
(char-to-string (read-char-by-name "Reaction (prepend \"*\" for
substring search): ")))
(ewoc-data (ewoc-locate ement-ewoc))
@@ -2748,22 +2798,22 @@ updates the markers in ROOM's buffer, not on the
server; see
`ement-room-mark-read' for that."
(declare (indent defun))
(cl-labels ((update-marker (symbol to-event)
- (let* ((old-node (symbol-value symbol))
- (new-event-id (cl-etypecase to-event
- (ement-event
(ement-event-id to-event))
- (string to-event)))
- (event-node
(ement-room--ewoc-last-matching ement-ewoc
- (lambda (data)
- (and (ement-event-p data)
- (equal
(ement-event-id data) new-event-id)))))
- (inhibit-read-only t))
- (with-silent-modifications
- (when old-node
- (ewoc-delete ement-ewoc old-node))
- (set symbol (when event-node
- ;; If the event hasn't been
inserted into the buffer yet,
- ;; this might be nil. That
shouldn't happen, but...
- (ewoc-enter-after ement-ewoc
event-node symbol)))))))
+ (let* ((old-node (symbol-value symbol))
+ (new-event-id (cl-etypecase to-event
+ (ement-event (ement-event-id to-event))
+ (string to-event)))
+ (event-node (ement-room--ewoc-last-matching ement-ewoc
+ (lambda (data)
+ (and (ement-event-p data)
+ (equal (ement-event-id data)
new-event-id)))))
+ (inhibit-read-only t))
+ (with-silent-modifications
+ (when old-node
+ (ewoc-delete ement-ewoc old-node))
+ (set symbol (when event-node
+ ;; If the event hasn't been inserted into
the buffer yet,
+ ;; this might be nil. That shouldn't
happen, but...
+ (ewoc-enter-after ement-ewoc event-node
symbol)))))))
(when-let ((buffer (alist-get 'buffer (ement-room-local room))))
;; MAYBE: Error if no buffer? Or does it matter?
(with-current-buffer buffer
@@ -2882,15 +2932,15 @@ the first and last nodes in the buffer, respectively."
(not (or (> (ewoc-location node-a) end-pos)
(when node-b
(> (ewoc-location node-b) end-pos)))))
- (cl-labels ((format-event
- (event) (format "TS:%S (%s) Sender:%s Message:%S"
- (/ (ement-event-origin-server-ts (ewoc-data
event)) 1000)
- (format-time-string "%Y-%m-%d %H:%M:%S"
- (/
(ement-event-origin-server-ts (ewoc-data event)) 1000))
- (ement-user-id (ement-event-sender
(ewoc-data event)))
- (when (alist-get 'body (ement-event-content
(ewoc-data event)))
- (substring-no-properties
- (truncate-string-to-width (alist-get
'body (ement-event-content (ewoc-data event))) 20))))))
+ (cl-labels ((format-event (event)
+ (format "TS:%S (%s) Sender:%s Message:%S"
+ (/ (ement-event-origin-server-ts (ewoc-data
event)) 1000)
+ (format-time-string "%Y-%m-%d %H:%M:%S"
+ (/
(ement-event-origin-server-ts (ewoc-data event)) 1000))
+ (ement-user-id (ement-event-sender (ewoc-data
event)))
+ (when (alist-get 'body (ement-event-content
(ewoc-data event)))
+ (substring-no-properties
+ (truncate-string-to-width (alist-get 'body
(ement-event-content (ewoc-data event))) 20))))))
(ement-debug "Comparing event timestamps:"
(list 'A (format-event node-a))
(list 'B (format-event node-b))))
@@ -2921,14 +2971,14 @@ the first and last nodes in the buffer, respectively."
"Insert sender headers into EWOC.
Inserts headers between START-NODE and END-NODE, which default to
the first and last nodes in the buffer, respectively."
- (cl-labels ((read-marker-p
- (data) (member data '(ement-room-fully-read-marker
- ement-room-read-receipt-marker)))
- (message-event-p
- (data) (and (ement-event-p data)
- (equal "m.room.message" (ement-event-type data))))
- (insert-sender-before
- (node) (ewoc-enter-before ewoc node (ement-event-sender
(ewoc-data node)))))
+ (cl-labels ((read-marker-p (data)
+ (member data '(ement-room-fully-read-marker
+ ement-room-read-receipt-marker)))
+ (message-event-p (data)
+ (and (ement-event-p data)
+ (equal "m.room.message" (ement-event-type data))))
+ (insert-sender-before (node)
+ (ewoc-enter-before ewoc node (ement-event-sender (ewoc-data
node)))))
(let* ((event-node (if (ement-event-p (ewoc-data start-node))
start-node
(ement-room--ewoc-next-matching ewoc start-node
@@ -2982,10 +3032,10 @@ the first and last nodes in the buffer, respectively."
(defun ement-room--coalesce-nodes (a b ewoc)
"Try to coalesce events in nodes A and B in EWOC.
Return absorbing node if coalesced."
- (cl-labels ((coalescable-p
- (node) (or (and (ement-event-p (ewoc-data node))
- (member (ement-event-type (ewoc-data node))
'("m.room.member")))
- (ement-room-membership-events-p (ewoc-data node)))))
+ (cl-labels ((coalescable-p (node)
+ (or (and (ement-event-p (ewoc-data node))
+ (member (ement-event-type (ewoc-data node))
'("m.room.member")))
+ (ement-room-membership-events-p (ewoc-data node)))))
(when (and (coalescable-p a) (coalescable-p b))
(let* ((absorbing-node (if (or (ement-room-membership-events-p
(ewoc-data a))
(not (ement-room-membership-events-p
(ewoc-data b))))
@@ -3004,40 +3054,39 @@ Return absorbing node if coalesced."
(defun ement-room--insert-event (event)
"Insert EVENT into current buffer."
- (cl-labels ((format-event
- (event) (format "TS:%S (%s) Sender:%s Message:%S"
- (/ (ement-event-origin-server-ts event) 1000)
- (format-time-string "%Y-%m-%d %H:%M:%S"
- (/
(ement-event-origin-server-ts event) 1000))
- (ement-user-id (ement-event-sender event))
- (when (alist-get 'body (ement-event-content
event))
- (substring-no-properties
- (truncate-string-to-width (alist-get 'body
(ement-event-content event)) 20)))))
- (find-node-if
- (ewoc pred &key (move #'ewoc-prev) (start (ewoc-nth ewoc -1)))
- "Return node in EWOC whose data matches PRED.
+ (cl-labels ((format-event (event)
+ (format "TS:%S (%s) Sender:%s Message:%S"
+ (/ (ement-event-origin-server-ts event) 1000)
+ (format-time-string "%Y-%m-%d %H:%M:%S"
+ (/ (ement-event-origin-server-ts
event) 1000))
+ (ement-user-id (ement-event-sender event))
+ (when (alist-get 'body (ement-event-content event))
+ (substring-no-properties
+ (truncate-string-to-width (alist-get 'body
(ement-event-content event)) 20)))))
+ (find-node-if (ewoc pred &key (move #'ewoc-prev) (start
(ewoc-nth ewoc -1)))
+ "Return node in EWOC whose data matches PRED.
Search starts from node START and moves by NEXT."
- (cl-loop for node = start then (funcall move ewoc node)
- while node
- when (funcall pred (ewoc-data node))
- return node))
+ (cl-loop for node = start then (funcall move ewoc node)
+ while node
+ when (funcall pred (ewoc-data node))
+ return node))
(timestamped-node-p (data)
- (pcase data
- ((pred ement-event-p) t)
- ((pred ement-room-membership-events-p) t)
- (`(ts . ,_) t)))
+ (pcase data
+ ((pred ement-event-p) t)
+ ((pred ement-room-membership-events-p) t)
+ (`(ts . ,_) t)))
(node-ts (data)
- (pcase data
- ((pred ement-event-p) (ement-event-origin-server-ts
data))
- ((pred ement-room-membership-events-p)
- ;; Not sure whether to use earliest or latest ts;
let's try this for now.
- (ement-room-membership-events-earliest-ts data))
- (`(ts ,ts)
- ;; Matrix server timestamps are in ms, so we must
convert back.
- (* 1000 ts))))
+ (pcase data
+ ((pred ement-event-p) (ement-event-origin-server-ts data))
+ ((pred ement-room-membership-events-p)
+ ;; Not sure whether to use earliest or latest ts; let's try
this for now.
+ (ement-room-membership-events-earliest-ts data))
+ (`(ts ,ts)
+ ;; Matrix server timestamps are in ms, so we must convert
back.
+ (* 1000 ts))))
(node< (a b)
- "Return non-nil if event A's timestamp is before B's."
- (< (node-ts a) (node-ts b))))
+ "Return non-nil if event A's timestamp is before B's."
+ (< (node-ts a) (node-ts b))))
(ement-debug "INSERTING NEW EVENT: " (format-event event))
(let* ((ewoc ement-ewoc)
(event-node-before (ement-room--ewoc-node-before ewoc event #'node<
:pred #'timestamped-node-p))
@@ -3120,11 +3169,11 @@ Search from FROM (either `first' or `last')."
(if (null (ewoc-nth ewoc 0))
(ement-debug "EWOC is empty: returning nil.")
(ement-debug "EWOC has data: add at appropriate place.")
- (cl-labels ((next-matching
- (ewoc node next-fn pred) (cl-loop do (setf node (funcall
next-fn ewoc node))
- until (or (null node)
- (funcall pred
(ewoc-data node)))
- finally return node)))
+ (cl-labels ((next-matching (ewoc node next-fn pred)
+ (cl-loop do (setf node (funcall next-fn ewoc node))
+ until (or (null node)
+ (funcall pred (ewoc-data node)))
+ finally return node)))
(let* ((next-fn (pcase from ('first #'ewoc-next) ('last #'ewoc-prev)))
(start-node (ewoc-nth ewoc (pcase from ('first 0) ('last -1)))))
(unless (funcall pred (ewoc-data start-node))
@@ -3267,38 +3316,38 @@ Formats according to `ement-room-message-format-spec',
which see."
"Return formatted reactions to EVENT."
;; TODO: Like other events, pop to a buffer showing the raw reaction events
when a key is pressed.
(if-let ((reactions (map-elt (ement-event-local event) 'reactions)))
- (cl-labels ((format-reaction
- (ks) (pcase-let* ((`(,key . ,senders) ks)
- (key (propertize key 'face
'ement-room-reactions-key))
- (count (propertize (format " (%s)"
(length senders))
- 'face
'ement-room-reactions))
- (string
- (propertize (concat key count)
- 'button '(t)
- 'category 'default-button
- 'action
#'ement-room-reaction-button-action
- 'follow-link t
- 'help-echo (lambda (_window
buffer _pos)
- ;; NOTE: If the
reaction key string is a Unicode character composed
- ;; with, e.g.
"VARIATION SELECTOR-16", `string-to-char' ignores the
- ;; composed
modifier/variation-selector and just returns the first
- ;; character of
the string. This should be fine, since it's just
- ;; for the
tooltip.
- (concat
-
(get-char-code-property (string-to-char key) 'name) ": "
- (senders-names
senders (buffer-local-value 'ement-room buffer))))))
- (local-user-p (cl-member (ement-user-id
(ement-session-user ement-session)) senders
- :key
#'ement-user-id :test #'equal)))
- (when local-user-p
- (add-face-text-property 0 (length string) '(:box
(:style pressed-button) :inverse-video t)
- nil string))
- (ement--remove-face-property string 'button)
- string))
- (senders-names
- (senders room) (cl-loop for sender in senders
- collect (ement--user-displayname-in
room sender)
- into names
- finally return (string-join names
", "))))
+ (cl-labels ((format-reaction (ks)
+ (pcase-let* ((`(,key . ,senders) ks)
+ (key (propertize key 'face
'ement-room-reactions-key))
+ (count (propertize (format " (%s)" (length
senders))
+ 'face
'ement-room-reactions))
+ (string
+ (propertize (concat key count)
+ 'button '(t)
+ 'category 'default-button
+ 'action
#'ement-room-reaction-button-action
+ 'follow-link t
+ 'help-echo (lambda (_window
buffer _pos)
+ ;; NOTE: If the
reaction key string is a Unicode character composed
+ ;; with, e.g.
"VARIATION SELECTOR-16", `string-to-char' ignores the
+ ;; composed
modifier/variation-selector and just returns the first
+ ;; character of the
string. This should be fine, since it's just
+ ;; for the tooltip.
+ (concat
+
(get-char-code-property (string-to-char key) 'name) ": "
+ (senders-names
senders (buffer-local-value 'ement-room buffer))))))
+ (local-user-p (cl-member (ement-user-id
(ement-session-user ement-session)) senders
+ :key #'ement-user-id
:test #'equal)))
+ (when local-user-p
+ (add-face-text-property 0 (length string) '(:box
(:style pressed-button) :inverse-video t)
+ nil string))
+ (ement--remove-face-property string 'button)
+ string))
+ (senders-names (senders room)
+ (cl-loop for sender in senders
+ collect (ement--user-displayname-in room sender)
+ into names
+ finally return (string-join names ", "))))
(cl-loop with keys-senders
for reaction in reactions
for key = (map-nested-elt (ement-event-content reaction)
'(m.relates_to key))
@@ -3471,8 +3520,10 @@ HTML is rendered to Emacs text using
`shr-insert-document'."
(let ((beg (point-marker)))
(funcall old-fn dom)
(add-text-properties beg (point-max)
- '(wrap-prefix " "
- line-prefix "
"))))))
+ '( wrap-prefix " "
+ line-prefix " "))
+ ;; NOTE: We use our own gv, `ement-text-property'; very
convenient.
+ (add-face-text-property beg (point-max)
'ement-room-quote 'append)))))
(shr-insert-document
(libxml-parse-html-region (point-min) (point-max))))))
(string-trim (buffer-substring (point) (point-max)))))
@@ -3488,8 +3539,8 @@ HTML is rendered to Emacs text using
`shr-insert-document'."
;; HACK: So we use the username slot, which was created just for this, for
now.
(when body
(cl-macrolet ((matches-body-p
- (form) `(when-let ((string ,form))
- (string-match-p (regexp-quote string) body))))
+ (form) `(when-let ((string ,form))
+ (string-match-p (regexp-quote string) body))))
(or (matches-body-p (ement-user-username user))
(matches-body-p (ement--user-displayname-in room user))
(matches-body-p (ement-user-id user)))))))
@@ -3528,31 +3579,30 @@ HTML is rendered to Emacs text using
`shr-insert-document'."
(defun ement-room--user-color (user)
"Return a color in which to display USER's messages."
- (cl-labels ((relative-luminance
- ;; Copy of `modus-themes-wcag-formula', an elegant
- ;; implementation by Protesilaos Stavrou. Also see
- ;; <https://en.wikipedia.org/wiki/Relative_luminance> and
- ;; <https://www.w3.org/TR/WCAG20/#relativeluminancedef>.
- (rgb) (cl-loop for k in '(0.2126 0.7152 0.0722)
- for x in rgb
- sum (* k (if (<= x 0.03928)
- (/ x 12.92)
- (expt (/ (+ x 0.055) 1.055) 2.4)))))
- (contrast-ratio
- ;; Copy of `modus-themes-contrast'; see above.
- (a b) (let ((ct (/ (+ (relative-luminance a) 0.05)
- (+ (relative-luminance b) 0.05))))
- (max ct (/ ct))))
- (increase-contrast
- (color against target toward)
- (let ((gradient (cdr (color-gradient color toward 20)))
- new-color)
- (cl-loop do (setf new-color (pop gradient))
- while new-color
- until (>= (contrast-ratio new-color against) target)
- ;; Avoid infinite loop in case of weirdness
- ;; by returning color as a fallback.
- finally return (or new-color color)))))
+ (cl-labels ((relative-luminance (rgb)
+ ;; Copy of `modus-themes-wcag-formula', an elegant
+ ;; implementation by Protesilaos Stavrou. Also see
+ ;; <https://en.wikipedia.org/wiki/Relative_luminance> and
+ ;; <https://www.w3.org/TR/WCAG20/#relativeluminancedef>.
+ (cl-loop for k in '(0.2126 0.7152 0.0722)
+ for x in rgb
+ sum (* k (if (<= x 0.03928)
+ (/ x 12.92)
+ (expt (/ (+ x 0.055) 1.055) 2.4)))))
+ (contrast-ratio (a b)
+ ;; Copy of `modus-themes-contrast'; see above.
+ (let ((ct (/ (+ (relative-luminance a) 0.05)
+ (+ (relative-luminance b) 0.05))))
+ (max ct (/ ct))))
+ (increase-contrast (color against target toward)
+ (let ((gradient (cdr (color-gradient color toward 20)))
+ new-color)
+ (cl-loop do (setf new-color (pop gradient))
+ while new-color
+ until (>= (contrast-ratio new-color against) target)
+ ;; Avoid infinite loop in case of weirdness
+ ;; by returning color as a fallback.
+ finally return (or new-color color)))))
(let* ((id (ement-user-id user))
(id-hash (float (+ (abs (sxhash id))
ement-room-prism-color-adjustment)))
;; TODO: Wrap-around the value to get the color I want.
@@ -3677,8 +3727,10 @@ To be called from an `ement-room-compose' buffer."
(eq data replying-to-event))))))
(body (if replying-to-event
(ement-room-with-highlighted-event-at pos
- (ement-room-read-string prompt (car kill-ring) nil nil
'inherit-input-method))
- (ement-room-read-string prompt (car kill-ring) nil nil
'inherit-input-method)) ))
+ (ement-room-read-string prompt (car kill-ring)
'ement-room-message-history
+ nil 'inherit-input-method))
+ (ement-room-read-string prompt (car kill-ring)
'ement-room-message-history
+ nil 'inherit-input-method)) ))
(ement-room-send-message ement-room ement-session :body body
:replying-to-event replying-to-event))))
(defun ement-room-init-compose-buffer (room session)
@@ -3731,24 +3783,24 @@ a copy of the local keymap, and sets
`header-line-format'."
event)
(sender-name (ement--user-displayname-in ement-room sender)))
(cl-macrolet ((nes (var)
- ;; For "non-empty-string". Needed because the
displayname can be
- ;; an empty string, but apparently is never null.
(Note that the
- ;; argument should be a variable, never any other form,
to avoid
- ;; multiple evaluation.)
- `(when (and ,var (not (string-empty-p ,var)))
- ,var))
- (sender-name-id-string
- () `(propertize sender-name
- 'help-echo (ement-user-id sender)))
- (new-displayname-sender-name-state-key-string
- () `(propertize (or (nes new-displayname) (nes sender-name)
(nes state-key))
- 'help-echo state-key))
- (sender-name-state-key-string
- () `(propertize sender-name
- 'help-echo state-key))
- (prev-displayname-id-string
- () `(propertize (or prev-displayname sender-name)
- 'help-echo (ement-user-id sender))))
+ ;; For "non-empty-string". Needed because the displayname
can be
+ ;; an empty string, but apparently is never null. (Note
that the
+ ;; argument should be a variable, never any other form, to
avoid
+ ;; multiple evaluation.)
+ `(when (and ,var (not (string-empty-p ,var)))
+ ,var))
+ (sender-name-id-string ()
+ `(propertize sender-name
+ 'help-echo (ement-user-id sender)))
+ (new-displayname-sender-name-state-key-string ()
+ `(propertize (or (nes new-displayname) (nes sender-name)
(nes state-key))
+ 'help-echo state-key))
+ (sender-name-state-key-string ()
+ `(propertize sender-name
+ 'help-echo state-key))
+ (prev-displayname-id-string ()
+ `(propertize (or prev-displayname sender-name)
+ 'help-echo (ement-user-id sender))))
(pcase-exhaustive new-membership
("invite"
(pcase prev-membership
@@ -3845,14 +3897,16 @@ a copy of the local keymap, and sets
`header-line-format'."
(defun ement-room--format-membership-events (struct room)
"Return string for STRUCT in ROOM.
STRUCT should be an `ement-room-membership-events' struct."
- (cl-labels ((event-user
- (event) (propertize (if-let (user (gethash
(ement-event-state-key event) ement-users))
- (ement--user-displayname-in room user)
- (ement-event-state-key event))
- 'help-echo (concat
(ement-room--format-member-event event room)
- " <"
(ement-event-state-key event) ">")))
- (old-membership (event) (map-nested-elt (ement-event-unsigned
event) '(prev_content membership)))
- (new-membership (event) (alist-get 'membership
(ement-event-content event))))
+ (cl-labels ((event-user (event)
+ (propertize (if-let (user (gethash (ement-event-state-key
event) ement-users))
+ (ement--user-displayname-in room user)
+ (ement-event-state-key event))
+ 'help-echo (concat
(ement-room--format-member-event event room)
+ " <" (ement-event-state-key
event) ">")))
+ (old-membership (event)
+ (map-nested-elt (ement-event-unsigned event) '(prev_content
membership)))
+ (new-membership (event)
+ (alist-get 'membership (ement-event-content event))))
(pcase-let* (((cl-struct ement-room-membership-events events) struct))
(pcase (length events)
(0 (warn "No events in `ement-room-membership-events' struct"))
@@ -4165,7 +4219,8 @@ Then invalidate EVENT's node to show the image."
event)
(url (when mxc-url
(ement--mxc-to-url mxc-url ement-session)))
- (human-size (file-size-human-readable size))
+ (human-size (when size
+ (file-size-human-readable size)))
(string (format "[file: %s (%s) (%s)]" filename mimetype
human-size)))
(concat (propertize string
'action #'browse-url
@@ -4212,6 +4267,7 @@ Then invalidate EVENT's node to show the image."
(defvar org-export-with-toc)
(defvar org-export-with-broken-links)
(defvar org-export-with-section-numbers)
+(defvar org-export-with-sub-superscripts)
(defvar org-html-inline-images)
(declare-function org-element-property "org-element")
@@ -4259,6 +4315,7 @@ compatibility), and the result is added to the CONTENT as
(let ((org-export-with-toc nil)
(org-export-with-broken-links t)
(org-export-with-section-numbers nil)
+ (org-export-with-sub-superscripts nil)
(org-html-inline-images nil))
(org-html-export-as-html nil nil nil 'body-only)))
(with-current-buffer "*Org HTML Export*"
diff --git a/ement-structs.el b/ement-structs.el
index d80a7bf7b7..f6e9462d40 100644
--- a/ement-structs.el
+++ b/ement-structs.el
@@ -1,6 +1,6 @@
;;; ement-structs.el --- Ement structs -*- lexical-binding: t;
-*-
-;; Copyright (C) 2022 Free Software Foundation, Inc.
+;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
;; Author: Adam Porter <adam@alphapapa.net>
;; Maintainer: Adam Porter <adam@alphapapa.net>
diff --git a/ement-tabulated-room-list.el b/ement-tabulated-room-list.el
index 047852b364..c020eee099 100644
--- a/ement-tabulated-room-list.el
+++ b/ement-tabulated-room-list.el
@@ -1,6 +1,6 @@
;;; ement-tabulated-room-list.el --- Ement tabulated room list buffer -*-
lexical-binding: t; -*-
-;; Copyright (C) 2022 Free Software Foundation, Inc.
+;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
;; Author: Adam Porter <adam@alphapapa.net>
;; Maintainer: Adam Porter <adam@alphapapa.net>
diff --git a/ement.el b/ement.el
index 0538e25596..0ad01a8078 100644
--- a/ement.el
+++ b/ement.el
@@ -1,11 +1,11 @@
;;; ement.el --- Matrix client -*- lexical-binding: t;
-*-
-;; Copyright (C) 2022 Free Software Foundation, Inc.
+;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
;; Author: Adam Porter <adam@alphapapa.net>
;; Maintainer: Adam Porter <adam@alphapapa.net>
;; URL: https://github.com/alphapapa/ement.el
-;; Version: 0.11
+;; Version: 0.12
;; Package-Requires: ((emacs "27.1") (map "2.1") (persist "0.5") (plz "0.6")
(taxy "0.10") (taxy-magit-section "0.12.1") (svg-lib "0.2.5") (transient
"0.3.7"))
;; Keywords: comm
@@ -60,6 +60,7 @@
;; This package.
(require 'ement-lib)
(require 'ement-room)
+(require 'ement-notifications)
(require 'ement-notify)
;;;; Variables
@@ -106,6 +107,9 @@ by users; ones who do so should know what they're doing.")
(defvar ement-read-receipt-idle-timer nil
"Idle timer used to update read receipts.")
+(defvar ement-connect-user-id-history nil
+ "History list of user IDs entered into `ement-connect'.")
+
;; From other files.
(defvar ement-room-avatar-max-width)
(defvar ement-room-avatar-max-height)
@@ -210,7 +214,7 @@ the port, e.g.
\"http://localhost:8080\"";
(interactive (if current-prefix-arg
;; Force new session.
- (list :user-id (read-string "User ID: "))
+ (list :user-id (read-string "User ID: " nil
'ement-connect-user-id-history))
;; Use known session.
(unless ement-sessions
;; Read sessions from disk.
@@ -219,110 +223,109 @@ the port, e.g.
(error (display-warning 'ement (format "Unable to read
session data from disk (%s). Prompting to log in again."
(error-message-string err))))))
(cl-case (length ement-sessions)
- (0 (list :user-id (read-string "User ID: ")))
+ (0 (list :user-id (read-string "User ID: " nil
'ement-connect-user-id-history)))
(1 (list :session (cdar ement-sessions)))
(otherwise (list :session (ement-complete-session))))))
(let (sso-server-process)
- (cl-labels ((new-session
- () (unless (string-match (rx bos "@" (group (1+ (not (any
":")))) ; Username
- ":" (group (optional (1+ (not
(any blank)))))) ; Server name
- user-id)
- (user-error "Invalid user ID format: use
@USERNAME:SERVER"))
- (let* ((username (match-string 1 user-id))
- (server-name (match-string 2 user-id))
- (uri-prefix (or uri-prefix (ement--hostname-uri
server-name)))
- (user (make-ement-user :id user-id :username username))
- (server (make-ement-server :name server-name
:uri-prefix uri-prefix))
- (transaction-id (ement--initial-transaction-id))
- (initial-device-display-name (format "Ement.el: %s@%s"
- ;; Just to be
extra careful:
- (or
user-login-name "[unknown user-login-name]")
- (or (system-name)
"[unknown system-name]")))
- (device-id (secure-hash 'sha256
initial-device-display-name)))
- (make-ement-session :user user :server server
:transaction-id transaction-id
- :device-id device-id
:initial-device-display-name initial-device-display-name
- :events (make-hash-table :test
#'equal))))
- (password-login
- () (pcase-let* (((cl-struct ement-session user device-id
initial-device-display-name) session)
- ((cl-struct ement-user id) user)
- (data (ement-alist "type" "m.login.password"
- "identifier"
- (ement-alist "type"
"m.id.user"
- "user" id)
- "password" (or password
-
(read-passwd (format "Password for %s: " id)))
- "device_id" device-id
-
"initial_device_display_name" initial-device-display-name)))
- ;; TODO: Clear password in callback (if we decide to
hold on to it for retrying login timeouts).
- (ement-api session "login" :method 'post :data
(json-encode data)
- :then (apply-partially #'ement--login-callback
session))
- (ement-message "Logging in with password...")))
- (sso-filter
- (process string)
- ;; NOTE: This is technically wrong, because it's not
guaranteed that the
- ;; string will be a complete request--it could just be a
chunk. But in
- ;; practice, if this works, it's much simpler than setting up
process log
- ;; functions and per-client buffers for this throwaway,
pretend HTTP server.
- (when (string-match (rx "GET /?loginToken=" (group (0+ nonl))
" " (0+ nonl)) string)
- (unwind-protect
- (pcase-let* ((token (match-string 1 string))
- ((cl-struct ement-session user device-id
initial-device-display-name)
- session)
- ((cl-struct ement-user id) user)
- (data (ement-alist
- "type" "m.login.token"
- "identifier" (ement-alist "type"
"m.id.user"
- "user" id)
- "token" token
- "device_id" device-id
- "initial_device_display_name"
initial-device-display-name)))
- (ement-api session "login" :method 'post
- :data (json-encode data)
- :then (apply-partially #'ement--login-callback
session))
- (process-send-string process "HTTP/1.0 202 Accepted
+ (cl-labels ((new-session ()
+ (unless (string-match (rx bos "@" (group (1+ (not (any
":")))) ; Username
+ ":" (group (optional (1+ (not (any
blank)))))) ; Server name
+ user-id)
+ (user-error "Invalid user ID format: use
@USERNAME:SERVER"))
+ (let* ((username (match-string 1 user-id))
+ (server-name (match-string 2 user-id))
+ (uri-prefix (or uri-prefix (ement--hostname-uri
server-name)))
+ (user (make-ement-user :id user-id :username
username))
+ (server (make-ement-server :name server-name
:uri-prefix uri-prefix))
+ (transaction-id (ement--initial-transaction-id))
+ (initial-device-display-name (format "Ement.el: %s@%s"
+ ;; Just to be
extra careful:
+ (or
user-login-name "[unknown user-login-name]")
+ (or
(system-name) "[unknown system-name]")))
+ (device-id (secure-hash 'sha256
initial-device-display-name)))
+ (make-ement-session :user user :server server
:transaction-id transaction-id
+ :device-id device-id
:initial-device-display-name initial-device-display-name
+ :events (make-hash-table :test
#'equal))))
+ (password-login ()
+ (pcase-let* (((cl-struct ement-session user device-id
initial-device-display-name) session)
+ ((cl-struct ement-user id) user)
+ (data (ement-alist "type" "m.login.password"
+ "identifier"
+ (ement-alist "type"
"m.id.user"
+ "user" id)
+ "password" (or password
+ (read-passwd
(format "Password for %s: " id)))
+ "device_id" device-id
+
"initial_device_display_name" initial-device-display-name)))
+ ;; TODO: Clear password in callback (if we decide to hold
on to it for retrying login timeouts).
+ (ement-api session "login" :method 'post :data
(json-encode data)
+ :then (apply-partially #'ement--login-callback session))
+ (ement-message "Logging in with password...")))
+ (sso-filter (process string)
+ ;; NOTE: This is technically wrong, because it's not
guaranteed that the
+ ;; string will be a complete request--it could just be a
chunk. But in
+ ;; practice, if this works, it's much simpler than setting
up process log
+ ;; functions and per-client buffers for this throwaway,
pretend HTTP server.
+ (when (string-match (rx "GET /?loginToken=" (group (0+
nonl)) " " (0+ nonl)) string)
+ (unwind-protect
+ (pcase-let* ((token (match-string 1 string))
+ ((cl-struct ement-session user device-id
initial-device-display-name)
+ session)
+ ((cl-struct ement-user id) user)
+ (data (ement-alist
+ "type" "m.login.token"
+ "identifier" (ement-alist "type"
"m.id.user"
+ "user"
id)
+ "token" token
+ "device_id" device-id
+ "initial_device_display_name"
initial-device-display-name)))
+ (ement-api session "login" :method 'post
+ :data (json-encode data)
+ :then (apply-partially #'ement--login-callback
session))
+ (process-send-string process "HTTP/1.0 202 Accepted
Content-Type: text/plain; charset=utf-8
Ement: SSO login accepted; session token received. Connecting to Matrix
server. (You may close this page.)")
- (process-send-eof process))
- (delete-process sso-server-process)
- (delete-process process))))
+ (process-send-eof process))
+ (delete-process sso-server-process)
+ (delete-process process))))
(sso-login ()
- (setf sso-server-process
- (make-network-process
- :name "ement-sso" :family 'ipv4 :host 'local
:service ement-sso-server-port
- :filter #'sso-filter :server t :noquery t))
- ;; Kill server after 2 minutes in case of problems.
- (run-at-time 120 nil (lambda ()
- (when (process-live-p
sso-server-process)
- (delete-process
sso-server-process))))
- (let ((url (concat (ement-server-uri-prefix
(ement-session-server session))
-
"/_matrix/client/r0/login/sso/redirect?redirectUrl=http://localhost:";
- (number-to-string
ement-sso-server-port))))
- (funcall browse-url-secondary-browser-function
url)
- (message "Browsing to single sign-on page
<%s>..." url)))
- (flows-callback
- (data) (let ((flows (cl-loop for flow across (map-elt data
'flows)
- for type = (map-elt flow 'type)
- when (member type
'("m.login.password" "m.login.sso"))
- collect type)))
- (pcase (length flows)
- (0 (error "Ement: No supported login flows:
Server:%S Supported flows:%S"
- (ement-server-uri-prefix
(ement-session-server session))
- (map-elt data 'flows)))
- (1 (pcase (car flows)
- ("m.login.password" (password-login))
- ("m.login.sso" (sso-login))
- (_ (error "Ement: Unsupported login flow: %s
Server:%S Supported flows:%S"
- (car flows)
(ement-server-uri-prefix (ement-session-server session))
- (map-elt data 'flows)))))
- (_ (pcase (completing-read "Select authentication
method: "
- (cl-loop for flow in
flows
- collect
(string-trim-left flow (rx "m.login."))))
- ("password" (password-login))
- ("sso" (sso-login))
- (else (error "Ement: Unsupported login
flow:%S Server:%S Supported flows:%S"
- else (ement-server-uri-prefix
(ement-session-server session))
- (map-elt data 'flows)))))))))
+ (setf sso-server-process
+ (make-network-process
+ :name "ement-sso" :family 'ipv4 :host 'local :service
ement-sso-server-port
+ :filter #'sso-filter :server t :noquery t))
+ ;; Kill server after 2 minutes in case of problems.
+ (run-at-time 120 nil (lambda ()
+ (when (process-live-p
sso-server-process)
+ (delete-process
sso-server-process))))
+ (let ((url (concat (ement-server-uri-prefix
(ement-session-server session))
+
"/_matrix/client/r0/login/sso/redirect?redirectUrl=http://localhost:";
+ (number-to-string
ement-sso-server-port))))
+ (funcall browse-url-secondary-browser-function url)
+ (message "Browsing to single sign-on page <%s>..." url)))
+ (flows-callback (data)
+ (let ((flows (cl-loop for flow across (map-elt data 'flows)
+ for type = (map-elt flow 'type)
+ when (member type '("m.login.password"
"m.login.sso"))
+ collect type)))
+ (pcase (length flows)
+ (0 (error "Ement: No supported login flows: Server:%S
Supported flows:%S"
+ (ement-server-uri-prefix (ement-session-server
session))
+ (map-elt data 'flows)))
+ (1 (pcase (car flows)
+ ("m.login.password" (password-login))
+ ("m.login.sso" (sso-login))
+ (_ (error "Ement: Unsupported login flow: %s
Server:%S Supported flows:%S"
+ (car flows) (ement-server-uri-prefix
(ement-session-server session))
+ (map-elt data 'flows)))))
+ (_ (pcase (completing-read "Select authentication
method: "
+ (cl-loop for flow in flows
+ collect
(string-trim-left flow (rx "m.login."))))
+ ("password" (password-login))
+ ("sso" (sso-login))
+ (else (error "Ement: Unsupported login flow:%S
Server:%S Supported flows:%S"
+ else (ement-server-uri-prefix
(ement-session-server session))
+ (map-elt data 'flows)))))))))
(if session
;; Start syncing given session.
(let ((user-id (ement-user-id (ement-session-user session))))
@@ -332,7 +335,7 @@ Ement: SSO login accepted; session token received.
Connecting to Matrix server.
;; Start password login flow. Prompt for user ID and password
;; if not given (i.e. if not called interactively.)
(unless user-id
- (setf user-id (read-string "User ID: ")))
+ (setf user-id (read-string "User ID: " nil
'ement-connect-user-id-history)))
(setf session (new-session))
(when (ement-api session "login" :then #'flows-callback)
(message "Ement: Checking server's login flows..."))))))
@@ -452,20 +455,20 @@ To be called from `ement-disconnect-hook'."
If no URI is found, prompt the user for the hostname."
;; FIXME: When fail-prompting, a URI should be returned, not just a hostname.
;; SPEC: <https://matrix.org/docs/spec/client_server/r0.6.1#id178> ("4.1
Well-known URI")
- (cl-labels ((fail-prompt
- () (let ((input (read-string "Auto-discovery of server's
well-known URI failed. Input server hostname, or leave blank to use server
name: ")))
- (pcase input
- ("" hostname)
- (_ input))))
+ (cl-labels ((fail-prompt ()
+ (let ((input (read-string "Auto-discovery of server's
well-known URI failed. Input server hostname, or leave blank to use server
name: ")))
+ (pcase input
+ ("" hostname)
+ (_ input))))
(parse (string)
- (if-let* ((object (ignore-errors (json-read-from-string
string)))
- (url (map-nested-elt object '(m.homeserver
base_url)))
- ((string-match-p
- (rx bos "http" (optional "s") "://" (1+ nonl))
- url)))
- url
- ;; Parsing error: FAIL_PROMPT.
- (fail-prompt))))
+ (if-let* ((object (ignore-errors (json-read-from-string
string)))
+ (url (map-nested-elt object '(m.homeserver
base_url)))
+ ((string-match-p
+ (rx bos "http" (optional "s") "://" (1+ nonl))
+ url)))
+ url
+ ;; Parsing error: FAIL_PROMPT.
+ (fail-prompt))))
(condition-case err
(let ((response (plz 'get (concat "https://"; hostname
"/.well-known/matrix/client")
:as 'response :then 'sync)))
@@ -548,13 +551,13 @@ a filter ID). When unspecified, the value of
plz-error)))
(_ (signal 'ement-api-error (list
"Ement: Unrecognized network error" plz-error)))))))
:json-read-fn (lambda ()
- "Print a message, then call
`json-read'."
+ "Print a message, then call
`ement--json-parse-buffer'."
(when (ement--sync-messages-p
session)
(message "Ement: Response arrived
after %.2f seconds. Reading %s JSON response..."
(- (time-to-seconds)
sync-start-time)
(file-size-human-readable
(buffer-size))))
(let ((start-time (time-to-seconds)))
- (prog1 (json-read)
+ (prog1 (ement--json-parse-buffer)
(when (ement--sync-messages-p
session)
(message "Ement: Reading JSON
took %.2f seconds"
(- (time-to-seconds)
start-time)))))))))
@@ -720,23 +723,22 @@ Also used for left rooms, in which case STATUS should be
set to
(alist-get 'new-account-data-events (ement-room-local room)))
;; Save state and timeline events.
- (cl-macrolet ((push-events
- (type accessor)
- ;; Push new events of TYPE to room's slot of ACCESSOR, and
return the latest timestamp pushed.
- `(let ((ts 0))
- ;; NOTE: We replace each event in the vector with the
- ;; struct, which is used when calling hooks later.
- (cl-loop for event across-ref (alist-get 'events ,type)
- do (setf event (ement--make-event event))
- do (push event (,accessor room))
- (when (ement--sync-messages-p session)
- (ement-progress-update))
- (when (> (ement-event-origin-server-ts event)
ts)
- (setf ts (ement-event-origin-server-ts
event))))
- ;; One would think that one should use `maximizing'
here, but, completely
- ;; inexplicably, it sometimes returns nil, even when
every single value it's comparing
- ;; is a number. It's absolutely bizarre, but I have to
do the equivalent manually.
- ts)))
+ (cl-macrolet ((push-events (type accessor)
+ ;; Push new events of TYPE to room's slot of ACCESSOR, and
return the latest timestamp pushed.
+ `(let ((ts 0))
+ ;; NOTE: We replace each event in the vector with the
+ ;; struct, which is used when calling hooks later.
+ (cl-loop for event across-ref (alist-get 'events ,type)
+ do (setf event (ement--make-event event))
+ do (push event (,accessor room))
+ (when (ement--sync-messages-p session)
+ (ement-progress-update))
+ (when (> (ement-event-origin-server-ts event)
ts)
+ (setf ts (ement-event-origin-server-ts
event))))
+ ;; One would think that one should use `maximizing'
here, but, completely
+ ;; inexplicably, it sometimes returns nil, even when
every single value it's comparing
+ ;; is a number. It's absolutely bizarre, but I have to
do the equivalent manually.
+ ts)))
;; FIXME: This is a bit convoluted and hacky now. Refactor it.
(setf latest-timestamp
(max (push-events state ement-room-state)
@@ -823,16 +825,16 @@ Adds sender to `ement-users' when necessary."
(defun ement--read-sessions ()
"Return saved sessions alist read from disk.
Returns nil if unable to read `ement-sessions-file'."
- (cl-labels ((plist-to-session
- (plist) (pcase-let* (((map (:user user-data) (:server
server-data)
- (:token token) (:transaction-id
transaction-id))
- plist)
- (user (apply #'make-ement-user user-data))
- (server (apply #'make-ement-server
server-data))
- (session (make-ement-session :user user
:server server
- :token token
:transaction-id transaction-id)))
- (setf (ement-session-events session) (make-hash-table
:test #'equal))
- session)))
+ (cl-labels ((plist-to-session (plist)
+ (pcase-let* (((map (:user user-data) (:server server-data)
+ (:token token) (:transaction-id
transaction-id))
+ plist)
+ (user (apply #'make-ement-user user-data))
+ (server (apply #'make-ement-server server-data))
+ (session (make-ement-session :user user :server
server
+ :token token
:transaction-id transaction-id)))
+ (setf (ement-session-events session) (make-hash-table :test
#'equal))
+ session)))
(when (file-exists-p ement-sessions-file)
(pcase-let* ((read-circle t)
(sessions (with-temp-buffer
@@ -854,16 +856,16 @@ Returns nil if unable to read `ement-sessions-file'."
;; NOTE: This writes all current sessions, even if there are multiple active
ones and only one
;; is being disconnected. That's probably okay, but it might be something
to keep in mind.
- (cl-labels ((session-plist
- (session) (pcase-let* (((cl-struct ement-session user server
token transaction-id) session)
- ((cl-struct ement-user (id user-id)
username) user)
- ((cl-struct ement-server (name
server-name) uri-prefix) server))
- (list :user (list :id user-id
- :username username)
- :server (list :name server-name
- :uri-prefix uri-prefix)
- :token token
- :transaction-id transaction-id))))
+ (cl-labels ((session-plist (session)
+ (pcase-let* (((cl-struct ement-session user server token
transaction-id) session)
+ ((cl-struct ement-user (id user-id) username)
user)
+ ((cl-struct ement-server (name server-name)
uri-prefix) server))
+ (list :user (list :id user-id
+ :username username)
+ :server (list :name server-name
+ :uri-prefix uri-prefix)
+ :token token
+ :transaction-id transaction-id))))
(message "Ement: Writing sessions...")
(with-temp-file ement-sessions-file
(pcase-let* ((print-level nil)
@@ -1059,6 +1061,26 @@ To be called after initial sync."
(when-let ((child-room (cl-find child-id rooms :key
#'ement-room-id :test #'equal)))
(cl-pushnew parent-id (alist-get 'parents (ement-room-local
child-room)) :test #'equal))))))))
+;;;;; Savehist compatibility
+
+;; See <https://github.com/alphapapa/ement.el/issues/216>.
+
+(defvar savehist-save-hook)
+
+(with-eval-after-load 'savehist
+ ;; TODO: Consider using a symbol property on our commands and checking that
rather than
+ ;; symbol names; would avoid consing.
+ (defun ement--savehist-save-hook ()
+ "Remove all `ement-' commands from `command-history'.
+Because when `savehist' saves `command-history', it includes the
+interactive arguments passed to the command, which in our case
+includes large data structures that should never be persisted!"
+ (setf command-history
+ (cl-remove-if (pcase-lambda (`(,command . ,_))
+ (string-match-p (rx bos "ement-") (symbol-name
command)))
+ command-history)))
+ (cl-pushnew 'ement--savehist-save-hook savehist-save-hook))
+
;;;; Footer
(provide 'ement)