- rewritten rendering of text in message window

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*.

modules/rewrite-message-urls.lisp

@@ -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-message-hook-fn (message-window)
+(defun %rewriting-link-rewrite-row (links-mapping)
-  (with-accessors ((support-text message-window:support-text)) message-window
+  (lambda (row)
-    (let* ((all-links      (text-utils:collect-links support-text))
+    (let* ((original-type     (message-window:line-get-original-object row))
-           (links-mapping  (rewriting-link-messages-links-rules all-links)))
+           (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 support-text
+              (setf replaced-string
-              (rewriting-link-replace-mapping mapping support-text))))))
+                    (rewriting-link-replace-mapping mapping replaced-string)))
+            replaced-string)))))
+
+(defun rewriting-link-message-hook-fn (message-window)
+  (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*

src/gemini-viewer.lisp

@@ -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))))
 

src/gemini/gemini-parser.lisp

@@ -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))

src/gemini/package.lisp

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

src/hooks.lisp

@@ -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")
 

src/line-oriented-window.lisp

@@ -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

src/message-window.lisp

@@ -20,11 +20,7 @@
                           row-oriented-widget
                           focus-marked-window
                           title-window)
-  ((support-text
+  ((line-position-mark
-     :initform nil
-     :initarg  :support-text
-     :reader   support-text)
-   (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 prepare-for-rendering (object text-data &key jump-to-first-row))
-
-(defgeneric append-support-text (object text
-                                &key prepare-for-rendering 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 ()
+(defun line-add-original-object (line original-object)
-  (make-instance 'line
+  (push original-object
-                 :normal-text (make-tui-string "")))
+        (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
+  (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)
+                                               :group-id        (gemini-parser:group-id text)))))
-                                    :original-object 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)
+                 (cond
-                     (push nil res)
+                   ((or (string-empty-p line)
-                     (loop
+                        (string= line (format nil "~%")))
-                       for fitted-line
+                    (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))))
+                         (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)
+                (if (typep text-line 'line)
+                    text-line
                     (make-instance 'line
-                                   :normal-text text-line))
+                                   :normal-text text-line)))
-                  new-rows)))))
+              new-rows))))
 
-(defmethod text->rendered-lines-rows (window (text null))
+;; (defmethod text->rendered-lines-rows (window (text null))
-  (make-render-vspace-row))
+;;   (make-render-vspace-row))
 
-(defmethod prepare-for-rendering ((object message-window) &key (jump-to-first-row t))
+(defmethod text->rendered-lines-rows (window (text line))
-  (with-accessors ((support-text support-text)) object
+  text)
-    (when hooks:*before-prepare-for-rendering-message*
+
-      (hooks:run-hook 'hooks:*before-prepare-for-rendering-message* object))
+(defmethod update-all-rows :around ((object message-window) (new-rows sequence))
-    (update-all-rows object
+  (let ((actual-rows (remove-if #'invisible-row-p new-rows)))
-                     (text->rendered-lines-rows object support-text))
+    (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))
+  object)
-
-(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))))
 
 (defun offset-to-move-end (win)
   (with-accessors ((rows                 rows)

src/package.lisp

@@ -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

src/program-events.lisp

@@ -1352,7 +1352,7 @@
       (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*)
+      (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*)

src/text-utils.lisp

@@ -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 " ")

src/thread-window.lisp

@@ -814,7 +814,7 @@ 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*)
+            (message-window:prepare-for-rendering *message-window*
                                                   (strcat header
                                                           actual-body
                                                           poll-text

src/tui-utils.lisp

@@ -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*))

src/ui-goodies.lisp

@@ -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 ()
+(defun send-to-pipe-on-input-complete (command data)
-  "Send contents of window to a command"
+  (when (and (string-not-empty-p command)
-  (flet ((on-input-complete (command)
+             data)
-           (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")))))))
+    (info-message (format nil (_ "Command ~s completed") command))))
+
+(defun send-to-pipe ()
+  "Send contents of window to a command"
+  (flet ((on-input-complete (command)
+           (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)
+             (send-to-pipe-on-input-complete command message)))
-               (push-event (make-instance 'send-to-pipe-event
-                                          :data    message
-                                          :command command))
-               (notify (format nil (_ "Command ~s completed"))))))
       (ask-string-input #'on-input-complete
                         :prompt (format nil (_ "Send message to command: "))))))