Paste: A word to print a class hierarchy

! Copyright (C) 2023 Jean-Marc Lugrin.
! See https://factorcode.org/license.txt for BSD license.

! Print a class heierarchy in the listener

USING:  classes hashtables ui.gadgets assocs kernel sequences prettyprint  vectors 
math io formatting strings sorting accessors io.styles ;

IN: introspection.gadget-classes

<PRIVATE

: add-child  ( c h  -- )
    over ! ( c h -- c h c )
    superclass-of  ! ( c h c -- c h s )
    swap at* ! (c h s -- c s h -- c v ? ) vector for superclass but if f ignore
        [ swap suffix! drop ]  ! ( c v -- )
        [ 2drop ] 
    if 
;

: print-class-name ( c -- )
    dup name>> swap write-object
;

: print-class ( c i -- ) 
    2 * CHAR: . <string>  write ! leader
    print-class-name
    nl
;

: print-superclasses ( c -- )
    superclass-of dup
    [ " < " write
        [ print-class-name ] 
        [ print-superclasses ] bi 
    ]
    [ drop ]
    if
;

: print-root-class ( c -- ) 
    [ print-class-name ]
    [ print-superclasses ] bi
    nl
;

 :: print-children ( h c i -- )
    i 0 = [ c print-root-class ] [ c i print-class ] if
    c h at
    [ h swap i 1 + print-children ] each
 ;

PRIVATE>

: print-hierarchy ( aclass -- )

    ! Get the hierarchy of all classes
    ! Hastable class -> empty mutable vector
    classes  [ drop V{ } clone ] zip-with >hashtable
    ! for each child-class, add it to its parent vector
    classes [  over add-child ] each
    [ sort ] assoc-map
    ! Print from the desired root class
    swap 0 print-children 
;
Author:	Jean-Marc Lugrin
Mode:	factor
Date:	Mon, 6 Nov 2023 10:06:22