mirror of https://codeberg.org/cage/tinmop/
1099 lines
50 KiB
Common Lisp
1099 lines
50 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 :thread-window)
|
|
|
|
(defclass thread-window (modeline-window
|
|
tree-holder
|
|
row-oriented-widget
|
|
focus-marked-window
|
|
title-window)
|
|
((favourite-text
|
|
:initform "+1"
|
|
:initarg :favourite-text
|
|
:accessor favourite-text)
|
|
(boosted-text
|
|
:initform "^"
|
|
:initarg :boosted-text
|
|
:accessor boosted-text)
|
|
(sensitive-text
|
|
:initform "!"
|
|
:initarg :sensitive-text
|
|
:accessor sensitive-text)
|
|
(root-text
|
|
:initform "*"
|
|
:initarg :root-text
|
|
:accessor root-text)
|
|
(favourite-text-off
|
|
:initform "~+1"
|
|
:initarg :favourite-text-off
|
|
:accessor favourite-text-off)
|
|
(boosted-text-off
|
|
:initform "~^"
|
|
:initarg :boosted-text-off
|
|
:accessor boosted-text-off)
|
|
(sensitive-text-off
|
|
:initform "!"
|
|
:initarg :sensitive-text-off
|
|
:accessor sensitive-text-off)
|
|
(root-text-off
|
|
:initform "*"
|
|
:initarg :root-text-off
|
|
:accessor root-text-off)
|
|
(read-fg
|
|
:initform :black
|
|
:initarg :read-fg
|
|
:accessor read-fg)
|
|
(read-bg
|
|
:initform :cyan
|
|
:initarg :read-bg
|
|
:accessor read-bg)
|
|
(read-attribute
|
|
:initform :nil
|
|
:initarg :read-attribute
|
|
:accessor read-attribute)
|
|
(unread-fg
|
|
:initform :black
|
|
:initarg :unread-fg
|
|
:accessor unread-fg)
|
|
(unread-bg
|
|
:initform :cyan
|
|
:initarg :unread-bg
|
|
:accessor unread-bg)
|
|
(unread-attribute
|
|
:initform :nil
|
|
:initarg :unread-attribute
|
|
:accessor unread-attribute)
|
|
(selected-fg
|
|
:initform :black
|
|
:initarg :selected-fg
|
|
:accessor selected-fg)
|
|
(selected-bg
|
|
:initform :cyan
|
|
:initarg :selected-bg
|
|
:accessor selected-bg)
|
|
(selected-attribute
|
|
:initform :nil
|
|
:initarg :selected-attribute
|
|
:accessor selected-attribute)
|
|
(deleted-fg
|
|
:initform :black
|
|
:initarg :deleted-fg
|
|
:accessor deleted-fg)
|
|
(deleted-bg
|
|
:initform :cyan
|
|
:initarg :deleted-bg
|
|
:accessor deleted-bg)
|
|
(deleted-attribute
|
|
:initform :nil
|
|
:initarg :deleted-attribute
|
|
:accessor deleted-attribute)
|
|
(date-format
|
|
:initform '(:year " " :month " " :day " " :hour ":" :minute)
|
|
:initarg :date-format
|
|
:accessor date-format)
|
|
(timeline-type
|
|
:initform db:+local-timeline+
|
|
:initarg :timeline-type
|
|
:accessor timeline-type)
|
|
(timeline-folder
|
|
:initform db:+default-status-folder+
|
|
:initarg :timeline-folder
|
|
:accessor timeline-folder)
|
|
(mentions
|
|
:initform ()
|
|
:initarg :mentions
|
|
:accessor mentions)
|
|
(announcements
|
|
:initform nil
|
|
:initarg :announcements
|
|
:accessor announcements)))
|
|
|
|
|
|
(defmacro lambda-ignore-args (args &body body)
|
|
`(lambda (,@args)
|
|
(declare (ignore ,@args))
|
|
,@body))
|
|
|
|
(defun make-tui-modeline-text (window text)
|
|
(with-accessors ((modeline-fg modeline-fg)
|
|
(modeline-bg modeline-bg)) window
|
|
(make-tui-string text :fgcolor modeline-fg :bgcolor modeline-bg)))
|
|
|
|
(defmacro with-tuify-results ((window) form)
|
|
`(make-tui-modeline-text ,window ,form))
|
|
|
|
(defun modeline-bold-expand (window text)
|
|
(with-accessors ((modeline-fg modeline-fg)
|
|
(modeline-bg modeline-bg)) window
|
|
(make-tui-string text
|
|
:fgcolor modeline-fg
|
|
:bgcolor modeline-bg
|
|
:attributes (attribute-bold))))
|
|
|
|
(defun expand-timeline-type (window)
|
|
(with-accessors ((timeline-type timeline-type)) window
|
|
(let* ((actual-timeline (if (string-not-empty-p timeline-type)
|
|
timeline-type
|
|
(_ "no timeline selected")))
|
|
(timeline-description (db:timeline-type->description actual-timeline)))
|
|
(modeline-bold-expand window timeline-description))))
|
|
|
|
(defun expand-folder-name (window)
|
|
(with-accessors ((timeline-folder timeline-folder)) window
|
|
(let ((folder (if (string-not-empty-p timeline-folder)
|
|
timeline-folder
|
|
(_ "no folder selected"))))
|
|
(modeline-bold-expand window folder))))
|
|
|
|
(defun expand-message-hashtags (window)
|
|
(let ((selected-row (selected-row window)))
|
|
(if selected-row
|
|
(with-tuify-results (window)
|
|
(db-utils:db-getf (fields selected-row) :tags))
|
|
"")))
|
|
|
|
(defun expand-total-messages (window)
|
|
(with-accessors ((timeline-folder timeline-folder)
|
|
(timeline-type timeline-type)) window
|
|
(if (and timeline-folder
|
|
timeline-type)
|
|
(with-tuify-results (window)
|
|
(to-s (db:count-status timeline-type
|
|
timeline-folder
|
|
:account-id nil)))
|
|
"")))
|
|
|
|
(defun expand-redp-messages (window)
|
|
(with-accessors ((timeline-folder timeline-folder)
|
|
(timeline-type timeline-type)) window
|
|
(if (and timeline-folder
|
|
timeline-type)
|
|
(with-tuify-results (window)
|
|
(to-s (db:count-status-redp timeline-type
|
|
timeline-folder
|
|
:account-id nil)))
|
|
"")))
|
|
|
|
(defun expand-mentions (window)
|
|
(with-accessors ((mentions mentions)) window
|
|
(if mentions
|
|
(with-tuify-results (window)
|
|
(format nil
|
|
"~a(~a)"
|
|
(swconf:config-notification-icon)
|
|
(length mentions)))
|
|
"")))
|
|
|
|
(defun expand-announcements (window)
|
|
(with-accessors ((announcements announcements)) window
|
|
(if announcements
|
|
(with-tuify-results (window)
|
|
(format nil
|
|
"~a"
|
|
(swconf:config-announcements-icon)))
|
|
"")))
|
|
|
|
(defun default-expander ()
|
|
(list (cons "%" (lambda (w) (with-tuify-results (w) "%")))
|
|
(cons "s" (lambda (w) (with-tuify-results (w) (swconf:current-server-name))))
|
|
(cons "u" (lambda (w) (with-tuify-results (w) (swconf:current-username))))
|
|
(cons "k" #'expand-timeline-type)
|
|
(cons "f" #'expand-folder-name)
|
|
(cons "h" #'expand-message-hashtags)
|
|
(cons "t" #'expand-total-messages)
|
|
(cons "r" #'expand-redp-messages)
|
|
(cons "m" #'expand-mentions)
|
|
(cons "A" #'expand-announcements)))
|
|
|
|
(defmethod initialize-instance :after ((object thread-window) &key &allow-other-keys)
|
|
(with-accessors ((mapping-code->fn mapping-code->fn)) object
|
|
(setf mapping-code->fn
|
|
(default-expander))))
|
|
|
|
(defmethod refresh-config :after ((object thread-window))
|
|
(refresh-config-colors object swconf:+key-thread-window+)
|
|
(refresh-config-sizes object swconf:+key-thread-window+)
|
|
(refresh-modeline-config object swconf:+key-thread-window+)
|
|
(with-accessors ((read-fg read-fg)
|
|
(read-bg read-bg)
|
|
(read-attribute read-attribute)
|
|
(unread-fg unread-fg)
|
|
(unread-bg unread-bg)
|
|
(unread-attribute unread-attribute)
|
|
(selected-fg selected-fg)
|
|
(selected-bg selected-bg)
|
|
(selected-attribute selected-attribute)
|
|
(deleted-fg deleted-fg)
|
|
(deleted-bg deleted-bg)
|
|
(deleted-attribute deleted-attribute)
|
|
(favourite-text-off favourite-text-off)
|
|
(boosted-text-off boosted-text-off)
|
|
(sensitive-text-off sensitive-text-off)
|
|
(date-format date-format)) object
|
|
(setf date-format (swconf:date-fmt swconf:+key-thread-window+))
|
|
(multiple-value-bind (cfg-read-bg cfg-read-fg cfg-read-attribute)
|
|
(swconf:thread-message-read-colors)
|
|
(multiple-value-bind (cfg-unread-bg cfg-unread-fg cfg-unread-attribute)
|
|
(swconf:thread-message-unread-colors)
|
|
(multiple-value-bind (cfg-selected-bg cfg-selected-fg cfg-selected-attribute)
|
|
(swconf:thread-message-selected-colors)
|
|
(multiple-value-bind (cfg-deleted-bg cfg-deleted-fg cfg-deleted-attribute)
|
|
(swconf:thread-message-deleted-colors)
|
|
(setf read-fg cfg-read-fg)
|
|
(setf read-bg cfg-read-bg)
|
|
(setf read-attribute cfg-read-attribute)
|
|
(setf unread-fg cfg-unread-fg)
|
|
(setf unread-bg cfg-unread-bg)
|
|
(setf unread-attribute cfg-unread-attribute)
|
|
(setf selected-fg cfg-selected-fg)
|
|
(setf selected-bg cfg-selected-bg)
|
|
(setf selected-attribute cfg-selected-attribute)
|
|
(setf deleted-fg cfg-deleted-fg)
|
|
(setf deleted-bg cfg-deleted-bg)
|
|
(setf deleted-attribute cfg-deleted-attribute)))))
|
|
(flet ((set-symbol (slot-on slot-off key)
|
|
(multiple-value-bind (value fg)
|
|
(swconf:thread-message-symbol key)
|
|
(setf (slot-value object slot-on)
|
|
(make-tui-string value :fgcolor fg))
|
|
(setf (slot-value object slot-off)
|
|
(make-tui-string value
|
|
:fgcolor fg
|
|
:attributes (attribute-invisible))))))
|
|
(set-symbol 'favourite-text 'favourite-text-off swconf:+key-favourite+)
|
|
(set-symbol 'sensitive-text 'sensitive-text-off swconf:+key-sensitive+)
|
|
(set-symbol 'boosted-text 'boosted-text-off swconf:+key-boosted+)
|
|
(set-symbol 'root-text 'root-text-off swconf:+key-root+))
|
|
(win-move object
|
|
(- (win-width *main-window*)
|
|
(win-width object))
|
|
0)))
|
|
|
|
(defmethod calculate ((object thread-window) dt))
|
|
|
|
(defun render-messages (window)
|
|
(let ((y 1))
|
|
(map-rows window
|
|
(lambda (message)
|
|
(cond
|
|
((selectedp message)
|
|
(print-text window (selected-text message) 1 y))
|
|
((marked-to-delete-p message)
|
|
(print-text window (deleted-text message) 1 y))
|
|
(t
|
|
(print-text window (normal-text message) 1 y)))
|
|
(incf y)))
|
|
(expand-modeline-spec window)
|
|
(win-refresh window)))
|
|
|
|
(defmethod draw ((object thread-window))
|
|
(when-window-shown (object)
|
|
(win-clear object :redraw nil)
|
|
(win-box object)
|
|
(render-messages object)
|
|
(call-next-method)))
|
|
|
|
(defgeneric build-lines (object annotated-tree selected-pos))
|
|
|
|
(defgeneric go-message-down (object))
|
|
|
|
(defgeneric go-message-up (object))
|
|
|
|
(defgeneric goto-message (object message-index &key redraw))
|
|
|
|
(defgeneric goto-first-message (object))
|
|
|
|
(defgeneric goto-last-message (object))
|
|
|
|
(defgeneric open-message (object))
|
|
|
|
(defgeneric mark-selected-message-to-delete (object &key move-down-selected-message))
|
|
|
|
(defgeneric mark-selected-message-prevent-delete (object &key move-down-selected-message))
|
|
|
|
(defgeneric search-next-message-body (object text-looking-for))
|
|
|
|
(defgeneric search-previous-message-body (object text-looking-for))
|
|
|
|
(defgeneric search-next-message-meta (object text-looking-for))
|
|
|
|
(defgeneric search-next-unread (object))
|
|
|
|
(defgeneric search-previous-message-meta (object text-looking-for))
|
|
|
|
(defgeneric add-mention (object mention))
|
|
|
|
(defgeneric remove-mention (object status-id))
|
|
|
|
(defgeneric add-announcements-notification (object))
|
|
|
|
(defgeneric remove-announcements-notification (object))
|
|
|
|
(defun message-root (tree)
|
|
(mtree:root-node tree))
|
|
|
|
(defun tree-lines (tree)
|
|
(mtree:count-nodes tree))
|
|
|
|
(defun grow-tree-to-fit-window (timeline-type
|
|
folder
|
|
message-index
|
|
desired-window-position
|
|
window-height
|
|
&key
|
|
(arrow-char ">")
|
|
(spacer-child "-")
|
|
(child-char "+")
|
|
(line-char "|")
|
|
(last-child-char "."))
|
|
"Note: assumes that the message are numbered in a BFS fashion, also
|
|
no gaps in numbering are allowed. (see mtree:tree->annotated-lines and
|
|
db:renumber-timeline-message-index."
|
|
(labels ((tree-line->data-plist (line)
|
|
(db:annotated-tree-line->data-plist line))
|
|
(plist-message-index (data)
|
|
(db-utils:db-getf data :message-index))
|
|
(tree= (a b)
|
|
(db:message-tree-root-equal a b))
|
|
(tree->annotated-tree (tree)
|
|
(tree->annotated-lines tree
|
|
:arrow-char arrow-char
|
|
:spacer-child spacer-child
|
|
:child-char child-char
|
|
:line-char line-char
|
|
:last-child-char last-child-char
|
|
:print-data t
|
|
:print-data-fn #'identity))
|
|
(slice-annotated-tree-lines (annotated-tree-lines
|
|
starting-message-index
|
|
ending-message-index)
|
|
(flet ((line-pos (lines message-index)
|
|
(position-if (lambda (a)
|
|
(let ((row (tree-line->data-plist a)))
|
|
(= message-index
|
|
(plist-message-index row))))
|
|
lines)))
|
|
(let* ((slice-start (line-pos annotated-tree-lines starting-message-index))
|
|
(slice-end (line-pos annotated-tree-lines ending-message-index))
|
|
(slice (subseq annotated-tree-lines
|
|
slice-start
|
|
slice-end))
|
|
(selected-pos (line-pos slice message-index)))
|
|
(values slice selected-pos)))))
|
|
(let ((starting-message-index (- message-index desired-window-position))
|
|
(end-message-index (+ message-index (- window-height
|
|
desired-window-position)))
|
|
(trees ())
|
|
(tree-lines ()))
|
|
(loop
|
|
for scan-index from starting-message-index to end-message-index
|
|
when (db:message-from-timeline-folder-message-index timeline-type
|
|
folder
|
|
scan-index)
|
|
do
|
|
(let ((tree (db:message-index->tree timeline-type folder scan-index)))
|
|
(pushnew tree trees :test #'tree=)))
|
|
(if (null trees)
|
|
(values nil nil)
|
|
(progn
|
|
(a:reversef trees)
|
|
(loop for tree in trees do
|
|
(setf tree-lines (lcat tree-lines (tree->annotated-tree tree))))
|
|
(multiple-value-bind (fitted-lines selected-pos)
|
|
(slice-annotated-tree-lines tree-lines
|
|
starting-message-index
|
|
end-message-index)
|
|
(values fitted-lines selected-pos)))))))
|
|
|
|
(defun fit-timeline-to-window (window message-index)
|
|
(with-accessors ((render-arrow-value render-arrow-value)
|
|
(render-leaf-value render-leaf-value)
|
|
(render-branch-value render-branch-value)
|
|
(render-spacer-value render-spacer-value)
|
|
(render-vertical-line-value render-vertical-line-value)
|
|
(timeline-folder timeline-folder)
|
|
(timeline-type timeline-type)) window
|
|
(let* ((window-height (win-height-no-border window))
|
|
(message-sequence-index (db:message-index->sequence-index message-index))
|
|
(window-selected-row-position (rem message-sequence-index window-height)))
|
|
(multiple-value-bind (annotated-tree selected-pos)
|
|
(grow-tree-to-fit-window timeline-type
|
|
timeline-folder
|
|
message-index
|
|
window-selected-row-position
|
|
window-height
|
|
:arrow-char render-arrow-value
|
|
:spacer-child render-spacer-value
|
|
:child-char render-branch-value
|
|
:line-char render-vertical-line-value
|
|
:last-child-char render-leaf-value)
|
|
(values annotated-tree selected-pos)))))
|
|
|
|
(defun annotated-line->message-subject (line)
|
|
(let* ((subject-placeholder (_ "Missing subject"))
|
|
(data-element (db:annotated-tree-line->data-plist line))
|
|
(subject (or (db:row-message-subject data-element)
|
|
subject-placeholder)))
|
|
#+debug-mode (join-with-strings* " " subject (db:row-message-status-id data-element))
|
|
#-debug-mode subject))
|
|
|
|
(defmethod build-lines ((object list) annotated-tree selected-pos)
|
|
(let* ((renderizable-tree (mapcar (lambda (line)
|
|
(let* ((annotation (annotated-text-symbol (a:last-elt line)))
|
|
(new-line (copy-list line))
|
|
(subject (annotated-line->message-subject line)))
|
|
(setf (a:last-elt new-line)
|
|
(cons annotation subject))
|
|
new-line))
|
|
annotated-tree))
|
|
(rendered-tree-lines (mapcar (lambda (line)
|
|
(reduce #'cat-tui-string
|
|
(colorize-tree-line line object)
|
|
:initial-value (make-tui-string "")))
|
|
renderizable-tree))
|
|
(fields (mapcar (lambda (line)
|
|
(rest (a:last-elt line)))
|
|
annotated-tree)))
|
|
(values rendered-tree-lines fields)))
|
|
|
|
(defclass row-prefix ()
|
|
((author
|
|
:initform nil
|
|
:initarg :author
|
|
:accessor author)
|
|
(creation-date
|
|
:initform nil
|
|
:initarg :creation-date
|
|
:accessor creation-date)
|
|
(index
|
|
:initform -1
|
|
:initarg :index
|
|
:accessor index)
|
|
(redp
|
|
:initform nil
|
|
:initarg :redp
|
|
:accessor redp)
|
|
(deletedp
|
|
:initform nil
|
|
:initarg :deletedp
|
|
:accessor deletedp)
|
|
(root-message-p
|
|
:initform nil
|
|
:initarg :root-message-p
|
|
:accessor root-message-p)))
|
|
|
|
(defun make-message-row-prefix (window fields index max-index max-author-length)
|
|
(with-accessors ((favourite-text favourite-text)
|
|
(favourite-text-off favourite-text-off)
|
|
(boosted-text boosted-text)
|
|
(boosted-text-off boosted-text-off)
|
|
(sensitive-text sensitive-text)
|
|
(sensitive-text-off sensitive-text-off)
|
|
(date-format date-format)) window
|
|
(flet ((append-space (a)
|
|
(strcat a " ")))
|
|
(let* ((author (db-utils:db-getf fields :username))
|
|
(created-at (db-utils:db-getf fields :created-at))
|
|
(redp (db-utils:db-getf fields :redp))
|
|
(deletedp (db-utils:db-getf fields :deletedp))
|
|
(rootp (not (db-utils:db-getf fields :in-reply-to-id)))
|
|
(encoded-date (db-utils:encode-datetime-string created-at))
|
|
(formatted-date (append-space (format-time encoded-date date-format)))
|
|
(padding-index-count (num:count-digit max-index))
|
|
(padded-index (append-space (text-utils:left-padding (to-s index)
|
|
padding-index-count)))
|
|
(padded-author (append-space (text-utils:right-padding author
|
|
max-author-length))))
|
|
(make-instance 'row-prefix
|
|
:index padded-index
|
|
:creation-date formatted-date
|
|
:author padded-author
|
|
:redp redp
|
|
:deletedp deletedp
|
|
:root-message-p rootp)))))
|
|
|
|
(defun pad-row-prefix (prefixes)
|
|
(flet ((find-max (slot)
|
|
(reduce (lambda (a b) (max a (length (slot-value b slot))))
|
|
prefixes
|
|
:initial-value -1))
|
|
(pad (instance slot total-size)
|
|
(setf (slot-value instance slot)
|
|
(right-padding (slot-value instance slot)
|
|
total-size))))
|
|
(let ((max-index (find-max 'index))
|
|
(max-creation-date (find-max 'creation-date)))
|
|
(loop for prefix in prefixes do
|
|
(pad prefix 'index max-index)
|
|
(pad prefix 'creation-date max-creation-date))
|
|
prefixes)))
|
|
|
|
(defun make-message-row (window rendered-tree-line row-message message-prefix-info)
|
|
(with-accessors ((favourite-text favourite-text)
|
|
(favourite-text-off favourite-text-off)
|
|
(boosted-text boosted-text)
|
|
(boosted-text-off boosted-text-off)
|
|
(sensitive-text sensitive-text)
|
|
(sensitive-text-off sensitive-text-off)
|
|
(root-text root-text)
|
|
(root-text-off root-text-off)
|
|
(read-fg read-fg)
|
|
(read-bg read-bg)
|
|
(read-attribute read-attribute)
|
|
(unread-fg unread-fg)
|
|
(unread-bg unread-bg)
|
|
(unread-attribute unread-attribute)
|
|
(selected-fg selected-fg)
|
|
(selected-bg selected-bg)
|
|
(selected-attribute selected-attribute)
|
|
(deleted-fg deleted-fg)
|
|
(deleted-bg deleted-bg)
|
|
(deleted-attribute deleted-attribute)
|
|
(date-format date-format)) window
|
|
(let* ((max-width (win-width-no-border window))
|
|
(fields (fields row-message))
|
|
(line-total-width (win-width-no-border window))
|
|
(favouritedp (db-utils:db-getf fields :favourited))
|
|
(boostedp (db-utils:db-getf fields :reblogged))
|
|
(sensitivep (db-utils:db-getf fields :sensitive))
|
|
(message (make-tui-string ""))
|
|
(raw-selected-message "")
|
|
(raw-deleted-message "")
|
|
(redp (redp message-prefix-info))
|
|
(rootp (root-message-p message-prefix-info))
|
|
(fg (if redp
|
|
read-fg
|
|
unread-fg))
|
|
(bg (if redp
|
|
read-bg
|
|
unread-bg))
|
|
(attribute (if redp
|
|
read-attribute
|
|
unread-attribute)))
|
|
(labels ((make-colored-string (a)
|
|
(make-tui-string a
|
|
:attributes attribute
|
|
:fgcolor fg
|
|
:bgcolor bg))
|
|
(message-cat (a)
|
|
(setf message (cat-tui-string message a)))
|
|
(selected-message-cat (a)
|
|
(if (typep a 'string)
|
|
(setf raw-selected-message (strcat raw-selected-message a))
|
|
(setf raw-selected-message (strcat raw-selected-message
|
|
(tui-string->chars-string a)))))
|
|
(deleted-message-cat (a)
|
|
(if (typep a 'string)
|
|
(setf raw-deleted-message (strcat raw-deleted-message a))
|
|
(setf raw-deleted-message (strcat raw-deleted-message
|
|
(tui-string->chars-string a)))))
|
|
(selected-message-invisible-text (text)
|
|
(selected-message-cat (build-string (text-length text))))
|
|
(deleted-message-invisible-text (text)
|
|
(deleted-message-cat (build-string (text-length text))))
|
|
(ellipsize (text)
|
|
(text-ellipsis text max-width)))
|
|
(message-cat (make-colored-string (index message-prefix-info)))
|
|
(message-cat (make-colored-string (creation-date message-prefix-info)))
|
|
(message-cat (make-colored-string (author message-prefix-info)))
|
|
(selected-message-cat (index message-prefix-info))
|
|
(selected-message-cat (creation-date message-prefix-info))
|
|
(selected-message-cat (author message-prefix-info))
|
|
(deleted-message-cat (index message-prefix-info))
|
|
(deleted-message-cat (creation-date message-prefix-info))
|
|
(deleted-message-cat (author message-prefix-info))
|
|
(if favouritedp
|
|
(progn
|
|
(deleted-message-cat favourite-text)
|
|
(selected-message-cat favourite-text)
|
|
(message-cat favourite-text))
|
|
(progn
|
|
(deleted-message-invisible-text favourite-text-off)
|
|
(selected-message-invisible-text favourite-text-off)
|
|
(message-cat favourite-text-off)))
|
|
(if boostedp
|
|
(progn
|
|
(deleted-message-cat boosted-text)
|
|
(selected-message-cat boosted-text)
|
|
(message-cat boosted-text))
|
|
(progn
|
|
(deleted-message-invisible-text boosted-text-off)
|
|
(selected-message-invisible-text boosted-text-off)
|
|
(message-cat boosted-text-off)))
|
|
(if sensitivep
|
|
(progn
|
|
(deleted-message-cat sensitive-text)
|
|
(selected-message-cat sensitive-text)
|
|
(message-cat sensitive-text))
|
|
(progn
|
|
(deleted-message-invisible-text sensitive-text-off)
|
|
(selected-message-invisible-text sensitive-text-off)
|
|
(message-cat sensitive-text-off)))
|
|
(if rootp
|
|
(progn
|
|
(deleted-message-cat root-text)
|
|
(selected-message-cat root-text)
|
|
(message-cat root-text))
|
|
(progn
|
|
(deleted-message-invisible-text root-text-off)
|
|
(selected-message-invisible-text root-text-off)
|
|
(message-cat root-text-off)))
|
|
(message-cat rendered-tree-line)
|
|
(selected-message-cat rendered-tree-line)
|
|
(deleted-message-cat rendered-tree-line)
|
|
(let* ((right-padding-string (right-padding-suffix raw-selected-message
|
|
line-total-width))
|
|
(right-padding-special (make-tui-string right-padding-string
|
|
:fgcolor fg
|
|
:bgcolor bg)))
|
|
(message-cat right-padding-special)
|
|
(selected-message-cat right-padding-string)
|
|
(deleted-message-cat right-padding-string)
|
|
(let ((selected-message (make-tui-string raw-selected-message
|
|
:attributes selected-attribute
|
|
:fgcolor selected-fg
|
|
:bgcolor selected-bg))
|
|
(deleted-message (make-tui-string raw-deleted-message
|
|
:attributes deleted-attribute
|
|
:fgcolor deleted-fg
|
|
:bgcolor deleted-bg)))
|
|
(values (ellipsize message)
|
|
(ellipsize selected-message)
|
|
(ellipsize deleted-message))))))))
|
|
|
|
(defmethod build-lines ((object thread-window) annotated-tree selected-pos)
|
|
(with-accessors ((tree-color-map tree-color-map)
|
|
(selected-bg selected-bg)
|
|
(selected-fg selected-fg)
|
|
(timeline-type timeline-type)
|
|
(timeline-folder timeline-folder)
|
|
(row-selected-index row-selected-index)) object
|
|
(if (null annotated-tree)
|
|
(update-all-rows object nil)
|
|
(progn
|
|
(setf row-selected-index selected-pos)
|
|
(multiple-value-bind (tree-lines all-fields)
|
|
(build-lines tree-color-map annotated-tree selected-pos)
|
|
(let* ((prefixes ())
|
|
(new-rows ())
|
|
(message-indices (mapcar (lambda (row)
|
|
(db-utils:db-getf row :message-index))
|
|
all-fields))
|
|
(max-message-index (a:last-elt message-indices))
|
|
(max-author-length (db:max-username-length timeline-type timeline-folder)))
|
|
(loop
|
|
for index from 0
|
|
for message-index in message-indices
|
|
for fields in all-fields do
|
|
(push (make-message-row-prefix object
|
|
fields
|
|
message-index
|
|
max-message-index
|
|
max-author-length)
|
|
prefixes)
|
|
(push (make-instance 'line
|
|
:fields fields
|
|
:selected-bg selected-bg
|
|
:selected-fg selected-fg
|
|
:index index
|
|
:selected (= index selected-pos))
|
|
new-rows))
|
|
(a:nreversef prefixes)
|
|
(a:nreversef new-rows)
|
|
(pad-row-prefix prefixes)
|
|
(loop
|
|
for row in new-rows
|
|
for message-prefix in prefixes
|
|
for rendered-tree-line in tree-lines
|
|
do
|
|
(multiple-value-bind (message selected-message deleted-message)
|
|
(make-message-row object rendered-tree-line row message-prefix)
|
|
(with-accessors ((normal-text normal-text)
|
|
(selected-text selected-text)
|
|
(deleted-text deleted-text)) row
|
|
(setf normal-text message)
|
|
(setf selected-text selected-message)
|
|
(setf deleted-text deleted-message))))
|
|
(update-all-rows object new-rows))))))
|
|
object)
|
|
|
|
(defmethod go-message-down ((object thread-window))
|
|
(with-accessors ((selected-bg selected-bg)
|
|
(selected-fg selected-fg)
|
|
(row-selected-index row-selected-index)
|
|
(timeline-type timeline-type)
|
|
(timeline-folder timeline-folder)) object
|
|
(when (not (rows-empty-p object))
|
|
(let ((new-index (1+ row-selected-index)))
|
|
(if (>= new-index
|
|
(rows-length object))
|
|
(let* ((last-message-index (db:row-message-index (fields (rows-last-elt object))))
|
|
(next-message-index (1+ last-message-index)))
|
|
(when (db:message-from-timeline-folder-message-index timeline-type
|
|
timeline-folder
|
|
next-message-index)
|
|
(multiple-value-bind (tree pos)
|
|
(fit-timeline-to-window object next-message-index)
|
|
(build-lines object tree pos))))
|
|
(progn
|
|
(unselect-all object)
|
|
(select-row object new-index)))
|
|
(draw object)))))
|
|
|
|
(defmethod go-message-up ((object thread-window))
|
|
(with-accessors ((selected-bg selected-bg)
|
|
(selected-fg selected-fg)
|
|
(row-selected-index row-selected-index)
|
|
(timeline-type timeline-type)
|
|
(timeline-folder timeline-folder)
|
|
(rows rows)) object
|
|
(when (not (rows-empty-p object))
|
|
(let ((new-index (1- row-selected-index)))
|
|
(if (< new-index 0)
|
|
(let* ((first-message-index (db:row-message-index (fields (rows-first-elt object))))
|
|
(previous-message-index (1- first-message-index)))
|
|
(when (db:message-from-timeline-folder-message-index timeline-type
|
|
timeline-folder
|
|
previous-message-index)
|
|
(multiple-value-bind (tree pos)
|
|
(fit-timeline-to-window object previous-message-index)
|
|
(build-lines object tree pos))))
|
|
(progn
|
|
(unselect-all object)
|
|
(select-row object new-index)))
|
|
(draw object)))))
|
|
|
|
(defun message-index-valid-p (timeline-type timeline-folder message-index)
|
|
(db:message-from-timeline-folder-message-index timeline-type
|
|
timeline-folder
|
|
message-index))
|
|
|
|
(defun update-thread-window (window message-index)
|
|
(multiple-value-bind (tree pos)
|
|
(fit-timeline-to-window window message-index)
|
|
(build-lines window tree pos)))
|
|
|
|
(defmethod goto-message ((object thread-window) (message-index number) &key (redraw t))
|
|
(with-accessors ((timeline-folder timeline-folder)
|
|
(timeline-type timeline-type)) object
|
|
(let ((message-index-valid-p (message-index-valid-p timeline-type
|
|
timeline-folder
|
|
message-index)))
|
|
(if message-index-valid-p
|
|
(progn
|
|
(update-thread-window object message-index)
|
|
(when redraw
|
|
(draw object)))
|
|
(ui:info-message (format nil
|
|
(_ "No message with index ~a exists")
|
|
message-index))))))
|
|
|
|
(defun message-tuple-id->message-index (timeline-type timeline-folder status-id)
|
|
(a:when-let* ((message (db::message-from-timeline-folder-id timeline-type
|
|
timeline-folder
|
|
status-id)))
|
|
(db:row-message-index message)))
|
|
|
|
(defmethod goto-message ((object thread-window) (message-index string) &key (redraw t))
|
|
(with-accessors ((timeline-folder timeline-folder)
|
|
(timeline-type timeline-type)) object
|
|
(a:when-let* ((index (message-tuple-id->message-index timeline-type
|
|
timeline-folder
|
|
message-index)))
|
|
(goto-message object index :redraw redraw))))
|
|
|
|
(defmethod goto-first-message ((object thread-window))
|
|
(goto-message object db:+message-index-start+))
|
|
|
|
(defmethod goto-last-message ((object thread-window))
|
|
(with-accessors ((timeline-folder timeline-folder)
|
|
(timeline-type timeline-type)) object
|
|
(a:when-let ((last-message-index (db:last-message-index-status timeline-type timeline-folder)))
|
|
(goto-message object last-message-index))))
|
|
|
|
(defun find-row-with-status-id (thread-window status-id)
|
|
(rows-find-if thread-window
|
|
(lambda (a) (client:id= status-id (db:row-message-status-id (fields a))))))
|
|
|
|
(defmethod resync-rows-db ((object thread-window)
|
|
&key
|
|
(redraw t)
|
|
(suggested-message-index nil)
|
|
(suggested-status-id nil))
|
|
(with-accessors ((row-selected-index row-selected-index)
|
|
(rows rows)
|
|
(timeline-folder timeline-folder)
|
|
(timeline-type timeline-type)) object
|
|
(when-window-shown (object)
|
|
(cond
|
|
(suggested-status-id
|
|
(a:when-let* ((message-index (message-tuple-id->message-index timeline-type
|
|
timeline-folder
|
|
suggested-status-id)))
|
|
(update-thread-window object message-index)))
|
|
(suggested-message-index
|
|
(update-thread-window object suggested-message-index))
|
|
(t
|
|
(a:when-let* ((selected-row (selected-row object))
|
|
(message-index (db:row-message-index (fields selected-row))))
|
|
(update-thread-window object message-index))))
|
|
(when redraw
|
|
(draw object))))
|
|
object)
|
|
|
|
(defun reblogged-data (reblogger-status)
|
|
(a:when-let* ((reblogged-id (db:row-message-reblog-id reblogger-status))
|
|
(reblogged-status (db:find-status-id reblogged-id)))
|
|
(let ((body (db:row-message-rendered-text reblogged-status))
|
|
(attachments (status-attachments->text reblogged-id)))
|
|
(values body attachments))))
|
|
|
|
(defun maybe-remove-mentions (window status-id)
|
|
(a:when-let ((exists-mention-p (db:single-status-exists-p status-id
|
|
db:+home-timeline+
|
|
db:+mentions-status-folder+)))
|
|
(remove-mention window status-id)))
|
|
|
|
(defun maybe-initialize-metadata (window)
|
|
(setf (message-window:metadata window) '())
|
|
(message-window:metadata window))
|
|
|
|
(defun set-status-tuple-shown-status (window status-id timeline folder)
|
|
(with-accessors ((metadata misc:metadata)) window
|
|
(setf metadata (acons :status-id status-id metadata))
|
|
(setf metadata (acons :timeline timeline metadata))
|
|
(setf metadata (acons :folder folder metadata))
|
|
window))
|
|
|
|
(defun get-status-tuple-shown-status (window)
|
|
(with-accessors ((metadata misc:metadata)) window
|
|
(values (cdr (assoc :status-id metadata))
|
|
(cdr (assoc :timeline metadata))
|
|
(cdr (assoc :folder metadata)))))
|
|
|
|
(defun select-messages-corresponding-to-shown ()
|
|
(multiple-value-bind (status-id timeline folder)
|
|
(get-status-tuple-shown-status *message-window*)
|
|
(let ((matching-status (db::find-status-id-folder-timeline status-id
|
|
folder
|
|
timeline)))
|
|
(if matching-status
|
|
(let ((new-message-index (db:row-message-index matching-status)))
|
|
(rebuild-lines *thread-window* new-message-index))
|
|
(ui:info-message (format nil (_ "No matching post in thread window")))))))
|
|
|
|
(defmethod open-message ((object thread-window))
|
|
(with-accessors ((row-selected-index row-selected-index)
|
|
(rows rows)
|
|
(timeline-type timeline-type)
|
|
(timeline-folder timeline-folder)) object
|
|
(a:when-let* ((selected-row (selected-row object))
|
|
(fields (fields selected-row))
|
|
(original (db-utils:db-getf fields :content :default ""))
|
|
(status-id (db:row-message-status-id fields))
|
|
(header (message-original->text-header fields)))
|
|
(let* ((body (db:row-message-rendered-text fields))
|
|
(attachments (status-attachments->text status-id))
|
|
(refresh-event (make-instance 'program-events:refresh-conversations-window-event))
|
|
(poll (db:find-poll-bound-to-status status-id))
|
|
(poll-text (poll->text (db:row-id poll)
|
|
(truncate (/ (win-width-no-border object)
|
|
2)))))
|
|
(multiple-value-bind (reblogged-status-body reblogged-status-attachments)
|
|
(reblogged-data fields)
|
|
(let ((actual-body (if (string= body reblogged-status-body)
|
|
body
|
|
(strcat body reblogged-status-body)))
|
|
(actual-attachments (if (string= attachments reblogged-status-attachments)
|
|
attachments
|
|
(strcat reblogged-status-attachments attachments))))
|
|
(maybe-remove-mentions object status-id)
|
|
(maybe-initialize-metadata *message-window*)
|
|
(set-status-tuple-shown-status *message-window*
|
|
status-id
|
|
timeline-type
|
|
timeline-folder)
|
|
(message-window:prepare-for-rendering *message-window*
|
|
(strcat header
|
|
actual-body
|
|
poll-text
|
|
actual-attachments))
|
|
(db:mark-status-read timeline-type timeline-folder status-id)
|
|
(resync-rows-db object :redraw t)
|
|
(program-events:push-event refresh-event)
|
|
(draw *message-window*)))))))
|
|
|
|
(defun mark-selected-status-boolean-value (window function)
|
|
(with-accessors ((row-selected-index row-selected-index)
|
|
(rows rows)
|
|
(timeline-type timeline-type)
|
|
(timeline-folder timeline-folder)) window
|
|
(assert (selected-row window))
|
|
(let* ((selected-row (selected-row window))
|
|
(fields (fields selected-row))
|
|
(status-id (db:row-message-status-id fields)))
|
|
(funcall function timeline-type timeline-folder status-id))))
|
|
|
|
(defmethod mark-selected-message-to-delete ((object thread-window)
|
|
&key (move-down-selected-message nil))
|
|
(if (selected-row object)
|
|
(progn
|
|
(mark-selected-status-boolean-value object #'db:mark-status-deleted)
|
|
(resync-rows-db object :redraw t)
|
|
(when move-down-selected-message
|
|
(go-message-down object)))
|
|
(ui:error-message (_ "No message to delete"))))
|
|
|
|
(defmethod mark-selected-message-prevent-delete ((object thread-window)
|
|
&key (move-down-selected-message nil))
|
|
(if (selected-row object)
|
|
(progn
|
|
(mark-selected-status-boolean-value object #'db:mark-status-prevent-deletion)
|
|
(resync-rows-db object :redraw t)
|
|
(when move-down-selected-message
|
|
(go-message-down object)))
|
|
(ui:error-message (_ "No message to undelete"))))
|
|
|
|
(defun rebuild-lines (window message-id)
|
|
(multiple-value-bind (tree pos)
|
|
(fit-timeline-to-window window message-id)
|
|
(build-lines window tree pos)))
|
|
|
|
(defun search-messages-body (window text-looking-for direction error-message)
|
|
(with-accessors ((row-selected-index row-selected-index)
|
|
(rows rows)
|
|
(timeline-folder timeline-folder)
|
|
(timeline-type timeline-type)) window
|
|
(a:when-let* ((selected-fields (selected-row-fields window))
|
|
(starting-index (db-utils:db-getf selected-fields :message-index)))
|
|
(let ((matching-status (if (eq direction :next)
|
|
(db:search-next-message-body timeline-type
|
|
timeline-folder
|
|
text-looking-for
|
|
starting-index)
|
|
(db:search-previous-message-body timeline-type
|
|
timeline-folder
|
|
text-looking-for
|
|
starting-index))))
|
|
(if matching-status
|
|
(let ((new-message-index (db:row-message-index matching-status)))
|
|
(rebuild-lines window new-message-index)
|
|
(open-message window))
|
|
(ui:info-message (format nil error-message text-looking-for)))))))
|
|
|
|
(defmethod search-next-message-body ((object thread-window) text-looking-for)
|
|
(search-messages-body object
|
|
text-looking-for
|
|
:next
|
|
(_ "No next message that contains ~s exists")))
|
|
|
|
(defmethod search-previous-message-body ((object thread-window) text-looking-for)
|
|
(search-messages-body object
|
|
text-looking-for
|
|
:previous
|
|
(_ "No previous message that contains ~s exists")))
|
|
|
|
(defun search-messages-meta (window text-looking-for direction error-message)
|
|
(with-accessors ((row-selected-index row-selected-index)
|
|
(rows rows)
|
|
(timeline-folder timeline-folder)
|
|
(timeline-type timeline-type)) window
|
|
(a:when-let* ((selected-fields (selected-row-fields window))
|
|
(starting-index (db-utils:db-getf selected-fields :message-index)))
|
|
(let ((matching-status (if (eq direction :next)
|
|
(db:search-next-message-meta timeline-type
|
|
timeline-folder
|
|
text-looking-for
|
|
starting-index)
|
|
(db:search-previous-message-meta timeline-type
|
|
timeline-folder
|
|
text-looking-for
|
|
starting-index))))
|
|
(if matching-status
|
|
(let ((new-message-index (db:row-message-index matching-status)))
|
|
(rebuild-lines window new-message-index)
|
|
(open-message window))
|
|
(ui:info-message (format nil error-message text-looking-for)))))))
|
|
|
|
(defmethod search-next-message-meta ((object thread-window) text-looking-for)
|
|
(search-messages-meta object
|
|
text-looking-for
|
|
:next
|
|
(_ "No next message that contains ~s exists")))
|
|
|
|
(defmethod search-previous-message-meta ((object thread-window) text-looking-for)
|
|
(search-messages-meta object
|
|
text-looking-for
|
|
:previous
|
|
(_ "No previous message that contains ~s exists")))
|
|
|
|
(defmethod search-next-unread ((object thread-window))
|
|
(with-accessors ((row-selected-index row-selected-index)
|
|
(rows rows)
|
|
(timeline-folder timeline-folder)
|
|
(timeline-type timeline-type)) object
|
|
(a:when-let* ((selected-fields (selected-row-fields object))
|
|
(starting-index (db-utils:db-getf selected-fields :message-index)))
|
|
(let ((matching-status (db:search-next-unread-message timeline-type
|
|
timeline-folder
|
|
starting-index)))
|
|
(if matching-status
|
|
(let ((new-message-index (db:row-message-index matching-status)))
|
|
(rebuild-lines object new-message-index)
|
|
(open-message object))
|
|
(ui:info-message (_ "No others unread messages exist")))))))
|
|
|
|
(defmethod add-mention ((object thread-window) mention)
|
|
(with-accessors ((mentions mentions)) object
|
|
(let ((reversed (reverse mentions)))
|
|
(push mention reversed)
|
|
(setf mentions (reverse reversed)))))
|
|
|
|
(defmethod remove-mention ((object thread-window) status-id)
|
|
(with-accessors ((mentions mentions)) object
|
|
(setf mentions
|
|
(remove-if (lambda (mention)
|
|
(let* ((mention-status (tooter:status mention))
|
|
(mention-status-id (tooter:id mention-status)))
|
|
(api-client:id= mention-status-id status-id)))
|
|
mentions))
|
|
object))
|
|
|
|
(defmethod add-announcements-notification ((object thread-window))
|
|
(setf (announcements object) t))
|
|
|
|
(defmethod remove-announcements-notification ((object thread-window))
|
|
(setf (announcements object) nil))
|
|
|
|
(defgeneric marked-to-delete-p (object))
|
|
|
|
(defmethod marked-to-delete-p ((object line))
|
|
(db-utils:db-getf (fields object) :deletedp))
|
|
|
|
(defun init ()
|
|
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
|
|
(setf *thread-window*
|
|
(make-instance 'thread-window
|
|
:title (_ "Threads")
|
|
:keybindings keybindings:*thread-keymap*
|
|
:key-config swconf:+key-thread-window+
|
|
:croatoan-window low-level-window))
|
|
(refresh-config *thread-window*)
|
|
(setf (keybindings *thread-window*) keybindings:*thread-keymap*)
|
|
(resync-rows-db *thread-window* :suggested-message-index db:+message-index-start+)
|
|
*thread-window*))
|