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     \ S@ pprint-word
  32     [ class pprint-word ]
  33     [ >c-ptr pprint* ] bi ;
  34
  35 PRIVATE>
  36
  37 M: struct-class see-class*
  38     <colon dup struct-definer-word pprint-word dup pprint-word
  39     <block struct-slots [ pprint-struct-slot ] each
  40     block> pprint-; block> ;
  41
  42 M: struct pprint-delims
  43     drop \ S{ \ } ;
  44
  45 M: struct >pprint-sequence
  46     [ class ] [ struct-slot-values ] bi class-slot-sequence ;
  47
  48 M: struct pprint*
  49     [ pprint-struct ]
  50     [ pprint-struct-pointer ] pprint-c-object ;