basis/classes/struct/prettyprint/prettyprint.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.data alien.prettyprint arrays
   3 assocs classes classes.struct combinators combinators.short-circuit
   4 continuations fry kernel libc make math math.parser mirrors
   5 prettyprint.backend prettyprint.custom prettyprint.sections
   6 see.private sequences slots strings summary words ;
   7 IN: classes.struct.prettyprint
   8
   9 <PRIVATE
  10
  11 : struct-definer-word ( class -- word )
  12     struct-slots dup length 2 >=
  13     [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
  14     [ drop \ STRUCT: ] if ;
  15
  16 : struct>assoc ( struct -- assoc )
  17     [ class struct-slots ] [ struct-slot-values ] bi zip ;
  18
  19 : pprint-struct-slot ( slot -- )
  20     <flow \ { pprint-word
  21     f <inset {
  22         [ name>> text ]
  23         [ type>> pprint-c-type ]
  24         [ read-only>> [ \ read-only pprint-word ] when ]
  25         [ initial>> [ \ initial: pprint-word pprint* ] when* ]
  26     } cleave block>
  27     \ } pprint-word block> ;
  28
  29 : pprint-struct ( struct -- )
  30     [
  31         [ \ S{ ] dip
  32         [ class ]
  33         [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
  34         \ } (pprint-tuple)
  35     ] ?pprint-tuple ;
  36
  37 : pprint-struct-pointer ( struct -- )
  38     \ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
  39
  40 PRIVATE>
  41
  42 M: struct-class see-class*
  43     <colon dup struct-definer-word pprint-word dup pprint-word
  44     <block struct-slots [ pprint-struct-slot ] each
  45     block> pprint-; block> ;
  46
  47 M: struct pprint-delims
  48     drop \ S{ \ } ;
  49
  50 M: struct >pprint-sequence
  51     [ class ] [ struct-slot-values ] bi class-slot-sequence ;
  52
  53 M: struct pprint*
  54     [ pprint-struct ]
  55     [ pprint-struct-pointer ] pprint-c-object ;
  56
  57 M: struct summary
  58     [
  59         dup class name>> %
  60         " struct of " %
  61         byte-length #
  62         " bytes " %
  63     ] "" make ;
  64
  65 TUPLE: struct-mirror { object read-only } ;
  66 C: <struct-mirror> struct-mirror
  67
  68 : get-struct-slot ( struct slot -- value present? )
  69     over class struct-slots slot-named
  70     [ name>> reader-word execute( struct -- value ) t ]
  71     [ drop f f ] if* ;
  72 : set-struct-slot ( value struct slot -- )
  73     over class struct-slots slot-named
  74     [ name>> writer-word execute( value struct -- ) ]
  75     [ 2drop ] if* ;
  76 : reset-struct-slot ( struct slot -- )
  77     over class struct-slots slot-named
  78     [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
  79     [ drop ] if* ;
  80 : reset-struct-slots ( struct -- )
  81     dup class struct-prototype
  82     dup byte-length memcpy ;
  83
  84 M: struct-mirror at*
  85     object>> {
  86         { [ over "underlying" = ] [ nip >c-ptr t ] }
  87         { [ over { [ array? ] [ length 1 >= ] } 1&& ] [ swap first get-struct-slot ] }
  88         [ 2drop f f ]
  89     } cond ;
  90
  91 M: struct-mirror set-at
  92     object>> {
  93         { [ over "underlying" = ] [ 3drop ] }
  94         { [ over array? ] [ swap first set-struct-slot ] }
  95         [ 3drop ]
  96     } cond ;
  97
  98 M: struct-mirror delete-at
  99     object>> {
 100         { [ over "underlying" = ] [ 2drop ] }
 101         { [ over array? ] [ swap first reset-struct-slot ] }
 102         [ 2drop ]
 103     } cond ;
 104
 105 M: struct-mirror clear-assoc
 106     object>> reset-struct-slots ;
 107
 108 M: struct-mirror >alist ( mirror -- alist )
 109     object>> [
 110         [ drop "underlying" ] [ >c-ptr ] bi 2array 1array
 111     ] [
 112         '[
 113             _ struct>assoc
 114             [ [ [ name>> ] [ type>> ] bi 2array ] dip ] assoc-map
 115         ] [ drop { } ] recover
 116     ] bi append ;
 117
 118 M: struct make-mirror <struct-mirror> ;
 119
 120 INSTANCE: struct-mirror assoc