basis/mirrors/mirrors.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs classes classes.tuple classes.tuple.private
   4 combinators fry hash-sets hashtables kernel math sequences sets slots
   5 slots.private summary ;
   6 IN: mirrors
   7
   8 TUPLE: mirror { object read-only } ;
   9
  10 C: <mirror> mirror
  11
  12 : object-slots ( mirror -- slots ) object>> class-of all-slots ; inline
  13
  14 M: mirror at*
  15     [ nip object>> ] [ object-slots slot-named ] 2bi
  16     [ offset>> slot t ] [ drop f f ] if* ;
  17
  18 ERROR: no-such-slot slot ;
  19 ERROR: read-only-slot slot ;
  20
  21 : check-set-slot ( val slot -- val offset )
  22     {
  23         { [ dup not ] [ no-such-slot ] }
  24         { [ dup read-only>> ] [ read-only-slot ] }
  25         { [ 2dup class>> instance? not ] [ class>> bad-slot-value ] }
  26         [ offset>> ]
  27     } cond ; inline
  28
  29 M: mirror set-at ( val key mirror -- )
  30     [ object-slots slot-named check-set-slot ] [ object>> ] bi
  31     swap set-slot ;
  32
  33 ERROR: mirror-slot-removal slots mirror method ;
  34
  35 M: mirror delete-at ( key mirror -- )
  36     \ delete-at mirror-slot-removal ;
  37
  38 M: mirror clear-assoc ( mirror -- )
  39     [ object-slots ] keep \ clear-assoc mirror-slot-removal ;
  40
  41 M: mirror-slot-removal summary
  42     drop "Slots cannot be removed from a tuple or a mirror of it" ;
  43
  44 M: mirror >alist ( mirror -- alist )
  45     [ object-slots ] [ object>> ] bi '[
  46         [ name>> ] [ offset>> _ swap slot ] bi
  47     ] { } map>assoc ;
  48
  49 M: mirror keys ( mirror -- keys )
  50     object-slots [ name>> ] map ;
  51
  52 M: mirror values ( mirror -- values )
  53     [ object-slots ] [ object>> ] bi
  54     '[ offset>> _ swap slot ] map ;
  55
  56 M: mirror assoc-size
  57     object>> class-of class-size ;
  58
  59 INSTANCE: mirror assoc
  60
  61 GENERIC: make-mirror ( obj -- assoc )
  62 M: hashtable make-mirror ;
  63 M: hash-set make-mirror members make-mirror ;
  64 M: integer make-mirror drop f ;
  65 M: sequence make-mirror <enumerated> ;
  66 M: object make-mirror <mirror> ;