mirror of https://codeberg.org/cage/tinmop/
571 lines
22 KiB
Common Lisp
571 lines
22 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 :line-oriented-window)
|
|
|
|
(defclass line ()
|
|
((selected-fg
|
|
:initform :black
|
|
:initarg :selected-fg
|
|
:accessor selected-fg
|
|
:documentation "The foreground color for a selected line")
|
|
(selected-bg
|
|
:initform :cyan
|
|
:initarg :selected-bg
|
|
:accessor selected-bg
|
|
:documentation "The background color for a selected line")
|
|
(normal-fg
|
|
:initform :cyan
|
|
:initarg :normal-fg
|
|
:accessor normal-fg
|
|
:documentation "The foreground color for a line")
|
|
(normal-bg
|
|
:initform :black
|
|
:initarg :normal-bg
|
|
:accessor normal-bg
|
|
:documentation "The background color for a line")
|
|
(normal-text
|
|
:initform (make-tui-string "…")
|
|
:initarg :normal-text
|
|
:accessor normal-text
|
|
:documentation "The actual not selected text")
|
|
(selected-text
|
|
:initform (make-tui-string "…")
|
|
:initarg :selected-text
|
|
:accessor selected-text
|
|
:documentation "The actual selected text")
|
|
(deleted-text
|
|
:initform (make-tui-string "…")
|
|
:initarg :deleted-text
|
|
:accessor deleted-text
|
|
:documentation "The actual deleted text ")
|
|
(fields
|
|
:initform ()
|
|
:initarg :fields
|
|
:accessor fields
|
|
:documentation "A generic plist of useful informations for the window")
|
|
(index
|
|
:initform 0
|
|
:initarg :index
|
|
:accessor index
|
|
:documentation "The index of this line in the window")
|
|
(selected
|
|
:initform nil
|
|
:initarg :selected
|
|
:reader selectedp
|
|
:writer (setf selected)
|
|
:documentation "Non nil if this line is selected state"))
|
|
(:documentation "This class represents a single line in a row-oriented-widget"))
|
|
|
|
(defmethod print-object ((object line) stream)
|
|
(format stream "line: ~s" (tui-string->chars-string (normal-text object))))
|
|
|
|
(defclass row-oriented-widget ()
|
|
((rows
|
|
:initform ()
|
|
:initarg :rows
|
|
:accessor rows
|
|
:documentation "The rows of data for this widget")
|
|
(row-selected-index
|
|
:initform 0
|
|
:initarg :row-selected-index
|
|
:accessor row-selected-index
|
|
:documentation "The index of the selected row")
|
|
(single-row-height
|
|
:initform 1
|
|
:initarg :single-row-height
|
|
:accessor single-row-height
|
|
:documentation "The height of a row (in character)")
|
|
(top-row-padding
|
|
:initform 0
|
|
:initarg :top-row-padding
|
|
:accessor top-row-padding
|
|
:documentation "the padding from the top of the window and the
|
|
position where to draw the first line")
|
|
(current-row-index
|
|
:initform 0
|
|
:initarg :current-row-index
|
|
:accessor current-row-index
|
|
:documentation "The active line index")
|
|
(y-current-row
|
|
:initform 0
|
|
:initarg :y-current-row
|
|
:accessor y-current-row
|
|
:documentation "The active line position")
|
|
(top-rows-slice
|
|
:initform 0
|
|
:initarg :top-rows-slice
|
|
:accessor top-rows-slice
|
|
:documentation "The start index of the visible rows")
|
|
(bottom-rows-slice
|
|
:initform 0
|
|
:initarg :bottom-rows-slice
|
|
:accessor bottom-rows-slice
|
|
:documentation "The start index of the visible rows"))
|
|
(:documentation "A widget that holds a selectable list of lines"))
|
|
|
|
(defmethod initialize-instance :after ((object row-oriented-widget) &key &allow-other-keys)
|
|
(with-accessors ((top-row-padding top-row-padding)
|
|
(y-current-row y-current-row)) object
|
|
(setf y-current-row top-row-padding)))
|
|
|
|
(defmethod (setf top-row-padding) ((object row-oriented-widget) new-padding)
|
|
(setf (slot-value object 'top-row-padding) new-padding)
|
|
(setf (slot-value object 'y-current-row) new-padding)
|
|
object)
|
|
|
|
(defgeneric renderizable-rows-data (object))
|
|
|
|
(defgeneric unselect-all (object))
|
|
|
|
(defgeneric select-row (object index))
|
|
|
|
(defgeneric select-first-row (object))
|
|
|
|
(defgeneric adjust-selected-rows (object strategy))
|
|
|
|
(defgeneric selected-row (object))
|
|
|
|
(defgeneric selected-row-fields (object))
|
|
|
|
(defgeneric selected-row-delete (object))
|
|
|
|
(defgeneric search-row (object regex &key redraw))
|
|
|
|
(defgeneric row-move (object amount)
|
|
(:documentation "Move selected line of 'amount'. 'Amount' can be
|
|
an integer number, if positive increase the position of the selected
|
|
line otherwise decrease, relative to current index position.
|
|
The value is clamped at range [ 0, '(length (rows object)))' ).
|
|
This function return the number of positions acually moved"))
|
|
|
|
(defgeneric update-all-rows (object new-rows))
|
|
|
|
(defgeneric append-new-rows (object new-rows))
|
|
|
|
(defgeneric map-rows (object function &key &allow-other-keys))
|
|
|
|
(defgeneric rows-map-raw (object function &key &allow-other-keys))
|
|
|
|
(defgeneric rows-length (object &key &allow-other-keys))
|
|
|
|
(defgeneric rows-empty-p (object &key &allow-other-keys))
|
|
|
|
(defgeneric rows-remove-if (object function &key &allow-other-keys))
|
|
|
|
(defgeneric rows-find-if (object function &key from-end start end key &allow-other-keys))
|
|
|
|
(defgeneric rows-safe-subseq (object start &key end &allow-other-keys))
|
|
|
|
(defgeneric rows-elt (object index &key &allow-other-keys))
|
|
|
|
(defgeneric rows-last-elt (object &key &allow-other-keys))
|
|
|
|
(defgeneric rows-first-elt (object &key &allow-other-keys))
|
|
|
|
(defgeneric rows-position-if (object predicate &key from-end start end key &allow-other-keys))
|
|
|
|
(defmethod renderizable-rows-data ((object row-oriented-widget))
|
|
"Cut from all the lines a slice that that fits into the widget"
|
|
(with-accessors ((top-row-padding top-row-padding)
|
|
(current-row-index current-row-index)
|
|
(row-selected-index row-selected-index)
|
|
(single-row-height single-row-height)
|
|
(top-rows-slice top-rows-slice)
|
|
(bottom-rows-slice bottom-rows-slice)
|
|
(rows rows)) object
|
|
(let* ((window-height (if (uses-border-p object)
|
|
(win-height-no-border object)
|
|
(win-height object)))
|
|
(available-rows (truncate (/ (- window-height top-row-padding)
|
|
single-row-height)))
|
|
(selected-top-offset (rem row-selected-index available-rows))
|
|
(top (- row-selected-index selected-top-offset))
|
|
(bottom (+ row-selected-index
|
|
(- available-rows selected-top-offset))))
|
|
(setf top-rows-slice top
|
|
bottom-rows-slice bottom)
|
|
(values (safe-subseq rows top bottom)
|
|
selected-top-offset))))
|
|
|
|
(defmethod unselect-all ((object row-oriented-widget))
|
|
(loop for row in (rows object) do
|
|
(setf (selected row) nil))
|
|
object)
|
|
|
|
(defmethod select-row ((object row-oriented-widget) (index number))
|
|
(with-accessors ((rows rows)
|
|
(row-selected-index row-selected-index)) object
|
|
(restart-case
|
|
(if (or (< index 0)
|
|
(>= index (length rows)))
|
|
(error 'conditions:out-of-bounds :idx index :seq rows)
|
|
(progn
|
|
(setf row-selected-index index)
|
|
(setf (selected (elt rows index)) t)))
|
|
(ignore-selecting-action (e)
|
|
(declare (ignore e))
|
|
nil)
|
|
(set-default-index (e)
|
|
(declare (ignore e))
|
|
(setf row-selected-index 0)))
|
|
object))
|
|
|
|
(defmethod select-first-row ((object row-oriented-widget))
|
|
(select-row object 0))
|
|
|
|
(defun adjust-rows-select-first (window)
|
|
(when (rows window)
|
|
(select-first-row window)))
|
|
|
|
(defun adjust-rows-noop (window)
|
|
window)
|
|
|
|
(defun adjust-rows-select-last (window)
|
|
(with-accessors ((rows rows)) window
|
|
(when rows
|
|
(let ((height (win-height-no-border window)))
|
|
(if (>= (rows-length window) height)
|
|
(select-row window (- (rows-length window)
|
|
height))
|
|
(select-first-row window)))))
|
|
window)
|
|
|
|
(defmethod adjust-selected-rows ((object row-oriented-widget) (strategy function))
|
|
(funcall strategy object)
|
|
object)
|
|
|
|
(defmethod selected-row ((object row-oriented-widget))
|
|
"Return the current selected row"
|
|
(with-accessors ((rows rows)
|
|
(row-selected-index row-selected-index)) object
|
|
(when rows
|
|
(if (<= 0
|
|
row-selected-index
|
|
(1- (length rows)))
|
|
(elt rows row-selected-index)
|
|
nil))))
|
|
|
|
(defmethod selected-row-fields ((object row-oriented-widget))
|
|
"Return the fields current selected row"
|
|
(when-let ((selected-row (selected-row object)))
|
|
(fields selected-row)))
|
|
|
|
(defmethod selected-row-delete ((object row-oriented-widget))
|
|
"delete the selected row"
|
|
(with-accessors ((rows rows)
|
|
(row-selected-index row-selected-index)) object
|
|
(let ((last-was-removed-p (= row-selected-index
|
|
(1- (length rows)))))
|
|
(setf rows (remove-if #'selectedp rows))
|
|
(if rows
|
|
(if last-was-removed-p
|
|
(select-row object (1- row-selected-index))
|
|
(select-row object row-selected-index))
|
|
(setf row-selected-index 0)))
|
|
object))
|
|
|
|
(defmethod row-move ((object row-oriented-widget) amount)
|
|
"Navigate the lines, move the selected row by `amount', returns the
|
|
actual of rows moved. This can be different from `amount' if moving
|
|
this exact quantity would go beyond the length or rows or zero."
|
|
(with-accessors ((rows rows)
|
|
(row-selected-index row-selected-index)) object
|
|
(if (and rows
|
|
row-selected-index
|
|
(/= 0 amount))
|
|
(let* ((desired-amount (+ amount row-selected-index))
|
|
(actual-amount (if (< amount 0)
|
|
(max (- desired-amount
|
|
row-selected-index)
|
|
(- row-selected-index))
|
|
(- (min desired-amount
|
|
(1- (length rows)))
|
|
row-selected-index))))
|
|
(select-row object (+ row-selected-index
|
|
actual-amount))
|
|
actual-amount)
|
|
0)))
|
|
|
|
(defmethod search-row ((object row-oriented-widget) regex &key (redraw t))
|
|
(handler-case
|
|
(with-accessors ((row-selected-index row-selected-index)) object
|
|
(let* ((scanner (create-scanner regex :case-insensitive-mode t))
|
|
(selected-row (selected-row object))
|
|
(selected-text (normal-text selected-row))
|
|
(actual-row-starting (if (scan scanner selected-text)
|
|
(1+ row-selected-index)
|
|
row-selected-index))
|
|
(position-found (position-if (lambda (a)
|
|
(if (selectedp a)
|
|
(scan scanner (selected-text a))
|
|
(scan scanner (normal-text a))))
|
|
(safe-subseq (rows object)
|
|
actual-row-starting))))
|
|
(when position-found
|
|
(unselect-all object)
|
|
(select-row object (+ actual-row-starting position-found))
|
|
(when redraw
|
|
(draw object))
|
|
position-found)))
|
|
(error ()
|
|
(ui:error-message (_ "Invalid regular expression")))))
|
|
|
|
(defmethod update-all-rows ((object row-oriented-widget) (new-rows sequence))
|
|
(setf (rows object) new-rows))
|
|
|
|
(defmethod append-new-rows ((object row-oriented-widget) (new-rows sequence))
|
|
(with-slots (rows) object
|
|
(let ((reversed-old-rows (reverse rows)))
|
|
(loop for new-row in new-rows do
|
|
(push new-row reversed-old-rows))
|
|
(setf rows (reverse reversed-old-rows)))))
|
|
|
|
(defmethod append-new-rows ((object row-oriented-widget) (new-rows line))
|
|
(append-new-rows object (list new-rows)))
|
|
|
|
(defmethod map-rows ((object row-oriented-widget) (function function)
|
|
&key &allow-other-keys)
|
|
(mapcar function (rows object)))
|
|
|
|
(defmethod rows-map-raw ((object row-oriented-widget) (function function)
|
|
&key &allow-other-keys)
|
|
(mapcar function (slot-value object 'rows)))
|
|
|
|
(defmacro do-rows ((object row) &body body)
|
|
`(map nil (lambda (,row) (progn ,@body)) (rows ,object)))
|
|
|
|
(defmacro do-rows-raw ((object row) &body body)
|
|
`(map nil (lambda (,row) (progn ,@body)) (slot-value ,object 'rows)))
|
|
|
|
(defmacro loop-rows ((object row &rest loop-clauses) &body body)
|
|
`(loop for ,row in (rows ,object)
|
|
,@loop-clauses
|
|
,@body))
|
|
|
|
(defmethod rows-length ((object row-oriented-widget) &key &allow-other-keys)
|
|
(length (rows object)))
|
|
|
|
(defmethod rows-empty-p ((object row-oriented-widget) &key &allow-other-keys)
|
|
(not (rows object)))
|
|
|
|
(defmethod rows-remove-if ((object row-oriented-widget) (function function) &key &allow-other-keys)
|
|
(remove-if function (rows object)))
|
|
|
|
(defmethod rows-find-if ((object row-oriented-widget) (predicate function)
|
|
&key from-end (start 0) end key &allow-other-keys)
|
|
(find-if predicate (rows object)
|
|
:from-end from-end
|
|
:start start
|
|
:end end
|
|
:key key))
|
|
|
|
(defmethod rows-safe-subseq ((object row-oriented-widget) start
|
|
&key (end nil) &allow-other-keys)
|
|
(safe-subseq (rows object) start end))
|
|
|
|
(defmethod rows-elt ((object row-oriented-widget) index &key &allow-other-keys)
|
|
(elt (rows object) index))
|
|
|
|
(defmethod rows-last-elt ((object row-oriented-widget) &key &allow-other-keys)
|
|
(last-elt (rows object)))
|
|
|
|
(defmethod rows-first-elt ((object row-oriented-widget) &key &allow-other-keys)
|
|
(first-elt (rows object)))
|
|
|
|
(defmethod rows-position-if ((object row-oriented-widget) (predicate function)
|
|
&key from-end (start 0) end key &allow-other-keys)
|
|
(position-if predicate
|
|
(rows object)
|
|
:from-end from-end
|
|
:start start
|
|
: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
|
|
:initarg :selected-line-bg
|
|
:accessor selected-line-bg
|
|
:documentation "The background color for a selected line")
|
|
(selected-line-fg
|
|
:initform :red
|
|
:initarg :selected-line-fg
|
|
:accessor selected-line-fg
|
|
:documentation "The foreground color for a selected line")
|
|
(unselected-line-bg
|
|
:initform :blue
|
|
:initarg :unselected-line-bg
|
|
:accessor unselected-line-bg
|
|
:documentation "The background color for a unselected line")
|
|
(unselected-line-fg
|
|
:initform :red
|
|
:initarg :unselected-line-fg
|
|
:accessor unselected-line-fg
|
|
:documentation "The foreground color for a unselected line")
|
|
(top-horizontal-padding
|
|
:initform 0
|
|
:initarg :top-horizontal-padding
|
|
:accessor top-horizontal-padding
|
|
:documentation "The vertical padding (from top) of each single row"))
|
|
(:documentation "A window that displays a navigable list of objects"))
|
|
|
|
(defmethod draw :after ((object simple-line-navigation-window))
|
|
(with-accessors ((uses-border-p uses-border-p)
|
|
(single-row-height single-row-height)
|
|
(top-row-padding top-row-padding)
|
|
(top-horizontal-padding top-horizontal-padding)) object
|
|
(when-window-shown (object)
|
|
(let ((max-line-size (if uses-border-p
|
|
(win-width-no-border object)
|
|
(win-width object))))
|
|
(let ((rows (renderizable-rows-data object))
|
|
(x (if (uses-border-p object)
|
|
1
|
|
0))
|
|
(y-start (if (uses-border-p object)
|
|
1
|
|
0)))
|
|
(loop
|
|
for y from (+ y-start
|
|
top-horizontal-padding
|
|
top-row-padding)
|
|
by single-row-height
|
|
for ct from 0
|
|
for row in rows do
|
|
(if (selectedp row)
|
|
(let ((tui-text (to-tui-string (selected-text row))))
|
|
(print-text object
|
|
(tui-string-apply-colors (right-pad-text (text-ellipsis tui-text
|
|
max-line-size)
|
|
max-line-size)
|
|
(selected-fg row)
|
|
(selected-bg row))
|
|
|
|
x y))
|
|
(print-text object
|
|
(right-pad-text (text-ellipsis (normal-text row)
|
|
max-line-size)
|
|
max-line-size)
|
|
x y
|
|
:bgcolor (normal-bg row)
|
|
:fgcolor (normal-fg row))))
|
|
(when (> (rows-length object) 0)
|
|
(let* ((current-selected (1+ (row-selected-index object)))
|
|
(pages-count-line (format nil
|
|
(_ "line ~a of ~a")
|
|
current-selected
|
|
(rows-length object)))
|
|
(x-count-line (- (win-width object)
|
|
(length pages-count-line)
|
|
1))
|
|
(y-count-line (1- (win-height object))))
|
|
(print-text object
|
|
(text-ellipsis pages-count-line (win-width-no-border object))
|
|
x-count-line
|
|
y-count-line))))))))
|
|
|
|
(defgeneric resync-rows-db (object &key redraw)
|
|
(:documentation "Synchronize information table slot of `object` with
|
|
table in the database, if `redraw` is not nil redraw the object, if
|
|
possible"))
|
|
|
|
(defmethod resync-rows-db ((object null) &key redraw)
|
|
(declare (ignore redraw))
|
|
t)
|
|
|
|
(defun event-quit-blocking-list-dialog-window-p (event)
|
|
(or (string= event "q")
|
|
(string= event "^G")))
|
|
|
|
(defun make-blocking-list-dialog-window (screen all-fields text-lines callback
|
|
&optional (title (_ "Information")))
|
|
"Draw a window with a scrollable list of entries, pressing enter
|
|
will fire the `callback' function (with the selected field from `all-fields'
|
|
and text from `text-line'. This window is fitten into `screen' sizes."
|
|
(assert (>= (length all-fields)
|
|
(length text-lines)))
|
|
(let* ((low-level-window (make-blocking-croatoan-window :enable-function-keys t))
|
|
(window-width (max (+ 4
|
|
(length title))
|
|
(+ (find-max-line-width text-lines)
|
|
2)))
|
|
(window-height (min (truncate (* 0.9 (win-height screen)))
|
|
(+ (max (length text-lines)
|
|
+min-shown-win-height+)
|
|
2)))
|
|
(window-x (truncate (- (* 0.5 (win-width screen))
|
|
(* 0.5 window-width))))
|
|
(window-y (truncate (- (* 0.5 (win-height screen))
|
|
(* 0.5 window-height))))
|
|
(bg (swconf:win-bg swconf:+key-info-dialog+))
|
|
(fg (swconf:win-fg swconf:+key-info-dialog+))
|
|
(high-level-window (make-instance 'simple-line-navigation-window
|
|
:single-row-height 1
|
|
:uses-border-p t
|
|
:croatoan-window low-level-window)))
|
|
(flet ((draw ()
|
|
(win-clear high-level-window :redraw nil)
|
|
(draw high-level-window)
|
|
(print-text high-level-window title 2 0)))
|
|
(setf (c:background low-level-window) (tui:make-win-background bg))
|
|
(setf (c:fgcolor low-level-window) fg)
|
|
(win-resize high-level-window window-width window-height)
|
|
(win-move high-level-window window-x window-y)
|
|
(setf (rows high-level-window)
|
|
(loop
|
|
for text in text-lines
|
|
for fields in all-fields
|
|
collect
|
|
(make-instance 'line
|
|
:fields fields
|
|
:normal-text text
|
|
:selected-text text
|
|
:normal-bg bg
|
|
:normal-fg fg
|
|
:selected-bg fg
|
|
:selected-fg bg)))
|
|
(select-row high-level-window 0)
|
|
(draw)
|
|
(loop named inner
|
|
for c = (tui:decode-key-event (c:get-wide-event low-level-window))
|
|
while (not (event-quit-blocking-list-dialog-window-p c))
|
|
do
|
|
(cond
|
|
((string= c :key-arrow-up)
|
|
(unselect-all high-level-window)
|
|
(row-move high-level-window -1))
|
|
((string= c :key-arrow-down)
|
|
(unselect-all high-level-window)
|
|
(row-move high-level-window 1))
|
|
((string= c "^J")
|
|
(let ((selected-fields (selected-row-fields high-level-window))
|
|
(selected-text (selected-text (selected-row high-level-window))))
|
|
(when callback
|
|
(funcall callback selected-text selected-fields)))))
|
|
(draw))
|
|
(win-close high-level-window))))
|