mirror of https://codeberg.org/cage/tinmop/
137 lines
4.7 KiB
Common Lisp
137 lines
4.7 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 :modeline-window)
|
|
|
|
(defclass modeline-window (wrapper-window)
|
|
((mapping-code->fn
|
|
:initform ()
|
|
:initarg :mapping-code->fn
|
|
:accessor mapping-code->fn)
|
|
(modeline-src
|
|
:initform ""
|
|
:initarg :modeline-text-src
|
|
:accessor modeline-src)
|
|
(modeline-text
|
|
:initform (_ "modeline")
|
|
:initarg :modeline-text
|
|
:accessor modeline-text)
|
|
(modeline-fg
|
|
:initform nil
|
|
:initarg :modeline-fg
|
|
:accessor modeline-fg)
|
|
(modeline-bg
|
|
:initform nil
|
|
:initarg :modeline-bg
|
|
:accessor modeline-bg)
|
|
(parsed-modeline
|
|
:initform ()
|
|
:initarg :parsed-modeline
|
|
:accessor parsed-modeline)))
|
|
|
|
(defgeneric expand-modeline-spec (object))
|
|
|
|
;; MODELINE := (FIELD | TEXT)*
|
|
;; FIELD := PERCENT KEY
|
|
;; KEY := [%abcdefghilmnopqrstuvzABCDEFGHILMNOPQRSTUVZ']
|
|
;; PERCENT := '%'
|
|
;; TEXT := (not percent)+
|
|
|
|
(defrule key
|
|
(or #\%
|
|
#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
|
|
#\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
|
|
#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
|
|
#\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)
|
|
(:text t))
|
|
|
|
(defrule percent #\%
|
|
(:constant :key))
|
|
|
|
(defrule field (and percent key))
|
|
|
|
(defrule text (+ (not percent))
|
|
(:text t))
|
|
|
|
(defrule modeline (* (or field text)))
|
|
|
|
(defun call-function-mapped (win key mapping)
|
|
(let ((fn (cdr (assoc key mapping :test #'string=))))
|
|
(if fn
|
|
(funcall fn win)
|
|
(format nil "~~~a" key))))
|
|
|
|
(defmethod expand-modeline-spec ((object modeline-window))
|
|
(with-accessors ((modeline-src modeline-src)
|
|
(modeline-text modeline-text)
|
|
(modeline-bg modeline-bg)
|
|
(modeline-fg modeline-fg)
|
|
(mapping-code->fn mapping-code->fn)
|
|
(parsed-modeline parsed-modeline)) object
|
|
;; parsed is like '("foo" (:key "a") "bar" ...)
|
|
(let ((res (make-tui-string "")))
|
|
(loop for i in parsed-modeline do
|
|
(let ((executed (cond
|
|
((listp i)
|
|
(call-function-mapped object (lastcar i) mapping-code->fn))
|
|
(t
|
|
(make-tui-string i
|
|
:fgcolor modeline-fg
|
|
:bgcolor modeline-bg)))))
|
|
(setf res (cat-tui-string res executed))))
|
|
(setf res (text-ellipsis res (win-width-no-border object)))
|
|
(setf modeline-text res))))
|
|
|
|
(defun refresh-modeline-config (win key)
|
|
(with-accessors ((modeline-src modeline-src)
|
|
(modeline-text modeline-text)
|
|
(modeline-bg modeline-bg)
|
|
(modeline-fg modeline-fg)
|
|
(mapping-code->fn mapping-code->fn)
|
|
(parsed-modeline parsed-modeline)) win
|
|
(multiple-value-bind (bg fg)
|
|
(swconf:modeline-colors key)
|
|
(setf modeline-fg fg)
|
|
(setf modeline-bg bg)
|
|
(setf modeline-src (swconf:modeline-fmt key))
|
|
(setf parsed-modeline (parse 'modeline modeline-src))
|
|
(expand-modeline-spec win))
|
|
win))
|
|
|
|
(defmethod calculate ((object modeline-window) dt))
|
|
|
|
(defmethod draw :after ((object modeline-window))
|
|
(with-accessors ((modeline-bg modeline-bg)
|
|
(modeline-fg modeline-fg)
|
|
(modeline-text modeline-text)) object
|
|
(when-window-shown (object)
|
|
(let* ((line modeline-text)
|
|
(line-length (text-length line))
|
|
(max-width (win-width-no-border object)))
|
|
(when (< line-length max-width)
|
|
(setf line
|
|
(cat-tui-string line
|
|
(build-string (- max-width line-length))
|
|
:color-attributes-contagion t)))
|
|
(print-text object line 1 (1- (win-height object)))))))
|
|
|
|
(defun add-modeline-char-expander (win code fn)
|
|
(assert (stringp code))
|
|
(assert (functionp fn))
|
|
(with-accessors ((mapping-code->fn mapping-code->fn)) win
|
|
(setf mapping-code->fn
|
|
(acons code fn mapping-code->fn))))
|