classes.intersection: make flatten-class more accurate. It is still not perfect, but it fixes the case where a generic word has a method on a tuple class, and another method on an intersection of a mixin with another tuple classes

core/classes/builtin/builtin.factor

@@ -50,13 +50,6 @@ M: builtin-class (classes-intersect?)
         [ swap classes-intersect? ]
     } cond ;
 
-M: anonymous-intersection (flatten-class)
+: full-cover ( -- ) builtins get sift [ (flatten-class) ] each ;
-    participants>> [ flatten-builtin-class ] map
-    [
-        builtins get sift [ (flatten-class) ] each
-    ] [
-        [ ] [ assoc-intersect ] map-reduce [ swap set ] assoc-each
-    ] if-empty ;
 
-M: anonymous-complement (flatten-class)
+M: anonymous-complement (flatten-class) drop full-cover ;
-    drop builtins get sift [ (flatten-class) ] each ;

core/classes/intersection/intersection-tests.factor

@@ -0,0 +1,38 @@
+USING: kernel tools.test generic generic.standard ;
+IN: classes.intersection.tests
+
+TUPLE: a ;
+TUPLE: a1 < a ; TUPLE: a2 < a ; TUPLE: a3 < a2 ;
+MIXIN: b
+INSTANCE: a3 b
+INSTANCE: a1 b
+INTERSECTION: c a2 b ;
+
+GENERIC: x ( a -- b )
+
+M: c x drop c ;
+M: a x drop a ;
+
+[ a ] [ T{ a } x ] unit-test
+[ a ] [ T{ a1 } x ] unit-test
+[ a ] [ T{ a2 } x ] unit-test
+
+[ t ] [ T{ a3 } c? ] unit-test
+[ t ] [ T{ a3 } \ x effective-method M\ c x eq? nip ] unit-test
+[ c ] [ T{ a3 } x ] unit-test
+
+! More complex case
+TUPLE: t1 ;
+TUPLE: t2 < t1 ; TUPLE: t3 < t1 ;
+TUPLE: t4 < t2 ; TUPLE: t5 < t2 ;
+
+UNION: m t4 t5 t3 ;
+INTERSECTION: i t2 m ;
+
+GENERIC: g ( a -- b )
+
+M: i g drop i ;
+M: t4 g drop t4 ;
+
+[ t4 ] [ T{ t4 } g ] unit-test
+[ i ] [ T{ t5 } g ] unit-test

core/classes/intersection/intersection.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: words sequences kernel assocs combinators classes
+USING: words accessors sequences kernel assocs combinators classes
 classes.algebra classes.builtin namespaces arrays math quotations ;
 IN: classes.intersection
 
@@ -34,3 +34,15 @@ M: intersection-class instance?
 
 M: intersection-class (flatten-class)
     participants <anonymous-intersection> (flatten-class) ;
+
+! Horribly inefficient and inaccurate
+: intersect-flattened-classes ( seq1 seq2 -- seq3 )
+    ! Only keep those in seq1 that intersect something in seq2.
+    [ [ classes-intersect? ] with any? ] curry filter ;
+
+M: anonymous-intersection (flatten-class)
+    participants>> [ full-cover ] [
+        [ flatten-class keys ]
+        [ intersect-flattened-classes ] map-reduce
+        [ dup set ] each
+    ] if-empty ;

core/classes/predicate/predicate-tests.factor

@@ -27,8 +27,18 @@ TUPLE: tuple-b < tuple-a ;
 
 PREDICATE: tuple-c < tuple-b slot>> ;
 
-GENERIC: ptest ( tuple -- )
+GENERIC: ptest ( tuple -- x )
-M: tuple-a ptest drop ;
+M: tuple-a ptest drop tuple-a ;
-M: tuple-c ptest drop ;
+M: tuple-c ptest drop tuple-c ;
 
-[ ] [ tuple-b new ptest ] unit-test
+[ tuple-a ] [ tuple-b new ptest ] unit-test
+[ tuple-c ] [ tuple-b new t >>slot ptest ] unit-test
+
+PREDICATE: tuple-d < tuple-a slot>> ;
+
+GENERIC: ptest' ( tuple -- x )
+M: tuple-a ptest' drop tuple-a ;
+M: tuple-d ptest' drop tuple-d ;
+
+[ tuple-a ] [ tuple-b new ptest' ] unit-test
+[ tuple-d ] [ tuple-b new t >>slot ptest' ] unit-test