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

- [gemini] removed link prefix for link labels that starts with an emoji; 

- [gemini] removed splitting of long link labels;
- fixed output stream of 'print-debug'.
This commit is contained in:
cage 2021-07-17 12:13:04 +02:00
parent 2015066c61
commit e5f93bd632
10 changed files with 97 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
etc/default-theme.conf
View File

@ -512,6 +512,12 @@ gemini.downloading.animation = "🕐 🕑 🕒 🕓 🕔
gemini.favicon = "🌍" gemini.favicon = "🌍"
#gemini.link.background = white
gemini.link.foreground = magenta
gemini.link.attribute = bold
gemini.link.scheme.gemini.prefix = "→ " gemini.link.scheme.gemini.prefix = "→ "
gemini.link.scheme.other.prefix = "➶ " gemini.link.scheme.other.prefix = "➶ "

7
etc/shared.conf
View File

@ -110,13 +110,6 @@ color-regexp = "[012][0-9]:[0123456][0-9]" cyan bold
# gemini colorization # gemini colorization
# gemini links
color-regexp = "→ .+" blue bold
# non gemini links
color-regexp = "➶ .+" magenta bold
# header level 1 # header level 1
color-regexp = "^🞂.*" white bold color-regexp = "^🞂.*" white bold

2
modules/rewrite-message-urls.lisp
View File

@ -77,7 +77,7 @@ So the whole list is like: '((\"foo\" \"bar\") (\"old\" \"new\") ...)")
(setf replaced-string (setf replaced-string
(rewriting-link-replace-mapping mapping replaced-string))) (rewriting-link-replace-mapping mapping replaced-string)))
(setf (line-oriented-window:normal-text row) (setf (line-oriented-window:normal-text row)
(message-window::colorize-lines replaced-string)) (tui:apply-coloring original-string replaced-string))
(setf (elt rows index) (setf (elt rows index)
(message-window:text->rendered-lines-rows window row)))))))) (message-window:text->rendered-lines-rows window row))))))))

25
src/gemini/client.lisp
View File

@ -183,16 +183,21 @@
(defun init-default-gemini-theme (viewport) (defun init-default-gemini-theme (viewport)
(setf *gemini-page-theme* (setf *gemini-page-theme*
(make-instance 'gemini-parser:gemini-page-theme (multiple-value-bind (link-bg link-fg link-attributes)
:viewport viewport (swconf:gemini-link-colors)
:link-prefix-other (swconf:gemini-link-prefix-to-other) (make-instance 'gemini-parser:gemini-page-theme
:link-prefix-gemini (swconf:gemini-link-prefix-to-gemini) :viewport viewport
:quote-prefix (swconf:gemini-quote-prefix) :link-prefix-other (swconf:gemini-link-prefix-to-other)
:h1-prefix (swconf:gemini-h1-prefix) :link-prefix-gemini (swconf:gemini-link-prefix-to-gemini)
:h2-prefix (swconf:gemini-h2-prefix) :link-bg link-bg
:h3-prefix (swconf:gemini-h3-prefix) :link-fg link-fg
:bullet-prefix (swconf:gemini-bullet-prefix) :link-attributes link-attributes
:preformatted-fg (swconf:gemini-preformatted-fg)))) :quote-prefix (swconf:gemini-quote-prefix)
:h1-prefix (swconf:gemini-h1-prefix)
:h2-prefix (swconf:gemini-h2-prefix)
:h3-prefix (swconf:gemini-h3-prefix)
:bullet-prefix (swconf:gemini-bullet-prefix)
:preformatted-fg (swconf:gemini-preformatted-fg)))))
(defclass gemini-file-response () (defclass gemini-file-response ()
((status-code ((status-code

44
src/gemini/gemini-parser.lisp
View File

@ -339,6 +339,18 @@
:initarg :link-prefix-other :initarg :link-prefix-other
:initform "^ " :initform "^ "
:accessor link-prefix-other) :accessor link-prefix-other)
(link-bg
:initarg :link-bg
:initform :red
:accessor link-bg)
(link-fg
:initarg :link-fg
:initform :yellow
:accessor link-fg)
(link-attributes
:initarg :link-attributes
:initform (tui:attribute-underline)
:accessor link-attributes)
(h1-prefix (h1-prefix
:initarg :h1-prefix :initarg :h1-prefix
:initform "+ " :initform "+ "
@ -448,8 +460,12 @@
(make-instance 'unordered-list-line (make-instance 'unordered-list-line
:lines (list text))) :lines (list text)))
(defclass link-line (with-lines) (defclass link-line ()
((link-name ((link-text
:initarg :link-text
:initform nil
:accessor link-text)
(link-name
:initarg :link-name :initarg :link-name
:initform nil :initform nil
:accessor link-name) :accessor link-name)
@ -458,9 +474,9 @@
:initform nil :initform nil
:accessor link-value))) :accessor link-value)))
(defun make-link-line (text link-name link-value) (defun make-link-line (link-text link-name link-value)
(make-instance 'link-line (make-instance 'link-line
:lines (list text) :link-text link-text
:link-name link-name :link-name link-name
:link-value link-value)) :link-value link-value))
@ -491,11 +507,21 @@
(trim text) (trim text)
text))) text)))
(linkify (link-name link-value) (linkify (link-name link-value)
(if (gemini-link-iri-p link-value) (let ((raw-link-text (if (gemini-link-iri-p link-value)
(if (text-utils:starting-emoji link-name) (if (text-utils:starting-emoji link-name)
(format nil "~a~%" link-name) (format nil "~a" link-name)
(format nil "~a~a~%" (link-prefix-gemini theme) link-name)) (format nil
(format nil "~a~a~%" (link-prefix-other theme) link-name))) "~a~a"
(link-prefix-gemini theme)
link-name))
(format nil
"~a~a"
(link-prefix-other theme)
link-name))))
(tui:make-tui-string raw-link-text
:attributes (link-attributes theme)
:fgcolor (link-fg theme)
:bgcolor (link-bg theme))))
(fit-quote-lines (line win-width) (fit-quote-lines (line win-width)
(let* ((words (split-words line)) (let* ((words (split-words line))
(quote-prefix (quote-prefix theme)) (quote-prefix (quote-prefix theme))

1
src/gemini/package.lisp
View File

@ -84,6 +84,7 @@
:level :level
:unordered-list-line :unordered-list-line
:link-line :link-line
:link-text
:sexp->text-rows :sexp->text-rows
:sexp->text :sexp->text
:parse-gemini-response-header :parse-gemini-response-header

7
src/message-window.lisp
View File

@ -370,9 +370,10 @@
(defmethod text->rendered-lines-rows (window (text complex-string)) (defmethod text->rendered-lines-rows (window (text complex-string))
text) text)
(defgeneric collect-lines-from-ir (object window)) (defgeneric collect-lines-from-ir (object window &key &allow-other-keys))
(defmethod collect-lines-from-ir ((object gemini-parser:with-lines) (window message-window)) (defmethod collect-lines-from-ir ((object gemini-parser:with-lines) (window message-window)
&key &allow-other-keys)
(let ((colorized-lines (colorize-lines (%fit-lines window (gemini-parser:lines object))))) (let ((colorized-lines (colorize-lines (%fit-lines window (gemini-parser:lines object)))))
(loop for i in colorized-lines (loop for i in colorized-lines
collect collect
@ -395,7 +396,7 @@
(collect-lines-from-ir text window)) (collect-lines-from-ir text window))
(defmethod text->rendered-lines-rows (window (text gemini-parser:link-line)) (defmethod text->rendered-lines-rows (window (text gemini-parser:link-line))
(let ((res (collect-lines-from-ir text window))) (let ((res (make-instance 'line :normal-text (gemini-parser:link-text text))))
(row-add-original-object res text) (row-add-original-object res text)
res)) ; even if row-add-original-object returns the modified line explicit returns for clarity res)) ; even if row-add-original-object returns the modified line explicit returns for clarity

1
src/package.lisp
View File

@ -1116,6 +1116,7 @@
:gemini-default-favicon :gemini-default-favicon
:directory-symbol :directory-symbol
:gemini-fetch-favicon-p :gemini-fetch-favicon-p
:gemini-link-colors
:gemini-link-prefix-to-gemini :gemini-link-prefix-to-gemini
:gemini-link-prefix-to-other :gemini-link-prefix-to-other
:gemini-quote-prefix :gemini-quote-prefix

14
src/software-configuration.lisp
View File

@ -588,6 +588,20 @@
+key-favicon+))) +key-favicon+)))
(db-utils:db-not-nil-p fetchp))) (db-utils:db-not-nil-p fetchp)))
(defun gemini-link-colors ()
(values (access:accesses *software-configuration*
+key-gemini+
+key-link+
+key-background+)
(access:accesses *software-configuration*
+key-gemini+
+key-link+
+key-foreground+)
(tui-utils:text->tui-attribute (access:accesses *software-configuration*
+key-gemini+
+key-link+
+key-attribute+))))
(defun gemini-link-prefix (scheme) (defun gemini-link-prefix (scheme)
(access-non-null-conf-value *software-configuration* (access-non-null-conf-value *software-configuration*
+key-gemini+ +key-gemini+

40
src/tui-utils.lisp
View File

@ -391,25 +391,25 @@ latter has a length equals to `total-size'"))
(last-char-bg (bgcolor last-char-from)) (last-char-bg (bgcolor last-char-from))
(last-char-attr (attributes last-char-from))) (last-char-attr (attributes last-char-from)))
(with-accessors ((complex-char-array-to complex-char-array)) res (with-accessors ((complex-char-array-to complex-char-array)) res
(loop (loop
for from-char across complex-char-array-from for from-char across complex-char-array-from
for to-char across complex-char-array-to for to-char across complex-char-array-to
do do
(setf (attributes to-char) (setf (attributes to-char)
(attributes from-char)) (attributes from-char))
(setf (fgcolor to-char) (setf (fgcolor to-char)
(fgcolor from-char)) (fgcolor from-char))
(setf (bgcolor to-char) (setf (bgcolor to-char)
(bgcolor from-char))) (bgcolor from-char)))
(when (> length-diff 0) (when (> length-diff 0)
(loop for i from length-diff below (length to) do (loop for i from length-diff below (length to) do
(let ((char (elt complex-char-array-to i))) (let ((char (elt complex-char-array-to i)))
(setf (attributes char) (setf (attributes char)
last-char-attr) last-char-attr)
(setf (fgcolor char) (setf (fgcolor char)
last-char-fg) last-char-fg)
(setf (bgcolor char) (setf (bgcolor char)
last-char-bg)))) last-char-bg))))
res)))) res))))
(defmethod remove-corrupting-utf8-chars ((object complex-string)) (defmethod remove-corrupting-utf8-chars ((object complex-string))
@ -440,7 +440,7 @@ latter has a length equals to `total-size'"))
(defmethod print-debug ((object complex-string) &optional (stream *standard-output*)) (defmethod print-debug ((object complex-string) &optional (stream *standard-output*))
(print-unreadable-object (object stream :type t :identity nil) (print-unreadable-object (object stream :type t :identity nil)
(loop for i across (complex-char-array object) do (loop for i across (complex-char-array object) do
(print-debug i)))) (print-debug i stream))))
(defun standard-error-notify-life () (defun standard-error-notify-life ()
(* (swconf:config-notification-life) 5)) (* (swconf:config-notification-life) 5))