core/classes/mixin/mixin.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See https://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 <PRIVATE
  22
  23 : redefine-mixin-class ( class members -- )
  24     [ (define-union-class) ]
  25     [ drop changed-conditionally ]
  26     [ drop t "mixin" set-word-prop ]
  27     2tri ;
  28
  29 : if-mixin-member? ( class mixin true false -- )
  30     [ 2dup class-members member-eq? ] 2dip if ; inline
  31
  32 : change-mixin-class ( class mixin quot -- )
  33     [ [ class-members swap bootstrap-word ] dip call ] [ drop ] 2bi
  34     swap redefine-mixin-class ; inline
  35
  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
  42     dup class-usages {
  43         [ nip update-methods ]
  44         [ drop [ suffix ] change-mixin-class ]
  45         [ drop [ f ] 2dip "instances" word-prop set-at ]
  46         [ 2nip [ update-class ] each ]
  47     } 3cleave ;
  48
  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
  55     dup class-usages {
  56         [ drop [ swap remove ] change-mixin-class ]
  57         [ drop "instances" word-prop delete-at ]
  58         [ 2nip [ update-class ] each ]
  59         [ nip update-methods ]
  60     } 3cleave ;
  61
  62 PRIVATE>
  63
  64 : check-types ( class mixin -- class mixin )
  65     [ class check-instance ] [ mixin-class check-instance ] bi* ;
  66
  67 : add-mixin-instance ( class mixin -- )
  68     check-types [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
  69
  70 : remove-mixin-instance ( class mixin -- )
  71     [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
  72
  73 M: mixin-class metaclass-changed
  74     over class? [ 2drop ] [ remove-mixin-instance ] if ;
  75
  76 : define-mixin-class ( class -- )
  77     dup mixin-class? [
  78         drop
  79     ] [
  80         [ { } redefine-mixin-class ]
  81         [ H{ } clone "instances" set-word-prop ]
  82         [ update-classes ]
  83         tri
  84     ] if ;
  85
  86 ! Definition protocol implementation ensures that removing an
  87 ! INSTANCE: declaration from a source file updates the mixin.
  88 TUPLE: mixin-instance class mixin ;
  89
  90 C: <mixin-instance> mixin-instance
  91
  92 <PRIVATE
  93
  94 : >mixin-instance< ( mixin-instance -- class mixin )
  95     [ class>> ] [ mixin>> ] bi ; inline
  96
  97 PRIVATE>
  98
  99 M: mixin-instance where >mixin-instance< "instances" word-prop at ;
 100
 101 M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ;
 102
 103 M: mixin-instance definer drop \ INSTANCE: f ;
 104
 105 M: mixin-instance definition drop f ;
 106
 107 M: mixin-instance forget*
 108     >mixin-instance<
 109     dup mixin-class? [ remove-mixin-instance ] [ 2drop ] if ;