diff --git a/geb.asd b/geb.asd index 53a47c48c..00d138fdc 100644 --- a/geb.asd +++ b/geb.asd @@ -165,6 +165,7 @@ (:file seqn) (:file pipeline) (:file list) + (:file mixins) (:module gui :serial t :components ((:file test) diff --git a/src/mixins/mixins.lisp b/src/mixins/mixins.lisp index 708aced75..150c217c5 100644 --- a/src/mixins/mixins.lisp +++ b/src/mixins/mixins.lisp @@ -53,8 +53,9 @@ (c2mop:class-direct-slots (class-of object))) (defmethod obj-equalp ((obj1 pointwise-mixin) (obj2 pointwise-mixin)) - (obj-equalp (to-pointwise-list obj1) - (to-pointwise-list obj2))) + (and (c2mop:subclassp (type-of obj1) (type-of obj2)) + (obj-equalp (to-pointwise-list obj1) + (to-pointwise-list obj2)))) (defmethod obj-equalp ((obj1 list) (obj2 list)) (or (eq obj1 obj2) diff --git a/test/mixins.lisp b/test/mixins.lisp new file mode 100644 index 000000000..52b89d228 --- /dev/null +++ b/test/mixins.lisp @@ -0,0 +1,58 @@ +(in-package :geb-test) + +(define-test geb-mixins :parent geb-test-suite) + +(defclass subclass-test (so1 distribute) ()) + +(define-test equalp-substobj :parent geb-mixins + (obj-equalp so1 so1) + (not (obj-equalp so1 so0)) + (obj-equalp so0 so0) + (obj-equalp (coprod so1 so1) (coprod so1 so1)) + (not (obj-equalp (coprod so1 so0) (coprod so1 so1))) + (obj-equalp (prod so1 so1) (prod so1 so1)) + (not (obj-equalp (prod so1 so0) (prod so1 so1))) + (not (obj-equalp (prod so1 so1) (coprod so1 so1))) + (obj-equalp (prod (prod so1 so1) so0) (prod (prod so1 so1) so0)) + (not (obj-equalp (prod (prod so1 so1) so0) (prod (coprod so1 so1) so0))) + (and (c2mop:subclassp (type-of (make-instance 'subclass-test)) (type-of so1)) + (not (obj-equalp (make-instance 'subclass-test) so1)))) + +;; Note that here we are testing object equality without +;; considering intensional aspects. E.g. initial morphism +;; !: so0 -> so0 is different from id : 0 -> 0 +(define-test equalp-substmorph :parent geb-mixins + (obj-equalp (init so1) (init so1)) + (not (obj-equalp (init so1) (init so0))) + (obj-equalp (terminal so1) (terminal so1)) + (not (obj-equalp (terminal so1) (terminal so0))) + (obj-equalp (mcase (terminal so1) (terminal so1)) + (mcase (terminal so1) (terminal so1))) + (not (obj-equalp (mcase (terminal so1) so1) + (mcase (terminal so1) (terminal so1)))) + (obj-equalp (distribute so1 so1 so1) + (distribute so1 so1 so1)) + (not (obj-equalp (distribute so1 so1 so1) + (distribute so1 so0 so0))) + (obj-equalp (pair (init so1) (init so1)) + (pair (init so1) (init so1))) + (not (obj-equalp (pair (init so1) so0) + (pair (init so1) (init so0)))) + (obj-equalp (->left so1 so1) + (->left so1 so1)) + (not (obj-equalp (->left so1 so1) + (->left so1 so0))) + (obj-equalp (->right so1 so1) + (->right so1 so1)) + (not (obj-equalp (->right so1 so1) + (->right so1 so0))) + (obj-equalp (<-left so1 so1) + (<-left so1 so1)) + (not (obj-equalp (<-left so1 so1) + (<-left so1 so0))) + (obj-equalp (<-right so1 so1) + (<-right so1 so1)) + (not (obj-equalp (<-right so1 so1) + (<-right so1 so0))) + (not (obj-equalp (<-right so1 so1) + (<-left so1 so1))))