classes.dispatch: dispatch<= -> left-dispatch<= + right-dispatch<=, f…

…ix eql-spec

A bit of a workaround because of missing multi-methods.
Correct class algebra for eql specializers.

core/classes/algebra/algebra.factor

@@ -183,7 +183,8 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
                 { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
                 { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
                 { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
-                { [ 2dup [ dispatch-type? ] either? ] [ dispatch<= ] }
+                { [ over dispatch-type? ] [ left-dispatch<= ] }
+                { [ dup dispatch-type? ] [ right-dispatch<= ] }
                 [ 2drop f ]
             } cond
         ] if

core/classes/dispatch/covariant-tuples/covariant-tuples-tests.factor

@@ -5,35 +5,35 @@ IN: classes.dispatch.covariant-tuples.tests
 { fixnum } [ { tuple fixnum } <covariant-tuple> 0 swap nth-dispatch-class ] unit-test
 { tuple } [ { tuple fixnum } <covariant-tuple> 1 swap nth-dispatch-class ] unit-test
 
-{ t } [ { tuple tuple } { tuple object } [ <covariant-tuple> ] bi@ covariant-tuple<= ] unit-test
-{ t } [ { tuple object } { tuple object } [ <covariant-tuple> ] bi@ covariant-tuple<= ] unit-test
-{ f } [ { tuple object } { tuple tuple } [ <covariant-tuple> ] bi@ covariant-tuple<= ] unit-test
-{ t } [ { tuple tuple } { tuple } [ <covariant-tuple> ] bi@ covariant-tuple<= ] unit-test
-{ f } [ { tuple } { tuple tuple } [ <covariant-tuple> ] bi@ covariant-tuple<= ] unit-test
-{ t } [ { tuple tuple } { object } [ <covariant-tuple> ] bi@ covariant-tuple<= ] unit-test
-{ f } [ { object object } { tuple } [ <covariant-tuple> ] bi@ covariant-tuple<= ] unit-test
-{ f } [ { object } { tuple tuple } [ <covariant-tuple> ] bi@ covariant-tuple<= ] unit-test
+{ t } [ { tuple tuple } { tuple object } [ <covariant-tuple> ] bi@ left-dispatch<= ] unit-test
+{ t } [ { tuple object } { tuple object } [ <covariant-tuple> ] bi@ left-dispatch<= ] unit-test
+{ f } [ { tuple object } { tuple tuple } [ <covariant-tuple> ] bi@ left-dispatch<= ] unit-test
+{ t } [ { tuple tuple } { tuple } [ <covariant-tuple> ] bi@ left-dispatch<= ] unit-test
+{ f } [ { tuple } { tuple tuple } [ <covariant-tuple> ] bi@ left-dispatch<= ] unit-test
+{ t } [ { tuple tuple } { object } [ <covariant-tuple> ] bi@ left-dispatch<= ] unit-test
+{ f } [ { object object } { tuple } [ <covariant-tuple> ] bi@ left-dispatch<= ] unit-test
+{ f } [ { object } { tuple tuple } [ <covariant-tuple> ] bi@ left-dispatch<= ] unit-test
 
 ! Comparisons between classes and dispatch-types
 ! { f } [ { tuple tuple } <covariant-tuple> tuple covariant-tuple<= ] unit-test
 ! { f } [ { tuple tuple } <covariant-tuple> object covariant-tuple<= ] unit-test
 ! { f } [ { tuple object } <covariant-tuple> tuple covariant-tuple<= ] unit-test
 
-{ f } [ { tuple tuple } <covariant-tuple> tuple dispatch<= ] unit-test
-{ f } [ { tuple tuple } <covariant-tuple> object dispatch<= ] unit-test
-{ f } [ { tuple object } <covariant-tuple> tuple dispatch<= ] unit-test
+{ f } [ { tuple tuple } <covariant-tuple> tuple left-dispatch<= ] unit-test
+{ f } [ { tuple tuple } <covariant-tuple> object left-dispatch<= ] unit-test
+{ f } [ { tuple object } <covariant-tuple> tuple left-dispatch<= ] unit-test
 
-{ f } [ tuple { object tuple } <covariant-tuple> covariant-tuple<= ] unit-test
-{ f } [ object { tuple object } <covariant-tuple> covariant-tuple<= ] unit-test
-{ f } [ object { tuple tuple } <covariant-tuple> covariant-tuple<= ] unit-test
+{ f } [ tuple { object tuple } <covariant-tuple> right-dispatch<= ] unit-test
+{ f } [ object { tuple object } <covariant-tuple> right-dispatch<= ] unit-test
+{ f } [ object { tuple tuple } <covariant-tuple> right-dispatch<= ] unit-test
 
 ! Same with class<=
 ! Debugging strange error: walking was working, running compiled not.  Turns out that classes.algebra had not been calling dispatch<=
 { { tuple tuple } { tuple object } } [ { tuple tuple } { tuple object } [ <covariant-tuple> ] bi@ covariant-classes ] unit-test
 { t } [ { tuple tuple } { tuple object } [ <covariant-tuple> ] bi@ covariant-classes [ (class<=) ] 2all? ] unit-test
 { t } [ { tuple tuple } { tuple object } [ <covariant-tuple> ] bi@ covariant-classes [ class<= ] 2all? ] unit-test
-{ t } [ { tuple tuple } { tuple object } [ <covariant-tuple> ] bi@ dispatch<= ] unit-test
-{ t } [ { tuple tuple } { tuple object } [ <covariant-tuple> ] bi@ covariant-tuple<= ] unit-test
+{ t } [ { tuple tuple } { tuple object } [ <covariant-tuple> ] bi@ left-dispatch<= ] unit-test
+{ t } [ { tuple tuple } { tuple object } [ <covariant-tuple> ] bi@ right-dispatch<= ] unit-test
 { t } [ { tuple tuple } { tuple object } [ <covariant-tuple> ] bi@ [ dispatch-type? ] both? ] unit-test
 { t } [ { tuple tuple } { tuple object } [ <covariant-tuple> ] bi@ (class<=) ] unit-test
 
@@ -47,9 +47,7 @@ IN: classes.dispatch.covariant-tuples.tests
 { f } [ { tuple tuple } <covariant-tuple> tuple (class<=) ] unit-test
 { t } [ { tuple tuple } <covariant-tuple> object (class<=) ] unit-test
 { f } [ { tuple object } <covariant-tuple> tuple (class<=) ] unit-test
-! { t } [ tuple { object tuple } <covariant-tuple> covariant-tuple<= ] unit-test
-! { f } [ object { tuple object } <covariant-tuple> covariant-tuple<= ] unit-test
-! { f } [ object { tuple tuple } <covariant-tuple> covariant-tuple<= ] unit-test
+
 { +incomparable+ } [ tuple { object tuple } compare-classes ] unit-test
 
 { t } [ { fixnum object } <covariant-tuple> { tuple tuple } <covariant-tuple> 2array

core/classes/dispatch/covariant-tuples/covariant-tuples.factor

@@ -38,15 +38,13 @@ M: covariant-tuple implementor-classes classes>>
     [ dup covariant-tuple? [ classes>> ] [ 1array ] if ] bi@
     object [ 2dup max-length ] dip [ pad-head ] 2curry bi@ ; inline
 
-GENERIC#: covariant-tuple<= 1 ( class1 class2 -- ? )
-M: covariant-tuple covariant-tuple<=
-    covariant-classes [ class<= ] 2all? ;
+M: covariant-tuple right-dispatch<=
+    over covariant-tuple?
+    [ covariant-classes [ class<= ] 2all? ]
+    [ 2drop f ] if ;
 
-M: classoid covariant-tuple<= 2drop f ;
 
-M: covariant-tuple dispatch<= covariant-tuple<= ;
-
-! TODO Dispatch falls back to this to call a lexicographically ordered more
+! NOTE: Dispatch falls back to this to call a lexicographically ordered more
 ! specific method right now, although this should never happen if ambiguity
 ! errors are caught correctly.  It is always done as a first step of sorting
 ! classes though.

core/classes/dispatch/dispatch.factor

@@ -9,10 +9,16 @@ IN: classes.dispatch
 
 MIXIN: dispatch-type
 INSTANCE: dispatch-type classoid
-GENERIC: dispatch<= ( dispatch-type1 dispatch-type2 -- ? )
+! Workaround for not having multi-methods here.  Left dispatch is checked first
+GENERIC#: left-dispatch<= 1 ( class1 class2 -- ? )
+GENERIC: right-dispatch<= ( class1 class2 -- ? )
 
 ! Dispatch types per default not comparable to concrete types
-M: classoid dispatch<= 2drop f ;
+M: dispatch-type left-dispatch<=
+    dup dispatch-type?
+    [ right-dispatch<= ] [ 2drop f ] if ;
+
+! TODO: used?  This should probably something specific during parsing/construction...
 GENERIC: class>dispatch ( class -- dispatch-type )
 M: dispatch-type class>dispatch ;
 ! This is used when building a decision tree to find the most specific method

core/classes/dispatch/eql/eql-tests.factor

@@ -1,14 +1,23 @@
-USING: arrays classes.dispatch classes.dispatch.covariant-tuples
-classes.dispatch.eql kernel math tools.test words ;
+USING: arrays classes.algebra classes.algebra.private classes.dispatch
+classes.dispatch.covariant-tuples classes.dispatch.eql kernel math tools.test
+words ;
 IN: classes.dispatch.eql.tests
 
+{ t } [ fixnum <eql-specializer> word (class<=) ] unit-test
+{ f } [ word fixnum <eql-specializer> (class<=) ] unit-test
 
-! { word } [ fixnum <eql-specializer> 0 swap nth-dispatch-class ] unit-test
-! { object } [ fixnum <eql-specializer> 1 swap nth-dispatch-class ] unit-test
-! { t } [ word fixnum <eql-specializer> 0 swap nth-dispatch-applicable? ] unit-test
-! { f } [ number fixnum <eql-specializer> 0 swap nth-dispatch-applicable? ] unit-test
-! { t } [ word fixnum <eql-specializer> 1 swap nth-dispatch-applicable? ] unit-test
-! { t } [ number fixnum <eql-specializer> 1 swap nth-dispatch-applicable? ] unit-test
+{ t } [ fixnum <eql-specializer> fixnum <eql-specializer> (classes-intersect?) ] unit-test
+{ f } [ float <eql-specializer> fixnum <eql-specializer> (classes-intersect?) ] unit-test
+
+{ t } [ fixnum 2 <eql-specializer> (classes-intersect?) ] unit-test
+{ f } [ float 2 <eql-specializer> (classes-intersect?) ] unit-test
+{ t } [ number 2 <eql-specializer> (classes-intersect?) ] unit-test
+{ f } [ array 2 <eql-specializer> (classes-intersect?) ] unit-test
+
+{ t } [ 2 <eql-specializer> fixnum classes-intersect? ] unit-test
+{ f } [ 2 <eql-specializer> float classes-intersect? ] unit-test
+{ t } [ 2 <eql-specializer> number classes-intersect? ] unit-test
+{ f } [ 2 <eql-specializer> array classes-intersect? ] unit-test
 
 
 { t } [ fixnum <eql-specializer> 1array <covariant-tuple> 0 swap nth-dispatch-class eql-specializer? ] unit-test

core/classes/dispatch/eql/eql.factor

@@ -1,6 +1,6 @@
 USING: accessors arrays classes classes.algebra classes.algebra.private
-classes.dispatch classes.private generic generic.single kernel make present
-sequences ;
+classes.dispatch classes.private combinators generic generic.single kernel make
+present sequences ;
 
 IN: classes.dispatch.eql
 
@@ -14,7 +14,7 @@ INSTANCE: eql-specializer dispatch-type
 ! M: wrapper class>dispatch wrapped>> <eql-specializer> ;
 
 M: eql-specializer predicate-def
-    obj>> [ = ] curry picker prepose ;
+    obj>> [ = ] curry ;
 
 ! TODO: Does present introduce dep cycle here?
 M: eql-specializer class-name obj>> present "=" prepend ;
@@ -23,21 +23,17 @@ M: eql-specializer implementor-classes obj>> class-of 1array ;
 
 M: eql-specializer (flatten-class) obj>> class-of , ;
 
-GENERIC#: eql-specializer-dispatch<= 1 ( class1 class2 -- ? )
+! An instance of an eql specializer is a proper subset of all instances of the
+! corresponding base class.
+! A base class can not be an instance of an eql specializer, (except for if it is
+! a singleton class with the same name)?
+M: eql-specializer right-dispatch<=
+    over eql-specializer? [ [ obj>> ] bi@ = ] [ 2drop f ] if ;
+M: eql-specializer left-dispatch<=
+    [ obj>> class-of ] dip class<= ;
 
-M: eql-specializer dispatch<= eql-specializer-dispatch<= ;
-M: eql-specializer eql-specializer-dispatch<=
-    [ obj>> class-of ] bi@ class<= ;
-M: classoid eql-specializer-dispatch<=
-    obj>> class-of class<= ;
 
-! Only occurs in nested context dispatching on top of stack
-! M: eql-specializer nth-dispatch-class
-!     obj>> class-of nth-dispatch-class ;
-
-! M: eql-specializer nth-dispatch-applicable?
-
-! TODO: maybe intersection should not be lowered to this.  Instead, the covariant-tuple context could cover this in covariant-classes?
+! Instances of an eql specializer do only intersect iff they are the same
 M: eql-specializer (classes-intersect?)
-    [ dup eql-specializer? [ obj>> class-of ] when ] dip
-    obj>> class-of classes-intersect? ;
+    { { [ over eql-specializer? ] [ [ obj>> ] same? ] }
+      [ obj>> class-of classes-intersect? ] } cond ;

core/generic/multi/multi.factor

@@ -64,6 +64,8 @@ DEFER: flatten-multi-methods
     [ current-index [ flatten-multi-methods ] with-variable
     ] keep nested-dispatch-engine boa ;
 
+! Preprocessing step.  Creates nested engine words so that flatten methods can
+! then operate and create the predicate engines
 : flatten-multi-methods ( methods -- methods' )
     [ dup assoc?
       [ <nested-dispatch-engine> ] when