cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- improved rendering for statuses that contains tag: <li> and <blockquote>.

This commit is contained in:
cage 2023-10-01 18:12:00 +02:00
parent 2b906efa3c
commit 3ec57b9040
8 changed files with 62 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
etc/default-theme.conf
View File

@ -491,6 +491,11 @@ message-window.visibility.private = "🔒"
message-window.visibility.direct = "📧"
message-window.quote.prefix = "🞂 "
message-window.bullet.prefix = "• "
# this is the window that allow to browse the attachments of a message
open-attach-window.background = black

4
src/chats-list-window.lisp
View File

@ -66,7 +66,9 @@
(_ "~a ~a wrote:~%~a ~a~2%")
formatted-created-date
username
(html-utils:html->text content)
(html-utils:html->text content
:quote-prefix (swconf:message-window-quote-prefix)
:list-item-prefix (swconf:message-window-bullet-prefix))
attachment-type)))))))
(defmethod resync-rows-db ((object chats-list-window)

19
src/html-utils.lisp
View File

@ -23,8 +23,12 @@
(define-constant +tag-paragraph+ "p" :test #'string=)
(define-constant +tag-list-item+ "li" :test #'string=)
(define-constant +tag-div+ "div" :test #'string=)
(define-constant +tag-blockquote+ "blockquote" :test #'string=)
(define-constant +attribute-url+ "href" :test #'string=)
(define-constant +http-scheme+ "http" :test #'string=)
@ -96,7 +100,11 @@
(defun node->link (node)
(html-utils:attribute-value (html-utils:find-attribute :href node)))
(defun html->text (html &key (add-link-footnotes t) (body-footnotes-separator ""))
(defparameter *prefix-text-line* "")
(defun html->text (html &key
(add-link-footnotes t) (body-footnotes-separator "")
(quote-prefix "> ") (list-item-prefix "* "))
"Transform html to text, note that if `add-link-footnotes` is non nil footnotes that marks html link in the text are added aftere the body of the message
This function uses a library that transform html5 text into s-expressions um the form
@ -122,7 +130,7 @@ Some convenience functions are provided to works with these structures.
(when node
(cond
((stringp node)
(princ node body-stream))
(princ (strcat *prefix-text-line* node) body-stream))
((consp (car node))
(descend (car node)))
((tag= +tag-link+ node)
@ -148,6 +156,13 @@ Some convenience functions are provided to works with these structures.
(format body-stream "~%")
(descend-children node)
(format body-stream "~%"))
((tag= +tag-list-item+ node)
(format body-stream list-item-prefix)
(descend-children node)
(format body-stream "~%"))
((tag= +tag-blockquote+ node)
(let ((*prefix-text-line* quote-prefix))
(descend-children node)))
(t
(descend-children node))))))
(descend root)

8
src/message-rendering-utils.lisp
View File

@ -119,7 +119,9 @@
(defun maybe-decrypt-message (message-row message-text &key (notify-cant-decrypt nil))
(let* ((username (db:row-message-username message-row))
(html-stripped (html-utils:html->text (db:row-message-content message-row)
:add-link-footnotes nil))
:add-link-footnotes nil
:quote-prefix (swconf:message-window-quote-prefix)
:list-item-prefix (swconf:message-window-bullet-prefix)))
(mention (find-first-mention-in-message html-stripped))
(reply-p (db:row-message-reply-to-id message-row))
(crypto-key (cond
@ -197,7 +199,9 @@
(defgeneric message-original->text-body (object &key &allow-other-keys))
(defmethod message-original->text-body ((object string) &key &allow-other-keys)
(let* ((raw-body (html-utils:html->text object)))
(let* ((raw-body (html-utils:html->text object
:quote-prefix (swconf:message-window-quote-prefix)
:list-item-prefix (swconf:message-window-bullet-prefix))))
(emoji-shortcodes:emojify raw-body)))
(defun prepend-crypto-marker (decrypted-text)

22
src/package.lisp
View File

@ -773,16 +773,16 @@
:ipv6-address-p
:iri-to-parent-path))
(defpackage :link-header-parser
(:use
:cl
:alexandria
:esrap
:cl-ppcre
:text-utils)
(:export
:parse-header
:extract-pagination-current-max-id))
;; (defpackage :link-header-parser
;; (:use
;; :cl
;; :alexandria
;; :esrap
;; :cl-ppcre
;; :text-utils)
;; (:export
;; :parse-header
;; :extract-pagination-current-max-id))
(defpackage :tour-mode-parser
(:use
@ -1466,6 +1466,8 @@
:message-window-line-mark-values
:message-windows-visibility-marks
:message-window-attachments-header
:message-window-quote-prefix
:message-window-bullet-prefix
:form-style
:background
:foreground

5
src/program-events.lisp
View File

@ -1877,7 +1877,10 @@
(defmethod process-event ((object show-announcements-event))
"Shows a window with all announcements"
(when-let* ((all-announcements (api-client:get-announcements))
(all-texts (mapcar #'html-utils:html->text
(all-texts (mapcar (lambda (a)
(html-utils:html->text a
:quote-prefix (swconf:message-window-quote-prefix)
:list-item-prefix (swconf:message-window-bullet-prefix)))
(mapcar #'tooter:content all-announcements)))
(lines (reduce #'append
(mapcar #'text-utils:split-lines all-texts)))

12
src/software-configuration.lisp
View File

@ -1433,6 +1433,18 @@
+key-mark+
+key-value+)))
(defun message-window-quote-prefix ()
(access-non-null-conf-value *software-configuration*
+key-message-window+
+key-quote+
+key-prefix+))
(defun message-window-bullet-prefix ()
(access-non-null-conf-value *software-configuration*
+key-message-window+
+key-bullet+
+key-prefix+))
(defun message-window-locked-account-mark ()
(locked/unlocked-account-mark-value +key-message-window+ t))

4
src/ui-goodies.lisp
View File

@ -965,7 +965,9 @@ It an existing file path is provided the command will refuse to run."
(let* ((row (mtree:data node))
(content (html-utils:html->text (db:row-message-content row)
:body-footnotes-separator
(format nil (_ "───── links ───── ~%"))))
(format nil (_ "───── links ───── ~%"))
:quote-prefix (swconf:message-window-quote-prefix)
:list-item-prefix (swconf:message-window-bullet-prefix)))
(author (format nil "~a (~a)"
(db:row-message-username row)
(db:row-message-user-display-name row)))