mirror of https://codeberg.org/cage/tinmop/
134 lines
4.6 KiB
Common Lisp
134 lines
4.6 KiB
Common Lisp
(in-package :gui-goodies)
|
|
|
|
(named-readtables:in-readtable nodgui.syntax:nodgui-syntax)
|
|
|
|
(defparameter *toplevel* gui:*tk*)
|
|
|
|
(defparameter *gui-server* nil)
|
|
|
|
(defparameter *main-frame* nil)
|
|
|
|
(a:define-constant +font-h1+ "sans 20 bold" :test #'string=)
|
|
|
|
(a:define-constant +font-h2+ "sans 15 bold" :test #'string=)
|
|
|
|
(a:define-constant +font-h3+ "bold" :test #'string=)
|
|
|
|
(defgeneric parse-color (object))
|
|
|
|
(defmethod parse-color ((object symbol))
|
|
(parse-color (string-downcase (symbol-name object))))
|
|
|
|
(defmethod parse-color ((object string))
|
|
(nodgui.utils:rgb->tk (cl-colors2:as-rgb object)))
|
|
|
|
(defmethod parse-color ((object number))
|
|
(nodgui.utils:rgb->tk (cl-colors2:as-rgb object)))
|
|
|
|
(defun make-font (font-name font-size font-weight font-slant underline)
|
|
(gui:font-create (nodgui.utils:create-name)
|
|
:family font-name
|
|
:size font-size
|
|
:weight font-weight
|
|
:slant font-slant
|
|
:underline underline
|
|
:overstrike nil))
|
|
|
|
(defun gui-resize-grid-all (w)
|
|
(gui:grid-columnconfigure w :all :weight 1)
|
|
(gui:grid-rowconfigure w :all :weight 1))
|
|
|
|
(defun confirm-deletion (parent how-many)
|
|
(gui:ask-yesno (format nil (n_ "~a element will be deleted; continue?"
|
|
"~a elements will be deleted; continue?"
|
|
how-many)
|
|
how-many)
|
|
:title (_ "Confirm operation")
|
|
:parent parent))
|
|
|
|
(defun info-operation-completed (parent)
|
|
(gui:message-box (_ "Operation completed") (_ "information") :ok "info" :parent parent))
|
|
|
|
(defun info-dialog (parent message &key (title (_ "Information")))
|
|
(gui:message-box message title :ok "info" :parent parent))
|
|
|
|
(defun error-dialog (parent message &key (title (_ "Error")))
|
|
(gui:message-box message title :ok "error" :parent parent))
|
|
|
|
(defun re-validate (parent datum regex error-message)
|
|
(let* ((validator (make-instance 'validation:regexp-validator
|
|
:error-message error-message
|
|
:regexp regex))
|
|
(passedp (validation:validate validator datum)))
|
|
(if (not passedp)
|
|
(progn
|
|
(error-dialog parent error-message)
|
|
nil)
|
|
t)))
|
|
|
|
(defmacro with-re-validate ((parent &rest filters) &body body)
|
|
"each filter is -> '(datum regexp error-message)"
|
|
`(and ,@(loop for filter in filters collect
|
|
`(apply #'re-validate (list ,parent ,@filter)))
|
|
,@body))
|
|
|
|
(defmacro with-entry-text-validate ((parent &rest filters) &body body)
|
|
"filtrers -> '(entry-widget regex error-message)"
|
|
`(with-re-validate (,parent ,@(loop for filter in filters collect
|
|
`((gui:text ,(elt filter 0))
|
|
,(elt filter 1)
|
|
,(elt filter 2))))
|
|
,@body))
|
|
|
|
(defun attach-tooltip (widget tootltip-message)
|
|
(let ((tooltip (make-instance 'nodgui.mw:tooltip
|
|
:borderwidth 1
|
|
:relief :solid)))
|
|
(nodgui.mw:register-tooltip tooltip widget tootltip-message)))
|
|
|
|
(defmacro attach-tooltips (&rest widget-text)
|
|
`(progn
|
|
,@(loop for i in widget-text collect
|
|
`(attach-tooltip ,(first i) ,(second i)))))
|
|
|
|
(defmacro with-busy* ((root-widget) &body body)
|
|
`(progn
|
|
(gui:with-busy (,root-widget)
|
|
(gui:with-hourglass ,(list root-widget)
|
|
,@body))))
|
|
|
|
(defun password-dialog (parent title message &key (button-message (_ "OK")))
|
|
(gui-mw:password-input-dialog parent title message :ok-button-label button-message))
|
|
|
|
(defclass table-frame (gui:frame)
|
|
((tree
|
|
:accessor tree
|
|
:initform nil
|
|
:initarg :tree)
|
|
(rows
|
|
:accessor rows
|
|
:initform '()
|
|
:initarg :rows)))
|
|
|
|
(defun quite-good-dialog-width (&optional (chars-unit t))
|
|
(if chars-unit
|
|
(truncate (min (/ (gui:screen-width) 2
|
|
(gui:font-measure gui:+tk-text-font+ "0"))))
|
|
(truncate (/ (gui:screen-width) 2))))
|
|
|
|
(defun notify-request-error (error)
|
|
(error-dialog gui-goodies:*toplevel* error))
|
|
|
|
(defmacro with-notify-errors (&body body)
|
|
`(handler-case
|
|
(progn ,@body)
|
|
(comm:rpc-error-response (e)
|
|
#+debug-mode (misc:dbg "backend comunication RPC error ~a" e)
|
|
(notify-request-error (format nil
|
|
(_ "~a: ~a")
|
|
(comm:code e)
|
|
(conditions:text e))))
|
|
(error (e)
|
|
#+debug-mode (misc:dbg "backend comunication error ~a" e)
|
|
(notify-request-error e))))
|