/core/classes/mixin/mixin.factor

http://github.com/abeaumont/factor · Factor · 115 lines · 82 code · 29 blank · 4 comment · 8 complexity · 74b9130b6f344044546a5cb09c84b21f MD5 · raw file

  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. PREDICATE: mixin-class < union-class "mixin" word-prop ;
  9. M: mixin-class normalize-class ;
  10. M: mixin-class (classes-intersect?)
  11. members [ classes-intersect? ] with any? ;
  12. M: mixin-class reset-class
  13. [ call-next-method ] [ { "mixin" } reset-props ] bi ;
  14. M: mixin-class rank-class drop 8 ;
  15. ERROR: check-mixin-class-error class ;
  16. : check-mixin-class ( mixin -- mixin )
  17. dup mixin-class? [
  18. check-mixin-class-error
  19. ] unless ;
  20. <PRIVATE
  21. : redefine-mixin-class ( class members -- )
  22. [ (define-union-class) ]
  23. [ drop changed-conditionally ]
  24. [ drop t "mixin" set-word-prop ]
  25. 2tri ;
  26. : if-mixin-member? ( class mixin true false -- )
  27. [ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
  28. : change-mixin-class ( class mixin quot -- )
  29. [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
  30. swap redefine-mixin-class ; inline
  31. : (add-mixin-instance) ( class mixin -- )
  32. #! Call update-methods before adding the member:
  33. #! - Call sites of generics specializing on 'mixin'
  34. #! where the inferred type is 'class' are updated,
  35. #! - Call sites where the inferred type is a subtype
  36. #! of 'mixin' disjoint from 'class' are not updated
  37. dup class-usages {
  38. [ nip update-methods ]
  39. [ drop [ suffix ] change-mixin-class ]
  40. [ drop [ f ] 2dip "instances" word-prop set-at ]
  41. [ 2nip [ update-class ] each ]
  42. } 3cleave ;
  43. : (remove-mixin-instance) ( class mixin -- )
  44. #! Call update-methods after removing 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. [ drop [ swap remove ] change-mixin-class ]
  51. [ drop "instances" word-prop delete-at ]
  52. [ 2nip [ update-class ] each ]
  53. [ nip update-methods ]
  54. } 3cleave ;
  55. PRIVATE>
  56. GENERIC# add-mixin-instance 1 ( class mixin -- )
  57. M: class add-mixin-instance
  58. [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
  59. : remove-mixin-instance ( class mixin -- )
  60. [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
  61. M: mixin-class metaclass-changed
  62. over class? [ 2drop ] [ remove-mixin-instance ] if ;
  63. : define-mixin-class ( class -- )
  64. dup mixin-class? [
  65. drop
  66. ] [
  67. [ { } redefine-mixin-class ]
  68. [ H{ } clone "instances" set-word-prop ]
  69. [ update-classes ]
  70. tri
  71. ] if ;
  72. ! Definition protocol implementation ensures that removing an
  73. ! INSTANCE: declaration from a source file updates the mixin.
  74. TUPLE: mixin-instance class mixin ;
  75. C: <mixin-instance> mixin-instance
  76. <PRIVATE
  77. : >mixin-instance< ( mixin-instance -- class mixin )
  78. [ class>> ] [ mixin>> ] bi ; inline
  79. PRIVATE>
  80. M: mixin-instance where >mixin-instance< "instances" word-prop at ;
  81. M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ;
  82. M: mixin-instance definer drop \ INSTANCE: f ;
  83. M: mixin-instance definition drop f ;
  84. M: mixin-instance forget*
  85. >mixin-instance<
  86. dup mixin-class? [ remove-mixin-instance ] [ 2drop ] if ;