From 9abfeafd1dbb42055e408c5becc34441868528d3 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Tue, 2 Aug 2022 10:26:49 -0700
Subject: [PATCH] classes: define predicate-def for anonymous classes

---
 core/classes/algebra/algebra.factor           | 16 +++++++-----
 core/classes/intersection/intersection.factor |  5 +++-
 core/classes/union/union.factor               | 26 +++++++++----------
 3 files changed, 26 insertions(+), 21 deletions(-)

diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 2edc0f253a..4d16c61749 100644
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -40,6 +40,9 @@ INSTANCE: anonymous-complement classoid
 
 M: anonymous-complement rank-class drop 3 ;
 
+M: anonymous-complement predicate-def
+    class>> '[ [ _ instance? not ] [ t ] if* ] curry ;
+
 M: anonymous-complement instance?
     over [ class>> instance? not ] [ 2drop t ] if ;
 
@@ -154,12 +157,13 @@ PREDICATE: nontrivial-anonymous-intersection < anonymous-intersection
     [ normalize-complement ] dip class<= ;
 
 PREDICATE: nontrivial-anonymous-complement < anonymous-complement
-    class>> {
-        [ anonymous-union? ]
-        [ anonymous-intersection? ]
-        [ class-members ]
-        [ class-participants ]
-    } cleave or or or ;
+    class>> dup anonymous-union? [ drop t ] [
+        dup anonymous-intersection? [ drop t ] [
+            dup class-members [ drop t ] [
+                class-participants
+            ] if
+        ] if
+    ] if ;
 
 PREDICATE: empty-union < anonymous-union members>> empty? ;
 
diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor
index 711e0dc226..1a76e11903 100644
--- a/core/classes/intersection/intersection.factor
+++ b/core/classes/intersection/intersection.factor
@@ -10,7 +10,7 @@ PREDICATE: intersection-class < class
 
 <PRIVATE
 
-: intersection-predicate-quot ( members -- quot )
+: intersection-predicate-quot ( participants -- quot )
     [
         [ drop t ]
     ] [
@@ -54,6 +54,9 @@ M: anonymous-intersection (flatten-class)
 M: anonymous-intersection class-name
     participants>> [ class-name ] map join-words ;
 
+M: anonymous-intersection predicate-def
+    participants>> intersection-predicate-quot ;
+
 PRIVATE>
 
 : define-intersection-class ( class participants -- )
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index ad03750e1d..5d0265f5d5 100644
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -22,20 +22,16 @@ M: union-class union-of-builtins?
 M: class union-of-builtins?
     drop f ;
 
-: empty-union-predicate-quot ( class -- quot )
+: empty-union-predicate-quot ( class-members -- quot )
     drop [ drop f ] ;
 
-: flatten-builtins ( class/builtin-classes -- seq )
-    dup sequence? [
-        [ flatten-class ] map concat
-    ] [
-        flatten-class
-    ] if ;
+: flatten-builtins ( builtin-classes -- seq )
+    [ flatten-class ] map concat ;
 
 : builtin-union-mask ( builtin-classes -- n )
     0 [ class>type 2^ bitor ] reduce ;
 
-: builtin-union-predicate-quot ( class/builtin-classes -- quot )
+: builtin-union-predicate-quot ( builtin-classes -- quot )
     flatten-builtins dup length 1 = [
         first class>type [ eq? ] curry [ tag ] prepose
     ] [
@@ -69,8 +65,7 @@ M: class union-of-builtins?
     [ layout-of ] prepose [ drop f ] [ if ] 2curry
     [ dup tuple? ] prepose ;
 
-: full-union-predicate-quot ( class -- quot )
-    class-members
+: full-union-predicate-quot ( class-members -- quot )
     [ union-of-builtins? ] partition
     [ [ f ] [ builtin-union-predicate-quot ] if-empty ] dip
     [ [ tuple-class? ] [ tuple-layout ] bi and ] partition
@@ -80,15 +75,15 @@ M: class union-of-builtins?
     swap [ suffix ] when*
     predicate-quot ;
 
-: union-predicate-quot ( class -- quot )
+: union-predicate-quot ( class-members -- quot )
     {
-        { [ dup class-members empty? ] [ empty-union-predicate-quot ] }
-        { [ dup union-of-builtins? ] [ builtin-union-predicate-quot ] }
+        { [ dup empty? ] [ empty-union-predicate-quot ] }
+        { [ dup [ union-of-builtins? ] all? ] [ builtin-union-predicate-quot ] }
         [ full-union-predicate-quot ]
     } cond ;
 
 : define-union-predicate ( class -- )
-    dup union-predicate-quot define-predicate ;
+    dup class-members union-predicate-quot define-predicate ;
 
 M: union-class update-class define-union-predicate ;
 
@@ -113,6 +108,9 @@ M: union-class rank-class drop 7 ;
 M: union-class instance?
     "members" word-prop [ instance? ] with any? ;
 
+M: anonymous-union predicate-def
+    members>> union-predicate-quot ;
+
 M: anonymous-union instance?
     members>> [ instance? ] with any? ;
 
-- 
2.34.1