test-receiver: full functionality, using head list as key in hash table

core/message.lisp

@@ -4,16 +4,33 @@
   (:use :common-lisp)
   (:local-nicknames (:core :scopes/core))
   (:export #:message #:simple-message
-           #:head #:data))
+           #:head #:data
+           #:as-list))
 
 (in-package :scopes/core/message)
 
+(defgeneric as-list (obj))
+
+;;;; message-head
+
 (defclass message-head ()
   ((domain)
    (action)
    (class)
    (item)))
 
+(defmethod print-object ((head message-head) stream)
+  (with-slots (domain action class item) head
+    (format stream 
+            "<message-head (~a ~a ~a ~a)>"
+            domain action class item)))
+
+(defmethod as-list ((h message-head))
+  (with-slots (domain action class item) h
+    (list domain action class item)))
+
+;;;; message
+
 (defclass message ()
   ((head :reader head :initarg :head)
    (sender)

test/test-core.lisp

@@ -2,7 +2,8 @@
 
 (defpackage :scopes/test-core
   (:use :common-lisp)
-  (:local-nicknames (:config :scopes/config)
+  (:local-nicknames (:alx :alexandria)
+                    (:config :scopes/config)
                     (:core :scopes/core)
                     (:message :scopes/core/message)
                     (:util :scopes/util)
@@ -24,13 +25,26 @@
    (expected :accessor expected :initform (make-hash-table :test #'equalp))))
 
 (defun check-message (ctx msg)
-  (multiple-value-bind (val found) (gethash (message:head msg) (expected ctx))
-    (if (not found)
-      (push (format nil "unexpected: ~s" msg)
-            (t:errors t:*test-suite*)))))
+  (let ((key (message:as-list (message:head msg))))
+    (multiple-value-bind (val found) (gethash key (expected ctx))
+      (if found
+        (progn
+          (if (not (equalp (message:data msg) val))
+            (push (format nil "no matchhing data: ~s, expected: ~s" msg val)
+                  (t:errors t:*test-suite*)))
+          (remhash key (expected ctx)))
+        (push (format nil "unexpected: ~s" msg)
+              (t:errors t:*test-suite*))))))
 
 (defun expect (ctx msg)
-  (setf (gethash (message:head msg) (expected ctx)) (message:data msg)))
+  (setf (gethash (message:as-list (message:head msg)) (expected ctx))
+        (message:data msg)))
+
+(defun check-expected ()
+  (let ((exp (alx:hash-table-keys (expected (receiver t:*test-suite*)))))
+    (if exp
+      (push (format nil "unused messages: ~s" exp) 
+            (t:errors t:*test-suite*)))))
 
 ;;;; test runner
 
@@ -44,13 +58,16 @@
         (t:*test-suite* (make-instance 'test-suite :name "core")))
     (load (t:test-path "config-core" "etc"))
     (test-send)
+    (check-expected)
     (t:show-result)))
 
 (t:deftest test-send ()
   (let ((rcvr (receiver t:*test-suite*))
-        (msg (message:simple-message :test :dummy)))
+        (msg (message:simple-message :test :dummy))
+        (msg-exp (message:simple-message :test :dummy)))
     (setf (message:data msg) "dummy payload")
-    (expect rcvr msg)
+    (setf (message:data msg-exp) "dummy payload")
+    (expect rcvr msg-exp)
     (== (core:name rcvr) :test-rcvr)
     (core:send rcvr msg)
     ))