mirror of https://codeberg.org/cage/tinmop/
152 lines
7.0 KiB
Common Lisp
152 lines
7.0 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 :tags-window)
|
|
|
|
(defclass tags-window (focus-marked-window
|
|
simple-line-navigation-window
|
|
title-window
|
|
border-window)
|
|
((new-messages-mark
|
|
:initarg :new-messages-mark
|
|
:initform ()
|
|
:accessor new-messages-mark)
|
|
(histogram-fg
|
|
:initarg :histogram-fg
|
|
:initform ()
|
|
:accessor histogram-fg)))
|
|
|
|
(defmethod refresh-config :after ((object tags-window))
|
|
(with-accessors ((croatoan-window croatoan-window)
|
|
(histogram-fg histogram-fg)
|
|
(selected-line-bg selected-line-bg)
|
|
(selected-line-fg selected-line-fg)
|
|
(new-messages-mark new-messages-mark)) object
|
|
(let* ((theme-style (swconf:form-style swconf:+key-tags-window+))
|
|
(fg (swconf:foreground theme-style))
|
|
(bg (swconf:background theme-style))
|
|
(selected-fg (swconf:selected-foreground theme-style))
|
|
(selected-bg (swconf:selected-background theme-style))
|
|
(new-message-value (swconf:tags-new-message-mark))
|
|
(width (- (win-width *main-window*)
|
|
(win-width *thread-window*)))
|
|
(raw-height (swconf:win-height swconf:+key-tags-window+))
|
|
(height (main-window:parse-subwin-h raw-height))
|
|
(y 0)
|
|
(x 0))
|
|
(setf selected-line-fg selected-fg)
|
|
(setf selected-line-bg selected-bg)
|
|
(setf new-messages-mark new-message-value)
|
|
(setf histogram-fg (swconf:tags-histogram-foreground))
|
|
(setf (c:background croatoan-window) (tui:make-win-background bg))
|
|
(setf (c:bgcolor croatoan-window) bg)
|
|
(setf (c:fgcolor croatoan-window) fg)
|
|
(win-resize object width height)
|
|
(win-move object x y)
|
|
object)))
|
|
|
|
(defmethod draw :before ((object tags-window))
|
|
(with-accessors ((rows rows)
|
|
(histogram-fg histogram-fg)
|
|
(single-row-height single-row-height)
|
|
(top-row-padding top-row-padding)
|
|
(new-messages-mark new-messages-mark)) object
|
|
(when-window-shown (object)
|
|
(win-clear object)
|
|
(with-croatoan-window (croatoan-window object)
|
|
(let ((histogram-width (truncate (* 2/3 (win-width-no-border object)))))
|
|
(loop
|
|
for y from (+ 2 top-row-padding) by single-row-height
|
|
for row-fields in (map-rows object #'fields) do
|
|
(let* ((histogram-data (fields-histogram row-fields))
|
|
(length-histogram-data (length histogram-data))
|
|
(histogram-visualized-data (safe-subseq histogram-data
|
|
(- length-histogram-data
|
|
histogram-width)
|
|
length-histogram-data))
|
|
(histogram (cl-spark:spark histogram-visualized-data))
|
|
(got-new-messages-p (getf row-fields :got-new-message-p)))
|
|
(print-text object
|
|
histogram
|
|
1 y
|
|
:bgcolor (c:bgcolor croatoan-window)
|
|
:fgcolor histogram-fg)
|
|
(when got-new-messages-p
|
|
(print-text object new-messages-mark nil nil
|
|
:bgcolor (c:bgcolor croatoan-window)
|
|
:fgcolor histogram-fg)))))))))
|
|
|
|
(defmethod resync-rows-db ((object tags-window) &key (redraw t) (suggested-message-index nil))
|
|
(with-accessors ((rows rows)
|
|
(selected-line-bg selected-line-bg)
|
|
(selected-line-fg selected-line-fg)) object
|
|
(when-window-shown (object)
|
|
(flet ((make-rows (line-fields bg fg)
|
|
(mapcar (lambda (fields)
|
|
(let ((text (db:tag->folder-name (fields-tag fields))))
|
|
(make-instance 'line
|
|
:fields fields
|
|
:normal-text text
|
|
:selected-text text
|
|
:normal-bg bg
|
|
:normal-fg fg
|
|
:selected-bg fg
|
|
:selected-fg bg)))
|
|
line-fields)))
|
|
(let ((line-fields (make-tag-line-fields)))
|
|
(line-oriented-window:update-all-rows object
|
|
(make-rows line-fields
|
|
selected-line-bg
|
|
selected-line-fg))
|
|
(when suggested-message-index
|
|
(select-row object suggested-message-index))
|
|
(when redraw
|
|
(draw object)))))))
|
|
|
|
(defun fields-tag (fields)
|
|
(getf fields :tag))
|
|
|
|
(defun fields-histogram (fields)
|
|
(getf fields :histogram))
|
|
|
|
(defun make-tag-line-fields ()
|
|
(let* ((all-tags-name (db:all-subscribed-tags-name :sort-data t))
|
|
(all-tags (db:all-subscribed-tags :sort-data t))
|
|
(all-histograms (loop for tag-name in all-tags-name collect
|
|
(db:tag-histogram tag-name))))
|
|
(loop
|
|
for tag in all-tags
|
|
for histogram in all-histograms collect
|
|
(list :tag (db:row-id tag)
|
|
:got-new-message-p (db:row-tag-got-new-message tag)
|
|
:histogram histogram))))
|
|
|
|
(defun init ()
|
|
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
|
|
(setf *tags-window*
|
|
(make-instance 'tags-window
|
|
:title (_ "Subscribed tags")
|
|
:single-row-height 3
|
|
:uses-border-p t
|
|
:keybindings keybindings:*tags-keymap*
|
|
:croatoan-window low-level-window))
|
|
(refresh-config *tags-window*)
|
|
(resync-rows-db *tags-window* :redraw nil)
|
|
(when (not (line-oriented-window:rows-empty-p *tags-window*))
|
|
(select-row *tags-window* 0))
|
|
(draw *tags-window*)
|
|
*tags-window*))
|