basis/classes/struct/prettyprint/prettyprint.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors alien assocs classes classes.struct
   3 combinators kernel math prettyprint.backend prettyprint.custom
   4 prettyprint.sections see.private sequences strings words ;
   5 IN: classes.struct.prettyprint
   6
   7 <PRIVATE
   8
   9 : struct-definer-word ( class -- word )
  10     struct-slots dup length 2 >=
  11     [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
  12     [ drop \ STRUCT: ] if ;
  13
  14 : struct>assoc ( struct -- assoc )
  15     [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
  16
  17 : pprint-struct-slot ( slot -- )
  18     <flow \ { pprint-word
  19     {
  20         [ name>> text ]
  21         [ c-type>> dup string? [ text ] [ pprint* ] if ]
  22         [ read-only>> [ \ read-only pprint-word ] when ]
  23         [ initial>> [ \ initial: pprint-word pprint* ] when* ]
  24     } cleave
  25     \ } pprint-word block> ;
  26
  27 : pprint-struct ( struct -- )
  28     [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
  29
  30 : pprint-struct-pointer ( struct -- )
  31     <block
  32     \ S@ pprint-word
  33     [ class pprint-word ]
  34     [ >c-ptr pprint* ] bi
  35     block> ;
  36
  37 PRIVATE>
  38
  39 M: struct-class see-class*
  40     <colon dup struct-definer-word pprint-word dup pprint-word
  41     <block struct-slots [ pprint-struct-slot ] each
  42     block> pprint-; block> ;
  43
  44 M: struct pprint-delims
  45     drop \ S{ \ } ;
  46
  47 M: struct >pprint-sequence
  48     [ class ] [ struct-slot-values ] bi class-slot-sequence ;
  49
  50 M: struct pprint*
  51     [ pprint-struct ]
  52     [ pprint-struct-pointer ] pprint-c-object ;