/core/classes/mixin/mixin.factor

  1! Copyright (C) 2004, 2010 Slava Pestov.
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: accessors assocs classes classes.algebra
  4classes.algebra.private classes.private classes.union
  5classes.union.private combinators definitions kernel sequences
  6words ;
  7IN: classes.mixin
  8
  9PREDICATE: mixin-class < union-class "mixin" word-prop ;
 10
 11M: mixin-class normalize-class ;
 12
 13M: mixin-class (classes-intersect?)
 14    members [ classes-intersect? ] with any? ;
 15
 16M: mixin-class reset-class
 17    [ call-next-method ] [ { "mixin" } reset-props ] bi ;
 18
 19M: mixin-class rank-class drop 8 ;
 20
 21ERROR: check-mixin-class-error class ;
 22
 23: check-mixin-class ( mixin -- mixin )
 24    dup mixin-class? [
 25        check-mixin-class-error
 26    ] unless ;
 27
 28<PRIVATE
 29
 30: redefine-mixin-class ( class members -- )
 31    [ (define-union-class) ]
 32    [ drop changed-conditionally ]
 33    [ drop t "mixin" set-word-prop ]
 34    2tri ;
 35
 36: if-mixin-member? ( class mixin true false -- )
 37    [ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
 38
 39: change-mixin-class ( class mixin quot -- )
 40    [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
 41    swap redefine-mixin-class ; inline
 42
 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
 49    dup class-usages {
 50        [ nip update-methods ]
 51        [ drop [ suffix ] change-mixin-class ]
 52        [ drop [ f ] 2dip "instances" word-prop set-at ]
 53        [ 2nip [ update-class ] each ]
 54    } 3cleave ;
 55
 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
 62    dup class-usages {
 63        [ drop [ swap remove ] change-mixin-class ]
 64        [ drop "instances" word-prop delete-at ]
 65        [ 2nip [ update-class ] each ]
 66        [ nip update-methods ]
 67    } 3cleave ;
 68
 69PRIVATE>
 70
 71GENERIC# add-mixin-instance 1 ( class mixin -- )
 72
 73M: class add-mixin-instance
 74    [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
 75
 76: remove-mixin-instance ( class mixin -- )
 77    [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
 78
 79M: mixin-class metaclass-changed
 80    over class? [ 2drop ] [ remove-mixin-instance ] if ;
 81
 82: define-mixin-class ( class -- )
 83    dup mixin-class? [
 84        drop
 85    ] [
 86        [ { } redefine-mixin-class ]
 87        [ H{ } clone "instances" set-word-prop ]
 88        [ update-classes ]
 89        tri
 90    ] if ;
 91
 92! Definition protocol implementation ensures that removing an
 93! INSTANCE: declaration from a source file updates the mixin.
 94TUPLE: mixin-instance class mixin ;
 95
 96C: <mixin-instance> mixin-instance
 97
 98<PRIVATE
 99
100: >mixin-instance< ( mixin-instance -- class mixin )
101    [ class>> ] [ mixin>> ] bi ; inline
102
103PRIVATE>
104
105M: mixin-instance where >mixin-instance< "instances" word-prop at ;
106
107M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ;
108
109M: mixin-instance definer drop \ INSTANCE: f ;
110
111M: mixin-instance definition drop f ;
112
113M: mixin-instance forget*
114    >mixin-instance<
115    dup mixin-class? [ remove-mixin-instance ] [ 2drop ] if ;