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

- [gemini] started coloring preformatted block.

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.preformatted-text.foreground = #fed700
# this is the window that allow to browse the gemini streams
open-gemini-stream-window.background = black

3
src/gemini/client.lisp
View File

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

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

@ -91,11 +91,12 @@
(* (not cr-lf))
cr-lf)
(:function (lambda (a)
(let ((saved-mode *raw-mode*))
(let ((saved-raw-mode *raw-mode*))
(setf *raw-mode* (not *raw-mode*))
(when (not saved-mode)
(list :pre
(list (list :alt (coerce (second a) 'string)))))))))
(if (not saved-raw-mode)
(list :pre
(list (list :alt (coerce (second a) 'string))))
(list :pre-end () ""))))))
(defrule link-prefix (and "=>"
(* space))
@ -103,7 +104,9 @@
(defrule text-line (and (+ (not cr-lf)) cr-lf)
(:function (lambda (a)
(list :text
(list (if *raw-mode*
:as-is
:text)
nil
(coerce (first a) 'string)))))
@ -304,17 +307,110 @@
:accessor h3-prefix)
(quote-prefix
:initarg :quote-prefix
:initform +quote-line-prefix+
:initform +quote-prefix+
:accessor quote-prefix)
(bullet-prefix
:initarg :bullet-prefix
:initform +bullet-line-prefix+
:initform "@ "
:accessor bullet-prefix)
(preformatted-fg
:initarg :preformatted-fg
:initform :red
:accessor preformatted-fg)
(viewport
:initarg :viewport
:initform nil
: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)
(labels ((header-prefix (prefix header)
(strcat prefix header))
@ -352,7 +448,8 @@
((null node)
(format stream "~%"))
((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)
(format stream "~a~%" (text-value node)))
((html-utils:tag= :h1 node)
@ -376,8 +473,8 @@
(write-sequence (fit-quote-lines (text-value node :trim nil)
win-width)
stream))
((html-utils:tag= :pre node)
(write-sequence (text-value node :trim nil) stream))
;; ((html-utils:tag= :pre node)
;; (write-sequence (text-value node :trim nil) stream))
((html-utils:tag= :a node)
(let ((link-name (text-value node :trim nil))
(link-value (html-utils:attribute-value (html-utils:find-attribute :href
@ -396,7 +493,7 @@
(if was-raw-mode
(if *raw-mode*
(list (html-utils:make-tag-node :as-is nil data))
nil)
parsed)
parsed)))
;; response header

4
src/gemini/package.lisp
View File

@ -64,6 +64,10 @@
:h3-prefix
:quote-prefix
:bullet-prefix
:pre-start
:pre-end
:value
:sexp->text-rows
:sexp->text
:parse-gemini-response-header
: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 "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 ()
((rows
:initform ()

69
src/message-window.lisp
View File

@ -21,9 +21,9 @@
focus-marked-window
title-window)
((source-text
:initform nil
:initarg :source-text
:reader source-text)
:initform nil
:initarg :source-text
:reader source-text)
(line-position-mark
:initform (make-tui-string "0")
:initarg :line-position-mark
@ -93,8 +93,8 @@
for line in actual-rows
for y from 1 below (win-height-no-border window) do
(let ((text-line (normal-text line)))
(when (string-not-empty-p text-line)
(print-text window text-line 1 y)))))))
(when (string-not-empty-p text-line)
(print-text window text-line 1 y)))))))
(defun draw-buffer-line-mark (window)
(with-accessors ((rows rows)
@ -113,7 +113,7 @@
(win-clear object :redraw nil)
(win-box object)
(draw-text object)
(when (source-text object)
(when (rows object)
(draw-buffer-line-mark object))
(call-next-method)))
@ -136,31 +136,56 @@
(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)
(let ((res ()))
(loop for line in lines do
(if (string-empty-p line)
(push nil res)
(loop
for fitted-line in
(flush-left-mono-text (split-words line)
(win-width-no-border window))
for fitted-line
in (flush-left-mono-text (split-words line)
(win-width-no-border window))
do
(push fitted-line res))))
(reverse res))))
(let* ((lines (split-lines text))
(fitted-lines (fit-lines lines))
(color-re (swconf:color-regexps))
(new-rows (loop for line in fitted-lines collect
(let ((res line))
(loop for re in color-re do
(setf res (colorize-line res re)))
(colorized-line->tui-string res)))))
(mapcar (lambda (text-line)
(make-instance 'line
:normal-text text-line))
new-rows))))
(if (string= text (format nil "~%"))
(make-instance 'line
:normal-text nil)
(let* ((lines (split-lines text))
(fitted-lines (fit-lines lines))
(color-re (swconf:color-regexps))
(new-rows (loop for line in fitted-lines collect
(let ((res line))
(loop for re in color-re do
(setf res (colorize-line res re)))
(colorized-line->tui-string res)))))
(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))
(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)))
(when first-byte
(let ((raw (loop
for c = (read-byte stream nil (char-code #\Newline))
while (/= c (char-code #\Newline))
collect c)))
(push first-byte raw)
for c = first-byte then (read-byte stream nil (char-code #\Newline))
while (/= c (char-code #\Newline))
collect c)))
(when add-newline-stopper
(let ((rev (reverse raw)))
(push (char-code #\Newline) rev)

1
src/package.lisp
View File

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

141
src/program-events.lisp
View File

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

9
src/software-configuration.lisp
View File

@ -421,6 +421,7 @@
h2
h3
bullet
preformatted-text
other
attribute
new-message
@ -613,6 +614,14 @@
+key-bullet+
+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 ()
"return three color values"
(values (access:accesses *software-configuration*