mirror of https://codeberg.org/cage/tinmop/
879 lines
38 KiB
Common Lisp
879 lines
38 KiB
Common Lisp
;; tinmop: a multiprotocol client
|
|
;; Copyright © cage
|
|
|
|
;; This program is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(in-package :message-window)
|
|
|
|
(define-constant +row-invisible-field-key+ :invisible :test #'eq)
|
|
|
|
(define-constant +row-vertical-space-field-key+ :vertical-space :test #'eq)
|
|
|
|
(defclass message-window (wrapper-window
|
|
row-oriented-widget
|
|
focus-marked-window
|
|
metadata-container
|
|
title-window)
|
|
((line-position-mark
|
|
:initform (make-tui-string "0")
|
|
:initarg :line-position-mark
|
|
:accessor line-position-mark)
|
|
(adjust-rows-strategy
|
|
:initform #'adjust-rows-noop
|
|
:initarg :adjust-rows-strategy
|
|
:accessor adjust-rows-strategy)
|
|
(text-starting-column
|
|
:initform 0
|
|
:initarg :text-starting-column
|
|
:accessor text-starting-column)))
|
|
|
|
(defgeneric prepare-for-rendering (object text-data &key jump-to-first-row))
|
|
|
|
(defgeneric scroll-down (object &optional amount))
|
|
|
|
(defgeneric scroll-up (object &optional amount))
|
|
|
|
(defgeneric scroll-left (object &optional amount))
|
|
|
|
(defgeneric scroll-right (object &optional amount))
|
|
|
|
(defgeneric scroll-end (object))
|
|
|
|
(defgeneric scroll-begin (object))
|
|
|
|
(defgeneric scroll-next-page (object))
|
|
|
|
(defgeneric scroll-previous-page (object))
|
|
|
|
(defgeneric search-regex (object regex))
|
|
|
|
(defgeneric jump-to-group-id (object gid-looking-for))
|
|
|
|
(defgeneric text->rendered-lines-rows (window text))
|
|
|
|
(defgeneric colorize-lines (object))
|
|
|
|
(defgeneric viewport-width (object))
|
|
|
|
(defgeneric generate-gemini-toc (object))
|
|
|
|
(defun gemini-window-p* (window)
|
|
(display-gemini-text-p window))
|
|
|
|
(defgeneric gemini-window-p (win))
|
|
|
|
(defmethod gemini-window-p ((win message-window))
|
|
(gemini-window-p* win))
|
|
|
|
(defun display-gemini-text-p (window)
|
|
(eq (keybindings window)
|
|
keybindings:*gemini-message-keymap*))
|
|
|
|
(defun display-chat-p (window)
|
|
(eq (keybindings window)
|
|
keybindings:*chat-message-keymap*))
|
|
|
|
(defun prepare-for-display-status-mode (window)
|
|
(when (not (or (display-gemini-text-p window)
|
|
(display-chat-p window)))
|
|
(setf (keybindings window)
|
|
keybindings:*message-keymap*)))
|
|
|
|
(defun refresh-line-mark-config (window)
|
|
(multiple-value-bind (mark-value mark-fg mark-bg)
|
|
(swconf:message-window-line-mark-values)
|
|
(setf (line-position-mark window)
|
|
(make-tui-string mark-value
|
|
:fgcolor mark-fg
|
|
:bgcolor mark-bg))))
|
|
|
|
(defmethod refresh-config :after ((object message-window))
|
|
(refresh-config-colors object swconf:+key-message-window+)
|
|
(refresh-line-mark-config object)
|
|
(let* ((reference-window (if command-line:*gemini-full-screen-mode*
|
|
*main-window*
|
|
*thread-window*))
|
|
(reference-window-width (if (and command-line:*gemini-full-screen-mode*
|
|
*gemini-toc-window*)
|
|
(- (win-width *main-window*)
|
|
(win-width *gemini-toc-window*))
|
|
(win-width reference-window)))
|
|
(reference-window-height (win-height reference-window))
|
|
(command-window-height (win-height *command-window*))
|
|
(main-window-height (win-height *main-window*))
|
|
(height (if (eq reference-window *thread-window*)
|
|
(- main-window-height
|
|
command-window-height
|
|
reference-window-height)
|
|
(- main-window-height
|
|
command-window-height
|
|
(swconf:config-gemini-fullscreen-links-height))))
|
|
(width reference-window-width)
|
|
(x (if (and command-line:*gemini-full-screen-mode*
|
|
*gemini-toc-window*)
|
|
(win-width *gemini-toc-window*)
|
|
(win-x reference-window)))
|
|
(y (if (and command-line:*gemini-full-screen-mode*
|
|
*gemini-toc-window*)
|
|
(swconf:config-gemini-fullscreen-links-height)
|
|
(+ (win-y reference-window)
|
|
reference-window-height))))
|
|
(win-resize object width height)
|
|
(win-move object x y)))
|
|
|
|
(defmethod calculate ((object message-window) dt)
|
|
(declare (ignore object dt)))
|
|
|
|
(defun visible-rows (window)
|
|
(with-accessors ((row-selected-index row-selected-index)) window
|
|
(let* ((start (max 0 row-selected-index))
|
|
(end (+ start
|
|
(win-height-no-border window)))
|
|
(rows (rows-safe-subseq window
|
|
row-selected-index
|
|
:end end)))
|
|
(values rows
|
|
start
|
|
(length rows)))))
|
|
|
|
(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)
|
|
(text-starting-column text-starting-column)) window
|
|
(let ((visible-rows (visible-rows window))
|
|
(window-width (win-width-no-border window))
|
|
(content-available-on-the-left-mark (swconf:left-arrow)))
|
|
(when hooks:*before-rendering-message-visible-rows*
|
|
(hooks:run-hook 'hooks:*before-rendering-message-visible-rows* visible-rows window))
|
|
(loop for line in visible-rows
|
|
for y from 1
|
|
do
|
|
(cond
|
|
;; testing invisibility should never returns true as
|
|
;; the method `row' is specialized on message-window
|
|
;; and always removes from the rows the invisible
|
|
;; ones.
|
|
((row-invisible-p line)
|
|
(decf y))
|
|
((not (row-vertical-space-p line))
|
|
(let* ((text-line (remove-corrupting-utf8-chars (normal-text line)))
|
|
(text-length (text-length text-line))
|
|
(truncate-at (- window-width
|
|
text-length
|
|
text-starting-column))
|
|
(truncatep (< truncate-at 0))
|
|
(actual-text-line (cond
|
|
((= text-length 0)
|
|
"")
|
|
((>= text-starting-column text-length)
|
|
content-available-on-the-left-mark)
|
|
(truncatep
|
|
(tui-string-subseq text-line
|
|
text-starting-column
|
|
(min text-length
|
|
(+ window-width
|
|
text-starting-column))))
|
|
(t
|
|
(tui-string-subseq text-line
|
|
text-starting-column
|
|
nil)))))
|
|
(print-text window actual-text-line 1 y))))))))
|
|
|
|
(defun draw-buffer-line-mark (window)
|
|
(with-accessors ((rows rows)
|
|
(row-selected-index row-selected-index)
|
|
(line-position-mark line-position-mark)) window
|
|
(let* ((height (1- (win-height-no-border window)))
|
|
(rows-count (- (rows-length window) height))
|
|
(fraction (/ row-selected-index
|
|
(max 1 rows-count)))
|
|
(mark-y (1+ (truncate (* fraction height))))
|
|
(mark-x (1- (win-width window))))
|
|
(print-text window line-position-mark mark-x mark-y))))
|
|
|
|
(defmethod draw ((object message-window))
|
|
(when-window-shown (object)
|
|
(win-clear object :redraw nil)
|
|
(win-box object)
|
|
(draw-text object)
|
|
(when (not (line-oriented-window:rows-empty-p object))
|
|
(draw-buffer-line-mark object))
|
|
(call-next-method)))
|
|
|
|
(let ((index 0)
|
|
(frames -1)
|
|
(slowness 15))
|
|
(declare (fixnum index frames slowness))
|
|
(defun draw-downloading-animation (window)
|
|
(declare (optimize (debug 0) (speed 3)))
|
|
(let* ((animation-frames (swconf:gemini-downloading-animation))
|
|
(max (length (the list animation-frames))))
|
|
(print-text window (elt animation-frames index) 0 0 :attributes (attribute-bold))
|
|
(incf frames)
|
|
(when (= (rem frames slowness)
|
|
0)
|
|
(setf index (rem (1+ index) max))))))
|
|
|
|
(defgeneric row-add-original-object (lines original-object))
|
|
|
|
(defgeneric row-find-original-object (object thing
|
|
&key from-end start end key))
|
|
|
|
|
|
(defgeneric row-position-original-object (object thing &key start from-end end))
|
|
|
|
(defmethod row-add-original-object ((lines line) original-object)
|
|
(push original-object
|
|
(fields lines))
|
|
(push :original-object
|
|
(fields lines))
|
|
lines)
|
|
|
|
(defun extract-original-object (row)
|
|
(getf (fields row) :original-object))
|
|
|
|
(defmethod row-add-original-object ((lines list) original-object)
|
|
(mapcar (lambda (a) (row-add-original-object a original-object))
|
|
lines)
|
|
lines)
|
|
|
|
(defmethod row-find-original-object ((object message-window) (thing symbol)
|
|
&key from-end (start 0) end key)
|
|
(rows-find-if object (lambda (a) (typep (extract-original-object a) thing))
|
|
:from-end from-end
|
|
:start start
|
|
:end end
|
|
:key key))
|
|
|
|
(defmethod row-find-original-object ((object list) (thing symbol)
|
|
&key from-end (start 0) end key)
|
|
(find-if (lambda (a) (typep (extract-original-object a) thing))
|
|
object
|
|
:from-end from-end
|
|
:start start
|
|
:end end
|
|
:key key))
|
|
|
|
(defmethod row-position-original-object ((object message-window) (thing symbol)
|
|
&key (start 0) (from-end nil) (end nil))
|
|
(when (and (>= start 0)
|
|
(< start (rows-length object))
|
|
(or (null end)
|
|
(and (< end (rows-length object))
|
|
(>= end start))))
|
|
(rows-position-if object (lambda (a) (typep (extract-original-object a) thing))
|
|
:start start
|
|
:end end
|
|
:from-end from-end)))
|
|
|
|
(defmethod row-position-original-object ((object list) (thing symbol)
|
|
&key (start 0) (from-end nil) (end nil))
|
|
(position-if (lambda (a) (typep (extract-original-object a) thing))
|
|
object
|
|
:start start
|
|
:end end
|
|
:from-end from-end))
|
|
|
|
(defun row-get-original-object (line)
|
|
(getf (fields line) :original-object))
|
|
|
|
(defun row-add-group-id (line group-id)
|
|
(push group-id
|
|
(fields line))
|
|
(push :group-id
|
|
(fields line))
|
|
line)
|
|
|
|
(defun row-get-group-id (line)
|
|
(getf (fields line) :group-id))
|
|
|
|
(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 +row-vertical-space-field-key+ 1))))
|
|
(row-add-original-object res original-object)
|
|
(row-add-group-id res (gemini-parser:group-id original-object))
|
|
res))
|
|
|
|
(defun row-vertical-space-p (row)
|
|
(getf (fields row) +row-vertical-space-field-key+))
|
|
|
|
(defun make-invisible-row (original-object &optional (text ""))
|
|
(let ((res (make-instance 'line
|
|
:fields (list +row-invisible-field-key+ t)
|
|
:normal-text (if (typep text 'c:complex-string)
|
|
text
|
|
(make-tui-string text)))))
|
|
(row-add-original-object res original-object)
|
|
res))
|
|
|
|
(defun row-link-p (row)
|
|
(typep (row-get-original-object row)
|
|
'gemini-parser:link-line))
|
|
|
|
(defun row-pre-start-p (row)
|
|
(typep (row-get-original-object row)
|
|
'gemini-parser:pre-start))
|
|
|
|
(defun row-preformatted-p (row)
|
|
(typep (row-get-original-object row)
|
|
'gemini-parser:pre-line))
|
|
|
|
(defun row-invisible-p (row)
|
|
(getf (fields row) +row-invisible-field-key+))
|
|
|
|
(defun row-visible-p (row)
|
|
(not (row-invisible-p row)))
|
|
|
|
(defun row-set-invisible (row)
|
|
(with-accessors ((fields fields)) row
|
|
(when (not (row-invisible-p row))
|
|
(push t fields)
|
|
(push +row-invisible-field-key+ fields))
|
|
row))
|
|
|
|
(defun row-set-visible (row)
|
|
(setf (fields row) (remove-from-plist (fields row) +row-invisible-field-key+))
|
|
row)
|
|
|
|
(defmacro with-map-update-raw-rows ((window function) &body body)
|
|
(with-gensyms (new-rows)
|
|
`(let ((,new-rows (rows-map-raw ,window
|
|
,function)))
|
|
,@body
|
|
(update-all-rows ,window ,new-rows)
|
|
(draw ,window))))
|
|
|
|
(defun row-hide-preformatted (message-window)
|
|
(with-map-update-raw-rows (message-window
|
|
(lambda (a)
|
|
(when (row-preformatted-p a)
|
|
(row-set-invisible a))
|
|
a))))
|
|
|
|
(defun row-show-pre-start (message-window)
|
|
(with-map-update-raw-rows (message-window
|
|
(lambda (a)
|
|
(when (row-pre-start-p a)
|
|
(row-set-visible a))
|
|
a))))
|
|
|
|
(defun row-show-preformatted (message-window)
|
|
(with-map-update-raw-rows (message-window
|
|
(lambda (a)
|
|
(when (row-preformatted-p a)
|
|
(row-set-visible a))
|
|
a))))
|
|
|
|
(defun row-hide-pre-start (message-window)
|
|
(with-map-update-raw-rows (message-window
|
|
(lambda (a)
|
|
(when (row-pre-start-p a)
|
|
(row-set-invisible a))
|
|
a))))
|
|
|
|
(let ((pre-visible-p t))
|
|
|
|
(defun set-default-preformatted-visibility (visibility)
|
|
(setf pre-visible-p visibility))
|
|
|
|
(defun get-default-preformatted-visibility ()
|
|
pre-visible-p)
|
|
|
|
(defun toggle-default-preformatted-visibility ()
|
|
(setf pre-visible-p (not pre-visible-p)))
|
|
|
|
(defun toggle-preformatted-block (message-window)
|
|
(if pre-visible-p
|
|
(progn
|
|
(row-hide-preformatted message-window)
|
|
(row-show-pre-start message-window))
|
|
(progn
|
|
(row-show-preformatted message-window)
|
|
(row-hide-pre-start message-window)))
|
|
(toggle-default-preformatted-visibility)
|
|
message-window))
|
|
|
|
(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 text (gemini-parser:alt-text text)))
|
|
|
|
(defmethod text->rendered-lines-rows (window (text gemini-parser:pre-end))
|
|
(make-invisible-row text))
|
|
|
|
(defmethod text->rendered-lines-rows (window (text gemini-parser:pre-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)))))
|
|
(row-add-original-object res text)
|
|
res)) ; even if row-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
|
|
collect
|
|
(text->rendered-lines-rows window i))))
|
|
|
|
(defmethod text->rendered-lines-rows (window (text c:complex-string))
|
|
text)
|
|
|
|
(defgeneric collect-lines-from-ir (object window &key &allow-other-keys))
|
|
|
|
(defmethod collect-lines-from-ir ((object gemini-parser:with-lines) (window message-window)
|
|
&key
|
|
(width (win-width-no-border window))
|
|
(empty-line-transform-fn (lambda () (make-render-vspace-row)))
|
|
&allow-other-keys)
|
|
(let ((colorized-lines (colorize-lines (%fit-lines window
|
|
(gemini-parser:lines object)
|
|
:width width
|
|
:empty-line-transform-fn
|
|
empty-line-transform-fn))))
|
|
(loop for text in colorized-lines
|
|
collect
|
|
(let ((res-line (text->line text))
|
|
(group-id (gemini-parser:group-id object)))
|
|
(row-add-original-object res-line object)
|
|
(row-add-group-id res-line group-id)
|
|
res-line))))
|
|
|
|
(defmethod text->rendered-lines-rows (window (text gemini-parser:quoted-lines))
|
|
(let* ((rows (collect-lines-from-ir text window
|
|
:width (1- (win-width-no-border window))
|
|
:empty-line-transform-fn (lambda () ""))))
|
|
(loop for row in rows do
|
|
(setf (normal-text row)
|
|
(colorize-lines (strcat (gemini-parser::prefix text)
|
|
(tui-string->chars-string (normal-text row))))))
|
|
rows))
|
|
|
|
(defmethod text->rendered-lines-rows (window (text gemini-parser:header-line))
|
|
(collect-lines-from-ir text window))
|
|
|
|
(defmethod text->rendered-lines-rows (window (text gemini-parser:unordered-list-line))
|
|
(collect-lines-from-ir text window))
|
|
|
|
(defmethod text->rendered-lines-rows (window (text gemini-parser:link-line))
|
|
(let ((res (make-instance 'line :normal-text (gemini-parser:link-text text))))
|
|
(row-add-original-object res text)
|
|
(row-add-group-id res (gemini-parser:group-id text))
|
|
res)) ; even if row-add-original-object returns the modified line explicit returns for clarity
|
|
|
|
(defun %fit-text (window text)
|
|
(let ((lines (split-lines text)))
|
|
(%fit-lines window lines)))
|
|
|
|
(defun %fit-lines (window lines
|
|
&key
|
|
(width (win-width-no-border window))
|
|
(empty-line-transform-fn (lambda () (make-render-vspace-row))))
|
|
(let ((res ()))
|
|
(loop for line in lines do
|
|
(cond
|
|
((string-empty-p (trim-blanks line))
|
|
(push (funcall empty-line-transform-fn) res))
|
|
(t
|
|
(loop for fitted-line in (flush-left-mono-text (split-words line) width) do
|
|
(push fitted-line res)))))
|
|
(reverse res)))
|
|
|
|
(defgeneric text->line (object))
|
|
|
|
(defmethod text->line ((object line))
|
|
object)
|
|
|
|
(defmethod text->line (object)
|
|
(make-instance 'line
|
|
:normal-text object))
|
|
|
|
(defgeneric line->text (object))
|
|
|
|
(defmethod line->text ((object line))
|
|
(tui-string->chars-string (normal-text object)))
|
|
|
|
(defmethod line->text ((object sequence))
|
|
(map 'list #'line->text object))
|
|
|
|
(defmethod text->rendered-lines-rows (window (text string))
|
|
(let* ((fitted-lines (%fit-text window text))
|
|
(new-rows (colorize-lines fitted-lines)))
|
|
(mapcar #'text->line new-rows)))
|
|
|
|
(defmethod text->rendered-lines-rows (window (text gemini-parser:simple-line))
|
|
(let* ((fitted-lines (%fit-text window (gemini-parser:text-line text)))
|
|
(new-rows (colorize-lines fitted-lines)))
|
|
(mapcar (lambda (text-line)
|
|
(let ((res (text->line text-line)))
|
|
(row-add-original-object res text)
|
|
(row-add-group-id res (gemini-parser:group-id text))))
|
|
new-rows)))
|
|
|
|
(defun remove-invisible-rows (rows)
|
|
(remove-if #'row-invisible-p rows))
|
|
|
|
(defmethod text->rendered-lines-rows (window (text line))
|
|
text)
|
|
|
|
(defmethod rows ((object message-window))
|
|
(with-slots (rows) object
|
|
(remove-invisible-rows rows)))
|
|
|
|
(defmethod colorize-lines ((object line))
|
|
object)
|
|
|
|
(defmethod colorize-lines ((object c: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 viewport-width ((object message-window))
|
|
(windows:win-width-no-border object))
|
|
|
|
(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 (and jump-to-first-row
|
|
(not (rows-empty-p object)))
|
|
(select-row object 0))
|
|
object)
|
|
|
|
(defun offset-to-move-end (win)
|
|
(with-accessors ((rows rows)
|
|
(row-selected-index row-selected-index)) win
|
|
(let ((win-height (win-height-no-border win)))
|
|
(- (- (rows-length win)
|
|
(- win-height 1))
|
|
row-selected-index))))
|
|
|
|
(defun scroll-end-reached-p (win)
|
|
(with-accessors ((rows rows)
|
|
(row-selected-index row-selected-index)) win
|
|
(let* ((win-height (win-height-no-border win))
|
|
(rows-left (- (rows-length win) row-selected-index)))
|
|
(< rows-left
|
|
win-height))))
|
|
|
|
(defmethod scroll-down ((object message-window) &optional (amount 1))
|
|
(when (not (or (scroll-end-reached-p object)
|
|
(= (row-move object amount)
|
|
0)))
|
|
(draw object)))
|
|
|
|
(defmethod scroll-up ((object message-window) &optional (amount 1))
|
|
(when (/= (row-move object (- amount))
|
|
0)
|
|
(draw object)))
|
|
|
|
(defmethod scroll-left ((object message-window) &optional (amount 1))
|
|
(with-accessors ((text-starting-column text-starting-column)) object
|
|
(when (> text-starting-column 0)
|
|
(decf text-starting-column amount)
|
|
(draw object))))
|
|
|
|
(defmethod scroll-right ((object message-window) &optional (amount 1))
|
|
(with-accessors ((text-starting-column text-starting-column)) object
|
|
(incf text-starting-column amount)
|
|
(draw object)))
|
|
|
|
(defmethod scroll-end ((object message-window))
|
|
(with-accessors ((rows rows)
|
|
(row-selected-index row-selected-index)) object
|
|
(let ((offset (offset-to-move-end object)))
|
|
(when (/= (row-move object offset)
|
|
0)
|
|
(draw object)))))
|
|
|
|
(defmethod scroll-begin ((object message-window))
|
|
(with-accessors ((rows rows)
|
|
(row-selected-index row-selected-index)) object
|
|
(when (/= (row-move object (- row-selected-index))
|
|
0)
|
|
(draw object))))
|
|
|
|
(defmethod scroll-next-page ((object message-window))
|
|
(with-accessors ((rows rows)
|
|
(row-selected-index row-selected-index)) object
|
|
(let ((actual-window-height (1- (win-height-no-border object)))
|
|
(rows-length (rows-length object)))
|
|
(when (and (> (- rows-length
|
|
row-selected-index)
|
|
actual-window-height)
|
|
(/= (row-move object (min actual-window-height
|
|
(- rows-length
|
|
(+ row-selected-index
|
|
actual-window-height))))
|
|
0))
|
|
(draw object)))))
|
|
|
|
(defmethod scroll-previous-page ((object message-window))
|
|
(when (/= (row-move object (- (win-height-no-border object)))
|
|
0)
|
|
(draw object)))
|
|
|
|
(defun first-line->string (window)
|
|
(with-accessors ((row-selected-index row-selected-index)) window
|
|
(let ((complex (normal-text (rows-elt window row-selected-index))))
|
|
(values (tui-string->chars-string complex)
|
|
complex))))
|
|
|
|
(defmethod search-regex ((object message-window) regex)
|
|
(with-accessors ((row-selected-index row-selected-index)) object
|
|
(when-let ((selected-row (selected-row object)))
|
|
(let* ((selected-text (normal-text selected-row))
|
|
(actual-row-starting (if (scan regex
|
|
(tui-string->chars-string selected-text))
|
|
(1+ row-selected-index)
|
|
row-selected-index))
|
|
(line-found (rows-position-if object
|
|
(lambda (a)
|
|
(scan regex
|
|
(tui-string->chars-string (normal-text a))))
|
|
:start (clamp actual-row-starting
|
|
0
|
|
(rows-length object))))
|
|
(replacements-strings ()))
|
|
(when line-found
|
|
(row-move object (- line-found row-selected-index))
|
|
(draw object)
|
|
(multiple-value-bind (first-window-line-simple first-window-line-complex)
|
|
(first-line->string object)
|
|
(labels ((calc-highlight (&optional (start-scan 0))
|
|
(multiple-value-bind (start end)
|
|
(scan regex first-window-line-simple :start start-scan)
|
|
(when start
|
|
(let* ((mask (make-tui-string (subseq first-window-line-simple
|
|
start end)
|
|
:fgcolor (win-bgcolor object)
|
|
:bgcolor (win-fgcolor object)))
|
|
(prefix (tui-string-subseq first-window-line-complex
|
|
0
|
|
start))
|
|
(new-prefix (cat-tui-string prefix mask)))
|
|
(push new-prefix replacements-strings)
|
|
(calc-highlight end)))))
|
|
(highlight ()
|
|
(loop for replacement in replacements-strings do
|
|
(print-text object replacement 1 1))))
|
|
(calc-highlight)
|
|
(highlight))))))))
|
|
|
|
(defmethod jump-to-group-id ((object message-window) gid-looking-for)
|
|
(when-let ((line-found (rows-position-if object
|
|
(lambda (a)
|
|
(when-let ((header (row-get-original-object a)))
|
|
(when (typep header 'gemini-parser:header-line)
|
|
(let ((gid (gemini-parser:group-id header)))
|
|
(= gid gid-looking-for)))))
|
|
:start 0)))
|
|
(select-row object 0)
|
|
(row-move object line-found)
|
|
(draw object)))
|
|
|
|
|
|
(defun gemini-sexp->toc-plist (all-headers
|
|
extract-header-fn
|
|
extract-level-fn
|
|
extract-gid-fn
|
|
extract-header-line-fn)
|
|
(let* ((toc-number (make-list gemini-parser:+max-header-level+ :initial-element 0))
|
|
(current-gid -1)
|
|
(toc (loop for row in all-headers
|
|
collect
|
|
(let* ((header (funcall extract-header-fn row))
|
|
(level (funcall extract-level-fn header))
|
|
(gid (funcall extract-gid-fn header)))
|
|
(when (/= gid current-gid)
|
|
(setf current-gid gid)
|
|
(incf (elt toc-number (1- level)))
|
|
(loop for i from level below (length toc-number) do
|
|
(setf (elt toc-number i) 0))
|
|
(loop for i from (- level 2 ) downto 0
|
|
when (= (elt toc-number i) 0) do
|
|
(setf (elt toc-number i) 1))
|
|
(list :header (funcall extract-header-line-fn header)
|
|
:group-id gid
|
|
:number (subseq toc-number
|
|
0
|
|
level)))))))
|
|
(remove-if #'null toc)))
|
|
|
|
(defmethod generate-gemini-toc ((object message-window))
|
|
(let* ((all-headers (remove-if-not (lambda (a)
|
|
(typep (row-get-original-object a)
|
|
'gemini-parser:header-line))
|
|
(rows object)))
|
|
(toc (gemini-sexp->toc-plist all-headers
|
|
#'row-get-original-object
|
|
#'gemini-parser:level
|
|
#'gemini-parser:group-id
|
|
(lambda (header)
|
|
;; just the first line
|
|
;; contains the header
|
|
;; text the second
|
|
;; contains the
|
|
;; underline
|
|
(first (gemini-parser:lines header))))))
|
|
(remove-if #'null toc)))
|
|
|
|
(defun gemini-toc-header (fields)
|
|
(getf fields :header))
|
|
|
|
(defun gemini-toc-max-number-length (toc)
|
|
(* 2
|
|
(num:find-max (mapcar (lambda (a) (length (getf a :number)))
|
|
toc))))
|
|
|
|
(defun gemini-toc-number (fields toc)
|
|
(let ((raw (mapcar #'to-s (getf fields :number)))
|
|
(max-number-length (gemini-toc-max-number-length toc)))
|
|
(right-padding (join-with-strings raw ".")
|
|
max-number-length
|
|
:padding-char (swconf:gemini-toc-padding-char))))
|
|
|
|
(defun gemini-toc-entry (fields toc)
|
|
(format nil "~a ~a" (gemini-toc-number fields toc) (gemini-toc-header fields)))
|
|
|
|
(defun gemini-toc-group-id (fields)
|
|
(getf fields :group-id))
|
|
|
|
(defun message-window-title ()
|
|
(if command-line:*gemini-full-screen-mode*
|
|
(_ "Gemini stream")
|
|
(_ "Messages")))
|
|
|
|
(defun init ()
|
|
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
|
|
(setf *message-window*
|
|
(make-instance 'message-window
|
|
:title (message-window-title)
|
|
:keybindings keybindings:*message-keymap*
|
|
:key-config swconf:+key-message-window+
|
|
:croatoan-window low-level-window))
|
|
(refresh-config *message-window*)
|
|
(draw *message-window*)
|
|
*message-window*))
|
|
|
|
(defun original-source-metadata (row)
|
|
(let* ((original-line (row-get-original-object row))
|
|
(source-line (gemini-parser:source-line original-line))
|
|
(source-line-id (gemini-parser:source-line-id original-line))
|
|
(artificialp (gemini-parser:artificialp original-line)))
|
|
(values source-line-id source-line artificialp)))
|
|
|
|
(defun search-gemini-fragment (window fragment)
|
|
"Search `fragment' in the source lines of the gemini steams and -if
|
|
fragment matches- move the window to the line when matching occurred."
|
|
(labels ((prefix-diff (text-rows source-line)
|
|
(- (length (first (split-words (first text-rows))))
|
|
(length (first (split-words source-line)))))
|
|
(reconstruct-source-lines (text-rows blanks &optional (accum '()))
|
|
(if (null text-rows)
|
|
(mapcar (lambda (a) (reduce #'strcat a)) accum)
|
|
(let ((text-rows-words (remove-if #'string-empty-p
|
|
(split-words (first text-rows)))))
|
|
(multiple-value-bind (reconstructed rest-blanks)
|
|
(reconstruct-source-line text-rows-words blanks)
|
|
(reconstruct-source-lines (rest text-rows)
|
|
rest-blanks
|
|
(append accum (list reconstructed)))))))
|
|
(quoted-line-p (row)
|
|
(typep (row-get-original-object row) 'gemini-parser:quoted-lines))
|
|
(strip-prefix-from-quoted-lines (text-rows prefix)
|
|
(append (list (first text-rows))
|
|
(mapcar (lambda (a) (regex-replace prefix a ""))
|
|
(rest text-rows))))
|
|
(rows->text-rows (rows)
|
|
(let ((text-rows (mapcar (lambda (a)
|
|
(tui-string->chars-string (normal-text a)))
|
|
rows)))
|
|
(if (quoted-line-p (first rows))
|
|
(let ((prefix (gemini-parser::prefix (row-get-original-object (first rows)))))
|
|
(strip-prefix-from-quoted-lines text-rows prefix))
|
|
text-rows)))
|
|
(reconstruct-source-line (words blanks)
|
|
(let ((rest-blanks '())
|
|
(res '()))
|
|
(loop for word in words
|
|
for blank in blanks
|
|
for ct from 1
|
|
do
|
|
(push word res)
|
|
(push blank res)
|
|
finally (setf rest-blanks (subseq blanks ct)))
|
|
(values (reverse res) rest-blanks))))
|
|
(with-accessors ((row-selected-index row-selected-index)) window
|
|
(let ((rest-rows (rest (rows-safe-subseq window row-selected-index)))
|
|
(matching-source-line nil)
|
|
(matching-source-id nil)
|
|
(matching-source-position nil)
|
|
(starting-match-row-pos nil))
|
|
(loop named sid-loop
|
|
for i from 0 below (length rest-rows)
|
|
for count-line-to-start-matching from 0
|
|
for current-row in rest-rows do
|
|
(multiple-value-bind (source-line-id source-line)
|
|
(original-source-metadata current-row)
|
|
(let* ((matching-string-pos (scan fragment source-line)))
|
|
(when matching-string-pos
|
|
(setf starting-match-row-pos count-line-to-start-matching)
|
|
(setf matching-source-line source-line)
|
|
(setf matching-source-id source-line-id)
|
|
(setf matching-source-position matching-string-pos)
|
|
(return-from sid-loop t)))))
|
|
(when matching-source-id
|
|
(let* ((matching-rows (remove-if-not (lambda (a)
|
|
(multiple-value-bind (source-line-id x artificialp)
|
|
(original-source-metadata a)
|
|
(declare (ignore x))
|
|
(and (not artificialp)
|
|
(= source-line-id matching-source-id))))
|
|
rest-rows))
|
|
(text-rows (rows->text-rows matching-rows))
|
|
(matching-source-blanks (extract-blanks matching-source-line))
|
|
(reconstructed-rows (reconstruct-source-lines text-rows matching-source-blanks))
|
|
(line-matched (loop
|
|
for reconstructed-row in reconstructed-rows
|
|
for line from 1
|
|
for length-accum = (length reconstructed-row)
|
|
then (+ length-accum
|
|
(length reconstructed-row))
|
|
while (<= (- length-accum
|
|
(prefix-diff text-rows matching-source-line))
|
|
matching-source-position)
|
|
finally (return line))))
|
|
(row-move window (+ starting-match-row-pos line-matched))
|
|
(draw window)))))))
|
|
|
|
(defmethod lines->uri ((object message-window))
|
|
(flatten (map-rows object
|
|
(lambda (row)
|
|
(when-let* ((text-line (line->text row))
|
|
(uri (lines->uri text-line)))
|
|
uri)))))
|