mirror of
https://codeberg.org/cage/tinmop/
synced 2025-02-01 04:26:47 +01:00
-[gemtext] added metadata to header lines;
- fixed processing of follow requests.
This commit is contained in:
cage
parent
15bbb49d5e
commit
a91ec4c7ae
@ -128,8 +128,8 @@
|
||||
requeste that are not be erased from the window (see the class
|
||||
row-oriented-widget)"
|
||||
(with-accessors ((all-accounts requests)) specials:*follow-requests-window*
|
||||
(let* ((accepted-usernames (line-oriented-window:map-rows #'normal-text
|
||||
specials:*follow-requests-window*))
|
||||
(let* ((accepted-usernames (line-oriented-window:map-rows specials:*follow-requests-window*
|
||||
#'normal-text))
|
||||
(accepted-accounts (remove-if-not (lambda (acc)
|
||||
(find-if (lambda (a)
|
||||
(string= a
|
||||
|
||||
@ -384,87 +384,109 @@
|
||||
:initarg :size
|
||||
:accessor size)))
|
||||
|
||||
(defclass header-line (with-group-id with-lines)
|
||||
((level
|
||||
:initform nil
|
||||
:initarg :level
|
||||
:accessor level)))
|
||||
|
||||
(defun make-header-line (text gid level)
|
||||
(make-instance 'header-line
|
||||
:lines (list text)
|
||||
:group-id gid
|
||||
:level level))
|
||||
|
||||
(defun sexp->text-rows (parsed-gemini theme)
|
||||
(labels ((header-prefix (prefix header)
|
||||
(strcat prefix header))
|
||||
(header-prefix-h1 (header)
|
||||
(header-prefix (h1-prefix theme) header))
|
||||
(header-prefix-h2 (header)
|
||||
(header-prefix (h2-prefix theme) header))
|
||||
(header-prefix-h3 (header)
|
||||
(header-prefix (h3-prefix theme) header))
|
||||
(underlineize (text underline-char)
|
||||
(let* ((size (length text))
|
||||
(underline (build-string size underline-char)))
|
||||
(format nil"~a~%~a~%" text underline)))
|
||||
(trim (a)
|
||||
(trim-blanks a))
|
||||
(text-value (node &key (trim t))
|
||||
(let ((text (first (html-utils:children node))))
|
||||
(if trim
|
||||
(trim text)
|
||||
text)))
|
||||
(linkify (link-name link-value)
|
||||
(if (gemini-link-iri-p link-value)
|
||||
(format nil "~a~a~%" (link-prefix-gemini theme) link-name)
|
||||
(format nil "~a~a~%" (link-prefix-other theme) link-name)))
|
||||
(fit-quote-lines (line win-width)
|
||||
(let* ((justified (flush-left-mono-text (split-words line)
|
||||
(- win-width
|
||||
(length (quote-prefix theme)))))
|
||||
(lines (mapcar (lambda (a) (strcat (quote-prefix theme) a))
|
||||
justified)))
|
||||
(make-quoted-lines (join-with-strings lines (format nil "~%")))))
|
||||
(pre-alt-text (node)
|
||||
(trim (html-utils:attribute-value (html-utils:find-attribute :alt node)))))
|
||||
(let ((win-width (message-window:viewport-width (viewport theme)))
|
||||
(pre-group-id -1)
|
||||
(pre-alt-text ""))
|
||||
(loop for node in parsed-gemini collect
|
||||
(cond
|
||||
((null node)
|
||||
(make-instance 'vertical-space)) ;(format nil "~%"))
|
||||
((html-utils:tag= :as-is node)
|
||||
(let* ((truncated-line (safe-subseq (text-value node) 0 (1- win-width)))
|
||||
(fg (preformatted-fg theme))
|
||||
(line (tui:make-tui-string (format nil "~a" truncated-line)
|
||||
:fgcolor fg)))
|
||||
(make-pre-line (list line) pre-group-id pre-alt-text)))
|
||||
((html-utils:tag= :text node)
|
||||
(format nil "~a~%" (text-value node)))
|
||||
((html-utils:tag= :h1 node)
|
||||
(underlineize (header-prefix-h1 (text-value node))
|
||||
+h1-underline+))
|
||||
((html-utils:tag= :h2 node)
|
||||
(underlineize (header-prefix-h2 (text-value node))
|
||||
+h2-underline+))
|
||||
((html-utils:tag= :h3 node)
|
||||
(underlineize (header-prefix-h3 (text-value node))
|
||||
+h3-underline+))
|
||||
((html-utils:tag= :li node)
|
||||
(format nil
|
||||
"~a ~a~%"
|
||||
(bullet-prefix theme)
|
||||
(text-value node)))
|
||||
((html-utils:tag= :quote node)
|
||||
(fit-quote-lines (text-value node :trim nil)
|
||||
win-width))
|
||||
((html-utils:tag= :pre node)
|
||||
(let ((current-alt-text (pre-alt-text node)))
|
||||
(incf pre-group-id)
|
||||
(setf pre-alt-text current-alt-text)
|
||||
(make-pre-start current-alt-text pre-group-id)))
|
||||
((html-utils:tag= :pre-end node)
|
||||
(make-pre-end))
|
||||
((html-utils:tag= :a node)
|
||||
(let ((link-name (text-value node :trim nil))
|
||||
(link-value (html-utils:attribute-value (html-utils:find-attribute :href
|
||||
node))))
|
||||
(if link-name
|
||||
(linkify link-name link-value)
|
||||
(linkify link-value link-value))))
|
||||
(t
|
||||
(break)))))))
|
||||
(let ((win-width (message-window:viewport-width (viewport theme)))
|
||||
(pre-group-id -1)
|
||||
(header-group-id -1)
|
||||
(pre-alt-text ""))
|
||||
(labels ((header-prefix (prefix header)
|
||||
(strcat prefix header))
|
||||
(header-prefix-h1 (header)
|
||||
(header-prefix (h1-prefix theme) header))
|
||||
(header-prefix-h2 (header)
|
||||
(header-prefix (h2-prefix theme) header))
|
||||
(header-prefix-h3 (header)
|
||||
(header-prefix (h3-prefix theme) header))
|
||||
(build-underline (text underline-char)
|
||||
(let* ((size (length text))
|
||||
(underline (build-string size underline-char)))
|
||||
underline))
|
||||
(make-header (level text underline-char)
|
||||
(let ((underline (build-underline text underline-char)))
|
||||
(incf header-group-id)
|
||||
(list (make-header-line text header-group-id level)
|
||||
(make-header-line underline header-group-id level))))
|
||||
(trim (a)
|
||||
(trim-blanks a))
|
||||
(text-value (node &key (trim t))
|
||||
(let ((text (first (html-utils:children node))))
|
||||
(if trim
|
||||
(trim text)
|
||||
text)))
|
||||
(linkify (link-name link-value)
|
||||
(if (gemini-link-iri-p link-value)
|
||||
(format nil "~a~a~%" (link-prefix-gemini theme) link-name)
|
||||
(format nil "~a~a~%" (link-prefix-other theme) link-name)))
|
||||
(fit-quote-lines (line win-width)
|
||||
(let* ((justified (flush-left-mono-text (split-words line)
|
||||
(- win-width
|
||||
(length (quote-prefix theme)))))
|
||||
(lines (mapcar (lambda (a) (strcat (quote-prefix theme) a))
|
||||
justified)))
|
||||
(make-quoted-lines (join-with-strings lines (format nil "~%")))))
|
||||
(pre-alt-text (node)
|
||||
(trim (html-utils:attribute-value (html-utils:find-attribute :alt node))))
|
||||
(build-rows ()
|
||||
(loop for node in parsed-gemini
|
||||
collect
|
||||
(cond
|
||||
((null node)
|
||||
(make-instance 'vertical-space)) ;(format nil "~%"))
|
||||
((html-utils:tag= :as-is node)
|
||||
(let* ((truncated-line (safe-subseq (text-value node) 0 (1- win-width)))
|
||||
(fg (preformatted-fg theme))
|
||||
(line (tui:make-tui-string (format nil "~a" truncated-line)
|
||||
:fgcolor fg)))
|
||||
(make-pre-line (list line) pre-group-id pre-alt-text)))
|
||||
((html-utils:tag= :text node)
|
||||
(format nil "~a~%" (text-value node)))
|
||||
((html-utils:tag= :h1 node)
|
||||
(make-header 1
|
||||
(header-prefix-h1 (text-value node))
|
||||
+h1-underline+))
|
||||
((html-utils:tag= :h2 node)
|
||||
(make-header 2
|
||||
(header-prefix-h2 (text-value node))
|
||||
+h2-underline+))
|
||||
((html-utils:tag= :h3 node)
|
||||
(make-header 3
|
||||
(header-prefix-h3 (text-value node))
|
||||
+h3-underline+))
|
||||
((html-utils:tag= :li node)
|
||||
(format nil
|
||||
"~a ~a~%"
|
||||
(bullet-prefix theme)
|
||||
(text-value node)))
|
||||
((html-utils:tag= :quote node)
|
||||
(fit-quote-lines (text-value node :trim nil)
|
||||
win-width))
|
||||
((html-utils:tag= :pre node)
|
||||
(let ((current-alt-text (pre-alt-text node)))
|
||||
(incf pre-group-id)
|
||||
(setf pre-alt-text current-alt-text)
|
||||
(make-pre-start current-alt-text pre-group-id)))
|
||||
((html-utils:tag= :pre-end node)
|
||||
(make-pre-end))
|
||||
((html-utils:tag= :a node)
|
||||
(let ((link-name (text-value node :trim nil))
|
||||
(link-value (html-utils:attribute-value (html-utils:find-attribute :href
|
||||
node))))
|
||||
(if link-name
|
||||
(linkify link-name link-value)
|
||||
(linkify link-value link-value))))))))
|
||||
(flatten (build-rows)))))
|
||||
|
||||
(defun sexp->text (parsed-gemini theme)
|
||||
(labels ((header-prefix (prefix header)
|
||||
|
||||
@ -64,6 +64,7 @@
|
||||
:h3-prefix
|
||||
:quote-prefix
|
||||
:bullet-prefix
|
||||
:with-lines
|
||||
:pre-start
|
||||
:value
|
||||
:pre-line
|
||||
@ -74,6 +75,8 @@
|
||||
:quoted-lines
|
||||
:lines
|
||||
:vertical-space
|
||||
:header-line
|
||||
:level
|
||||
:sexp->text-rows
|
||||
:sexp->text
|
||||
:parse-gemini-response-header
|
||||
|
||||
@ -149,6 +149,16 @@
|
||||
(defun row-get-original-object (line)
|
||||
(getf (fields line) :original-object))
|
||||
|
||||
(defun row-add-group-id (line group-id)
|
||||
(push group-id
|
||||
(fields line))
|
||||
(push :group-id
|
||||
(fields line))
|
||||
line)
|
||||
|
||||
(defun row-get-group-id (line)
|
||||
(getf (fields line) :group-id))
|
||||
|
||||
(defun make-render-vspace-row (&optional (original-object
|
||||
(make-instance 'gemini-parser:vertical-space)))
|
||||
(let ((res (make-instance 'line
|
||||
@ -277,13 +287,27 @@
|
||||
(defmethod text->rendered-lines-rows (window (text complex-string))
|
||||
text)
|
||||
|
||||
(defmethod text->rendered-lines-rows (window (text gemini-parser:quoted-lines))
|
||||
(let ((colorized-lines (colorize-lines (gemini-parser:lines text))))
|
||||
(defgeneric collect-lines-from-ir (object))
|
||||
|
||||
(defmethod collect-lines-from-ir ((object gemini-parser:with-lines))
|
||||
(let ((colorized-lines (colorize-lines (gemini-parser:lines object))))
|
||||
(loop for i in colorized-lines
|
||||
collect
|
||||
(make-instance 'line
|
||||
:normal-text i))))
|
||||
|
||||
(defmethod text->rendered-lines-rows (window (text gemini-parser:quoted-lines))
|
||||
(collect-lines-from-ir text))
|
||||
|
||||
(defmethod text->rendered-lines-rows (window (text gemini-parser:header-line))
|
||||
(let* ((group-id (gemini-parser:group-id text))
|
||||
(lines (collect-lines-from-ir text))
|
||||
(res (mapcar (lambda (a)
|
||||
(let ((line (row-add-original-object a text)))
|
||||
(row-add-group-id line group-id)))
|
||||
lines)))
|
||||
res))
|
||||
|
||||
(defmethod text->rendered-lines-rows (window (text string))
|
||||
(labels ((fit-lines (lines)
|
||||
(let ((res ()))
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user