cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-02-22 08:57:37 +01:00
Code Issues

- [gemini] started coloring preformatted block.

Browse Source
This commit is contained in:
cage 2021-04-05 12:01:30 +02:00
parent 9e3269576d
commit fac77297e8
10 changed files with 256 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
etc/default-theme.conf
View File

@ -491,6 +491,8 @@ gemini.h2.prefix = "🞐 "
gemini.h3.prefix = "🞎 " gemini.h3.prefix = "🞎 "
gemini.preformatted-text.foreground = #fed700
# this is the window that allow to browse the gemini streams # this is the window that allow to browse the gemini streams
open-gemini-stream-window.background = black open-gemini-stream-window.background = black

3
src/gemini/client.lisp
View File

@ -191,7 +191,8 @@
:h1-prefix (swconf:gemini-h1-prefix) :h1-prefix (swconf:gemini-h1-prefix)
:h2-prefix (swconf:gemini-h2-prefix) :h2-prefix (swconf:gemini-h2-prefix)
:h3-prefix (swconf:gemini-h3-prefix) :h3-prefix (swconf:gemini-h3-prefix)
:bullet-prefix (swconf:gemini-bullet-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

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

@ -91,11 +91,12 @@
(* (not cr-lf)) (* (not cr-lf))
cr-lf) cr-lf)
(:function (lambda (a) (:function (lambda (a)
(let ((saved-mode *raw-mode*)) (let ((saved-raw-mode *raw-mode*))
(setf *raw-mode* (not *raw-mode*)) (setf *raw-mode* (not *raw-mode*))
(when (not saved-mode) (if (not saved-raw-mode)
(list :pre (list :pre
(list (list :alt (coerce (second a) 'string))))))))) (list (list :alt (coerce (second a) 'string))))
(list :pre-end () ""))))))
(defrule link-prefix (and "=>" (defrule link-prefix (and "=>"
(* space)) (* space))
@ -103,7 +104,9 @@
(defrule text-line (and (+ (not cr-lf)) cr-lf) (defrule text-line (and (+ (not cr-lf)) cr-lf)
(:function (lambda (a) (:function (lambda (a)
(list :text (list (if *raw-mode*
:as-is
:text)
nil nil
(coerce (first a) 'string))))) (coerce (first a) 'string)))))
@ -304,17 +307,110 @@
:accessor h3-prefix) :accessor h3-prefix)
(quote-prefix (quote-prefix
:initarg :quote-prefix :initarg :quote-prefix
:initform +quote-line-prefix+ :initform +quote-prefix+
:accessor quote-prefix) :accessor quote-prefix)
(bullet-prefix (bullet-prefix
:initarg :bullet-prefix :initarg :bullet-prefix
:initform +bullet-line-prefix+ :initform "@ "
:accessor bullet-prefix) :accessor bullet-prefix)
(preformatted-fg
:initarg :preformatted-fg
:initform :red
:accessor preformatted-fg)
(viewport (viewport
:initarg :viewport :initarg :viewport
:initform nil :initform nil
:accessor viewport))) :accessor viewport)))
(defclass pre-start ()
((alt-text
:initform nil
:initarg :alt-text
:accessor alt-text)))
(defun make-pre-start (value)
(make-instance 'pre-start :alt-text value))
(defclass pre-end () ())
(defun make-pre-end ()
(make-instance 'pre-end))
(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)
(string-trim '(#\Newline #\Return) 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)
(join-with-strings (mapcar (lambda (a) (strcat (quote-prefix theme) a))
(flush-left-mono-text (split-words line)
(- win-width
(length (quote-prefix theme)))))
(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))))
(loop for node in parsed-gemini collect
(cond
((null node)
(format nil "~%"))
((html-utils:tag= :as-is node)
(let ((truncated-line (safe-subseq (text-value node) 0 (1- win-width)))
(fg (preformatted-fg theme)))
(tui:make-tui-string (format nil "~a" truncated-line)
:fgcolor fg)))
((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)
(make-pre-start (pre-alt-text node)))
((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)))))))
(defun sexp->text (parsed-gemini theme) (defun sexp->text (parsed-gemini theme)
(labels ((header-prefix (prefix header) (labels ((header-prefix (prefix header)
(strcat prefix header)) (strcat prefix header))
@ -352,7 +448,8 @@
((null node) ((null node)
(format stream "~%")) (format stream "~%"))
((html-utils:tag= :as-is node) ((html-utils:tag= :as-is node)
(format stream "~a~%" (text-value node))) (let ((truncated-line (safe-subseq (text-value node) 0 win-width)))
(format stream "~a~%" truncated-line)))
((html-utils:tag= :text node) ((html-utils:tag= :text node)
(format stream "~a~%" (text-value node))) (format stream "~a~%" (text-value node)))
((html-utils:tag= :h1 node) ((html-utils:tag= :h1 node)
@ -376,8 +473,8 @@
(write-sequence (fit-quote-lines (text-value node :trim nil) (write-sequence (fit-quote-lines (text-value node :trim nil)
win-width) win-width)
stream)) stream))
((html-utils:tag= :pre node) ;; ((html-utils:tag= :pre node)
(write-sequence (text-value node :trim nil) stream)) ;; (write-sequence (text-value node :trim nil) stream))
((html-utils:tag= :a node) ((html-utils:tag= :a node)
(let ((link-name (text-value node :trim nil)) (let ((link-name (text-value node :trim nil))
(link-value (html-utils:attribute-value (html-utils:find-attribute :href (link-value (html-utils:attribute-value (html-utils:find-attribute :href
@ -396,7 +493,7 @@
(if was-raw-mode (if was-raw-mode
(if *raw-mode* (if *raw-mode*
(list (html-utils:make-tag-node :as-is nil data)) (list (html-utils:make-tag-node :as-is nil data))
nil) parsed)
parsed))) parsed)))
;; response header ;; response header

4
src/gemini/package.lisp
View File

@ -64,6 +64,10 @@
:h3-prefix :h3-prefix
:quote-prefix :quote-prefix
:bullet-prefix :bullet-prefix
:pre-start
:pre-end
:value
:sexp->text-rows
:sexp->text :sexp->text
:parse-gemini-response-header :parse-gemini-response-header
:gemini-iri-p)) :gemini-iri-p))

3
src/line-oriented-window.lisp
View File

@ -70,6 +70,9 @@
:documentation "Non nil if this line is selected state")) :documentation "Non nil if this line is selected state"))
(:documentation "This class represents a single line in a row-oriented-widget")) (:documentation "This class represents a single line in a row-oriented-widget"))
(defmethod print-object ((object line) stream)
(format stream "line: ~s" (normal-text object)))
(defclass row-oriented-widget () (defclass row-oriented-widget ()
((rows ((rows
:initform () :initform ()

69
src/message-window.lisp
View File

@ -21,9 +21,9 @@
focus-marked-window focus-marked-window
title-window) title-window)
((source-text ((source-text
:initform nil :initform nil
:initarg :source-text :initarg :source-text
:reader source-text) :reader source-text)
(line-position-mark (line-position-mark
:initform (make-tui-string "0") :initform (make-tui-string "0")
:initarg :line-position-mark :initarg :line-position-mark
@ -93,8 +93,8 @@
for line in actual-rows for line in actual-rows
for y from 1 below (win-height-no-border window) do for y from 1 below (win-height-no-border window) do
(let ((text-line (normal-text line))) (let ((text-line (normal-text line)))
(when (string-not-empty-p text-line) (when (string-not-empty-p text-line)
(print-text window text-line 1 y))))))) (print-text window text-line 1 y)))))))
(defun draw-buffer-line-mark (window) (defun draw-buffer-line-mark (window)
(with-accessors ((rows rows) (with-accessors ((rows rows)
@ -113,7 +113,7 @@
(win-clear object :redraw nil) (win-clear object :redraw nil)
(win-box object) (win-box object)
(draw-text object) (draw-text object)
(when (source-text object) (when (rows object)
(draw-buffer-line-mark object)) (draw-buffer-line-mark object))
(call-next-method))) (call-next-method)))
@ -136,31 +136,56 @@
(defgeneric search-regex (object regex)) (defgeneric search-regex (object regex))
(defun text->rendered-lines-rows (window text) (defgeneric text->rendered-lines-rows (window text))
(defmethod text->rendered-lines-rows (window (text gemini-parser:pre-start))
(make-instance 'line
:normal-text ""))
(defmethod text->rendered-lines-rows (window (text gemini-parser:pre-end))
(make-instance 'line
:normal-text ""))
(defmethod text->rendered-lines-rows (window (text list))
(flatten (loop for i in text collect
(text->rendered-lines-rows window i))))
(defmethod text->rendered-lines-rows (window (text complex-string))
(make-instance 'line
:normal-text text))
(defmethod text->rendered-lines-rows (window (text string))
(labels ((fit-lines (lines) (labels ((fit-lines (lines)
(let ((res ())) (let ((res ()))
(loop for line in lines do (loop for line in lines do
(if (string-empty-p line) (if (string-empty-p line)
(push nil res) (push nil res)
(loop (loop
for fitted-line in for fitted-line
(flush-left-mono-text (split-words line) in (flush-left-mono-text (split-words line)
(win-width-no-border window)) (win-width-no-border window))
do do
(push fitted-line res)))) (push fitted-line res))))
(reverse res)))) (reverse res))))
(let* ((lines (split-lines text)) (if (string= text (format nil "~%"))
(fitted-lines (fit-lines lines)) (make-instance 'line
(color-re (swconf:color-regexps)) :normal-text nil)
(new-rows (loop for line in fitted-lines collect (let* ((lines (split-lines text))
(let ((res line)) (fitted-lines (fit-lines lines))
(loop for re in color-re do (color-re (swconf:color-regexps))
(setf res (colorize-line res re))) (new-rows (loop for line in fitted-lines collect
(colorized-line->tui-string res))))) (let ((res line))
(mapcar (lambda (text-line) (loop for re in color-re do
(make-instance 'line (setf res (colorize-line res re)))
:normal-text text-line)) (colorized-line->tui-string res)))))
new-rows)))) (mapcar (lambda (text-line)
(make-instance 'line
:normal-text text-line))
new-rows)))))
(defmethod text->rendered-lines-rows (window (text null))
(make-instance 'line
:normal-text ""))
(defmethod prepare-for-rendering ((object message-window) &key (jump-to-first-row t)) (defmethod prepare-for-rendering ((object message-window) &key (jump-to-first-row t))
(with-accessors ((source-text source-text)) object (with-accessors ((source-text source-text)) object

7
src/misc-utils.lisp
View File

@ -472,10 +472,9 @@ to the array"
(let ((first-byte (read-byte stream nil nil))) (let ((first-byte (read-byte stream nil nil)))
(when first-byte (when first-byte
(let ((raw (loop (let ((raw (loop
for c = (read-byte stream nil (char-code #\Newline)) for c = first-byte then (read-byte stream nil (char-code #\Newline))
while (/= c (char-code #\Newline)) while (/= c (char-code #\Newline))
collect c))) collect c)))
(push first-byte raw)
(when add-newline-stopper (when add-newline-stopper
(let ((rev (reverse raw))) (let ((rev (reverse raw)))
(push (char-code #\Newline) rev) (push (char-code #\Newline) rev)

1
src/package.lisp
View File

@ -1096,6 +1096,7 @@
:gemini-h2-prefix :gemini-h2-prefix
:gemini-h3-prefix :gemini-h3-prefix
:gemini-bullet-prefix :gemini-bullet-prefix
:gemini-preformatted-fg
:gemini-certificates-window-colors :gemini-certificates-window-colors
:signature-file-path :signature-file-path
:vote-vertical-bar :vote-vertical-bar

141
src/program-events.lisp
View File

@ -1047,25 +1047,29 @@
"" ""
:comes-from-local-file t)) :comes-from-local-file t))
(text (gemini-parser:sexp->text parsed (text (gemini-parser:sexp->text parsed
gemini-client:*gemini-page-theme*))) gemini-client:*gemini-page-theme*))
(ir (gemini-parser:sexp->text-rows parsed
gemini-client:*gemini-page-theme*)))
(gemini-viewer:maybe-initialize-metadata window) (gemini-viewer:maybe-initialize-metadata window)
(gemini-viewer:add-url-to-history window index-path) (gemini-viewer:add-url-to-history window index-path)
(refresh-gemini-message-window links raw-text text nil) (refresh-gemini-message-window links raw-text text ir nil)
(windows:draw window))) (windows:draw window)))
(t (t
(let* ((file-string (fs:slurp-file local-path)) (let* ((file-string (fs:slurp-file local-path))
(parent-dir (fs:parent-dir-path local-path)) (parent-dir (fs:parent-dir-path local-path))
(parsed (gemini-parser:parse-gemini-file file-string)) (parsed (gemini-parser:parse-gemini-file file-string))
(links (gemini-parser:sexp->links parsed (links (gemini-parser:sexp->links parsed
nil nil
nil nil
parent-dir parent-dir
:comes-from-local-file t)) :comes-from-local-file t))
(text (gemini-parser:sexp->text parsed (ir-text (gemini-parser:sexp->text-rows parsed
gemini-client:*gemini-page-theme*))) gemini-client:*gemini-page-theme*))
(flat-text (gemini-parser:sexp->text parsed
gemini-client:*gemini-page-theme*)))
(gemini-viewer:maybe-initialize-metadata window) (gemini-viewer:maybe-initialize-metadata window)
(gemini-viewer:add-url-to-history window local-path) (gemini-viewer:add-url-to-history window local-path)
(refresh-gemini-message-window links file-string text nil) (refresh-gemini-message-window links file-string flat-text ir-text nil)
(windows:draw window)))))))) (windows:draw window))))))))
(defclass gemini-back-event (program-event) ()) (defclass gemini-back-event (program-event) ())
@ -1089,13 +1093,13 @@
:reader skip-rendering-p :reader skip-rendering-p
:writer (setf skip-rendering)))) :writer (setf skip-rendering))))
(defun refresh-gemini-message-window (links source rendered-text append-text) (defun refresh-gemini-message-window (links source rendered-text ir-rows append-text)
(let* ((win specials:*message-window*) (let* ((win specials:*message-window*)
(window-metadata (message-window:metadata win))) (window-metadata (message-window:metadata win)))
(if append-text (if append-text
(with-accessors ((rows message-window::rows)) win (with-accessors ((rows message-window::rows)) win
(let ((new-rows (message-window:text->rendered-lines-rows win (let ((new-rows (message-window:text->rendered-lines-rows win
rendered-text)) ir-rows))
(reversed-rows (reverse rows))) (reversed-rows (reverse rows)))
(message-window:append-source-text win rendered-text :prepare-for-rendering nil) (message-window:append-source-text win rendered-text :prepare-for-rendering nil)
(gemini-viewer:append-metadata-link window-metadata links) (gemini-viewer:append-metadata-link window-metadata links)
@ -1103,10 +1107,16 @@
(loop for new-row in new-rows do (loop for new-row in new-rows do
(push new-row reversed-rows)) (push new-row reversed-rows))
(setf rows (reverse reversed-rows)))) (setf rows (reverse reversed-rows))))
(progn (with-accessors ((rows message-window::rows)) win
(setf (message-window:source-text win) rendered-text) (let ((new-rows (message-window:text->rendered-lines-rows win
(setf (gemini-viewer:gemini-metadata-source-file window-metadata) source) ir-rows))
(setf (gemini-viewer:gemini-metadata-links window-metadata) links))))) (reversed-rows (reverse rows)))
(loop for new-row in new-rows do
(push new-row reversed-rows))
(setf rows (reverse reversed-rows))
(setf (message-window:source-text win) rendered-text)
(setf (gemini-viewer:gemini-metadata-source-file window-metadata) source)
(setf (gemini-viewer:gemini-metadata-links window-metadata) links))))))
(defmethod process-event ((object gemini-got-line-event)) (defmethod process-event ((object gemini-got-line-event))
(with-accessors ((response payload) (with-accessors ((response payload)
@ -1123,59 +1133,61 @@
(when (and (gemini-viewer:downloading-allowed-p wrapper-object) (when (and (gemini-viewer:downloading-allowed-p wrapper-object)
(not (skip-rendering-p object))) (not (skip-rendering-p object)))
(let* ((win specials:*message-window*) (let* ((win specials:*message-window*)
(ir-line (gemini-parser:sexp->text-rows parsed-file
text-rendering-theme))
(rendered-line (gemini-parser:sexp->text parsed-file (rendered-line (gemini-parser:sexp->text parsed-file
text-rendering-theme))) text-rendering-theme)))
(setf (windows:keybindings win) (setf (windows:keybindings win)
keybindings:*gemini-message-keymap*) keybindings:*gemini-message-keymap*)
(refresh-gemini-message-window links source rendered-line append-text) (refresh-gemini-message-window links source rendered-line ir-line append-text)
(windows:draw win)))))) (windows:draw win))))))
(defclass gemini-compact-lines-event (program-event) ;; (defclass gemini-compact-lines-event (program-event)
((download-iri ;; ((download-iri
:initform nil ;; :initform nil
:initarg :download-iri ;; :initarg :download-iri
:accessor download-iri))) ;; :accessor download-iri)))
(defmethod process-event ((object gemini-compact-lines-event)) ;; (defmethod process-event ((object gemini-compact-lines-event))
(with-accessors ((download-iri download-iri)) object ;; (with-accessors ((download-iri download-iri)) object
(let ((all-lines "") ;; (let ((all-lines "")
(all-links ()) ;; (all-links ())
(all-source "") ;; (all-source "")
(append-text t)) ;; (append-text t))
(map-events (lambda (a) ;; (map-events (lambda (a)
(with-accessors ((response payload) ;; (with-accessors ((response payload)
(wrapper-object wrapper-object)) a ;; (wrapper-object wrapper-object)) a
(with-accessors ((parsed-file gemini-client:parsed-file) ;; (with-accessors ((parsed-file gemini-client:parsed-file)
(source gemini-client:source) ;; (source gemini-client:source)
(links gemini-client:links) ;; (links gemini-client:links)
(text-rendering-theme gemini-client:text-rendering-theme)) ;; (text-rendering-theme gemini-client:text-rendering-theme))
response ;; response
(when (and (typep a 'gemini-got-line-event) ;; (when (and (typep a 'gemini-got-line-event)
(string= download-iri ;; (string= download-iri
(gemini-viewer:download-iri wrapper-object)) ;; (gemini-viewer:download-iri wrapper-object))
(gemini-viewer:downloading-allowed-p wrapper-object) ;; (gemini-viewer:downloading-allowed-p wrapper-object)
(not (skip-rendering-p a))) ;; (not (skip-rendering-p a)))
(let ((rendered-text (gemini-parser:sexp->text parsed-file ;; (let ((rendered-text (gemini-parser:sexp->text parsed-file
text-rendering-theme))) ;; text-rendering-theme)))
(when (null (append-text a)) ;; (when (null (append-text a))
(setf append-text nil)) ;; (setf append-text nil))
(appendf all-links links) ;; (appendf all-links links)
(setf all-source ;; (setf all-source
(text-utils:strcat all-source source)) ;; (text-utils:strcat all-source source))
(setf all-lines ;; (setf all-lines
(text-utils:strcat all-lines rendered-text)))))) ;; (text-utils:strcat all-lines rendered-text))))))
a)) ;; a))
(when (text-utils:string-not-empty-p all-lines) ;; (when (text-utils:string-not-empty-p all-lines)
(remove-event-if (lambda (a) ;; (remove-event-if (lambda (a)
(with-accessors ((wrapper-object wrapper-object)) a ;; (with-accessors ((wrapper-object wrapper-object)) a
(and (typep a 'gemini-got-line-event) ;; (and (typep a 'gemini-got-line-event)
(string= download-iri ;; (string= download-iri
(gemini-viewer:download-iri wrapper-object)))))) ;; (gemini-viewer:download-iri wrapper-object))))))
(let* ((win specials:*message-window*)) ;; (let* ((win specials:*message-window*))
(setf (windows:keybindings win) ;; (setf (windows:keybindings win)
keybindings:*gemini-message-keymap*) ;; keybindings:*gemini-message-keymap*)
(refresh-gemini-message-window all-links all-source all-lines append-text) ;; (refresh-gemini-message-window all-links all-source all-lines append-text)
(windows:draw win)))))) ;; (windows:draw win))))))
(defclass gemini-abort-downloading-event (program-event) ()) (defclass gemini-abort-downloading-event (program-event) ())
@ -1288,6 +1300,7 @@
(refresh-gemini-message-window links (refresh-gemini-message-window links
gemini-page gemini-page
(gemini-parser:sexp->text parsed theme) (gemini-parser:sexp->text parsed theme)
(gemini-parser:sexp->text-rows parsed theme)
nil) nil)
(setf (windows:keybindings specials:*message-window*) (setf (windows:keybindings specials:*message-window*)
keybindings:*gemini-message-keymap*) keybindings:*gemini-message-keymap*)
@ -1355,7 +1368,7 @@
(setf (windows:keybindings specials:*message-window*) (setf (windows:keybindings specials:*message-window*)
keybindings:*chat-message-keymap*) keybindings:*chat-message-keymap*)
(setf (message-window:source-text specials:*message-window*) (setf (message-window:source-text specials:*message-window*)
(chats-list-window:chat->text chat)) (chats-list-window:chat->text chat))
(message-window:scroll-end specials:*message-window*) (message-window:scroll-end specials:*message-window*)
(setf (message-window:metadata specials:*message-window*) (setf (message-window:metadata specials:*message-window*)
chat) chat)

9
src/software-configuration.lisp
View File

@ -421,6 +421,7 @@
h2 h2
h3 h3
bullet bullet
preformatted-text
other other
attribute attribute
new-message new-message
@ -613,6 +614,14 @@
+key-bullet+ +key-bullet+
+key-prefix+)) +key-prefix+))
(defun gemini-preformatted-fg ()
(or
(access-non-null-conf-value *software-configuration*
+key-gemini+
+key-preformatted-text+
+key-foreground+)
:white))
(defun gemini-certificates-window-colors () (defun gemini-certificates-window-colors ()
"return three color values" "return three color values"
(values (access:accesses *software-configuration* (values (access:accesses *software-configuration*