1 ! Copyright (C) 2023 Jean-Marc Lugrin.
2 ! See https://factorcode.org/license.txt for BSD license.
4 ! Print a class heierarchy in the listener
5 ! or to a file: "TESTDUMP.TXT" utf8 [ gadget hierarchy. ] with-file-writer
8 USING: classes hashtables ui.gadgets assocs kernel sequences prettyprint vectors
9 math io formatting strings sorting accessors io.styles vocabs ;
11 IN: classes.prettyprinter
13 ERROR: not-a-class-error ;
19 : add-child ( c h -- )
20 over ! ( c h -- c h c )
21 superclass-of ! ( c h c -- c h s )
22 swap at* ! (c h s -- c s h -- c v ? ) vector for superclass but if f ignore
23 [ swap suffix! drop ] ! ( c v -- )
28 : print-class-name ( c -- )
29 dup name>> swap write-object
34 vocabulary>> lookup-vocab dup name>>
35 dup ".private" tail? [ " P" ] [ " " ] if write ! Mark if private
40 : print-leader ( i -- )
41 ! 2 * CHAR: . <string> write ! leader
42 [ "| " ] replicate "" concat-as write
43 ! 1 CHAR: \x20 <string> write
46 : print-class ( c i -- )
47 2dup print-leader print-class-name ! ( c i -- c i )
48 2 * over name>> length + ! Current column c ci --
49 dup in-col < [ in-col swap - CHAR: \x20 <string> write ] [ drop ] if
54 : print-superclasses ( c -- )
58 [ print-superclasses ] bi
64 : print-root-class ( c -- )
66 [ print-superclasses ] bi
70 :: print-children ( h c i -- )
71 i 0 = [ c print-root-class ] [ c i print-class ] if
73 [ h swap i 1 + print-children ] each
78 : class-hierarchy ( -- hash )
79 ! Hastable class -> empty mutable vector
80 classes [ drop V{ } clone ] zip-with >hashtable
81 ! for each child-class, add it to its parent vector
82 classes [ over add-child ] each
86 : hierarchy. ( class -- )
87 dup class? [ not-a-class-error ] unless
89 ! Print from the desired root class