core/classes/union/union.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: words sequences kernel assocs combinators classes
   4 classes.algebra namespaces arrays math quotations ;
   5 IN: classes.union
   6
   7 PREDICATE: union-class < class
   8     "metaclass" word-prop union-class eq? ;
   9
  10 : union-predicate-quot ( members -- quot )
  11     [
  12         [ drop f ]
  13     ] [
  14         unclip "predicate" word-prop swap [
  15             "predicate" word-prop [ dup ] prepend
  16             [ drop t ]
  17         ] { } map>assoc alist>quot
  18     ] if-empty ;
  19
  20 : define-union-predicate ( class -- )
  21     dup members union-predicate-quot define-predicate ;
  22
  23 M: union-class update-class define-union-predicate ;
  24
  25 : (define-union-class) ( class members -- )
  26     f swap f union-class define-class ;
  27
  28 : define-union-class ( class members -- )
  29     [ (define-union-class) ] [ drop update-classes ] 2bi ;
  30
  31 M: union-class rank-class drop 2 ;
  32
  33 M: union-class instance?
  34     "members" word-prop [ instance? ] with any? ;
  35
  36 M: union-class (flatten-class)
  37     members <anonymous-union> (flatten-class) ;