Working on intersection classes

core/bootstrap/syntax.factor

@@ -46,6 +46,7 @@ IN: bootstrap.syntax
     "TUPLE:"
     "T{"
     "UNION:"
+    "INTERSECTION:"
     "USE:"
     "USING:"
     "V{"

core/classes/algebra/algebra-tests.factor

@@ -6,6 +6,12 @@ classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units growable
 random inference effects kernel.private sbufs math.order ;
 
+\ class< must-infer
+\ class-and must-infer
+\ class-or must-infer
+\ flatten-class must-infer
+\ flatten-builtin-class must-infer
+
 : class= [ class<= ] [ swap class<= ] 2bi and ;
 
 : class-and* >r class-and r> class= ;
@@ -261,3 +267,18 @@ TUPLE: xg < xb ;
 TUPLE: xh < xb ;
 
 [ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
+
+INTERSECTION: generic-class generic class ;
+
+[ t ] [ generic-class generic class<= ] unit-test
+[ t ] [ generic-class \ class class<= ] unit-test
+
+[ t ] [ \ class generic class-and generic-class class<= ] unit-test
+[ t ] [ \ class generic class-and generic-class swap class<= ] unit-test
+
+[ t ] [ \ word generic-class classes-intersect? ] unit-test
+[ f ] [ number generic-class classes-intersect? ] unit-test
+
+[ H{ { word word } } ] [ 
+    generic-class flatten-class
+] unit-test

core/classes/algebra/algebra.factor

@@ -37,7 +37,7 @@ TUPLE: anonymous-union members ;
 
 C: <anonymous-union> anonymous-union
 
-TUPLE: anonymous-intersection members ;
+TUPLE: anonymous-intersection participants ;
 
 C: <anonymous-intersection> anonymous-intersection
 
@@ -54,19 +54,25 @@ C: <anonymous-complement> anonymous-complement
 : right-union-class<= ( first second -- ? )
     members [ class<= ] with contains? ;
 
-: left-anonymous-union< ( first second -- ? )
+: left-intersection-class<= ( first second -- ? )
+    >r participants r> [ class<= ] curry contains? ;
+
+: right-intersection-class<= ( first second -- ? )
+    participants [ class<= ] with all? ;
+
+: left-anonymous-union<= ( first second -- ? )
     >r members>> r> [ class<= ] curry all? ;
 
-: right-anonymous-union< ( first second -- ? )
+: right-anonymous-union<= ( first second -- ? )
     members>> [ class<= ] with contains? ;
 
-: left-anonymous-intersection< ( first second -- ? )
+: left-anonymous-intersection<= ( first second -- ? )
-    >r members>> r> [ class<= ] curry contains? ;
+    >r participants>> r> [ class<= ] curry contains? ;
 
-: right-anonymous-intersection< ( first second -- ? )
+: right-anonymous-intersection<= ( first second -- ? )
-    members>> [ class<= ] with all? ;
+    participants>> [ class<= ] with all? ;
 
-: anonymous-complement< ( first second -- ? )
+: anonymous-complement<= ( first second -- ? )
     [ class>> ] bi@ swap class<= ;
 
 : (class<=) ( first second -- -1/0/1 )  
@@ -74,15 +80,17 @@ C: <anonymous-complement> anonymous-complement
         { [ 2dup eq? ] [ 2drop t ] }
         { [ dup object eq? ] [ 2drop t ] }
         { [ over null eq? ] [ 2drop t ] }
-        { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
+        { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
-        { [ over anonymous-union? ] [ left-anonymous-union< ] }
+        { [ over anonymous-union? ] [ left-anonymous-union<= ] }
-        { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
+        { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
         { [ over members ] [ left-union-class<= ] }
-        { [ dup anonymous-union? ] [ right-anonymous-union< ] }
+        { [ over participants ] [ left-intersection-class<= ] }
-        { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
+        { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
+        { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
         { [ over anonymous-complement? ] [ 2drop f ] }
         { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
         { [ dup members ] [ right-union-class<= ] }
+        { [ dup participants ] [ right-intersection-class<= ] }
         { [ over superclass ] [ superclass<= ] }
         [ 2drop f ]
     } cond ;
@@ -91,7 +99,7 @@ C: <anonymous-complement> anonymous-complement
     members>> [ classes-intersect? ] with contains? ;
 
 : anonymous-intersection-intersect? ( first second -- ? )
-    members>> [ classes-intersect? ] with all? ;
+    participants>> [ classes-intersect? ] with all? ;
 
 : anonymous-complement-intersect? ( first second -- ? )
     class>> class<= not ;
@@ -99,6 +107,9 @@ C: <anonymous-complement> anonymous-complement
 : union-class-intersect? ( first second -- ? )
     members [ classes-intersect? ] with contains? ;
 
+: intersection-class-intersect? ( first second -- ? )
+    participants [ classes-intersect? ] with all? ;
+
 : tuple-class-intersect? ( first second -- ? )
     {
         { [ over tuple eq? ] [ 2drop t ] }
@@ -123,6 +134,7 @@ C: <anonymous-complement> anonymous-complement
         { [ dup builtin-class? ] [ builtin-class-intersect? ] }
         { [ dup superclass ] [ superclass classes-intersect? ] }
         { [ dup members ] [ union-class-intersect? ] }
+        { [ dup participants ] [ intersection-class-intersect? ] }
     } cond ;
 
 : left-union-and ( first second -- class )
@@ -131,6 +143,12 @@ C: <anonymous-complement> anonymous-complement
 : right-union-and ( first second -- class )
     members [ class-and ] with map <anonymous-union> ;
 
+: left-intersection-and ( first second -- class )
+    >r participants r> suffix <anonymous-intersection> ;
+
+: right-intersection-and ( first second -- class )
+    participants swap suffix <anonymous-intersection> ;
+
 : left-anonymous-union-and ( first second -- class )
     >r members>> r> [ class-and ] curry map <anonymous-union> ;
 
@@ -138,10 +156,10 @@ C: <anonymous-complement> anonymous-complement
     members>> [ class-and ] with map <anonymous-union> ;
 
 : left-anonymous-intersection-and ( first second -- class )
-    >r members>> r> suffix <anonymous-intersection> ;
+    >r participants>> r> suffix <anonymous-intersection> ;
 
 : right-anonymous-intersection-and ( first second -- class )
-    members>> swap suffix <anonymous-intersection> ;
+    participants>> swap suffix <anonymous-intersection> ;
 
 : (class-and) ( first second -- class )
     {
@@ -149,9 +167,11 @@ C: <anonymous-complement> anonymous-complement
         { [ 2dup swap class<= ] [ nip ] }
         { [ 2dup classes-intersect? not ] [ 2drop null ] }
         { [ dup members ] [ right-union-and ] }
+        { [ dup participants ] [ right-intersection-and ] }
         { [ dup anonymous-union? ] [ right-anonymous-union-and ] }
         { [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] }
         { [ over members ] [ left-union-and ] }
+        { [ over participants ] [ left-intersection-and ] }
         { [ over anonymous-union? ] [ left-anonymous-union-and ] }
         { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }
         [ 2array <anonymous-intersection> ]
@@ -203,11 +223,23 @@ C: <anonymous-complement> anonymous-complement
         tuck [ class<= ] with all? [ peek ] [ drop f ] if
     ] if ;
 
+DEFER: (flatten-class)
+DEFER: flatten-builtin-class
+
+: flatten-intersection-class ( class -- )
+    participants [ flatten-builtin-class ] map
+    dup empty? [
+        drop object (flatten-class)
+    ] [
+        unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
+    ] if ;
+
 : (flatten-class) ( class -- )
     {
         { [ dup tuple-class? ] [ dup set ] }
         { [ dup builtin-class? ] [ dup set ] }
         { [ dup members ] [ members [ (flatten-class) ] each ] }
+        { [ dup participants ] [ flatten-intersection-class ] }
         { [ dup superclass ] [ superclass (flatten-class) ] }
         [ drop ]
     } cond ;

core/classes/classes-docs.factor

@@ -40,6 +40,7 @@ $nl
 "There are several sorts of classes:"
 { $subsection "builtin-classes" }
 { $subsection "unions" }
+{ $subsection "intersections" }
 { $subsection "mixins" }
 { $subsection "predicates" }
 { $subsection "singletons" }
@@ -86,7 +87,11 @@ HELP: members
 { $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
 { $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
 
+HELP: participants
+{ $values { "class" class } { "seq" "a sequence of intersection participants, or " { $link f } } }
+{ $description "If " { $snippet "class" } " is an intersection class, outputs a sequence of its participant classes, otherwise outputs " { $link f } "." } ;
+
 HELP: define-class
-{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } }
+{ $values { "word" word } { "superclass" class } { "members" "a sequence of class words" } { "participants" "a sequence of class words" } { "metaclass" class } }
 { $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link update-map } "." }
 $low-level-note ;

core/classes/classes.factor

@@ -57,6 +57,10 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
     #! Output f for non-classes to work with algebra code
     dup class? [ "members" word-prop ] [ drop f ] if ;
 
+: participants ( class -- seq )
+    #! Output f for non-classes to work with algebra code
+    dup class? [ "participants" word-prop ] [ drop f ] if ;
+
 GENERIC: rank-class ( class -- n )
 
 GENERIC: reset-class ( class -- )
@@ -67,7 +71,12 @@ M: word reset-class drop ;
 
 ! update-map
 : class-uses ( class -- seq )
-    [ members ] [ superclass ] bi [ suffix ] when* ;
+    [
+        [ members % ]
+        [ participants % ]
+        [ superclass [ , ] when* ]
+        tri
+    ] { } make ;
 
 : class-usages ( class -- assoc )
     [ update-map get at ] closure ;
@@ -78,12 +87,14 @@ M: word reset-class drop ;
 : update-map- ( class -- )
     dup class-uses update-map get remove-vertex ;
 
-: make-class-props ( superclass members metaclass -- assoc )
+: make-class-props ( superclass members participants metaclass -- assoc )
     [
-        [ dup [ bootstrap-word ] when "superclass" set ]
+        {
-        [ [ bootstrap-word ] map "members" set ]
+            [ dup [ bootstrap-word ] when "superclass" set ]
-        [ "metaclass" set ]
+            [ [ bootstrap-word ] map "members" set ]
-        tri*
+            [ [ bootstrap-word ] map "participants" set ]
+            [ "metaclass" set ]
+        } spread
     ] H{ } make-assoc ;
 
 : (define-class) ( word props -- )
@@ -112,7 +123,7 @@ GENERIC: update-methods ( assoc -- )
     [ update-methods ]
     bi ;
 
-: define-class ( word superclass members metaclass -- )
+: define-class ( word superclass members participants metaclass -- )
     #! If it was already a class, update methods after.
     reset-caches
     make-class-props

core/classes/intersection/intersection-docs.factor

@@ -0,0 +1,28 @@
+USING: generic help.markup help.syntax kernel kernel.private
+namespaces sequences words arrays layouts help effects math
+layouts classes.private classes compiler.units ;
+IN: classes.intersection
+
+ARTICLE: "intersections" "Intersection classes"
+"An object is an instance of a intersection class if it is an instance of all of its participants."
+{ $subsection POSTPONE: INTERSECTION: }
+{ $subsection define-intersection-class }
+"Intersection classes can be introspected:"
+{ $subsection participants }
+"The set of intersection classes is a class:"
+{ $subsection intersection-class }
+{ $subsection intersection-class? }
+"Intersection classes are used to associate a method with objects which are simultaneously instances of multiple different classes, as well as to conveniently define predicates." ;
+
+ABOUT: "intersections"
+
+HELP: define-intersection-class
+{ $values { "class" class } { "participants" "a sequence of classes" } }
+{ $description "Defines a intersection class with specified participants. This is the run time equivalent of " { $link POSTPONE: INTERSECTION: } "." }
+{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
+{ $side-effects "class" } ;
+
+{ intersection-class define-intersection-class POSTPONE: INTERSECTION: } related-words
+
+HELP: intersection-class
+{ $class-description "The class of intersection classes." } ;

core/classes/intersection/intersection.factor

@@ -0,0 +1,33 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words sequences kernel assocs combinators classes
+namespaces arrays math quotations ;
+IN: classes.intersection
+
+PREDICATE: intersection-class < class
+    "metaclass" word-prop intersection-class eq? ;
+
+: intersection-predicate-quot ( members -- quot )
+    dup empty? [
+        drop [ drop t ]
+    ] [
+        unclip "predicate" word-prop swap [
+            "predicate" word-prop [ dup ] swap [ not ] 3append
+            [ drop f ]
+        ] { } map>assoc alist>quot
+    ] if ;
+
+: define-intersection-predicate ( class -- )
+    dup participants intersection-predicate-quot define-predicate ;
+
+M: intersection-class update-class define-intersection-predicate ;
+
+: define-intersection-class ( class members -- )
+    [ f f rot intersection-class define-class ]
+    [ drop update-classes ]
+    2bi ;
+
+M: intersection-class reset-class
+    { "class" "metaclass" "participants" } reset-props ;
+
+M: intersection-class rank-class drop 2 ;

core/classes/predicate/predicate.factor

@@ -14,7 +14,7 @@ PREDICATE: predicate-class < class
     ] [ ] make ;
 
 : define-predicate-class ( class superclass definition -- )
-    [ drop f predicate-class define-class ]
+    [ drop f f predicate-class define-class ]
     [ nip "predicate-definition" set-word-prop ]
     [
         2drop

core/classes/tuple/tuple.factor

@@ -160,7 +160,7 @@ M: tuple-class update-class
     tri ;
 
 : define-new-tuple-class ( class superclass slots -- )
-    [ drop f tuple-class define-class ]
+    [ drop f f tuple-class define-class ]
     [ nip "slot-names" set-word-prop ]
     [ 2drop update-classes ]
     3tri ;
@@ -226,10 +226,11 @@ M: tuple-class reset-class
         } reset-props
     ] bi ;
 
+: reset-tuple-class ( class -- )
+    [ [ reset-class ] [ update-map- ] bi ] each-subclass ;
+
 M: tuple-class forget*
-    [ [ reset-class ] each-subclass ]
+    [ reset-tuple-class ] [ call-next-method ] bi ;
-    [ call-next-method ]
-    bi ;
 
 M: tuple-class rank-class drop 0 ;
 

core/classes/union/union-docs.factor

@@ -4,7 +4,7 @@ layouts classes.private classes compiler.units ;
 IN: classes.union
 
 ARTICLE: "unions" "Union classes"
-"An object is an instance of a union class if it is an instance of one of its members. Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates."
+"An object is an instance of a union class if it is an instance of one of its members."
 { $subsection POSTPONE: UNION: }
 { $subsection define-union-class }
 "Union classes can be introspected:"
@@ -12,7 +12,7 @@ ARTICLE: "unions" "Union classes"
 "The set of union classes is a class:"
 { $subsection union-class }
 { $subsection union-class? } 
-"Unions are used to define behavior shared between a fixed set of classes."
+"Unions are used to define behavior shared between a fixed set of classes, as well as to conveniently define predicates."
 { $see-also "mixins" "tuple-subclassing" } ;
 
 ABOUT: "unions"

core/classes/union/union.factor

@@ -7,7 +7,6 @@ IN: classes.union
 PREDICATE: union-class < class
     "metaclass" word-prop union-class eq? ;
 
-! Union classes for dispatch on multiple classes.
 : union-predicate-quot ( members -- quot )
     dup empty? [
         drop [ drop f ]
@@ -24,7 +23,7 @@ PREDICATE: union-class < class
 M: union-class update-class define-union-predicate ;
 
 : define-union-class ( class members -- )
-    [ f swap union-class define-class ]
+    [ f swap f union-class define-class ]
     [ drop update-classes ]
     2bi ;
 

core/syntax/syntax.factor

@@ -5,8 +5,9 @@ definitions generic hashtables kernel math
 namespaces parser sequences strings sbufs vectors words
 quotations io assocs splitting classes.tuple generic.standard
 generic.math classes io.files vocabs float-arrays
-classes.union classes.mixin classes.predicate classes.singleton
+classes.union classes.intersection classes.mixin
-compiler.units combinators debugger ;
+classes.predicate classes.singleton compiler.units
+combinators debugger ;
 IN: bootstrap.syntax
 
 ! These words are defined as a top-level form, instead of with
@@ -135,6 +136,10 @@ IN: bootstrap.syntax
         CREATE-CLASS parse-definition define-union-class
     ] define-syntax
 
+    "INTERSECTION:" [
+        CREATE-CLASS parse-definition define-intersection-class
+    ] define-syntax
+
     "MIXIN:" [
         CREATE-CLASS define-mixin-class
     ] define-syntax

extra/locals/locals-tests.factor

@@ -246,3 +246,5 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
 : no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
 
 [ { 4 5 6 } ] [ no-with-locals-test ] unit-test
+
+[ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test

extra/locals/locals.factor

@@ -355,30 +355,34 @@ M: wlet pprint* \ [wlet pprint-let ;
 
 M: let* pprint* \ [let* pprint-let ;
 
-PREDICATE: lambda-word < word
+PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
-    "lambda" word-prop >boolean ;
 
 M: lambda-word definer drop \ :: \ ; ;
 
 M: lambda-word definition
     "lambda" word-prop body>> ;
 
-PREDICATE: lambda-macro < macro
+INTERSECTION: lambda-macro macro lambda-word ;
-    "lambda" word-prop >boolean ;
 
 M: lambda-macro definer drop \ MACRO:: \ ; ;
 
 M: lambda-macro definition
     "lambda" word-prop body>> ;
 
-PREDICATE: lambda-method < method-body
+INTERSECTION: lambda-method method-body lambda-word ;
-    "lambda" word-prop >boolean ;
 
 M: lambda-method definer drop \ M:: \ ; ;
 
 M: lambda-method definition
     "lambda" word-prop body>> ;
 
+INTERSECTION: lambda-memoized memoized lambda-word ;
+
+M: lambda-memoized definer drop \ MEMO:: \ ; ;
+
+M: lambda-memoized definition
+    "lambda" word-prop body>> ;
+
 : method-stack-effect ( method -- effect )
     dup "lambda" word-prop vars>>
     swap "method-generic" word-prop stack-effect