basis/mirrors/mirrors.factor

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