mirror of
https://github.com/vale981/ement.el
synced 2025-03-05 09:21:37 -05:00
WIP
It almost works, but events aren't being inserted in order...
This commit is contained in:
Adam Porter
parent
e2d3e47eee
commit
692bce7df4
4 changed files with 74 additions and 295 deletions
264
ement-ewoc.el
264
ement-ewoc.el
|
|
@ -1,264 +0,0 @@
|
|||
;;; ement-ewoc.el --- EWOC testing -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2020 Adam Porter
|
||||
|
||||
;; Author: Adam Porter <adam@alphapapa.net>
|
||||
;; Keywords:
|
||||
|
||||
;; 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:
|
||||
|
||||
;;
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;;; Requirements
|
||||
|
||||
(require 'ewoc)
|
||||
(require 'map)
|
||||
(require 'subr-x)
|
||||
|
||||
;;;; Debugging
|
||||
|
||||
(eval-and-compile
|
||||
(setq-local warning-minimum-log-level nil)
|
||||
(setq-local warning-minimum-log-level :debug))
|
||||
|
||||
(cl-defmacro debug-warn (&rest args)
|
||||
"Display a debug warning showing the runtime value of ARGS.
|
||||
The warning automatically includes the name of the containing
|
||||
function, and it is only displayed if `warning-minimum-log-level'
|
||||
is `:debug' at expansion time (otherwise the macro expands to nil
|
||||
and is eliminated by the byte-compiler). When debugging, the
|
||||
form also returns nil so, e.g. it may be used in a conditional in
|
||||
place of nil.
|
||||
|
||||
Each of ARGS may be a string, which is displayed as-is, or a
|
||||
symbol, the value of which is displayed prefixed by its name, or
|
||||
a Lisp form, which is displayed prefixed by its first symbol.
|
||||
|
||||
Before the actual ARGS arguments, you can write keyword
|
||||
arguments, i.e. alternating keywords and values. The following
|
||||
keywords are supported:
|
||||
|
||||
:buffer BUFFER Name of buffer to pass to `display-warning'.
|
||||
:level LEVEL Level passed to `display-warning', which see.
|
||||
Default is :debug."
|
||||
(pcase-let* ((fn-name (with-current-buffer
|
||||
(or byte-compile-current-buffer (current-buffer))
|
||||
;; This is a hack, but a nifty one.
|
||||
(save-excursion
|
||||
(beginning-of-defun)
|
||||
(cl-second (read (current-buffer))))))
|
||||
(plist-args (cl-loop while (keywordp (car args))
|
||||
collect (pop args)
|
||||
collect (pop args)))
|
||||
((map (:buffer buffer) (:level level)) plist-args)
|
||||
(level (or level :debug))
|
||||
(string (cl-loop for arg in args
|
||||
concat (pcase arg
|
||||
((pred stringp) "%S ")
|
||||
((pred symbolp)
|
||||
(concat (upcase (symbol-name arg)) ":%S "))
|
||||
((pred listp)
|
||||
(concat "(" (upcase (symbol-name (car arg)))
|
||||
(pcase (length arg)
|
||||
(1 ")")
|
||||
(_ "...)"))
|
||||
":%S "))))))
|
||||
(when (eq :debug warning-minimum-log-level)
|
||||
`(progn
|
||||
(display-warning ',fn-name (format ,string ,@args) ,level ,buffer)
|
||||
nil))))
|
||||
|
||||
(defvar-local argh-counter 0)
|
||||
|
||||
;;;; Structs
|
||||
|
||||
(cl-defstruct ement-event
|
||||
id sender content origin-server-ts type unsigned)
|
||||
|
||||
(cl-defstruct ement-user
|
||||
id displayname)
|
||||
|
||||
;;;; Variables
|
||||
|
||||
(defvar ement-widget-users
|
||||
(list (make-ement-user :id "@alice:example.com" :displayname "Alice")
|
||||
(make-ement-user :id "@bob:example.com" :displayname "Bob")
|
||||
(make-ement-user :id "@charlie:example.com" :displayname "Charlie")
|
||||
;; (make-ement-user :id "@dave:example.com" :displayname "Dave")
|
||||
;; (make-ement-user :id "@edith:example.com" :displayname "Edith")
|
||||
))
|
||||
|
||||
(defvar-local matrix-ewoc nil)
|
||||
|
||||
;;;; Customization
|
||||
|
||||
(defgroup ement nil
|
||||
"Options for Ement.el."
|
||||
:group 'matrix-client)
|
||||
|
||||
(defcustom ement-timestamp-format "%H:%M:%S"
|
||||
"Format string for event timestamps.
|
||||
See function `format-time-string'."
|
||||
:type 'string)
|
||||
|
||||
(defface ement-timestamp
|
||||
'((t (:inherit matrix-client-metadata)))
|
||||
"Event timestamps.")
|
||||
|
||||
;;;; Commands
|
||||
|
||||
(defun ement-ewoc-groups-test ()
|
||||
"Start a new EWOC test."
|
||||
(interactive)
|
||||
(let* ((buffer (get-buffer-create "*EWOC Test")))
|
||||
(with-current-buffer buffer
|
||||
(kill-all-local-variables)
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer))
|
||||
(remove-overlays)
|
||||
(setf buffer-read-only t
|
||||
argh-counter 0)
|
||||
(setq-local matrix-ewoc (ewoc-create #'ement-ewoc-pp "HEADER" "FOOTER" nil)))
|
||||
(pop-to-buffer buffer)
|
||||
(ement-ewoc-groups-test-add-random-event matrix-ewoc)))
|
||||
|
||||
(defun ement-ewoc-groups-test-add-random-event (&optional ewoc)
|
||||
"Add a randon event to the EWOC test buffer."
|
||||
(interactive)
|
||||
(with-current-buffer (get-buffer-create "*EWOC Test")
|
||||
(let* ((ewoc (or ewoc matrix-ewoc))
|
||||
(offset-seconds (if (zerop (random 2))
|
||||
(- (random 60))
|
||||
(random 60)))
|
||||
(user (seq-random-elt ement-widget-users))
|
||||
(event (make-ement-event :id "$deadbeef:example.com" :sender user
|
||||
:content (format "Hi, I'm %s (%s)" (ement-user-displayname user)
|
||||
(cl-incf argh-counter))
|
||||
:origin-server-ts (ts-adjust 'second offset-seconds (ts-now))
|
||||
:type "m.message"))
|
||||
(_ (debug-warn user (ts-format "%H:%M:%S" (ement-event-origin-server-ts event))))
|
||||
(node-before (ement-ewoc-node-before ewoc event #'ement-event< :pred #'ement-event-p))
|
||||
new-node)
|
||||
(setf new-node (if (not node-before)
|
||||
(progn
|
||||
(debug-warn "No event before it: add first.")
|
||||
(if-let ((first-node (ewoc-nth ewoc 0)))
|
||||
(progn
|
||||
(debug-warn "EWOC not empty.")
|
||||
(if (and (ement-user-p (ewoc-data first-node))
|
||||
(equal (ement-event-sender event)
|
||||
(ewoc-data first-node)))
|
||||
(progn
|
||||
(debug-warn "First node is header for this sender: insert after it, instead.")
|
||||
(setf node-before first-node)
|
||||
(ewoc-enter-after ewoc first-node event))
|
||||
(debug-warn "First node is not header for this sender: insert first.")
|
||||
(ewoc-enter-first ewoc event)))
|
||||
(debug-warn "EWOC empty: add first.")
|
||||
(ewoc-enter-first ewoc event)))
|
||||
(debug-warn "Found event before new event: insert after it.")
|
||||
(when-let ((next-node (ewoc-next ewoc node-before)))
|
||||
(when (and (ement-user-p (ewoc-data next-node))
|
||||
(equal (ement-event-sender event)
|
||||
(ewoc-data next-node)))
|
||||
(debug-warn "Next node is header for this sender: insert after it, instead.")
|
||||
(setf node-before next-node)))
|
||||
(ewoc-enter-after ewoc node-before event)))
|
||||
;; Insert sender where necessary.
|
||||
(if (not node-before)
|
||||
(progn
|
||||
(debug-warn "No event before: Add sender before new node.")
|
||||
(ewoc-enter-before ewoc new-node (ement-event-sender event)))
|
||||
(debug-warn "Event before: compare sender.")
|
||||
(if (equal (ement-event-sender event)
|
||||
(cl-typecase (ewoc-data node-before)
|
||||
(ement-event (ement-event-sender (ewoc-data node-before)))
|
||||
(ement-user (ewoc-data node-before))))
|
||||
(debug-warn "Same sender.")
|
||||
(debug-warn "Different sender: insert new sender node.")
|
||||
(ewoc-enter-before ewoc new-node (ement-event-sender event))
|
||||
(when-let* ((next-node (ewoc-next ewoc new-node)))
|
||||
(when (ement-event-p (ewoc-data next-node))
|
||||
(debug-warn "Event after from different sender: insert its sender before it.")
|
||||
(ewoc-enter-before ewoc next-node (ement-event-sender (ewoc-data next-node)))))))
|
||||
(pulse-momentary-highlight-one-line (ewoc-location new-node)))))
|
||||
|
||||
|
||||
;;;; Functions
|
||||
|
||||
(defun ement-ewoc-pp (data)
|
||||
"Pretty-print DATA.
|
||||
See function `ewoc-create'."
|
||||
(cl-etypecase data
|
||||
;; FIXME: Null probably not needed anymore.
|
||||
(null (insert ""))
|
||||
(ement-event (insert " " (ement-event-format data)))
|
||||
(ement-user (insert (ement-user-format data)))
|
||||
;; FIXME: Function probably not needed anymore.
|
||||
(function (insert ""))))
|
||||
|
||||
(defun ement-event-format (event)
|
||||
"Format `ement-event' EVENT."
|
||||
(pcase-let* (((cl-struct ement-event content origin-server-ts) event))
|
||||
(concat (propertize (format "[%s] " (ts-format "%H:%M:%S" origin-server-ts))
|
||||
'face 'matrix-client-date-header)
|
||||
content)))
|
||||
|
||||
(defun ement-user-format (user)
|
||||
"Format `ement-user' USER."
|
||||
(propertize (ement-user-displayname user)
|
||||
'face 'matrix-client-metadata))
|
||||
|
||||
(cl-defun ement-ewoc-node-before (ewoc data <-fn
|
||||
&key (from 'last) (pred #'identity))
|
||||
"Return node in EWOC that matches PRED and belongs before DATA according to COMPARATOR."
|
||||
(cl-assert (member from '(first last)))
|
||||
(if (null (ewoc-nth ewoc 0))
|
||||
(debug-warn "EWOC is empty: returning nil.")
|
||||
(debug-warn "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)))
|
||||
(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))
|
||||
(setf start-node (next-matching ewoc start-node next-fn pred)))
|
||||
(if (funcall <-fn (ewoc-data start-node) data)
|
||||
(progn
|
||||
(debug-warn "New data goes before start node.")
|
||||
start-node)
|
||||
(debug-warn "New data goes after start node: find node before new data.")
|
||||
(let ((compare-node start-node))
|
||||
(cl-loop while (setf compare-node (next-matching ewoc compare-node next-fn pred))
|
||||
until (funcall <-fn (ewoc-data compare-node) data)
|
||||
finally return (if compare-node
|
||||
(progn
|
||||
(debug-warn "Found place: enter there.")
|
||||
compare-node)
|
||||
(debug-warn "Reached end of collection: insert there.")
|
||||
(pcase from
|
||||
('first (ewoc-nth ewoc -1))
|
||||
('last nil))))))))))
|
||||
|
||||
;;;; Footer
|
||||
|
||||
;; (provide 'ement-ewoc)
|
||||
|
||||
;;; ement-ewoc.el ends here
|
||||
|
|
@ -60,29 +60,26 @@ See function `format-time-string'."
|
|||
'((t (:inherit font-lock-variable-name-face)))
|
||||
"Event timestamps.")
|
||||
|
||||
(defface ement-room-username
|
||||
'((t (:inherit font-lock-function-name-face)))
|
||||
(defface ement-room-user
|
||||
'((t (:inherit font-lock-keyword-face)))
|
||||
"Usernames.")
|
||||
|
||||
;;;; Commands
|
||||
|
||||
(defun ement-room-view (room)
|
||||
"Switch to a buffer showing ROOM."
|
||||
(interactive (list (ement-complete-room (car ement-sessions))))
|
||||
(pop-to-buffer (ement-room--buffer room)))
|
||||
|
||||
;;;; Functions
|
||||
|
||||
(defun ement-room--buffer (room)
|
||||
"Return a buffer showing ROOM's events."
|
||||
(let* ((buffer-name (concat ement-room-buffer-prefix
|
||||
(setf (ement-room-display-name room)
|
||||
(ement--room-display-name room))
|
||||
ement-room-buffer-suffix)))
|
||||
(or (get-buffer buffer-name)
|
||||
(with-current-buffer (get-buffer-create buffer-name)
|
||||
(ement-room-mode)
|
||||
(ement-room--insert-events room)))))
|
||||
(defun ement-room--buffer (room name)
|
||||
"Return a buffer named NAME showing ROOM's events."
|
||||
(or (get-buffer name)
|
||||
(with-current-buffer (get-buffer-create name)
|
||||
(ement-room-mode)
|
||||
(visual-line-mode 1)
|
||||
(setf ement-room room)
|
||||
;; Move new events to main list.
|
||||
(setf (ement-room-timeline room) (append (ement-room-timeline* room) (ement-room-timeline room))
|
||||
(ement-room-timeline* room) nil)
|
||||
(ement-room--insert-events room)
|
||||
(current-buffer)))) ; Return the buffer!
|
||||
|
||||
(define-derived-mode ement-room-mode fundamental-mode "Ement Room"
|
||||
"Major mode for Ement room buffers.
|
||||
|
|
@ -98,12 +95,16 @@ and erases the buffer."
|
|||
|
||||
;;;;; EWOC
|
||||
|
||||
(defvar-local ement-room nil
|
||||
"The room displayed in the current buffer.")
|
||||
|
||||
(defun ement-room--insert-events (room)
|
||||
"Insert events for ROOM into current buffer."
|
||||
(mapc #'ement-room--insert-event (ement-room-timeline* room))
|
||||
;; Move new events to timeline slot.
|
||||
(mapc #'ement-room--insert-event (ement-room-timeline room))
|
||||
;; Move new events to timeline slot. FIXME: This belongs elsewhere.
|
||||
(setf (ement-room-timeline room) (append (ement-room-timeline* room) (ement-room-timeline room))
|
||||
(ement-room-timeline* room) nil))
|
||||
(ement-room-timeline* room) nil)
|
||||
)
|
||||
|
||||
(defun ement-room--pp-event (struct)
|
||||
"Pretty-print STRUCT.
|
||||
|
|
@ -112,22 +113,51 @@ To be used as the pretty-printer for `ewoc-create'."
|
|||
;; FIXME: Null probably not needed anymore.
|
||||
;; (null (insert ""))
|
||||
(ement-event (insert " " (ement-room--format-event struct)))
|
||||
(ement-user (insert (ement-room--format-format struct)))
|
||||
(ement-user (insert (ement-room--format-user struct)))
|
||||
;; FIXME: Function probably not needed anymore.
|
||||
;; (function (insert ""))
|
||||
))
|
||||
|
||||
(defface ement-room-membership
|
||||
'((t (:inherit font-lock-comment-face)))
|
||||
"Membership events (join/part).")
|
||||
|
||||
(defun ement-room--format-event (event)
|
||||
"Format `ement-event' EVENT."
|
||||
(pcase-let* (((cl-struct ement-event content origin-server-ts) event))
|
||||
(concat (propertize (format "[%s] " (format-time-string "%H:%M:%S" origin-server-ts))
|
||||
'face 'ement-room-timestamp)
|
||||
content)))
|
||||
(pcase-let* (((cl-struct ement-event type content origin-server-ts) event)
|
||||
((map body) content)
|
||||
(timestamp (propertize (format "[%s] " (format-time-string "%H:%M:%S" origin-server-ts))
|
||||
'face 'ement-room-timestamp))
|
||||
(body-face (pcase type
|
||||
("m.room.member" 'ement-room-membership)
|
||||
(_ 'default)))
|
||||
(string (propertize (pcase type
|
||||
("m.room.message" body)
|
||||
("m.room.member" (alist-get 'membership content)))
|
||||
'face body-face)))
|
||||
(concat timestamp string)))
|
||||
|
||||
(defun ement-room--format-format (user)
|
||||
"Format `ement-user' USER."
|
||||
(propertize (ement-user-displayname user)
|
||||
'face 'matrix-client-metadata))
|
||||
(defun ement-room--format-user (user)
|
||||
"Format `ement-user' USER for current buffer's room."
|
||||
(propertize (or (gethash ement-room (ement-user-room-display-names user))
|
||||
(puthash ement-room (ement-room--user-display-name user ement-room)
|
||||
(ement-user-room-display-names user)))
|
||||
'face 'ement-room-user))
|
||||
|
||||
(defun ement-room--user-display-name (user room)
|
||||
"Return the displayname for USER in ROOM."
|
||||
;; SPEC: <https://matrix.org/docs/spec/client_server/r0.6.1#calculating-the-display-name-for-a-user>.
|
||||
(if-let ((member-state-event (cl-loop for event in (ement-room-state room)
|
||||
when (and (equal "m.room.member" (ement-event-type event))
|
||||
(equal user (ement-event-sender event)))
|
||||
return event)))
|
||||
(or (alist-get 'displayname (ement-event-content member-state-event))
|
||||
;; FIXME: Add step 3 of the spec. For now we skip to step 4.
|
||||
;; No displayname given: use raw user ID.
|
||||
(ement-user-id user))
|
||||
;; No membership state event: use pre-calculated displayname or ID.
|
||||
(or (ement-user-displayname user)
|
||||
(ement-user-id user))))
|
||||
|
||||
(defun ement-room--insert-event (event)
|
||||
"Insert EVENT into current buffer."
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@
|
|||
;;;; Structs
|
||||
|
||||
(cl-defstruct ement-user
|
||||
id displayname account-data)
|
||||
id displayname account-data room-display-names)
|
||||
|
||||
(cl-defstruct ement-event
|
||||
id sender content origin-server-ts type unsigned)
|
||||
|
|
|
|||
15
ement.el
15
ement.el
|
|
@ -48,6 +48,7 @@
|
|||
(require 'ement-api)
|
||||
(require 'ement-macros)
|
||||
(require 'ement-structs)
|
||||
(require 'ement-room)
|
||||
|
||||
;;;; Variables
|
||||
|
||||
|
|
@ -100,6 +101,15 @@
|
|||
(debug-warn (car ement-sessions))
|
||||
(ement--sync (car ement-sessions)))
|
||||
|
||||
(defun ement-view-room (room)
|
||||
"Switch to a buffer showing ROOM."
|
||||
(interactive (list (ement-complete-room (car ement-sessions))))
|
||||
(let ((buffer-name (concat ement-room-buffer-prefix
|
||||
(setf (ement-room-display-name room)
|
||||
(ement--room-display-name room))
|
||||
ement-room-buffer-suffix)))
|
||||
(pop-to-buffer (ement-room--buffer room buffer-name))))
|
||||
|
||||
(defvar ement-progress-reporter nil
|
||||
"Used to report progress while processing sync events.")
|
||||
;; (defun ement-view-room (room)
|
||||
|
|
@ -187,6 +197,8 @@ SINCE may be such a token."
|
|||
(progress-reporter-update ement-progress-reporter (cl-incf ement-progress-value)))))
|
||||
|
||||
(defvar ement-users (make-hash-table :test #'equal)
|
||||
;; NOTE: When changing the ement-user struct, it's necessary to
|
||||
;; reset this table to clear old-type structs.
|
||||
"Hash table storing user structs keyed on user ID.")
|
||||
|
||||
(require 'map)
|
||||
|
|
@ -198,7 +210,8 @@ Adds sender to `ement-users' when necessary."
|
|||
('event_id id) ('origin_server_ts ts) ('sender sender-id) ('state_key _state-key))
|
||||
event)
|
||||
(sender (or (gethash sender-id ement-users)
|
||||
(puthash sender-id (make-ement-user :id sender-id) ement-users))))
|
||||
(puthash sender-id (make-ement-user :id sender-id :room-display-names (make-hash-table))
|
||||
ement-users))))
|
||||
(make-ement-event :id id :sender sender :content content :origin-server-ts ts :type type :unsigned unsigned)))
|
||||
|
||||
(defun ement--room-display-name (room)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue