From 926c46841b40c1e57d34352cb8fccb001a381c41 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 7 Aug 2009 22:30:57 -0500
Subject: [PATCH] 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           | 11 +-----
 .../intersection/intersection-tests.factor    | 38 +++++++++++++++++++
 core/classes/intersection/intersection.factor | 14 ++++++-
 core/classes/predicate/predicate-tests.factor | 18 +++++++--
 4 files changed, 67 insertions(+), 14 deletions(-)
 create mode 100644 core/classes/intersection/intersection-tests.factor

diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor
index 32f7af8113..c74c8f3b50 100644
--- a/core/classes/builtin/builtin.factor
+++ b/core/classes/builtin/builtin.factor
@@ -50,13 +50,6 @@ M: builtin-class (classes-intersect?)
         [ swap classes-intersect? ]
     } cond ;
 
-M: anonymous-intersection (flatten-class)
-    participants>> [ flatten-builtin-class ] map
-    [
-        builtins get sift [ (flatten-class) ] each
-    ] [
-        [ ] [ assoc-intersect ] map-reduce [ swap set ] assoc-each
-    ] if-empty ;
+: full-cover ( -- ) builtins get sift [ (flatten-class) ] each ;
 
-M: anonymous-complement (flatten-class)
-    drop builtins get sift [ (flatten-class) ] each ;
+M: anonymous-complement (flatten-class) drop full-cover ;
diff --git a/core/classes/intersection/intersection-tests.factor b/core/classes/intersection/intersection-tests.factor
new file mode 100644
index 0000000000..57e716fe44
--- /dev/null
+++ b/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
\ No newline at end of file
diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor
index 43018f6358..a0481a62a7 100644
--- a/core/classes/intersection/intersection.factor
+++ b/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 ;
diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor
index 951608931b..dadfa59917 100644
--- a/core/classes/predicate/predicate-tests.factor
+++ b/core/classes/predicate/predicate-tests.factor
@@ -27,8 +27,18 @@ TUPLE: tuple-b < tuple-a ;
 
 PREDICATE: tuple-c < tuple-b slot>> ;
 
-GENERIC: ptest ( tuple -- )
-M: tuple-a ptest drop ;
-M: tuple-c ptest drop ;
+GENERIC: ptest ( tuple -- x )
+M: tuple-a ptest drop tuple-a ;
+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