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

- added some functions to build the GUI.

This commit is contained in:
cage 2023-02-08 13:02:26 +01:00
parent 2a96ff70ef
commit abef1cfe33
10 changed files with 314 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
Makefile.am
View File

@ -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
View File

@ -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)

5
src/gui/client/constants.lisp Normal file
View File

@ -0,0 +1,5 @@
(in-package :constants)
(define-constant +minimum-padding+ 2 :test #'=)
(define-constant +ps-file-dialog-filter+ '(("PostScript Files" "*.ps")) :test #'equalp)

72
src/gui/client/gui-goodies.lisp Normal file
View File

@ -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))))

26
src/gui/client/icons.lisp
View File

@ -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+)))

116
src/gui/client/main-window.lisp
View File

@ -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*)))))

2
src/gui/client/menu-command.lisp
View File

@ -7,5 +7,5 @@
(gui:pack editor))))
(defun quit ()
(serv:close-server)
;;(serv:close-server)
(gui:break-mainloop))

31
src/gui/client/validation.lisp Normal file
View File

@ -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)))

58
src/package.lisp
View File

@ -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)

5
tinmop.asd
View File

@ -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")))