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 classes.algebra.private namespaces arrays math
   5 quotations ;
   6 IN: classes.union
   7
   8 PREDICATE: union-class < class
   9     "metaclass" word-prop union-class eq? ;
  10
  11 : union-predicate-quot ( members -- quot )
  12     [
  13         [ drop f ]
  14     ] [
  15         unclip "predicate" word-prop swap [
  16             "predicate" word-prop [ dup ] prepend
  17             [ drop t ]
  18         ] { } map>assoc alist>quot
  19     ] if-empty ;
  20
  21 : define-union-predicate ( class -- )
  22     dup members union-predicate-quot define-predicate ;
  23
  24 M: union-class update-class define-union-predicate ;
  25
  26 : (define-union-class) ( class members -- )
  27     f swap f union-class define-class ;
  28
  29 : define-union-class ( class members -- )
  30     [ (define-union-class) ] [ drop update-classes ] 2bi ;
  31
  32 M: union-class rank-class drop 2 ;
  33
  34 M: union-class instance?
  35     "members" word-prop [ instance? ] with any? ;
  36
  37 M: union-class (flatten-class)
  38     members <anonymous-union> (flatten-class) ;