csys tests: use test-core receiver; + test-core fixes

This commit is contained in:
Helmut Merz 2026-03-09 07:51:02 +01:00
parent 3782305853
commit 0335e7e54d
4 changed files with 39 additions and 30 deletions

View file

@ -15,7 +15,7 @@
#:send #:send-message #:send #:send-message
#:neuron #:synapse #:neuron #:synapse
#:make-neuron #:update-neuron #:make-neuron #:update-neuron
#:make-eff-proc #:handle-action)) #:handle-action))
(in-package :scopes/csys) (in-package :scopes/csys)
@ -87,12 +87,6 @@
(forward nmsg nsyns) (forward nmsg nsyns)
(update-neuron #'std-proc nst nsyns env))) (update-neuron #'std-proc nst nsyns env)))
(defun make-eff-proc (handler)
(lambda (msg state syns env)
;(util:lgi msg)
(funcall handler msg)
(handle-action msg state syns env :default #'remember)))
(defun forward (msg syns) (defun forward (msg syns)
(dolist (s syns) (dolist (s syns)
(funcall s msg))) (funcall s msg)))
@ -115,3 +109,7 @@
(sensor (make-neuron actor:*self* :state key))) (sensor (make-neuron actor:*self* :state key)))
(setf (gethash key (sensors env)) (list sensor)) (setf (gethash key (sensors env)) (list sensor))
(list msg state syns))) (list msg state syns)))
(defun add (msg state syns env)
(list msg (+ (shape:data msg) state) syns env))

View file

@ -14,7 +14,7 @@
:in-order-to ((test-op (test-op "scopes-csys/test")))) :in-order-to ((test-op (test-op "scopes-csys/test"))))
(defsystem :scopes-csys/test (defsystem :scopes-csys/test
:depends-on (:scopes-csys) :depends-on (:scopes-csys :scopes-core/test)
:components ((:file "test/test-csys")) :components ((:file "test/test-csys"))
:perform (test-op (o c) :perform (test-op (o c)
(symbol-call :scopes/test-csys :run))) (symbol-call :scopes/test-csys :run)))

View file

@ -14,7 +14,9 @@
(:shape :scopes/shape) (:shape :scopes/shape)
(:util :scopes/util) (:util :scopes/util)
(:t :scopes/testing)) (:t :scopes/testing))
(:export #:run #:user #:password) (:export #:run #:user #:password
#:test-receiver #:receiver #:expect #:check-message #:check-expected
#:setup #:test-suite)
(:import-from :scopes/testing #:deftest #:== #:!=)) (:import-from :scopes/testing #:deftest #:== #:!=))
(in-package :scopes/test-core) (in-package :scopes/test-core)
@ -22,18 +24,21 @@
;;;; core/testing: test-receiver ;;;; core/testing: test-receiver
(defclass test-receiver (core:context) (defclass test-receiver (core:context)
((expected :accessor expected ((suite :reader suite :initarg :suite)
(expected :accessor expected
:initform (make-hash-table :test #'equalp)))) :initform (make-hash-table :test #'equalp))))
(defun setup (cfg) (defun setup (cfg)
(funcall (core:make-setup :class 'test-receiver) cfg)) (funcall (core:make-setup :class 'test-receiver
:args (list :suite t:*test-suite*)) cfg))
(defun check-message (ctx msg) (defun check-message (ctx msg)
(let ((key (shape:head msg))) (let ((key (shape:head msg))
(t:*test-suite* (suite ctx)))
(multiple-value-bind (val found) (gethash key (expected ctx)) (multiple-value-bind (val found) (gethash key (expected ctx))
(if found (if found
(progn (progn
(if (not (equalp (shape:data msg) val)) (if (and val (not (equalp (shape:data msg) val)))
(t:failure "data mismatch: ~s, expected: ~s" msg val)) (t:failure "data mismatch: ~s, expected: ~s" msg val))
(remhash key (expected ctx))) (remhash key (expected ctx)))
(t:failure "unexpected: ~s" msg))))) (t:failure "unexpected: ~s" msg)))))

View file

@ -12,7 +12,8 @@
(:message :scopes/core/message) (:message :scopes/core/message)
(:shape :scopes/shape) (:shape :scopes/shape)
(:util :scopes/util) (:util :scopes/util)
(:t :scopes/testing)) (:t :scopes/testing)
(:tc :scopes/test-core))
(:export #:run) (:export #:run)
(:import-from :scopes/testing #:deftest #:== #:!= #:in-seq)) (:import-from :scopes/testing #:deftest #:== #:!= #:in-seq))
@ -23,41 +24,46 @@
(defclass test-env (csys:environment) (defclass test-env (csys:environment)
((test-suite :reader test-suite :initarg :test-suite))) ((test-suite :reader test-suite :initarg :test-suite)))
(defun eff-handler (state &optional (env csys:*environment*)) (defun setup-config ()
(lambda (msg) (config:add :test-receiver :setup #'tc:setup)
(util:lgi msg state) (config:add-action '(:csys :sub) #'tc:check-message)
(let ((t:*test-suite* (test-suite env)) (config:add-action '(:csys) (constantly nil))
(val (shape:data msg))) )
(unless (consp val)
(setf state (in-seq val state :remove t))))))
(defun add (msg state syns env) (defun eff-proc (msg state syns env)
(list msg (+ (shape:data msg) state) syns env)) (util:lgi msg)
(let ((t:*test-suite* (test-suite env)))
(actor:send (core:mailbox (tc:receiver t:*test-suite*)) msg))
(csys:handle-action msg state syns env))
;;;; test runner ;;;; test runner
(defun run () (defun run ()
(async:init) (async:init)
(let* ((t:*test-suite* (make-instance 't:test-suite :name "csys")) (let* ((t:*test-suite* (make-instance 'tc:test-suite :name "csys"))
(csys:*environment* (make-instance 'test-env :test-suite t:*test-suite*))) (csys:*environment* (make-instance 'test-env :test-suite t:*test-suite*)))
(load (t:test-path "config-csys" "etc")) (load (t:test-path "config-csys" "etc"))
(setup-config)
(core:setup-services) (core:setup-services)
(unwind-protect (unwind-protect
(progn (let ((rcvr (core:find-service :test-receiver)))
(test-init)) (setf (tc:receiver t:*test-suite*) rcvr)
(test-init rcvr))
(sleep 0.1) (sleep 0.1)
(async:finish) (core:shutdown)
(tc:check-expected)
(t:show-result)))) (t:show-result))))
(deftest test-init () (deftest test-init (rcvr)
(setf (gethash '(:effect :default) (csys:procs csys:*environment*)) (setf (gethash '(:effect :default) (csys:procs csys:*environment*)) #'eff-proc)
(csys:make-eff-proc (eff-handler '(1 3 4 5)))) ;(csys:make-eff-proc (eff-handler '(1 3 4 5))))
(csys:init) (csys:init)
(csys:send-message '(:csys :sensor :init :zero) '(:std :s1)) (csys:send-message '(:csys :sensor :init :zero) '(:std :s1))
(csys:send-message '(:csys :sensor :init :zero) '(:std :s2)) (csys:send-message '(:csys :sensor :init :zero) '(:std :s2))
(sleep 0.1) (sleep 0.1)
(csys:send-message '(:csys :add :std :s1) 1) (csys:send-message '(:csys :add :std :s1) 1)
(csys:send-message '(:csys :add :std :s1) 3) (csys:send-message '(:csys :add :std :s1) 3)
(tc:expect rcvr (message:create '(:csys :sub :std :s2) :data 4))
(csys:send-message '(:csys :sub :std :s2) 4) (csys:send-message '(:csys :sub :std :s2) 4)
(csys:send-message '(:csys :add :std :s2) 5) (csys:send-message '(:csys :add :std :s2) 5)
) )