core/classes/mixin/mixin.factor

   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
   6 words ;
   7 IN: classes.mixin
   8
   9 PREDICATE: mixin-class < union-class "mixin" word-prop ;
  10
  11 M: mixin-class normalize-class ;
  12
  13 M: mixin-class (classes-intersect?)
  14     class-members [ classes-intersect? ] with any? ;
  15
  16 M: mixin-class reset-class
  17     [ call-next-method ] [ "mixin" remove-word-prop ] bi ;
  18
  19 M: mixin-class rank-class drop 8 ;
  20
  21 ERROR: 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 class-members member-eq? ] 2dip if ; inline
  38
  39 : change-mixin-class ( class mixin quot -- )
  40     [ [ class-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
  69 PRIVATE>
  70
  71 GENERIC# add-mixin-instance 1 ( class mixin -- )
  72
  73 M: 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
  79 M: 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.
  94 TUPLE: mixin-instance class mixin ;
  95
  96 C: <mixin-instance> mixin-instance
  97
  98 <PRIVATE
  99
 100 : >mixin-instance< ( mixin-instance -- class mixin )
 101     [ class>> ] [ mixin>> ] bi ; inline
 102
 103 PRIVATE>
 104
 105 M: mixin-instance where >mixin-instance< "instances" word-prop at ;
 106
 107 M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ;
 108
 109 M: mixin-instance definer drop \ INSTANCE: f ;
 110
 111 M: mixin-instance definition drop f ;
 112
 113 M: mixin-instance forget*
 114     >mixin-instance<
 115     dup mixin-class? [ remove-mixin-instance ] [ 2drop ] if ;