mirror of https://codeberg.org/cage/tinmop/
- [GUI] added client events loop.
This commit is contained in:
parent
045819b4a4
commit
155cdc1117
|
@ -32,7 +32,7 @@
|
|||
(typep thing 'box))
|
||||
|
||||
(defun box (thing)
|
||||
"Put `thing' in a box, if thing is aalready a box return `thing'."
|
||||
"Put `thing' in a box, if thing is a already a box return `thing'."
|
||||
(if (boxp thing)
|
||||
thing
|
||||
(make-instance 'box :contents thing)))
|
||||
|
|
|
@ -1598,6 +1598,11 @@
|
|||
:remove-event
|
||||
:remove-event-if
|
||||
:find-event
|
||||
:function-event
|
||||
:with-enqueued-process
|
||||
:event-on-own-thread
|
||||
:blocking-caller-event
|
||||
:push-function-and-wait-results
|
||||
:ask-user-input-string-event
|
||||
:user-input-string-event
|
||||
:notify-user-event
|
||||
|
@ -1698,8 +1703,6 @@
|
|||
:send-to-pipe-event
|
||||
:print-mentions-event
|
||||
:delete-all-notifications-event
|
||||
:function-event
|
||||
:with-enqueued-process
|
||||
:dispatch-program-events))
|
||||
|
||||
(defpackage :api-pleroma
|
||||
|
@ -3230,6 +3233,21 @@
|
|||
:gemini-preformatted-fg
|
||||
:gemini-toc-padding-char))
|
||||
|
||||
(defpackage :client-events
|
||||
(:use
|
||||
:cl
|
||||
:config
|
||||
:constants
|
||||
:text-utils
|
||||
:misc-utils)
|
||||
(:local-nicknames (:re :cl-ppcre)
|
||||
(:a :alexandria)
|
||||
(:ev :program-events))
|
||||
(:export
|
||||
:events-loop-running-p
|
||||
:stop-events-loop
|
||||
:start-events-loop))
|
||||
|
||||
(defpackage :main
|
||||
(:use
|
||||
:cl
|
||||
|
|
|
@ -180,6 +180,20 @@
|
|||
(wrapped-in-lock (*events-queue*)
|
||||
(map-elements *events-queue* fn)))
|
||||
|
||||
;;;; generic events
|
||||
|
||||
(defclass function-event (program-event) ())
|
||||
|
||||
(defmethod process-event ((object function-event))
|
||||
(with-accessors ((payload payload)) object
|
||||
(assert (functionp payload))
|
||||
(funcall payload)))
|
||||
|
||||
(defmacro with-enqueued-process ((&optional (priority +standard-event-priority+)) &body body)
|
||||
`(push-event (make-instance 'function-event
|
||||
:payload (lambda () ,@body)
|
||||
:priority ,priority)))
|
||||
|
||||
(defclass event-on-own-thread (program-event)
|
||||
((lock
|
||||
:initform (bt:make-recursive-lock)
|
||||
|
@ -190,9 +204,38 @@
|
|||
:initarg :condition-variable
|
||||
:accessor condition-variable))
|
||||
(:documentation "This is the parent of all events that are
|
||||
generated in athread that is not the main thread, contains a
|
||||
generated in a thread that is not the main thread, contains a
|
||||
condition variable and associated lock"))
|
||||
|
||||
(defclass blocking-caller-event (event-on-own-thread function-event)
|
||||
((results
|
||||
:initform (make-instance 'box:box)
|
||||
:initarg :results
|
||||
:accessor results)))
|
||||
|
||||
(defmethod process-event ((object blocking-caller-event))
|
||||
(with-accessors ((lock lock)
|
||||
(condition-variable condition-variable)
|
||||
(callback payload)
|
||||
(results results)) object
|
||||
(setf (box:unbox results) (funcall callback))
|
||||
(with-lock (lock)
|
||||
(bt:condition-notify condition-variable))))
|
||||
|
||||
(defun push-function-and-wait-results (fn)
|
||||
(let* ((event (make-instance 'blocking-caller-event :payload fn))
|
||||
(lock (lock event))
|
||||
(condition-variable (condition-variable event)))
|
||||
(push-event event)
|
||||
(with-lock (lock)
|
||||
(loop
|
||||
while (null (box:unbox (results event)))
|
||||
do
|
||||
(bt:condition-wait condition-variable lock)))
|
||||
(box:unbox (results event))))
|
||||
|
||||
;;;;
|
||||
|
||||
(defclass ask-user-input-string-event (event-on-own-thread)
|
||||
((prompt
|
||||
:initform +default-command-prompt+
|
||||
|
@ -1714,20 +1757,6 @@
|
|||
(windows:draw message-window))
|
||||
(ui:info-message (_ "No mentions")))))
|
||||
|
||||
;;;; general usage
|
||||
|
||||
(defclass function-event (program-event) ())
|
||||
|
||||
(defmethod process-event ((object function-event))
|
||||
(with-accessors ((payload payload)) object
|
||||
(assert (functionp payload))
|
||||
(funcall payload)))
|
||||
|
||||
(defmacro with-enqueued-process ((&optional (priority +standard-event-priority+)) &body body)
|
||||
`(push-event (make-instance 'function-event
|
||||
:payload (lambda () ,@body)
|
||||
:priority ,priority)))
|
||||
|
||||
(defclass delete-all-notifications-event (program-event) ())
|
||||
|
||||
(defmethod process-event ((object delete-all-notifications-event))
|
||||
|
|
|
@ -73,3 +73,26 @@
|
|||
(setf specials:*command-window* (make-instance 'dummy-window))
|
||||
(assert-true
|
||||
(string= "foo" (dunbox (simulated-string-input)))))
|
||||
|
||||
(defun callback ()
|
||||
"callback called!")
|
||||
|
||||
(defun callback-example ()
|
||||
(flet ((callback () "callback called!"))
|
||||
(client-events:start-events-loop)
|
||||
(let ((res nil))
|
||||
(bt:make-thread (lambda ()
|
||||
(sleep 1)
|
||||
(setf res (push-function-and-wait-results #'callback))))
|
||||
(map 'nil
|
||||
(lambda (a)
|
||||
(sleep 1)
|
||||
(push-event (make-instance 'function-event
|
||||
:payload (lambda () (format t "~a~%" a)))))
|
||||
(loop for i from 0 to 10 collect i))
|
||||
(sleep 20)
|
||||
(client-events:stop-events-loop)
|
||||
res)))
|
||||
|
||||
(deftest test-callback (program-events-suite)
|
||||
(assert-equality #'string= "callback called!" (callback-example)))
|
||||
|
|
|
@ -156,7 +156,8 @@
|
|||
(:file "json-rpc-communication")))
|
||||
(:module gui-client
|
||||
:pathname "gui/client"
|
||||
:components ((:file "client-configuration")))
|
||||
:components ((:file "client-configuration")
|
||||
(:file "program-events")))
|
||||
(:file "main")
|
||||
(:module tests
|
||||
:components ((:file "package")
|
||||
|
|
Loading…
Reference in New Issue