basis/ui/tools/inspector/inspector.factor

   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
  13
  14 TUPLE: inspector-gadget < tool table ;
  15
  16 TUPLE: slot-description key key-string value value-string ;
  17
  18 : <slot-description> ( key value -- slot-description )
  19     [ dup unparse-short ] bi@ slot-description boa ;
  20
  21 SINGLETON: inspector-renderer
  22
  23 M: inspector-renderer row-columns
  24     drop [ key-string>> ] [ value-string>> ] bi 2array ;
  25
  26 M: inspector-renderer row-value
  27     drop value>> ;
  28
  29 M: inspector-renderer column-titles
  30     drop { "Key" "Value" } ;
  31
  32 : <summary-gadget> ( model -- gadget )
  33     [
  34         standard-table-style [
  35             {
  36                 [
  37                     [
  38                         [ "Class:" write ] with-cell
  39                         [ class-of pprint ] with-cell
  40                     ] with-row
  41                 ]
  42                 [
  43                     [
  44                         [ "Object:" write ] with-cell
  45                         [ pprint-short ] with-cell
  46                     ] with-row
  47                 ]
  48                 [
  49                     [
  50                         [ "Summary:" write ] with-cell
  51                         [ print-summary ] with-cell
  52                     ] with-row
  53                 ]
  54                 [
  55                     content-gadget [
  56                         [
  57                             [ "Content:" write ] with-cell
  58                             [ output-stream get write-gadget ] with-cell
  59                         ] with-row
  60                     ] when*
  61                 ]
  62             } cleave
  63         ] tabular-output
  64     ] <pane-control> ;
  65
  66 GENERIC: make-slot-descriptions ( obj -- seq )
  67
  68 M: object make-slot-descriptions
  69     make-mirror [ <slot-description> ] { } assoc>map ;
  70
  71 M: string make-slot-descriptions
  72     [
  73         swap [ dup number>string ] dip dup
  74         dup unicode:printable? [ 1string ] [
  75             dup 0xff <= [
  76                 H{
  77                     { CHAR: \a "\\a" }
  78                     { CHAR: \b "\\b" }
  79                     { CHAR: \e "\\e" }
  80                     { CHAR: \f "\\f" }
  81                     { CHAR: \n "\\n" }
  82                     { CHAR: \r "\\r" }
  83                     { CHAR: \t "\\t" }
  84                     { CHAR: \v "\\v" }
  85                     { CHAR: \0 "\\0" }
  86                 } ?at [ "\\x%02x" sprintf ] unless
  87             ] [
  88                 "\\u{%x}" sprintf
  89             ] if
  90         ] if slot-description boa
  91     ] { } map-index-as ;
  92
  93 M: hashtable make-slot-descriptions
  94     call-next-method [ key-string>> ] sort-by ;
  95
  96 TUPLE: inspector-table < table ;
  97
  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 { } ] [
 102         [ drop gap>> ]
 103         [ initial-widths ]
 104         [ keys longest "" 2array row-column-widths ] 2tri
 105         vmax [ compute-total-width ] keep
 106     ] if-empty ;
 107
 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
 114         6 >>gap
 115         15 >>min-rows
 116         15 >>max-rows
 117         40 >>min-cols
 118         40 >>max-cols ;
 119
 120 : <inspector-gadget> ( model -- gadget )
 121     vertical inspector-gadget new-track with-lines
 122         add-toolbar
 123         swap >>model
 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 ;
 129
 130 M: inspector-gadget focusable-child*
 131     table>> ;
 132
 133 : com-refresh ( inspector -- )
 134     model>> notify-connections ;
 135
 136 : com-push ( inspector -- obj )
 137     control-value ;
 138
 139 \ com-push H{ { +listener+ t } } define-command
 140
 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
 147         slot-editor-window
 148     ] [ 4drop ] if ;
 149
 150 : inspector-help ( -- ) "ui-inspector" com-browse ;
 151
 152 \ inspector-help H{ { +nullary+ t } } define-command
 153
 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 }
 159 } define-command-map
 160
 161 inspector-gadget "multi-touch" f {
 162     { up-action com-refresh }
 163 } define-command-map
 164
 165 : inspect-model ( model -- )
 166     <inspector-gadget> "Inspector" open-status-window ;
 167
 168 : inspector ( obj -- )
 169     <model> inspect-model ;
 170
 171 inspector-gadget default-font-size { 46 33 } n*v set-tool-dim