core/classes/mixin/mixin.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: classes classes.union words kernel sequences
   4 definitions combinators arrays assocs generic accessors ;
   5 IN: classes.mixin
   6
   7 PREDICATE: mixin-class < union-class "mixin" word-prop ;
   8
   9 M: mixin-class reset-class
  10     [ call-next-method ] [ { "mixin" } reset-props ] bi ;
  11
  12 M: mixin-class rank-class drop 3 ;
  13
  14 : redefine-mixin-class ( class members -- )
  15     [ (define-union-class) ]
  16     [ drop t "mixin" set-word-prop ]
  17     2bi ;
  18
  19 : define-mixin-class ( class -- )
  20     dup mixin-class? [
  21         drop
  22     ] [
  23         [ { } redefine-mixin-class ]
  24         [ update-classes ]
  25         bi
  26     ] if ;
  27
  28 TUPLE: check-mixin-class class ;
  29
  30 : check-mixin-class ( mixin -- mixin )
  31     dup mixin-class? [
  32         \ check-mixin-class boa throw
  33     ] unless ;
  34
  35 : if-mixin-member? ( class mixin true false -- )
  36     [ check-mixin-class 2dup members memq? ] 2dip if ; inline
  37
  38 : change-mixin-class ( class mixin quot -- )
  39     [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
  40     swap redefine-mixin-class ; inline
  41
  42 : update-classes/new ( mixin -- )
  43     class-usages
  44     [ [ update-class ] each ]
  45     [ implementors [ remake-generic ] each ] bi ;
  46
  47 : add-mixin-instance ( class mixin -- )
  48     #! Note: we call update-classes on the new member, not the
  49     #! mixin. This ensures that we only have to update the
  50     #! methods whose specializer intersects the new member, not
  51     #! the entire mixin (since the other mixin members are not
  52     #! affected at all). Also, all usages of the mixin will get
  53     #! updated by transitivity; the mixins usages appear in
  54     #! class-usages of the member, now that it's been added.
  55     [ 2drop ] [
  56         [ [ suffix ] change-mixin-class ] 2keep
  57         tuck [ new-class? ] either? [
  58             update-classes/new
  59         ] [
  60             update-classes
  61         ] if
  62     ] if-mixin-member? ;
  63
  64 : remove-mixin-instance ( class mixin -- )
  65     #! The order of the three clauses is important here. The last
  66     #! one must come after the other two so that the entries it
  67     #! adds to changed-generics are not overwritten.
  68     [
  69         [ [ swap remove ] change-mixin-class ]
  70         [ nip update-classes ]
  71         [ class-usages update-methods ]
  72         2tri
  73     ] [ 2drop ] if-mixin-member? ;
  74
  75 M: mixin-class class-forgotten remove-mixin-instance ;
  76
  77 ! Definition protocol implementation ensures that removing an
  78 ! INSTANCE: declaration from a source file updates the mixin.
  79 TUPLE: mixin-instance loc class mixin ;
  80
  81 M: mixin-instance equal?
  82     {
  83         { [ over mixin-instance? not ] [ f ] }
  84         { [ 2dup [ class>> ] bi@ = not ] [ f ] }
  85         { [ 2dup [ mixin>> ] bi@ = not ] [ f ] }
  86         [ t ]
  87     } cond 2nip ;
  88
  89 M: mixin-instance hashcode*
  90     [ class>> ] [ mixin>> ] bi 2array hashcode* ;
  91
  92 : <mixin-instance> ( class mixin -- definition )
  93     mixin-instance new
  94         swap >>mixin
  95         swap >>class ;
  96
  97 M: mixin-instance where loc>> ;
  98
  99 M: mixin-instance set-where (>>loc) ;
 100
 101 M: mixin-instance definer drop \ INSTANCE: f ;
 102
 103 M: mixin-instance definition drop f ;
 104
 105 M: mixin-instance forget*
 106     [ class>> ] [ mixin>> ] bi
 107     dup mixin-class? [ remove-mixin-instance ] [ 2drop ] if ;