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 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     dupd define-union-class
  16     t "mixin" set-word-prop ;
  17
  18 : define-mixin-class ( class -- )
  19     dup mixin-class? [
  20         drop
  21     ] [
  22         { } redefine-mixin-class
  23     ] if ;
  24
  25 TUPLE: check-mixin-class mixin ;
  26
  27 : check-mixin-class ( mixin -- mixin )
  28     dup mixin-class? [
  29         \ check-mixin-class boa throw
  30     ] unless ;
  31
  32 : if-mixin-member? ( class mixin true false -- )
  33     >r >r check-mixin-class 2dup members memq? r> r> if ; inline
  34
  35 : change-mixin-class ( class mixin quot -- )
  36     [ members swap bootstrap-word ] prepose keep
  37     swap redefine-mixin-class ; inline
  38
  39 : add-mixin-instance ( class mixin -- )
  40     [ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
  41
  42 : remove-mixin-instance ( class mixin -- )
  43     [ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
  44
  45 ! Definition protocol implementation ensures that removing an
  46 ! INSTANCE: declaration from a source file updates the mixin.
  47 TUPLE: mixin-instance loc class mixin ;
  48
  49 M: mixin-instance equal?
  50     {
  51         { [ over mixin-instance? not ] [ f ] }
  52         { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
  53         { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
  54         [ t ]
  55     } cond 2nip ;
  56
  57 M: mixin-instance hashcode*
  58     [ class>> ] [ mixin>> ] bi 2array hashcode* ;
  59
  60 : <mixin-instance> ( class mixin -- definition )
  61     { set-mixin-instance-class set-mixin-instance-mixin }
  62     mixin-instance construct ;
  63
  64 M: mixin-instance where mixin-instance-loc ;
  65
  66 M: mixin-instance set-where set-mixin-instance-loc ;
  67
  68 M: mixin-instance definer drop \ INSTANCE: f ;
  69
  70 M: mixin-instance definition drop f ;
  71
  72 M: mixin-instance forget*
  73     dup mixin-instance-class
  74     swap mixin-instance-mixin dup mixin-class?
  75     [ remove-mixin-instance ] [ 2drop ] if ;