1 ! Copyright (C) 2006, 2009 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes combinators fonts
4 formatting hashtables inspector io io.styles kernel math
5 math.parser math.vectors mirrors models models.arrow namespaces
6 prettyprint sequences sorting strings ui ui.commands ui.gadgets
7 ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
8 ui.gadgets.status-bar ui.gadgets.tables
9 ui.gadgets.tables.private ui.gadgets.toolbar ui.gadgets.tracks
10 ui.gestures ui.operations ui.theme ui.tools.browser
11 ui.tools.common ui.tools.inspector.slots unicode ;
12 IN: ui.tools.inspector
14 TUPLE: inspector-gadget < tool table ;
16 TUPLE: slot-description key key-string value value-string ;
18 : <slot-description> ( key value -- slot-description )
19 [ dup unparse-short ] bi@ slot-description boa ;
21 SINGLETON: inspector-renderer
23 M: inspector-renderer row-columns
24 drop [ key-string>> ] [ value-string>> ] bi 2array ;
26 M: inspector-renderer row-value
29 M: inspector-renderer column-titles
30 drop { "Key" "Value" } ;
32 : <summary-gadget> ( model -- gadget )
34 standard-table-style [
38 [ "Class:" write ] with-cell
39 [ class-of pprint ] with-cell
44 [ "Object:" write ] with-cell
45 [ pprint-short ] with-cell
50 [ "Summary:" write ] with-cell
51 [ print-summary ] with-cell
57 [ "Content:" write ] with-cell
58 [ output-stream get write-gadget ] with-cell
66 GENERIC: make-slot-descriptions ( obj -- seq )
68 M: object make-slot-descriptions
69 make-mirror [ <slot-description> ] { } assoc>map ;
71 M: string make-slot-descriptions
73 swap [ dup number>string ] dip dup
74 dup unicode:printable? [ 1string ] [
86 } ?at [ "\\x%02x" sprintf ] unless
90 ] if slot-description boa
93 M: hashtable make-slot-descriptions
94 call-next-method [ key-string>> ] sort-by ;
96 TUPLE: inspector-table < table ;
98 ! Improve performance for big arrays or large hashtables by
99 ! only calculating column width for the longest key.
100 M: inspector-table compute-column-widths
101 dup rows>> [ drop 0 { } ] [
104 [ keys longest "" 2array row-column-widths ] 2tri
105 vmax [ compute-total-width ] keep
108 : <inspector-table> ( model -- table )
109 [ make-slot-descriptions ] <arrow> inspector-renderer
110 inspector-table new-table
111 [ invoke-primary-operation ] >>action
112 monospace-font >>font
113 line-color >>column-line-color
120 : <inspector-gadget> ( model -- gadget )
121 vertical inspector-gadget new-track with-lines
124 dup model>> <inspector-table> >>table
125 dup model>> <summary-gadget> margins white-interior
126 "Object" object-color <colored-labeled-gadget> f track-add
127 dup table>> <scroller> margins white-interior
128 "Contents" contents-color <colored-labeled-gadget> 1 track-add ;
130 M: inspector-gadget focusable-child*
133 : com-refresh ( inspector -- )
134 model>> notify-connections ;
136 : com-push ( inspector -- obj )
139 \ com-push H{ { +listener+ t } } define-command
141 : com-edit-slot ( inspector -- )
142 [ close-window ] swap
143 [ '[ _ com-refresh ] ]
144 [ control-value make-mirror ]
145 [ table>> (selected-row) ] tri [
146 [ key>> ] [ key-string>> ] bi
150 : inspector-help ( -- ) "ui-inspector" com-browse ;
152 \ inspector-help H{ { +nullary+ t } } define-command
154 inspector-gadget "toolbar" f {
155 { T{ key-down f f "r" } com-refresh }
156 { T{ key-down f f "p" } com-push }
157 { T{ key-down f f "e" } com-edit-slot }
158 { T{ key-down f f "F1" } inspector-help }
161 inspector-gadget "multi-touch" f {
162 { up-action com-refresh }
165 : inspect-model ( model -- )
166 <inspector-gadget> "Inspector" open-status-window ;
168 : inspector ( obj -- )
169 <model> inspect-model ;
171 inspector-gadget default-font-size { 46 33 } n*v set-tool-dim