From 155cdc1117f23002a972a83a3ca825d9f2530efa Mon Sep 17 00:00:00 2001 From: cage Date: Sun, 15 Jan 2023 15:56:00 +0100 Subject: [PATCH] - [GUI] added client events loop. --- src/box.lisp | 2 +- src/package.lisp | 22 ++++++++++- src/program-events.lisp | 59 +++++++++++++++++++++-------- src/tests/program-events-tests.lisp | 23 +++++++++++ tinmop.asd | 3 +- 5 files changed, 90 insertions(+), 19 deletions(-) diff --git a/src/box.lisp b/src/box.lisp index a331c11..8aaa299 100644 --- a/src/box.lisp +++ b/src/box.lisp @@ -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))) diff --git a/src/package.lisp b/src/package.lisp index 28e90ea..d82298e 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -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 diff --git a/src/program-events.lisp b/src/program-events.lisp index 1ebec22..f1d0f5e 100644 --- a/src/program-events.lisp +++ b/src/program-events.lisp @@ -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)) diff --git a/src/tests/program-events-tests.lisp b/src/tests/program-events-tests.lisp index 8a9d2c8..8194390 100644 --- a/src/tests/program-events-tests.lisp +++ b/src/tests/program-events-tests.lisp @@ -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))) diff --git a/tinmop.asd b/tinmop.asd index 63a642d..cecb78b 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -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")