cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- improved macro 'when-window-shown' to prevent crash of the program when terminal window is too small.

This commit is contained in:
cage 2021-08-13 12:14:58 +02:00
parent d04f4e001b
commit 423779986a
5 changed files with 114 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
src/line-oriented-window.lisp
View File

@ -409,38 +409,39 @@ this exact quantity would go beyond the length or rows or zero."
(single-row-height single-row-height)
(top-row-padding top-row-padding)
(top-horizontal-padding top-horizontal-padding)) 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)
(print-text object
(right-pad-text (text-ellipsis (selected-text row)
max-line-size)
max-line-size)
x y
:bgcolor (selected-bg row)
:fgcolor (selected-fg row))
(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-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)
(print-text object
(right-pad-text (text-ellipsis (selected-text row)
max-line-size)
max-line-size)
x y
:bgcolor (selected-bg row)
:fgcolor (selected-fg row))
(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)))))))))
(defgeneric resync-rows-db (object &key redraw)
(:documentation "Synchronize information table slot of `object` with

1
src/package.lisp
View File

@ -1679,6 +1679,7 @@
:in-focus-p
:border-window
:uses-border-p
:window-uses-border-p
:title-window))
(defpackage :notify-window

90
src/tags-window.lisp
View File

@ -65,55 +65,57 @@
(single-row-height single-row-height)
(top-row-padding top-row-padding)
(new-messages-mark new-messages-mark)) 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 (bgcolor croatoan-window)
:fgcolor histogram-fg)
(when got-new-messages-p
(print-text object new-messages-mark nil nil
:bgcolor (bgcolor croatoan-window)
:fgcolor histogram-fg))))))))
(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 (bgcolor croatoan-window)
:fgcolor histogram-fg)
(when got-new-messages-p
(print-text object new-messages-mark nil nil
:bgcolor (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
(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))))))
(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))

31
src/thread-window.lisp
View File

@ -784,21 +784,22 @@ db:renumber-timeline-message-index."
(defmethod resync-rows-db ((object thread-window) &key (redraw t) (suggested-message-index nil))
(with-accessors ((row-selected-index row-selected-index)
(rows rows)) object
(let ((saved-row-selected-index (if suggested-message-index
(db:message-index->sequence-index suggested-message-index)
row-selected-index))
(first-message-index (or suggested-message-index
(db:row-message-index (fields (rows-first-elt object))))))
(handler-bind ((conditions:out-of-bounds
(lambda (e)
(invoke-restart 'ignore-selecting-action e))))
(multiple-value-bind (tree pos)
(fit-timeline-to-window object first-message-index)
(build-lines object tree pos)
(unselect-all object)
(select-row object saved-row-selected-index)
(when redraw
(draw object))))))
(when-window-shown (object)
(let ((saved-row-selected-index (if suggested-message-index
(db:message-index->sequence-index suggested-message-index)
row-selected-index))
(first-message-index (or suggested-message-index
(db:row-message-index (fields (rows-first-elt object))))))
(handler-bind ((conditions:out-of-bounds
(lambda (e)
(invoke-restart 'ignore-selecting-action e))))
(multiple-value-bind (tree pos)
(fit-timeline-to-window object first-message-index)
(build-lines object tree pos)
(unselect-all object)
(select-row object saved-row-selected-index)
(when redraw
(draw object)))))))
object)
(defun reblogged-data (reblogger-status)

22
src/windows.lisp
View File

@ -98,10 +98,19 @@
`(with-accessors ((,slot croatoan-window)) ,window
,@body))
(defmacro when-window-shown ((window) &body body)
`(when (and ,window
(win-shown-p ,window))
,@body))
(defmacro when-window-shown ((window &key (min-valid-height 5) (min-valid-width 5)) &body body)
(with-gensyms (height width)
`(when ,window
(let ((,height (if (window-uses-border-p ,window)
(win-height-no-border ,window)
(win-height ,window)))
(,width (if (window-uses-border-p ,window)
(win-width-no-border ,window)
(win-width ,window))))
(when (and (win-shown-p ,window)
(> ,height ,min-valid-height)
(> ,width ,min-valid-width))
,@body)))))
(defun win-clear (window &key (redraw t))
"Clear window content"
@ -654,6 +663,11 @@ insetred by the user"
:reader uses-border-p))
(:documentation "This is a window that has a border."))
(defun window-uses-border-p (window)
(and window
(typep window 'border-window)
(uses-border-p window)))
(defmethod draw :after ((object border-window))
(when (uses-border-p object)
(win-box object)))