! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inspector
USING: generic hashtables io kernel kernel-internals listener
lists math memory namespaces prettyprint sequences strings
styles test vectors words ;

GENERIC: sheet ( obj -- sheet )

M: object sheet ( obj -- sheet )
    dup class "slots" word-prop
    [ second ] map
    tuck [ execute ] map-with
    2vector ;

M: list sheet 1vector ;

M: vector sheet 1vector ;

M: array sheet 1vector ;

M: hashtable sheet dup hash-keys swap hash-values 2vector ;

: format-column ( list -- list )
    [ unparse-short ] map
    [ max-length ] keep
    [ swap CHAR: \s pad-right ] map-with ;

: sheet-numbers ( sheet -- sheet )
    dup first length >vector 1vector swap append ;

SYMBOL: inspector-slots

: format-sheet ( sheet -- list )
    sheet-numbers
    dup peek inspector-slots set
    [ format-column ] map
    flip
    [ " | " join ] map ;

: vocab-banner ( word -- )
    dup word-vocabulary [
        dup interned? [
            "This word is located in the " write
        ] [
            "This is an orphan not part of the dictionary." print
            "It claims to belong to the " write
        ] ifte
        word-vocabulary pprint " vocabulary." print
    ] [
        drop
        "The word is a uniquely generated symbol." print
    ] ifte ;

GENERIC: extra-banner ( obj -- )

M: word extra-banner ( obj -- )
    dup vocab-banner
    metaclass [
        "This is a class whose behavior is specifed by the " write
        pprint " metaclass." print
    ] when* ;

M: object extra-banner ( obj -- ) drop ;

: inspect-banner ( obj -- )
    "You are looking at an instance of the " write dup class pprint
    " class:" print
    "  " write dup pprint-short terpri
    "It takes up " write dup size pprint " bytes of memory." print
    extra-banner ;

: describe ( obj -- )
    sheet dup format-sheet swap peek
    [ write-object terpri ] 2each ;

SYMBOL: inspector-stack

: inspecting ( -- obj ) inspector-stack get peek ;

: (inspect) ( obj -- )
    dup inspector-stack get push
    dup inspect-banner describe ;

: inspector-help ( -- )
    "Object inspector." print
    "inspecting ( -- obj ) push current object" print
    "go ( n -- ) inspect nth slot" print
    "up -- return to previous object" print
    "refs -- inspect references to current object" print
    "bye -- exit inspector" print ;

: inspector ( obj -- )
    [
        inspector-help
        terpri
        "inspector " listener-prompt set
        [ inspector-stack get "Inspector history:" ] callstack-hook set
        { } clone inspector-stack set
        (inspect)
        listener
    ] with-scope ;

: inspect ( obj -- )
    #! Start an inspector if its not already running.
    inspector-stack get [ (inspect) ] [ inspector ] ifte ;

: go ( n -- ) inspector-slots get nth (inspect) ;

: up ( -- ) inspector-stack get >pop> pop (inspect) ;

: refs ( -- ) inspecting references (inspect) ;