1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs classes classes.algebra
4 classes.algebra.private classes.private classes.union
5 classes.union.private combinators definitions kernel sequences
9 PREDICATE: mixin-class < union-class "mixin" word-prop ;
11 M: mixin-class normalize-class ;
13 M: mixin-class (classes-intersect?)
14 class-members [ classes-intersect? ] with any? ;
16 M: mixin-class reset-class
17 [ call-next-method ] [ "mixin" remove-word-prop ] bi ;
19 M: mixin-class rank-class drop 8 ;
21 ERROR: check-mixin-class-error class ;
23 : check-mixin-class ( mixin -- mixin )
25 throw-check-mixin-class-error
30 : redefine-mixin-class ( class members -- )
31 [ (define-union-class) ]
32 [ drop changed-conditionally ]
33 [ drop t "mixin" set-word-prop ]
36 : if-mixin-member? ( class mixin true false -- )
37 [ check-mixin-class 2dup class-members member-eq? ] 2dip if ; inline
39 : change-mixin-class ( class mixin quot -- )
40 [ [ class-members swap bootstrap-word ] dip call ] [ drop ] 2bi
41 swap redefine-mixin-class ; inline
43 : (add-mixin-instance) ( class mixin -- )
44 #! Call update-methods before adding the member:
45 #! - Call sites of generics specializing on 'mixin'
46 #! where the inferred type is 'class' are updated,
47 #! - Call sites where the inferred type is a subtype
48 #! of 'mixin' disjoint from 'class' are not updated
50 [ nip update-methods ]
51 [ drop [ suffix ] change-mixin-class ]
52 [ drop [ f ] 2dip "instances" word-prop set-at ]
53 [ 2nip [ update-class ] each ]
56 : (remove-mixin-instance) ( class mixin -- )
57 #! Call update-methods after removing the member:
58 #! - Call sites of generics specializing on 'mixin'
59 #! where the inferred type is 'class' are updated,
60 #! - Call sites where the inferred type is a subtype
61 #! of 'mixin' disjoint from 'class' are not updated
63 [ drop [ swap remove ] change-mixin-class ]
64 [ drop "instances" word-prop delete-at ]
65 [ 2nip [ update-class ] each ]
66 [ nip update-methods ]
71 GENERIC# add-mixin-instance 1 ( class mixin -- )
73 M: class add-mixin-instance
74 [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
76 : remove-mixin-instance ( class mixin -- )
77 [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
79 M: mixin-class metaclass-changed
80 over class? [ 2drop ] [ remove-mixin-instance ] if ;
82 : define-mixin-class ( class -- )
86 [ { } redefine-mixin-class ]
87 [ H{ } clone "instances" set-word-prop ]
92 ! Definition protocol implementation ensures that removing an
93 ! INSTANCE: declaration from a source file updates the mixin.
94 TUPLE: mixin-instance class mixin ;
96 C: <mixin-instance> mixin-instance
100 : >mixin-instance< ( mixin-instance -- class mixin )
101 [ class>> ] [ mixin>> ] bi ; inline
105 M: mixin-instance where >mixin-instance< "instances" word-prop at ;
107 M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ;
109 M: mixin-instance definer drop \ INSTANCE: f ;
111 M: mixin-instance definition drop f ;
113 M: mixin-instance forget*
115 dup mixin-class? [ remove-mixin-instance ] [ 2drop ] if ;