hiro/ement.el
1
0
Fork 0
mirror of https://github.com/vale981/ement.el synced 2025-03-05 09:21:37 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Tidy: Move --format-user and --prism-color into -lib

Browse source
This commit is contained in:
Adam Porter 2022-05-30 06:13:50 -05:00
parent 41318e2969
commit 306c1ecfb0
3 changed files with 73 additions and 69 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

70
ement-lib.el
View file

@ -38,6 +38,7 @@
(require 'cl-lib) (require 'cl-lib)
(require 'color)
(require 'map) (require 'map)
(require 'xml) (require 'xml)
@ -54,6 +55,9 @@
(defvar ement-room-buffer-name-prefix) (defvar ement-room-buffer-name-prefix)
(defvar ement-room-buffer-name-suffix) (defvar ement-room-buffer-name-suffix)
(defvar ement-room-prism)
(defvar ement-room-prism-color-adjustment)
(defvar ement-room-prism-minimum-contrast)
;;;; Functions ;;;; Functions
@ -210,7 +214,7 @@ members, show in a new buffer; otherwise show in echo area."
(with-current-buffer (get-buffer-create (format "*Ement room description: %s*" (or display-name canonical-alias room-id))) (with-current-buffer (get-buffer-create (format "*Ement room description: %s*" (or display-name canonical-alias room-id)))
(erase-buffer) (erase-buffer)
(let ((members (cl-sort (cl-loop for user being the hash-values of members (let ((members (cl-sort (cl-loop for user being the hash-values of members
collect (format "%s <%s>" (ement-room--format-user user room session) collect (format "%s <%s>" (ement--format-user user room session)
(id (ement-user-id user)))) (id (ement-user-id user))))
(lambda (a b) (string-collate-lessp a b nil t))))) (lambda (a b) (string-collate-lessp a b nil t)))))
(save-excursion (save-excursion
@ -401,6 +405,70 @@ Also handle the echoed-back event."
;; These functions aren't expected to be called by code in other packages (but if that ;; These functions aren't expected to be called by code in other packages (but if that
;; were necessary, they could be renamed accordingly). ;; were necessary, they could be renamed accordingly).
(cl-defun ement--prism-color (string &key (contrast-with (face-background 'default)))
"Return a computed color for STRING.
Useful for user messages, generated room avatars, etc."
;; TODO: Use this instead of `ement-room--user-color'. (Same algorithm ,just takes a
;; 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)))))
(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.
(ratio (/ id-hash (float most-positive-fixnum)))
(color-num (round (* (* 255 255 255) ratio)))
(color-rgb (list (/ (float (logand color-num 255)) 255)
(/ (float (lsh (logand color-num 65280) -8)) 255)
(/ (float (lsh (logand color-num 16711680) -16)) 255)))
(contrast-with-rgb (color-name-to-rgb contrast-with)))
(when (< (contrast-ratio color-rgb contrast-with-rgb) ement-room-prism-minimum-contrast)
(setf color-rgb (increase-contrast color-rgb contrast-with-rgb ement-room-prism-minimum-contrast
contrast-with-rgb)))
(apply #'color-rgb-to-hex (append color-rgb (list 2))))))
(cl-defun ement--format-user (user &optional (room ement-room) (session ement-session))
"Format `ement-user' USER for ROOM on SESSION.
ROOM defaults to the value of `ement-room'."
(let ((face (cond ((equal (ement-user-id (ement-session-user session))
(ement-user-id user))
'ement-room-self)
(ement-room-prism
`(:inherit ement-room-user :foreground ,(or (ement-user-color user)
(setf (ement-user-color user)
(ement--prism-color user)))))
(t 'ement-room-user))))
;; FIXME: If a membership state event has not yet been received, this
;; sets the display name in the room to the user ID, and that prevents
;; the display name from being used if the state event arrives later.
(propertize (ement--user-displayname-in room user)
'face face
'help-echo (ement-user-id user))))
(cl-defun ement--format-body-mentions (cl-defun ement--format-body-mentions
(body room &key (template "<a href=\"https://matrix.to/#/%s\">%s</a>")) (body room &key (template "<a href=\"https://matrix.to/#/%s\">%s</a>"))
"Return string for BODY with mentions in ROOM linkified with TEMPLATE." "Return string for BODY with mentions in ROOM linkified with TEMPLATE."

70
ement-room.el
View file

@ -800,7 +800,7 @@ BODY is wrapped in a lambda form that binds `event', `room', and
(ement-room-define-event-formatter ?S (ement-room-define-event-formatter ?S
"Sender display name." "Sender display name."
(ignore session) (ignore session)
(pcase-let ((sender (ement-room--format-user (ement-event-sender event) room)) (pcase-let ((sender (ement--format-user (ement-event-sender event) room))
((cl-struct ement-room (local (map buffer))) room)) ((cl-struct ement-room (local (map buffer))) room))
;; NOTE: When called from an `ement-notify' function, ROOM may have no buffer. In ;; NOTE: When called from an `ement-notify' function, ROOM may have no buffer. In
;; that case, just use the current buffer (which should be a temp buffer used to ;; that case, just use the current buffer (which should be a temp buffer used to
@ -821,7 +821,7 @@ BODY is wrapped in a lambda form that binds `event', `room', and
'help-echo (concat sender " ")))))) 'help-echo (concat sender " "))))))
;; NOTE: I'd like to add a help-echo function to display the sender ID, but the Emacs ;; NOTE: I'd like to add a help-echo function to display the sender ID, but the Emacs
;; manual says that there is currently no way to make text in the margins mouse-sensitive. ;; manual says that there is currently no way to make text in the margins mouse-sensitive.
;; So `ement-room--format-user' returns a string propertized with `help-echo' as a string. ;; So `ement--format-user' returns a string propertized with `help-echo' as a string.
(concat sender "​"))) (concat sender "​")))
(ement-room-define-event-formatter ?r (ement-room-define-event-formatter ?r
@ -2864,7 +2864,7 @@ seconds."
((pred ement-event-p) ((pred ement-event-p)
(insert "" (ement-room--format-event thing ement-room ement-session))) (insert "" (ement-room--format-event thing ement-room ement-session)))
((pred ement-user-p) ((pred ement-user-p)
(insert (propertize (ement-room--format-user thing) (insert (propertize (ement--format-user thing)
'display ement-room-username-display-property))) 'display ement-room-username-display-property)))
(`(ts ,(and (pred numberp) ts)) ;; Insert a date header. (`(ts ,(and (pred numberp) ts)) ;; Insert a date header.
(insert (insert
@ -3157,24 +3157,6 @@ HTML is rendered to Emacs text using `shr-insert-document'."
(libxml-parse-html-region (point-min) (point-max)))))) (libxml-parse-html-region (point-min) (point-max))))))
(string-trim (buffer-substring (point) (point-max))))) (string-trim (buffer-substring (point) (point-max)))))
(cl-defun ement-room--format-user (user &optional (room ement-room) (session ement-session))
"Format `ement-user' USER for ROOM on SESSION.
ROOM defaults to the value of `ement-room'."
(let ((face (cond ((equal (ement-user-id (ement-session-user session))
(ement-user-id user))
'ement-room-self)
(ement-room-prism
`(:inherit ement-room-user :foreground ,(or (ement-user-color user)
(setf (ement-user-color user)
(ement-room--user-color user)))))
(t 'ement-room-user))))
;; FIXME: If a membership state event has not yet been received, this
;; sets the display name in the room to the user ID, and that prevents
;; the display name from being used if the state event arrives later.
(propertize (ement--user-displayname-in room user)
'face face
'help-echo (ement-user-id user))))
(cl-defun ement-room--event-mentions-user-p (event user &optional (room ement-room)) (cl-defun ement-room--event-mentions-user-p (event user &optional (room ement-room))
"Return non-nil if EVENT in ROOM mentions USER." "Return non-nil if EVENT in ROOM mentions USER."
(pcase-let* (((cl-struct ement-event content) event) (pcase-let* (((cl-struct ement-event content) event)
@ -3264,52 +3246,6 @@ ROOM defaults to the value of `ement-room'."
(color-name-to-rgb (face-foreground 'default))))) (color-name-to-rgb (face-foreground 'default)))))
(apply #'color-rgb-to-hex (append color-rgb (list 2)))))) (apply #'color-rgb-to-hex (append color-rgb (list 2))))))
(cl-defun ement-prism-color (string &key (contrast-with (face-background 'default)))
"Return a computed color for STRING.
Useful for user messages, generated room avatars, etc."
;; TODO: Use this instead of `ement-room--user-color'. (Same algorithm ,just takes a
;; 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)))))
(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.
(ratio (/ id-hash (float most-positive-fixnum)))
(color-num (round (* (* 255 255 255) ratio)))
(color-rgb (list (/ (float (logand color-num 255)) 255)
(/ (float (lsh (logand color-num 65280) -8)) 255)
(/ (float (lsh (logand color-num 16711680) -16)) 255)))
(contrast-with-rgb (color-name-to-rgb contrast-with)))
(when (< (contrast-ratio color-rgb contrast-with-rgb) ement-room-prism-minimum-contrast)
(setf color-rgb (increase-contrast color-rgb contrast-with-rgb ement-room-prism-minimum-contrast
contrast-with-rgb)))
(apply #'color-rgb-to-hex (append color-rgb (list 2))))))
;;;;; Compose buffer ;;;;; Compose buffer
;; Compose messages in a separate buffer, like `org-edit-special'. ;; Compose messages in a separate buffer, like `org-edit-special'.

2
ement-taxy.el
View file

@ -250,7 +250,7 @@
;; Room has no avatar: make one. ;; Room has no avatar: make one.
(let* ((string (or display-name (ement--room-display-name room))) (let* ((string (or display-name (ement--room-display-name room)))
(ement-room-prism-minimum-contrast 1) (ement-room-prism-minimum-contrast 1)
(color (ement-prism-color string :contrast-with "white"))) (color (ement--prism-color string :contrast-with "white")))
(when (string-match (rx bos (or "#" "!" "@")) string) (when (string-match (rx bos (or "#" "!" "@")) string)
(setf string (substring string 1))) (setf string (substring string 1)))
(propertize " " 'display (svg-lib-tag (substring string 0 1) nil (propertize " " 'display (svg-lib-tag (substring string 0 1) nil