! Copyright (C) 2023 Your name.
! See https://factorcode.org/license.txt for BSD license.
USING: accessors classes combinators formatting io io.styles
kernel math namespaces prettyprint sequences strings ui.gadgets
ui.gadgets.labels ui.gadgets.worlds vocabs ;

IN: introspection.gadgets

CONSTANT: max_depth 10
CONSTANT: max_length 8

DEFER: component-hierarchy.

<PRIVATE

: each-child-index ( gadget quot -- ) [ children>> ] dip each-index  ; inline

: write-leader ( n -- )
    [ "| " ] replicate "" concat-as write
;

! Number of gadget up to the root (0 for the root)
: hierarchy-depth ( g -- l )
    parents length 1 -
;


: dump-name (  g -- ) 
    [ hierarchy-depth write-leader ] keep 
    [ class-of dup dup name>> swap write-object 
        vocabulary>> lookup-vocab name>> 
        ".private" tail? [ " P " ]  [ "   " ] if  write
    ] keep 
    ! [ class-of dup name>> swap write-object ] keep 
    dup label instance? [ string>> pprint-short ] [ drop  ] if ! print text of label
    nl
    ;



: dump-with-children-cond ( gadget idx -- ) ! dump if within length and depth limit
    1 + ! ( ... gadget idx -> gadget idx+1 )
    { 
        { [ dup max_length <  ] [ drop component-hierarchy. ] }
        { [ dup max_length = ] [ 
            drop
            [ hierarchy-depth write-leader ] keep 
            parent>> children>> length 
            max_length 
            "* COUNT %d > %d, skipped\n" printf
        ] }
        [ drop  drop ] 
    } cond
;


PRIVATE>


: component-hierarchy.  ( gadget --  ) 
    gadget check-instance
    [ dump-name ] keep   
    dup hierarchy-depth max_depth <  
    [
        [ dump-with-children-cond ] each-child-index  
    ]  
    [ 
        hierarchy-depth write-leader max_depth  "| * DEPTH > %d (max_depth), ignored \n" printf 
    ] 
    if
    ;

: hierarchy. ( -- )  world get component-hierarchy. ;