mirror of https://codeberg.org/cage/tinmop/
- added some functions to build the GUI.
This commit is contained in:
parent
2a96ff70ef
commit
abef1cfe33
30
Makefile.am
30
Makefile.am
|
@ -42,19 +42,23 @@ confdir = $(sysconfdir)/$(PACKAGE)
|
|||
|
||||
dist_conf_DATA = etc/init.lisp etc/default-theme.conf etc/shared.conf
|
||||
|
||||
nobase_dist_pkgdata_DATA = \
|
||||
data/modules/delete-by-regex.lisp \
|
||||
data/modules/expand-abbrev-command-window.lisp \
|
||||
data/modules/next-previous-open.lisp \
|
||||
data/modules/rewrite-message-urls.lisp \
|
||||
data/modules/share-gemini-link.lisp \
|
||||
data/scripts/export-gemini-subscriptions.lisp \
|
||||
data/scripts/gemget.lisp \
|
||||
data/scripts/get-following.lisp \
|
||||
data/scripts/import-following.lisp \
|
||||
data/scripts/import-gemini-subscriptions.lisp \
|
||||
data/scripts/welcome-bot.lisp \
|
||||
data/icons/search.png
|
||||
nobase_dist_pkgdata_DATA = \
|
||||
data/modules/delete-by-regex.lisp \
|
||||
data/modules/expand-abbrev-command-window.lisp \
|
||||
data/modules/next-previous-open.lisp \
|
||||
data/modules/rewrite-message-urls.lisp \
|
||||
data/modules/share-gemini-link.lisp \
|
||||
data/scripts/export-gemini-subscriptions.lisp \
|
||||
data/scripts/gemget.lisp \
|
||||
data/scripts/get-following.lisp \
|
||||
data/scripts/import-following.lisp \
|
||||
data/scripts/import-gemini-subscriptions.lisp \
|
||||
data/scripts/welcome-bot.lisp \
|
||||
data/icons/fmw_open_tour.png \
|
||||
data/icons/fmw_search.png \
|
||||
data/icons/fmw_refresh.png \
|
||||
data/icons/fmw_back.png \
|
||||
data/icons/fmw_go.png
|
||||
|
||||
dist_man1_MANS = doc/tinmop.man
|
||||
|
||||
|
|
28
Makefile.in
28
Makefile.in
|
@ -407,18 +407,22 @@ doc/tinmop.org doc/send-toot.lisp NEWS.org ChangeLog AUTHORS
|
|||
confdir = $(sysconfdir)/$(PACKAGE)
|
||||
dist_conf_DATA = etc/init.lisp etc/default-theme.conf etc/shared.conf
|
||||
nobase_dist_pkgdata_DATA = \
|
||||
data/modules/delete-by-regex.lisp \
|
||||
data/modules/expand-abbrev-command-window.lisp \
|
||||
data/modules/next-previous-open.lisp \
|
||||
data/modules/rewrite-message-urls.lisp \
|
||||
data/modules/share-gemini-link.lisp \
|
||||
data/scripts/export-gemini-subscriptions.lisp \
|
||||
data/scripts/gemget.lisp \
|
||||
data/scripts/get-following.lisp \
|
||||
data/scripts/import-following.lisp \
|
||||
data/scripts/import-gemini-subscriptions.lisp \
|
||||
data/scripts/welcome-bot.lisp \
|
||||
data/icons/search.png
|
||||
data/modules/delete-by-regex.lisp \
|
||||
data/modules/expand-abbrev-command-window.lisp \
|
||||
data/modules/next-previous-open.lisp \
|
||||
data/modules/rewrite-message-urls.lisp \
|
||||
data/modules/share-gemini-link.lisp \
|
||||
data/scripts/export-gemini-subscriptions.lisp \
|
||||
data/scripts/gemget.lisp \
|
||||
data/scripts/get-following.lisp \
|
||||
data/scripts/import-following.lisp \
|
||||
data/scripts/import-gemini-subscriptions.lisp \
|
||||
data/scripts/welcome-bot.lisp \
|
||||
data/icons/fmw_open_tour.png \
|
||||
data/icons/fmw_search.png \
|
||||
data/icons/fmw_refresh.png \
|
||||
data/icons/fmw_back.png \
|
||||
data/icons/fmw_go.png
|
||||
|
||||
dist_man1_MANS = doc/tinmop.man
|
||||
all: $(BUILT_SOURCES)
|
||||
|
|
|
@ -0,0 +1,5 @@
|
|||
(in-package :constants)
|
||||
|
||||
(define-constant +minimum-padding+ 2 :test #'=)
|
||||
|
||||
(define-constant +ps-file-dialog-filter+ '(("PostScript Files" "*.ps")) :test #'equalp)
|
|
@ -0,0 +1,72 @@
|
|||
(in-package :gui-goodies)
|
||||
|
||||
(cl-syntax:use-syntax 'gui-utils:nodgui-color-syntax)
|
||||
|
||||
(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=)
|
||||
|
||||
(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
|
||||
`((text ,(elt filter 0))
|
||||
,(elt filter 1)
|
||||
,(elt filter 2))))
|
||||
,@body))
|
||||
|
||||
(defun attach-tooltip (widget text)
|
||||
(let ((tooltip (make-instance 'nodgui.mw:tooltip
|
||||
:borderwidth 1
|
||||
:relief :solid)))
|
||||
(nodgui.mw:register-tooltip tooltip widget text)))
|
||||
|
||||
(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
|
||||
(with-busy (,root-widget)
|
||||
(with-hourglass ,(list root-widget)
|
||||
,@body))))
|
|
@ -1,6 +1,6 @@
|
|||
(in-package :icons)
|
||||
|
||||
(a:define-constant +icon-dir+ "/icons/" :test #'string=)
|
||||
(a:define-constant +icon-dir+ "/data/icons/" :test #'string=)
|
||||
|
||||
(a:define-constant +search+ "fmw_search" :test #'string=)
|
||||
|
||||
|
@ -12,28 +12,28 @@
|
|||
|
||||
(a:define-constant +refresh+ "fmw_refresh" :test #'string=)
|
||||
|
||||
(defparameter *icon-search* nil)
|
||||
(defparameter *search* nil)
|
||||
|
||||
(defparameter *icon-back* nil)
|
||||
(defparameter *back* nil)
|
||||
|
||||
(defparameter *icon-go* nil)
|
||||
(defparameter *open-iri* nil)
|
||||
|
||||
(defparameter *icon-open-tour* nil)
|
||||
(defparameter *open-tour* nil)
|
||||
|
||||
(defparameter *icon-refresh* nil)
|
||||
(defparameter *refresh* nil)
|
||||
|
||||
(defun load-icon (filename)
|
||||
(let ((path (if (not (re:scan "(?i)png$" filename))
|
||||
(res:get-config-file (fs:cat-parent-dir +icon-dir+
|
||||
(res:get-data-file (fs:cat-parent-dir +icon-dir+
|
||||
(strcat filename ".png")))
|
||||
(res:get-config-file (fs:cat-parent-dir +icon-dir+ filename)))))
|
||||
(res:get-data-file (fs:cat-parent-dir +icon-dir+ filename)))))
|
||||
(with-open-file (stream path :element-type '(unsigned-byte 8))
|
||||
(let ((data (gui-utils:read-into-array stream (file-length stream))))
|
||||
(gui:make-image data)))))
|
||||
|
||||
(defun load-icons ()
|
||||
(setf *icon-search* (load-icon +search+))
|
||||
(setf *icon-back* (load-icon +back+))
|
||||
(setf *icon-search* (load-icon +go+))
|
||||
(setf *icon-search* (load-icon +open-tour+))
|
||||
(setf *icon-search* (load-icon +refresh+)))
|
||||
(setf *search* (load-icon +search+))
|
||||
(setf *back* (load-icon +back+))
|
||||
(setf *open-iri* (load-icon +go+))
|
||||
(setf *open-tour* (load-icon +open-tour+))
|
||||
(setf *refresh* (load-icon +refresh+)))
|
||||
|
|
|
@ -85,12 +85,88 @@
|
|||
(defun initialize-menu (parent)
|
||||
(with-accessors ((main-window main-window)) parent
|
||||
(let* ((bar (gui:make-menubar))
|
||||
(file (gui:make-menu bar (_ "File")))
|
||||
(help (gui:make-menu bar (_ "Help"))))
|
||||
(file (gui:make-menu bar (_ "File") :underline 0))
|
||||
(help (gui:make-menu bar (_ "Help") :underline 0)))
|
||||
(gui:make-menubutton file (_ "Quit") #'menu:quit :underline 0)
|
||||
(gui:make-menubutton help (_ "About") #'menu:help-about :underline 0))))
|
||||
|
||||
(defclass main-frame (frame)
|
||||
(defclass tool-bar (gui:frame)
|
||||
((iri-entry
|
||||
:initform nil
|
||||
:initarg :iri-entry
|
||||
:accessor iri-entry)
|
||||
(back-button
|
||||
:initform nil
|
||||
:initarg :back-button
|
||||
:accessor back-button)
|
||||
(reload-button
|
||||
:initform nil
|
||||
:initarg :reload-button
|
||||
:accessor reload-button)
|
||||
(go-button
|
||||
:initform nil
|
||||
:initarg :go-button
|
||||
:accessor go-button)))
|
||||
|
||||
(defun autocomplete-iri-clsr (toolbar)
|
||||
(declare (ignore toolbar))
|
||||
(lambda (hint)
|
||||
hint))
|
||||
|
||||
(defmethod initialize-instance :after ((object tool-bar) &key &allow-other-keys)
|
||||
(with-accessors ((iri-entry iri-entry)
|
||||
(back-button back-button)
|
||||
(reload-button reload-button)
|
||||
(go-button go-button)) object
|
||||
(gui:configure object :relief :raised)
|
||||
(setf iri-entry
|
||||
(make-instance 'gui-mw:autocomplete-entry
|
||||
:master object
|
||||
:autocomplete-function (autocomplete-iri-clsr object)))
|
||||
(setf back-button (make-instance 'gui:button
|
||||
:master object
|
||||
:image icons:*back*))
|
||||
(setf reload-button (make-instance 'gui:button
|
||||
:master object
|
||||
:image icons:*refresh*))
|
||||
(setf go-button (make-instance 'gui:button
|
||||
:master object
|
||||
:image icons:*open-iri*))
|
||||
(gui-goodies:attach-tooltips (back-button (_ "go back"))
|
||||
(go-button (_ "go to address"))
|
||||
(reload-button (_ "reload address")))
|
||||
(gui:grid back-button 0 1 :sticky :nsw :padx +minimum-padding+)
|
||||
(gui:grid iri-entry 0 2 :sticky :we :padx +minimum-padding+)
|
||||
(gui:grid go-button 0 3 :sticky :e :padx +minimum-padding+)
|
||||
(gui:grid reload-button 0 4 :sticky :e)
|
||||
(gui:grid-columnconfigure object 2 :weight 2)
|
||||
object))
|
||||
|
||||
(defclass toc-frame (gui:frame)
|
||||
((toc-listbox
|
||||
:initform nil
|
||||
:initarg :toc-listbox
|
||||
:accessor toc-listbox)
|
||||
(toc-data
|
||||
:initform nil
|
||||
:initarg :toc-data
|
||||
:accessor toc-data)))
|
||||
|
||||
(defmethod initialize-instance :after ((object toc-frame) &key &allow-other-keys)
|
||||
(with-accessors ((toc-listbox toc-listbox)
|
||||
(toc-data toc-data)) object
|
||||
(setf toc-listbox (make-instance 'gui:scrolled-listbox
|
||||
:master object
|
||||
:name nil))
|
||||
(gui:grid toc-listbox 0 0
|
||||
:sticky :nswe
|
||||
:ipadx +minimum-padding+
|
||||
:ipady +minimum-padding+)
|
||||
(gui-goodies:gui-resize-grid-all object)
|
||||
))
|
||||
|
||||
|
||||
(defclass main-frame (gui:frame)
|
||||
((main-window
|
||||
:initform nil
|
||||
:initarg :main-window
|
||||
|
@ -99,19 +175,33 @@
|
|||
:initform nil
|
||||
:initarg :tool-bar
|
||||
:accessor tool-bar)
|
||||
(toc-pane
|
||||
(toc-frame
|
||||
:initform nil
|
||||
:initarg :toc-pane
|
||||
:accessor toc-pane)
|
||||
(info-pane
|
||||
:initarg :toc-frame
|
||||
:accessor toc-frame)
|
||||
(info-frame
|
||||
:initform nil
|
||||
:initarg :info-pane
|
||||
:accessor info-pane)))
|
||||
:initarg :info-frame
|
||||
:accessor info-frame)))
|
||||
|
||||
(defmethod initialize-instance :after ((object main-frame) &key &allow-other-keys))
|
||||
|
||||
;; (nodgui-utils:gui-resize-grid-all object))))
|
||||
(defmethod initialize-instance :after ((object main-frame) &key &allow-other-keys)
|
||||
(with-accessors ((main-window main-window)
|
||||
(tool-bar tool-bar)
|
||||
(toc-frame toc-frame)
|
||||
(info-frame info-frame)) object
|
||||
(setf tool-bar (make-instance 'tool-bar :master object))
|
||||
(setf toc-frame (make-instance 'toc-frame :master object))
|
||||
(gui:grid tool-bar 0 0 :sticky :new)
|
||||
(gui:grid toc-frame 1 0 :sticky :nsw)
|
||||
(gui:grid-columnconfigure object :all :weight 1)
|
||||
(gui:grid-rowconfigure object 1 :weight 1)
|
||||
object))
|
||||
|
||||
(defun init-main-window ()
|
||||
(let ((gui:*debug-tk* nil))
|
||||
(gui:with-nodgui (:title +program-name+))))
|
||||
(gui:with-nodgui (:title +program-name+)
|
||||
(icons:load-icons)
|
||||
(initialize-menu gui:*tk*)
|
||||
(let ((main-frame (make-instance 'main-frame)))
|
||||
(gui:grid main-frame 0 0 :sticky :nswe)
|
||||
(gui-goodies:gui-resize-grid-all gui:*tk*)))))
|
||||
|
|
|
@ -7,5 +7,5 @@
|
|||
(gui:pack editor))))
|
||||
|
||||
(defun quit ()
|
||||
(serv:close-server)
|
||||
;;(serv:close-server)
|
||||
(gui:break-mainloop))
|
||||
|
|
|
@ -0,0 +1,31 @@
|
|||
(in-package :validation)
|
||||
|
||||
(defgeneric validate (object datum))
|
||||
|
||||
(defclass validator ()
|
||||
((error-message
|
||||
:initform ""
|
||||
:initarg :error-message
|
||||
:accessor error-message)
|
||||
(validation-function
|
||||
:initform (lambda (datum) datum)
|
||||
:initarg :validation-function
|
||||
:accessor validation-function)))
|
||||
|
||||
(defmethod validate ((object validator) datum)
|
||||
(when (not (funcall (validation-function datum)))
|
||||
(error-message object)))
|
||||
|
||||
(defclass regexp-validator (validator)
|
||||
((regexp
|
||||
:initform ".*"
|
||||
:initarg :regexp
|
||||
:accessor regexp)
|
||||
(error-message
|
||||
:initform ".*"
|
||||
:initarg :error-message
|
||||
:accessor error-message)))
|
||||
|
||||
(defmethod regexp-validate ((object regexp-validator) datum)
|
||||
(when (not (re:scan (regexp object) datum))
|
||||
(error-message object)))
|
|
@ -65,7 +65,10 @@
|
|||
:+mention-prefix+
|
||||
:+cache-tls-certificate-type+
|
||||
:+standard-editor+
|
||||
:+octect-type+))
|
||||
:+octect-type+
|
||||
;; GUI
|
||||
:+minimum-padding+
|
||||
:+ps-file-dialog-filter+))
|
||||
|
||||
(defpackage :conditions
|
||||
(:use :cl
|
||||
|
@ -3268,17 +3271,60 @@
|
|||
(:gui-utils :nodgui.utils))
|
||||
(:export
|
||||
:+icon-dir+
|
||||
:*icon-search*
|
||||
:*icon-back*
|
||||
:*icon-go*
|
||||
:*icon-open-tour*
|
||||
:*icon-refresh*))
|
||||
:load-icons
|
||||
:*search*
|
||||
:*back*
|
||||
:*open-iri*
|
||||
:*open-tour*
|
||||
:*refresh*))
|
||||
|
||||
(defpackage :validation
|
||||
(:use
|
||||
:cl
|
||||
:config
|
||||
:constants)
|
||||
(:local-nicknames (:serv :json-rpc-communication)
|
||||
(:re :cl-ppcre)
|
||||
(:a :alexandria)
|
||||
(:gui :nodgui)
|
||||
(:gui-utils :nodgui.utils))
|
||||
(:export
|
||||
:validator
|
||||
:regexp-validator
|
||||
:validate))
|
||||
|
||||
(defpackage :gui-goodies
|
||||
(:use :cl
|
||||
:config
|
||||
:constants
|
||||
:misc
|
||||
:text-utils)
|
||||
(:local-nicknames (:serv :json-rpc-communication)
|
||||
(:re :cl-ppcre)
|
||||
(:a :alexandria)
|
||||
(:gui :nodgui)
|
||||
(:gui-mw :nodgui.mw)
|
||||
(:gui-utils :nodgui.utils)
|
||||
(:gui-shapes :nodgui.shapes))
|
||||
(:export
|
||||
:gui-resize-grid-all
|
||||
:confirm-deletion
|
||||
:info-operation-completed
|
||||
:info-dialog
|
||||
:error-dialog
|
||||
:re-validate
|
||||
:with-re-validate
|
||||
:with-entry-text-validate
|
||||
:attach-tooltip
|
||||
:attach-tooltips
|
||||
:with-busy*))
|
||||
|
||||
(defpackage :client-menu-command
|
||||
(:use
|
||||
:cl
|
||||
:config
|
||||
:constants
|
||||
:gui-goodies
|
||||
:text-utils
|
||||
:misc-utils)
|
||||
(:local-nicknames (:serv :json-rpc-communication)
|
||||
|
|
|
@ -157,9 +157,12 @@
|
|||
(:file "json-rpc-communication")))
|
||||
(:module gui-client
|
||||
:pathname "gui/client"
|
||||
:components ((:file "client-configuration")
|
||||
:components ((:file "constants")
|
||||
(:file "client-configuration")
|
||||
(:file "program-events")
|
||||
(:file "json-rpc-communication")
|
||||
(:file "validation")
|
||||
(:file "gui-goodies")
|
||||
(:file "icons")
|
||||
(:file "menu-command")
|
||||
(:file "main-window")))
|
||||
|
|
Loading…
Reference in New Issue