Fix inspector bug
							parent
							
								
									d34d3a6f31
								
							
						
					
					
						commit
						14b5e35a0e
					
				| 
						 | 
				
			
			@ -33,10 +33,10 @@ SYMBOL: +editable+
 | 
			
		|||
: write-value ( mirror key -- )
 | 
			
		||||
    <value-ref> write-slot-editor ;
 | 
			
		||||
 | 
			
		||||
: describe-row ( obj key n -- )
 | 
			
		||||
: describe-row ( mirror key n -- )
 | 
			
		||||
    [
 | 
			
		||||
        +number-rows+ get [ pprint-cell ] [ drop ] if
 | 
			
		||||
        2dup write-key write-value
 | 
			
		||||
        [ write-key ] [ write-value ] 2bi
 | 
			
		||||
    ] with-row ;
 | 
			
		||||
 | 
			
		||||
: summary. ( obj -- ) [ summary ] keep write-object nl ;
 | 
			
		||||
| 
						 | 
				
			
			@ -48,21 +48,19 @@ SYMBOL: +editable+
 | 
			
		|||
        sort-keys values
 | 
			
		||||
    ] [ keys ] if ;
 | 
			
		||||
 | 
			
		||||
: describe* ( obj flags -- )
 | 
			
		||||
    clone [
 | 
			
		||||
        dup summary.
 | 
			
		||||
        make-mirror dup sorted-keys dup empty? [
 | 
			
		||||
            2drop
 | 
			
		||||
        ] [
 | 
			
		||||
            dup enum? [ +sequence+ on ] when
 | 
			
		||||
            standard-table-style [
 | 
			
		||||
                dup length
 | 
			
		||||
                rot [ -rot describe-row ] curry 2each
 | 
			
		||||
            ] tabular-output
 | 
			
		||||
        ] if
 | 
			
		||||
    ] bind ;
 | 
			
		||||
: describe* ( obj mirror keys -- )
 | 
			
		||||
    rot summary.
 | 
			
		||||
    dup empty? [
 | 
			
		||||
        2drop
 | 
			
		||||
    ] [
 | 
			
		||||
        dup enum? [ +sequence+ on ] when
 | 
			
		||||
        standard-table-style [
 | 
			
		||||
            swap [ -rot describe-row ] curry each-index
 | 
			
		||||
        ] tabular-output
 | 
			
		||||
    ] if ;
 | 
			
		||||
 | 
			
		||||
: describe ( obj -- ) H{ } describe* ;
 | 
			
		||||
: describe ( obj -- )
 | 
			
		||||
    dup make-mirror dup sorted-keys describe* ;
 | 
			
		||||
 | 
			
		||||
M: tuple error. describe ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -78,19 +76,21 @@ M: tuple error. describe ;
 | 
			
		|||
 | 
			
		||||
SYMBOL: inspector-hook
 | 
			
		||||
 | 
			
		||||
[ H{ { +number-rows+ t } } describe* ] inspector-hook set-global
 | 
			
		||||
[ t +number-rows+ [ describe* ] with-variable ] inspector-hook set-global
 | 
			
		||||
 | 
			
		||||
SYMBOL: inspector-stack
 | 
			
		||||
 | 
			
		||||
SYMBOL: me
 | 
			
		||||
 | 
			
		||||
: reinspect ( obj -- )
 | 
			
		||||
    dup me set
 | 
			
		||||
    dup make-mirror dup mirror set keys \ keys set
 | 
			
		||||
    inspector-hook get call ;
 | 
			
		||||
    [ me set ]
 | 
			
		||||
    [
 | 
			
		||||
        dup make-mirror dup mirror set dup sorted-keys dup \ keys set
 | 
			
		||||
        inspector-hook get call
 | 
			
		||||
    ] bi ;
 | 
			
		||||
 | 
			
		||||
: (inspect) ( obj -- )
 | 
			
		||||
    dup inspector-stack get push reinspect ;
 | 
			
		||||
    [ inspector-stack get push ] [ reinspect ] bi ;
 | 
			
		||||
 | 
			
		||||
: key@ ( n -- key ) \ keys get nth ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -123,6 +123,7 @@ SYMBOL: me
 | 
			
		|||
    "&add ( value key -- ) add new slot" print
 | 
			
		||||
    "&delete ( n -- ) remove a slot" print
 | 
			
		||||
    "&rename ( key n -- ) change a slot's key" print
 | 
			
		||||
    "&globals ( -- ) inspect global namespace" print
 | 
			
		||||
    "&help -- display this message" print
 | 
			
		||||
    nl ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -133,3 +134,5 @@ SYMBOL: me
 | 
			
		|||
 | 
			
		||||
: inspect ( obj -- )
 | 
			
		||||
    inspector-stack get [ (inspect) ] [ inspector ] if ;
 | 
			
		||||
 | 
			
		||||
: &globals ( -- ) global inspect ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,6 @@
 | 
			
		|||
! Copyright (C) 2006, 2007 Slava Pestov.
 | 
			
		||||
! Copyright (C) 2006, 2008 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: ui.tools.workspace inspector kernel ui.commands
 | 
			
		||||
USING: accessors ui.tools.workspace inspector kernel ui.commands
 | 
			
		||||
ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
 | 
			
		||||
ui.gadgets.slots ui.gadgets.tracks ui.gestures
 | 
			
		||||
ui.gadgets.buttons namespaces ;
 | 
			
		||||
| 
						 | 
				
			
			@ -9,8 +9,10 @@ IN: ui.tools.inspector
 | 
			
		|||
TUPLE: inspector-gadget < track object pane ;
 | 
			
		||||
 | 
			
		||||
: refresh ( inspector -- )
 | 
			
		||||
    dup inspector-gadget-object swap inspector-gadget-pane [
 | 
			
		||||
        H{ { +editable+ t } { +number-rows+ t } } describe*
 | 
			
		||||
    [ object>> ] [ pane>> ] bi [
 | 
			
		||||
        +editable+ on
 | 
			
		||||
        +number-rows+ on
 | 
			
		||||
        describe
 | 
			
		||||
    ] with-pane ;
 | 
			
		||||
 | 
			
		||||
: <inspector-gadget> ( -- gadget )
 | 
			
		||||
| 
						 | 
				
			
			@ -20,16 +22,14 @@ TUPLE: inspector-gadget < track object pane ;
 | 
			
		|||
        <pane> g-> set-inspector-gadget-pane <scroller> 1 track,
 | 
			
		||||
    ] make-gadget ;
 | 
			
		||||
 | 
			
		||||
: inspect-object ( obj inspector -- )
 | 
			
		||||
    [ set-inspector-gadget-object ] keep refresh ;
 | 
			
		||||
: inspect-object ( obj mirror keys inspector -- )
 | 
			
		||||
    2nip swap >>object refresh ;
 | 
			
		||||
 | 
			
		||||
\ &push H{ { +nullary+ t } { +listener+ t } } define-command
 | 
			
		||||
 | 
			
		||||
\ &back H{ { +nullary+ t } { +listener+ t } } define-command
 | 
			
		||||
 | 
			
		||||
: globals ( -- ) global inspect ;
 | 
			
		||||
 | 
			
		||||
\ globals H{ { +nullary+ t } { +listener+ t } } define-command
 | 
			
		||||
\ &globals H{ { +nullary+ t } { +listener+ t } } define-command
 | 
			
		||||
 | 
			
		||||
: inspector-help ( -- ) "ui-inspector" help-window ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -39,7 +39,7 @@ inspector-gadget "toolbar" f {
 | 
			
		|||
    { T{ update-object } refresh }
 | 
			
		||||
    { f &push }
 | 
			
		||||
    { f &back }
 | 
			
		||||
    { f globals }
 | 
			
		||||
    { f &globals }
 | 
			
		||||
    { T{ key-down f f "F1" } inspector-help }
 | 
			
		||||
} define-command-map
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue