1
0
Fork 0
tinmop/src/message-window.lisp

369 lines
14 KiB
Common Lisp
Raw Normal View History

2020-09-06 11:32:08 +02:00
;; tinmop: an humble gemini and pleroma client
2020-05-08 15:45:43 +02:00
;; Copyright (C) 2020 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)
(defclass message-window (wrapper-window
row-oriented-widget
focus-marked-window
title-window)
((support-text
:initform nil
:initarg :support-text
:reader support-text)
2020-05-08 15:45:43 +02:00
(line-position-mark
:initform (make-tui-string "0")
:initarg :line-position-mark
:accessor line-position-mark)
(metadata
:initform nil
:initarg :metadata
:accessor metadata)))
(defun gemini-window-p ()
(gemini-viewer:gemini-metadata-p (message-window:metadata specials:*message-window*)))
(defun display-gemini-text-p (window)
(eq (keybindings window)
keybindings:*gemini-message-keymap*))
2020-05-08 15:45:43 +02:00
2020-09-06 17:28:16 +02:00
(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*)))
(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)))
2020-05-08 15:45:43 +02:00
(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* ((thread-window-width (win-width *thread-window*))
(thread-window-height (win-height *thread-window*))
(command-window-height (win-height *command-window*))
(main-window-height (win-height *main-window*))
(height (- main-window-height
command-window-height
thread-window-height))
(width thread-window-width)
(x (win-x *thread-window*))
(y (+ (win-y *thread-window*)
thread-window-height)))
(win-resize object width height)
(win-move object x y)))
(defmethod calculate ((object message-window) dt)
(declare (ignore object dt)))
(defun draw-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
for y from 1 below (win-height-no-border window)
do
(cond
((invisible-row-p line)
(decf y))
((not (vspace-row-p line))
(let ((text-line (normal-text line)))
(print-text window text-line 1 y))))))))
2020-05-08 15:45:43 +02:00
(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))
2020-05-08 15:45:43 +02:00
(fraction (/ row-selected-index
(max 1 rows-count)))
2020-05-08 15:45:43 +02:00
(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))
2020-05-08 15:45:43 +02:00
(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))
2020-05-08 15:45:43 +02:00
(defgeneric scroll-down (object &optional amount))
(defgeneric scroll-up (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 text->rendered-lines-rows (window text))
(defun make-render-vspace-row ()
(make-instance 'line
:normal-text (make-tui-string "")))
(defun vspace-row-p (row)
(string-empty-p (normal-text row)))
(defun make-invisible-row ()
(make-instance 'line
:fields (list :invisible t)
:normal-text (make-tui-string "")))
(defun invisible-row-p (row)
(getf (fields row) :invisible))
(defmethod text->rendered-lines-rows (window (text gemini-parser:pre-start))
(make-invisible-row))
(defmethod text->rendered-lines-rows (window (text gemini-parser:pre-end))
(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)))
(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))
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
collect
(make-instance 'line
:normal-text i))))
(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))
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)
(make-instance 'line
:normal-text text-line))
new-rows)))))
(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 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)
(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))))
2020-05-08 15:45:43 +02:00
(defmethod scroll-down ((object message-window) &optional (amount 1))
(when (not (or (scroll-end-reached-p object)
(= (row-move object amount)
0)))
2020-05-08 15:45:43 +02:00
(draw object)))
(defmethod scroll-up ((object message-window) &optional (amount 1))
(when (/= (row-move object (- amount))
0)
(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)))))
2020-05-08 15:45:43 +02:00
(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 (win-height-no-border object)))
(when (and (> (- (rows-length object)
2020-05-08 15:45:43 +02:00
row-selected-index)
actual-window-height)
(/= (row-move object 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))))
2020-05-08 15:45:43 +02:00
(defmethod search-regex ((object message-window) regex)
(with-accessors ((row-selected-index row-selected-index)) object
(let ((line-found (rows-position-if object
(lambda (a)
(scan regex
(tui-string->chars-string (normal-text a))))
:start (min (1+ row-selected-index)
(rows-length object))))
(replacements-strings ()))
(if line-found
(progn
(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))))
(line-oriented-window:cleanup-after-search object)))))
2020-05-08 15:45:43 +02:00
(defun init ()
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
(setf *message-window*
(make-instance 'message-window
:title (_ "Messages")
:keybindings keybindings:*message-keymap*
:key-config swconf:+key-message-window+
:croatoan-window low-level-window))
(refresh-config *message-window*)
(draw *message-window*)
*message-window*))
(defgeneric viewport-width (object))
(defmethod viewport-width ((object message-window))
(windows:win-width-no-border object))