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

- [GUI] ensured the rendering of the gemtext respects the directives in the configuration file (font, color, justification, etc).

This commit is contained in:
cage 2023-02-26 15:03:03 +01:00
parent 744c85331e
commit cc633fc29c
4 changed files with 178 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
src/gui/client/client-configuration.lisp
View File

@ -29,7 +29,8 @@
weight
slant
underline
preformatted-text)
preformatted-text
justification)
(defun load-config-file (&optional (virtual-filepath +client-conf-filename+)
(perform-missing-value-check nil))
@ -183,11 +184,28 @@
swconf:+key-bullet+
swconf:+key-prefix+))
(defun conf-justification (key)
(let ((conf-value (access:accesses *client-configuration*
swconf:+key-gemini+
key
+key-justification+)))
(or conf-value
:left)))
(swconf:gen-simple-access (gemini-fragment-as-regex-p
:transform-value-fn (lambda (a) (not (swconf:false-value-p a))))
swconf:+key-experimental+
swconf:+key-gemini+
swconf:+key-iri+
swconf:+key-fragment+
swconf:+key-regex+)
(defmacro gen-conf-justification (prefix key)
(let* ((no-key (cl-ppcre:regex-replace-all "key-" (string-downcase (symbol-name key)) ""))
(no-plus (text-utils:trim-blanks no-key '(#\+))))
`(defun ,(misc:format-fn-symbol t "~a-~a-justification" prefix no-plus) ()
(conf-justification ,key))))
(gen-conf-justification gemini swconf:+key-link+)
(gen-conf-justification gemini swconf:+key-quote+)
(gen-conf-justification gemini swconf:+key-h1+)
(gen-conf-justification gemini swconf:+key-h2+)
(gen-conf-justification gemini swconf:+key-h3+)
(gen-conf-justification gemini swconf:+key-preformatted-text+)

3
src/gui/client/gui-goodies.lisp
View File

@ -22,6 +22,9 @@
(defmethod parse-color ((object string))
(nodgui.utils:rgb->tk (cl-colors2:as-rgb object)))
(defmethod parse-color ((object number))
(nodgui.utils:rgb->tk (cl-colors2:as-rgb object)))
(defun make-font (font-name font-size font-weight font-slant underline)
(gui:font-create (nodgui.utils:create-name)
:family font-name

213
src/gui/client/main-window.lisp
View File

@ -197,77 +197,150 @@
(labels ((push-prefixed (prefix ir)
(let ((raw-line (format nil "~a~a" prefix (ir-line ir))))
(vector-push-extend raw-line ir-rendered-lines)))
(key->font (key)
(ecase key
((:vertical-space :pre-end :text :li)
nil)
(:as-is
(gui-conf:gemini-preformatted-text-font-configuration))
(:h1
(gui-conf:gemini-h1-font-configuration))
(:h2
(gui-conf:gemini-h2-font-configuration))
(:h3
(gui-conf:gemini-h3-font-configuration))
(:quote
(gui-conf:gemini-quote-font-configuration))
(:pre
(gui-conf:gemini-preformatted-text-font-configuration))
(:a
(gui-conf:gemini-link-font-configuration))))
(key->colors (key)
(ecase key
((:vertical-space :pre-end :text :li)
nil)
(:as-is
(gui-conf:gemini-preformatted-text-colors))
(:h1
(gui-conf:gemini-h1-colors))
(:h2
(gui-conf:gemini-h2-colors))
(:h3
(gui-conf:gemini-h3-colors))
(:quote
(gui-conf:gemini-quote-colors))
(:pre
(gui-conf:gemini-preformatted-text-colors))
(:a
(gui-conf:gemini-link-colors))))
(key->justification (key)
(ecase key
((:vertical-space :text :pre-end :li :a)
nil)
(:as-is
(gui-conf:gemini-preformatted-text-justification))
(:h1
(gui-conf:gemini-h1-justification))
(:h2
(gui-conf:gemini-h2-justification))
(:h3
(gui-conf:gemini-h3-justification))
(:quote
(gui-conf:gemini-quote-justification))
(:pre
(gui-conf:gemini-preformatted-text-justification))))
(linkify (line)
(let* ((link-value (ir-href line))
(link-name (or (ir-line line)
link-value))
(prefix-gemini (gui-conf:gemini-link-prefix-to-gemini))
(prefix-www (gui-conf:gemini-link-prefix-to-http))
(prefix-other (gui-conf:gemini-link-prefix-to-other))
(link-text (if (text-utils:starting-emoji link-name)
(format nil
"~a~a"
(trim-blanks prefix-other)
link-name)
(cond
((gemini-parser::gemini-link-iri-p link-value)
(format nil "~a~a" prefix-gemini link-name))
((html-utils::http-link-iri-p link-value)
(format nil "~a~a" prefix-www link-name))
(t
(format nil "~a~a" prefix-other link-name))))))
(vector-push-extend link-text ir-rendered-lines)))
(render-line (text)
(gui:append-line gemtext-widget text)))
(let ((link-font (gui-conf:gemini-link-font-configuration)))
(multiple-value-bind (link-bg link-fg)
(gui-conf:gemini-link-colors)
(loop for line in lines do
(vector-push-extend line ir-lines)
(let ((type (ir-type line)))
(ecase (format-keyword type)
(:vertical-space
(vector-push-extend (format nil "") ir-rendered-lines)
(render-line (a:last-elt ir-rendered-lines)))
(:as-is
(vector-push-extend (ir-line line) ir-rendered-lines)
(render-line (a:last-elt ir-rendered-lines)))
(:text
(vector-push-extend (ir-line line) ir-rendered-lines)
(render-line (a:last-elt ir-rendered-lines)))
(:h1
(push-prefixed (gui-conf:gemini-h1-prefix) line)
(render-line (a:last-elt ir-rendered-lines)))
(:h2
(push-prefixed (gui-conf:gemini-h1-prefix) line)
(render-line (a:last-elt ir-rendered-lines)))
(:h3
(push-prefixed (gui-conf:gemini-h1-prefix) line)
(render-line (a:last-elt ir-rendered-lines)))
(:li
(push-prefixed (gui-conf:gemini-bullet-prefix) line)
(render-line (a:last-elt ir-rendered-lines)))
(:quote
(push-prefixed (gui-conf:gemini-quote-prefix) line)
(render-line (a:last-elt ir-rendered-lines)))
(:pre
(vector-push-extend (format nil "") ir-rendered-lines)
(render-line (a:last-elt ir-rendered-lines)))
(:pre-end
(vector-push-extend (format nil "") ir-rendered-lines)
(render-line (a:last-elt ir-rendered-lines)))
(:a
(linkify line)
(gui:append-text gemtext-widget (a:last-elt ir-rendered-lines))
(gui:move-cursor-to-last-line gemtext-widget)
(gui:make-link-button gemtext-widget
(gui:raw-coordinates gemtext-widget)
(gui:make-indices-end)
link-font
link-fg
link-bg
(lambda () t))
(gui:append-line gemtext-widget ""))))))))))
(multiple-value-bind (link-bg link-fg)
(gui-conf:gemini-link-colors)
(let* ((link-font (gui-conf:gemini-link-font-configuration))
(link-value (ir-href line))
(link-name (or (ir-line line)
link-value))
(prefix-gemini (gui-conf:gemini-link-prefix-to-gemini))
(prefix-www (gui-conf:gemini-link-prefix-to-http))
(prefix-other (gui-conf:gemini-link-prefix-to-other))
(link-text (if (text-utils:starting-emoji link-name)
(format nil
"~a~a"
(trim-blanks prefix-other)
link-name)
(cond
((gemini-parser::gemini-link-iri-p link-value)
(format nil "~a~a" prefix-gemini link-name))
((html-utils::http-link-iri-p link-value)
(format nil "~a~a" prefix-www link-name))
(t
(format nil "~a~a" prefix-other link-name))))))
(vector-push-extend link-text ir-rendered-lines)
(let ((new-text-line-start (gui:raw-coordinates gemtext-widget)))
(gui:append-text gemtext-widget (a:last-elt ir-rendered-lines))
(gui:make-link-button gemtext-widget
new-text-line-start
(gui:make-indices-end)
link-font
link-fg
link-bg
(lambda () t))
(gui:append-line gemtext-widget "")))))
(render-line (key text)
(let ((font (key->font key))
(justification (key->justification key))
(new-text-line-start (gui:raw-coordinates gemtext-widget)))
(gui:append-text gemtext-widget text)
(if font
(multiple-value-bind (background foreground)
(key->colors key)
(let ((tag (gui:tag-create gemtext-widget
(gui::create-tag-name)
new-text-line-start
(gui:make-indices-end))))
(gui:tag-configure gemtext-widget
tag
:font font
:foreground foreground
:background background
:justify justification)
(gui:append-line gemtext-widget "")
tag))
(progn
(gui:append-line gemtext-widget "")
nil)))))
(loop for line in lines do
(vector-push-extend line ir-lines)
(let ((type (ir-type line)))
(ecase (format-keyword type)
(:vertical-space
(vector-push-extend (format nil "") ir-rendered-lines)
(render-line :vertical-space (a:last-elt ir-rendered-lines)))
(:as-is
(vector-push-extend (ir-line line) ir-rendered-lines)
(render-line :as-is (a:last-elt ir-rendered-lines)))
(:text
(vector-push-extend (ir-line line) ir-rendered-lines)
(render-line :text (a:last-elt ir-rendered-lines)))
(:h1
(push-prefixed (gui-conf:gemini-h1-prefix) line)
(render-line :h1 (a:last-elt ir-rendered-lines)))
(:h2
(push-prefixed (gui-conf:gemini-h1-prefix) line)
(render-line :h2 (a:last-elt ir-rendered-lines)))
(:h3
(push-prefixed (gui-conf:gemini-h1-prefix) line)
(render-line :h3 (a:last-elt ir-rendered-lines)))
(:li
(push-prefixed (gui-conf:gemini-bullet-prefix) line)
(render-line :li (a:last-elt ir-rendered-lines)))
(:quote
(push-prefixed (gui-conf:gemini-quote-prefix) line)
(render-line :quote (a:last-elt ir-rendered-lines)))
(:pre
(vector-push-extend (format nil "") ir-rendered-lines)
(render-line :pre (a:last-elt ir-rendered-lines)))
(:pre-end
(vector-push-extend (format nil "") ir-rendered-lines)
(render-line :pre-end (a:last-elt ir-rendered-lines)))
(:a
(linkify line))))))))
(defun displace-gemini-response (response)
(values (getf response :status)

7
src/package.lisp
View File

@ -3255,7 +3255,12 @@
:gemini-h1-colors
:gemini-h2-colors
:gemini-h3-colors
:gemini-preformatted-text-colors))
:gemini-preformatted-text-colors
:gemini-quote-justification
:gemini-h1-justification
:gemini-h2-justification
:gemini-h3-justification
:gemini-preformatted-text-justification))
(defpackage :client-events
(:use