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 ;
23 : redefine-mixin-class ( class members -- )
24 [ (define-union-class) ]
25 [ drop changed-conditionally ]
26 [ drop t "mixin" set-word-prop ]
29 : if-mixin-member? ( class mixin true false -- )
30 [ 2dup class-members member-eq? ] 2dip if ; inline
32 : change-mixin-class ( class mixin quot -- )
33 [ [ class-members swap bootstrap-word ] dip call ] [ drop ] 2bi
34 swap redefine-mixin-class ; inline
36 : (add-mixin-instance) ( class mixin -- )
37 ! Call update-methods before adding the member:
38 ! - Call sites of generics specializing on 'mixin'
39 ! where the inferred type is 'class' are updated,
40 ! - Call sites where the inferred type is a subtype
41 ! of 'mixin' disjoint from 'class' are not updated
43 [ nip update-methods ]
44 [ drop [ suffix ] change-mixin-class ]
45 [ drop [ f ] 2dip "instances" word-prop set-at ]
46 [ 2nip [ update-class ] each ]
49 : (remove-mixin-instance) ( class mixin -- )
50 ! Call update-methods after removing the member:
51 ! - Call sites of generics specializing on 'mixin'
52 ! where the inferred type is 'class' are updated,
53 ! - Call sites where the inferred type is a subtype
54 ! of 'mixin' disjoint from 'class' are not updated
56 [ drop [ swap remove ] change-mixin-class ]
57 [ drop "instances" word-prop delete-at ]
58 [ 2nip [ update-class ] each ]
59 [ nip update-methods ]
64 : check-types ( class mixin -- class mixin )
65 [ class check-instance ] [ mixin-class check-instance ] bi* ;
67 : add-mixin-instance ( class mixin -- )
68 check-types [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
70 : remove-mixin-instance ( class mixin -- )
71 [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
73 M: mixin-class metaclass-changed
74 over class? [ 2drop ] [ remove-mixin-instance ] if ;
76 : define-mixin-class ( class -- )
80 [ { } redefine-mixin-class ]
81 [ H{ } clone "instances" set-word-prop ]
86 ! Definition protocol implementation ensures that removing an
87 ! INSTANCE: declaration from a source file updates the mixin.
88 TUPLE: mixin-instance class mixin ;
90 C: <mixin-instance> mixin-instance
94 : >mixin-instance< ( mixin-instance -- class mixin )
95 [ class>> ] [ mixin>> ] bi ; inline
99 M: mixin-instance where >mixin-instance< "instances" word-prop at ;
101 M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ;
103 M: mixin-instance definer drop \ INSTANCE: f ;
105 M: mixin-instance definition drop f ;
107 M: mixin-instance forget*
109 dup mixin-class? [ remove-mixin-instance ] [ 2drop ] if ;