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     { "class" "metaclass" "members" "mixin" } reset-props ;
  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     ] if ;
  25
  26 TUPLE: check-mixin-class mixin ;
  27
  28 : check-mixin-class ( mixin -- mixin )
  29     dup mixin-class? [
  30         \ check-mixin-class boa throw
  31     ] unless ;
  32
  33 : if-mixin-member? ( class mixin true false -- )
  34     [ check-mixin-class 2dup members memq? ] 2dip if ; inline
  35
  36 : change-mixin-class ( class mixin quot -- )
  37     [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
  38     swap redefine-mixin-class ; inline
  39
  40 : update-classes/new ( mixin -- )
  41     class-usages
  42     [ keys [ update-class ] each ]
  43     [ implementors [ make-generic ] each ] bi ;
  44
  45 : add-mixin-instance ( class mixin -- )
  46     #! Note: we call update-classes on the new member, not the
  47     #! mixin. This ensures that we only have to update the
  48     #! methods whose specializer intersects the new member, not
  49     #! the entire mixin (since the other mixin members are not
  50     #! affected at all). Also, all usages of the mixin will get
  51     #! updated by transitivity; the mixins usages appear in
  52     #! class-usages of the member, now that it's been added.
  53     [ 2drop ] [
  54         [ [ suffix ] change-mixin-class ] 2keep
  55         nip update-classes
  56         ! over new-class? [ nip update-classes/new ] [ drop update-classes ] if
  57     ] if-mixin-member? ;
  58
  59 : remove-mixin-instance ( class mixin -- )
  60     [
  61         [ [ swap remove ] change-mixin-class ] keep
  62         update-classes
  63     ] [ 2drop ] if-mixin-member? ;
  64
  65 ! Definition protocol implementation ensures that removing an
  66 ! INSTANCE: declaration from a source file updates the mixin.
  67 TUPLE: mixin-instance loc class mixin ;
  68
  69 M: mixin-instance equal?
  70     {
  71         { [ over mixin-instance? not ] [ f ] }
  72         { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
  73         { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
  74         [ t ]
  75     } cond 2nip ;
  76
  77 M: mixin-instance hashcode*
  78     [ class>> ] [ mixin>> ] bi 2array hashcode* ;
  79
  80 : <mixin-instance> ( class mixin -- definition )
  81     { set-mixin-instance-class set-mixin-instance-mixin }
  82     mixin-instance construct ;
  83
  84 M: mixin-instance where mixin-instance-loc ;
  85
  86 M: mixin-instance set-where set-mixin-instance-loc ;
  87
  88 M: mixin-instance definer drop \ INSTANCE: f ;
  89
  90 M: mixin-instance definition drop f ;
  91
  92 M: mixin-instance forget*
  93     dup mixin-instance-class
  94     swap mixin-instance-mixin dup mixin-class?
  95     [ remove-mixin-instance ] [ 2drop ] if ;