cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-02-01 04:26:47 +01:00
Code Issues

- rewritten rendering of text in message window

Browse Source 
i got rid of slot support-text in message-window, so that class does
  not maintain a state.

- changed behaivour of split-line
  (split-line (format nil "~2%")) ; => ("" "")

  That is an emtpy line is returned as empty string and not skipped
  Thanks to people from IRC and cl-ppcre maintainer for help!

- [breaking changes] changed 'hooks:*before-prepare-for-rendering-message*
  with 'hooks:*before-rendering-message-text*.
This commit is contained in:
cage 2021-04-10 13:52:56 +02:00
parent ddb74a600f
commit 6786d48f6d
13 changed files with 212 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16,7 +16,7 @@
(in-package :modules)
(defparameter *rewriting-link-rules* ()
(defparameter *rewriting-link-rules* '()
"Before displaying messages that module will rewrites the first
element of each item of this list with the second
@ -56,13 +56,28 @@ So the whole list is like: '((\"foo\" \"bar\") (\"old\" \"new\") ...)")
text
(cdr mapping)))
(defun %rewriting-link-rewrite-row (links-mapping)
(lambda (row)
(let* ((original-type (message-window:line-get-original-object row))
(original-string (line-oriented-window:normal-text row))
(skipped-row-types (list 'gemini-parser:pre-line
'gemini-parser:vertical-space)))
(if (member original-type skipped-row-types)
row
(let* ((simple-string (tui:tui-string->chars-string original-string))
(replaced-string simple-string))
(loop for mapping in links-mapping do
(setf replaced-string
(rewriting-link-replace-mapping mapping replaced-string)))
replaced-string)))))
(defun rewriting-link-message-hook-fn (message-window)
(with-accessors ((support-text message-window:support-text)) message-window
(let* ((all-links (text-utils:collect-links support-text))
(links-mapping (rewriting-link-messages-links-rules all-links)))
(loop for mapping in links-mapping do
(setf support-text
(rewriting-link-replace-mapping mapping support-text))))))
(let* ((map-fn (%rewriting-link-rewrite-row *rewriting-link-rules*))
(replaced-rows (line-oriented-window:map-rows message-window
map-fn))
(new-rows (message-window:text->rendered-lines-rows message-window
replaced-rows)))
(line-oriented-window:update-all-rows message-window new-rows)))
(defun rewriting-link-links-window-hook-fn (all-links)
(let ((links-mapping (rewriting-link-messages-links-rules all-links))
@ -75,7 +90,7 @@ So the whole list is like: '((\"foo\" \"bar\") (\"old\" \"new\") ...)")
(push mapped results)))
(reverse results)))
(hooks:add-hook 'hooks:*before-prepare-for-rendering-message*
(hooks:add-hook 'hooks:*before-rendering-message-text*
#'rewriting-link-message-hook-fn)
(hooks:add-hook 'hooks:*before-displaying-links-hook*

2
src/gemini-viewer.lisp
View File

@ -689,7 +689,7 @@
(when-let* ((metadata (message-window:metadata window))
(source (gemini-metadata-source-file metadata))
(last (misc:safe-last-elt (gemini-metadata-history metadata))))
(setf (message-window:support-text window) source)
(message-window:prepare-for-rendering window source)
(draw window)
(ui:info-message (format nil (_ "Viewing source of: ~a") last))))

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

@ -378,6 +378,12 @@
:group-id group-id
:alt-text alt-text))
(defclass vertical-space ()
((size
:initform 1
:initarg :size
:accessor size)))
(defun sexp->text-rows (parsed-gemini theme)
(labels ((header-prefix (prefix header)
(strcat prefix header))
@ -417,7 +423,7 @@
(loop for node in parsed-gemini collect
(cond
((null node)
(format nil "~%"))
(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))

1
src/gemini/package.lisp
View File

@ -73,6 +73,7 @@
:pre-end
:quoted-lines
:lines
:vertical-space
:sexp->text-rows
:sexp->text
:parse-gemini-response-header

2
src/hooks.lisp
View File

@ -84,7 +84,7 @@ non-nil.")
"Run this hooks just before closing the database connection and the
program")
(defparameter *before-prepare-for-rendering-message* '()
(defparameter *before-rendering-message-text* '()
"Run this hooks before rendering the message on a
message-window (the message window is passed as parameter")

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

@ -71,7 +71,7 @@
(: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)))
(format stream "line: ~s" (tui-string->chars-string (normal-text object))))
(defclass row-oriented-widget ()
((rows
@ -347,6 +347,16 @@ this exact quantity would go beyond the length or rows or zero."
:end end
:key key))
(defun rows->text-rows (window &key (accessor-fn #'normal-text))
(let ((*blanks* '(#\Newline)))
(map-rows window
(lambda (a)
(trim-blanks (tui:tui-string->chars-string (funcall accessor-fn a)))))))
(defun rows->text (window &key (accessor-fn #'normal-text))
(join-with-strings (rows->text-rows window :accessor-fn accessor-fn)
(format nil "~%")))
(defclass simple-line-navigation-window (wrapper-window row-oriented-widget border-window)
((selected-line-bg
:initform :blue

173
src/message-window.lisp
View File

@ -20,11 +20,7 @@
row-oriented-widget
focus-marked-window
title-window)
((support-text
:initform nil
:initarg :support-text
:reader support-text)
(line-position-mark
((line-position-mark
:initform (make-tui-string "0")
:initarg :line-position-mark
:accessor line-position-mark)
@ -50,13 +46,6 @@
(setf (keybindings window)
keybindings:*message-keymap*)))
(defmethod (setf support-text) (new-text (object message-window))
(setf (slot-value object 'support-text) new-text)
(handler-bind ((conditions:out-of-bounds
(lambda (e)
(invoke-restart 'ignore-selecting-action e))))
(prepare-for-rendering object)))
(defun refresh-line-mark-config (window)
(multiple-value-bind (mark-value mark-fg mark-bg)
(swconf:message-window-line-mark-values)
@ -86,6 +75,8 @@
(declare (ignore object dt)))
(defun draw-text (window)
(when hooks:*before-rendering-message-text*
(hooks:run-hook 'hooks:*before-rendering-message-text* window))
(with-accessors ((row-selected-index row-selected-index)) window
(let ((actual-rows (line-oriented-window:rows-safe-subseq window row-selected-index)))
(loop for line in actual-rows
@ -119,10 +110,7 @@
(draw-buffer-line-mark object))
(call-next-method)))
(defgeneric prepare-for-rendering (object &key (jump-to-first-row)))
(defgeneric append-support-text (object text
&key prepare-for-rendering jump-to-first-row))
(defgeneric prepare-for-rendering (object text-data &key jump-to-first-row))
(defgeneric scroll-down (object &optional amount))
@ -140,12 +128,26 @@
(defgeneric text->rendered-lines-rows (window text))
(defun make-render-vspace-row ()
(make-instance 'line
:normal-text (make-tui-string "")))
(defun line-add-original-object (line original-object)
(push original-object
(fields line))
(push :original-object
(fields line))
line)
(defun line-get-original-object (line)
(getf (fields line) :original-object))
(defun make-render-vspace-row (&optional (original-object
(make-instance 'gemini-parser:vertical-space)))
(let ((res (make-instance 'line
:normal-text (make-tui-string (format nil "~%"))
:fields (list :vertical-space 1))))
(line-add-original-object res original-object)
res)) ; even if line-add-original-object returns the modified line explicit returns for clarity
(defun vspace-row-p (row)
(string-empty-p (normal-text row)))
(getf (fields row) :vertical-space))
(defun make-invisible-row ()
(make-instance 'line
@ -155,6 +157,9 @@
(defun invisible-row-p (row)
(getf (fields row) :invisible))
(defmethod text->rendered-lines-rows (window (text gemini-parser:vertical-space))
(make-render-vspace-row text))
(defmethod text->rendered-lines-rows (window (text gemini-parser:pre-start))
(make-invisible-row))
@ -162,13 +167,14 @@
(make-invisible-row))
(defmethod text->rendered-lines-rows (window (text gemini-parser:pre-line))
(make-instance 'line
:normal-text
(reduce #'tui:cat-complex-string
(text->rendered-lines-rows window (gemini-parser:lines text)))
:fields (list :alt-text (gemini-parser:alt-text text)
:group-id (gemini-parser:group-id text)
:original-object text)))
(let ((res (make-instance 'line
:normal-text
(reduce #'tui:cat-complex-string
(text->rendered-lines-rows window (gemini-parser:lines text)))
:fields (list :alt-text (gemini-parser:alt-text text)
:group-id (gemini-parser:group-id text)))))
(line-add-original-object res text)
res)) ; even if line-add-original-object returns the modified line explicit returns for clarity
(defmethod text->rendered-lines-rows (window (text list))
(flatten (loop for i in text
@ -178,26 +184,6 @@
(defmethod text->rendered-lines-rows (window (text complex-string))
text)
(defmethod update-all-rows :around ((object message-window) (new-rows sequence))
(let ((new-rows (remove-if #'invisible-row-p new-rows)))
(call-next-method object new-rows)))
(defmethod append-new-rows :around ((object message-window) (new-rows sequence))
(let ((new-rows (loop for new-row in new-rows
when (not (invisible-row-p new-row))
collect
new-row)))
(call-next-method object new-rows)))
(defun colorize-lines (lines)
(let ((color-re (swconf:color-regexps)))
(loop for line in lines
collect
(let ((res line))
(loop for re in color-re do
(setf res (colorize-line res re)))
(colorized-line->tui-string res)))))
(defmethod text->rendered-lines-rows (window (text gemini-parser:quoted-lines))
(let ((colorized-lines (colorize-lines (gemini-parser:lines text))))
(loop for i in colorized-lines
@ -209,46 +195,69 @@
(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))
do
(push fitted-line res))))
(cond
((or (string-empty-p line)
(string= line (format nil "~%")))
(push (make-render-vspace-row) res))
(t
(loop for fitted-line
in (flush-left-mono-text (split-words line)
(win-width-no-border window))
do
(push fitted-line res)))))
(reverse res))))
(if (string= text (format nil "~%"))
(make-render-vspace-row)
(let* ((lines (split-lines text))
(fitted-lines (fit-lines lines))
(new-rows (colorize-lines fitted-lines)))
(mapcar (lambda (text-line)
(let* ((lines (split-lines text))
(fitted-lines (fit-lines lines))
(new-rows (colorize-lines fitted-lines)))
(mapcar (lambda (text-line)
(if (typep text-line 'line)
text-line
(make-instance 'line
:normal-text text-line))
new-rows)))))
:normal-text text-line)))
new-rows))))
(defmethod text->rendered-lines-rows (window (text null))
(make-render-vspace-row))
;; (defmethod text->rendered-lines-rows (window (text null))
;; (make-render-vspace-row))
(defmethod prepare-for-rendering ((object message-window) &key (jump-to-first-row t))
(with-accessors ((support-text support-text)) object
(when hooks:*before-prepare-for-rendering-message*
(hooks:run-hook 'hooks:*before-prepare-for-rendering-message* object))
(update-all-rows object
(text->rendered-lines-rows object support-text))
(when jump-to-first-row
(select-row object 0))
object))
(defmethod text->rendered-lines-rows (window (text line))
text)
(defmethod append-support-text ((object message-window) text
&key
(prepare-for-rendering nil)
(jump-to-first-row nil))
(with-slots (support-text) object
(setf support-text (strcat support-text text))
(when prepare-for-rendering
(prepare-for-rendering object :jump-to-first-row jump-to-first-row))))
(defmethod update-all-rows :around ((object message-window) (new-rows sequence))
(let ((actual-rows (remove-if #'invisible-row-p new-rows)))
(call-next-method object actual-rows)))
(defmethod append-new-rows :around ((object message-window) (new-rows sequence))
(let ((new-rows (loop for new-row in new-rows
when (not (invisible-row-p new-row))
collect
new-row)))
(call-next-method object new-rows)))
(defgeneric colorize-lines (object))
(defmethod colorize-lines ((object line))
object)
(defmethod colorize-lines ((object complex-string))
(make-instance 'line :normal-text object))
(defmethod colorize-lines ((object string))
(let ((color-re (swconf:color-regexps))
(res object))
(loop for re in color-re do
(setf res (colorize-line res re)))
(colorized-line->tui-string res)))
(defmethod colorize-lines ((object list))
(loop for line in object
collect
(colorize-lines line)))
(defmethod prepare-for-rendering ((object message-window) text-data &key (jump-to-first-row t))
(update-all-rows object (text->rendered-lines-rows object text-data))
(when jump-to-first-row
(select-row object 0))
object)
(defun offset-to-move-end (win)
(with-accessors ((rows rows)

10
src/package.lisp
View File

@ -348,6 +348,7 @@
(:export
:+float-regexp+
:+integer-regexp+
:*blanks*
:uchar-length
:utf8-encoded-p
:clean-unprintable-chars
@ -1201,6 +1202,7 @@
:combine-attributes
:colorize-line
:colorized-line->tui-string
:apply-coloring
:standard-error-notify-life
:with-notify-errors
:with-print-error-message
@ -1506,7 +1508,7 @@
:run-hook-until-success
:*before-main-loop*
:*before-quit*
:*before-prepare-for-rendering-message*
:*before-rendering-message-text*
:*before-sending-message*
:*skip-message-hook*
:*after-saving-message*
@ -1826,6 +1828,8 @@
:rows-last-elt
:rows-first-elt
:rows-position-if
:rows->text-rows
:rows->text
:row-move
:simple-line-navigation-window
:selected-line-bg
@ -1926,14 +1930,14 @@
(:shadowing-import-from :misc :random-elt :shuffle)
(:export
:message-window
:support-text
:metadata
:gemini-window-p
:display-gemini-text-p
:display-chat-p
:line-get-original-object
:text->rendered-lines-rows
:prepare-for-display-status-mode
:append-support-text
:prepare-for-rendering
:scroll-down
:scroll-up
:scroll-end

4
src/program-events.lisp
View File

@ -1352,8 +1352,8 @@
(db:mark-all-chat-messages-read chat-id)
(setf (windows:keybindings specials:*message-window*)
keybindings:*chat-message-keymap*)
(setf (message-window:support-text specials:*message-window*)
(chats-list-window:chat->text chat))
(message-window:prepare-for-rendering specials:*message-window*
(chats-list-window:chat->text chat))
(message-window:scroll-end specials:*message-window*)
(setf (message-window:metadata specials:*message-window*)
chat)

30
src/text-utils.lisp
View File

@ -143,11 +143,28 @@
(defun join-with-strings* (junction &rest strings)
(apply #'join-with-strings strings (list junction)))
(defvar *blanks* '(#\Space #\Newline #\Backspace #\Tab
#\Linefeed #\Page #\Return #\Rubout))
(defgeneric trim-blanks (s))
(defmethod trim-blanks ((s string))
(string-trim *blanks* s))
(defmethod trim-blanks ((s null))
s)
(defun split-words (text)
(cl-ppcre:split "\\p{White_Space}" text))
(defun split-lines (text)
(cl-ppcre:split "[\\n\\r]" text))
(let ((res ()))
(flex:with-input-from-sequence (stream (babel:string-to-octets text))
(loop for line-as-array = (misc:read-line-into-array stream)
while line-as-array do
(push (babel:octets-to-string line-as-array) res)))
(let ((*blanks* '(#\Newline)))
(reverse (mapcar #'trim-blanks res)))))
(defun min-length-word (text)
(loop for i in (split-words text)
@ -237,17 +254,6 @@ Uses `test' to match strings (default #'string=)"
(length end))
(funcall test s end :start1 (- (length s) (length end)))))
(defvar *blanks* '(#\Space #\Newline #\Backspace #\Tab
#\Linefeed #\Page #\Return #\Rubout))
(defgeneric trim-blanks (s))
(defmethod trim-blanks ((s string))
(string-trim *blanks* s))
(defmethod trim-blanks ((s null))
s)
(defun justify-monospaced-text (text &optional (chars-per-line 30))
(if (null (split-words text))
(list " ")

10
src/thread-window.lisp
View File

@ -814,11 +814,11 @@ db:renumber-timeline-message-index."
(actual-attachments (if (string= attachments reblogged-status-attachments)
attachments
(strcat reblogged-status-attachments attachments))))
(setf (message-window:support-text *message-window*)
(strcat header
actual-body
poll-text
actual-attachments))
(message-window:prepare-for-rendering *message-window*
(strcat header
actual-body
poll-text
actual-attachments))
(db:mark-status-red-p timeline-type timeline-folder status-id)
(resync-rows-db object :redraw t)
(program-events:push-event refresh-event)

34
src/tui-utils.lisp
View File

@ -369,7 +369,6 @@ latter has a length equals to `total-size'"))
:fgcolor fgcolor
:bgcolor bgcolor))
(defmethod colorized-line->tui-string ((line complex-string) &key &allow-other-keys)
line)
@ -380,6 +379,39 @@ latter has a length equals to `total-size'"))
line
:initial-value (make-tui-string "")))
(defgeneric apply-coloring (from to))
(defmethod apply-coloring ((from complex-string) (to string))
(with-accessors ((complex-char-array-from complex-char-array)) from
(let* ((res (make-tui-string to))
(length-diff (- (length to)
(text-length from)))
(last-char-from (last-elt complex-char-array-from))
(last-char-fg (fgcolor last-char-from))
(last-char-bg (bgcolor last-char-from))
(last-char-attr (attributes last-char-from)))
(with-accessors ((complex-char-array-to complex-char-array)) res
(loop
for from-char across complex-char-array-from
for to-char across complex-char-array-to
do
(setf (attributes to-char)
(attributes from-char))
(setf (fgcolor to-char)
(fgcolor from-char))
(setf (bgcolor to-char)
(bgcolor from-char)))
(when (> length-diff 0)
(loop for i from length-diff below (length to) do
(let ((char (elt complex-char-array-to i)))
(setf (attributes char)
last-char-attr)
(setf (fgcolor char)
last-char-fg)
(setf (bgcolor char)
last-char-bg))))
res))))
(defgeneric print-debug (object &optional stream))
(defmethod print-debug ((object complex-char) &optional (stream *standard-output*))

24
src/ui-goodies.lisp
View File

@ -42,7 +42,7 @@
(temporary-files-count (length fs:*temporary-files-created*)))
(if (> temporary-files-count 0)
(progn
(setf (message-window:support-text *message-window*) temporary-text)
(message-window:prepare-for-rendering *message-window* temporary-text)
(windows:draw *message-window*)
(ask-string-input #'on-input-complete
:prompt (format nil
@ -1876,15 +1876,19 @@ gemini://gemini.circumlunar.space/docs/companion/subscription.gmi
:payload url)))
(push-event event)))))
(defun send-to-pipe-on-input-complete (command data)
(when (and (string-not-empty-p command)
data)
(push-event (make-instance 'send-to-pipe-event
:data data
:command command))
(info-message (format nil (_ "Command ~s completed") command))))
(defun send-to-pipe ()
"Send contents of window to a command"
(flet ((on-input-complete (command)
(when (string-not-empty-p command)
(when-let ((data (message-window:support-text *message-window*)))
(push-event (make-instance 'send-to-pipe-event
:data data
:command command))
(info-message (format nil (_ "Command ~s completed")))))))
(let ((data (line-oriented-window:rows->text *message-window*)))
(send-to-pipe-on-input-complete command data))))
(ask-string-input #'on-input-complete
:prompt (format nil (_ "Send to command: ")))))
@ -1893,10 +1897,6 @@ gemini://gemini.circumlunar.space/docs/companion/subscription.gmi
(when-let* ((selected-message (line-oriented-window:selected-row-fields *thread-window*))
(message (db:row-message-rendered-text selected-message)))
(flet ((on-input-complete (command)
(when (string-not-empty-p command)
(push-event (make-instance 'send-to-pipe-event
:data message
:command command))
(notify (format nil (_ "Command ~s completed"))))))
(send-to-pipe-on-input-complete command message)))
(ask-string-input #'on-input-complete
:prompt (format nil (_ "Send message to command: "))))))