basis/ui/tools/inspector/inspector.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors colors inspector namespaces kernel models fry
   4 colors.constants models.arrow prettyprint sequences mirrors assocs
   5 classes io io.styles arrays hashtables math.order sorting refs fonts
   6 ui.tools.browser ui.commands ui.operations ui.gadgets ui.gadgets.panes
   7 ui.gadgets.scrollers ui.gadgets.slots ui.gadgets.tracks ui.gestures
   8 ui.gadgets.buttons ui.gadgets.lines ui.gadgets.tables
   9 ui.gadgets.toolbar ui.gadgets.status-bar
  10 ui.gadgets.labeled ui.tools.common ui combinators ui.gadgets.worlds ;
  11 IN: ui.tools.inspector
  12
  13 TUPLE: inspector-gadget < tool table ;
  14
  15 TUPLE: slot-description key key-string value value-string ;
  16
  17 : <slot-description> ( key value -- slot-description )
  18     [ dup unparse-short ] bi@ slot-description boa ;
  19
  20 SINGLETON: inspector-renderer
  21
  22 M: inspector-renderer row-columns
  23     drop [ key-string>> ] [ value-string>> ] bi 2array ;
  24
  25 M: inspector-renderer row-value
  26     drop value>> ;
  27
  28 M: inspector-renderer column-titles
  29     drop { "Key" "Value" } ;
  30
  31 : <summary-gadget> ( model -- gadget )
  32     [
  33         standard-table-style [
  34             {
  35                 [
  36                     [
  37                         [ "Class:" write ] with-cell
  38                         [ class-of pprint ] with-cell
  39                     ] with-row
  40                 ]
  41                 [
  42                     [
  43                         [ "Object:" write ] with-cell
  44                         [ pprint-short ] with-cell
  45                     ] with-row
  46                 ]
  47                 [
  48                     [
  49                         [ "Summary:" write ] with-cell
  50                         [ print-summary ] with-cell
  51                     ] with-row
  52                 ]
  53                 [
  54                     content-gadget [
  55                         [
  56                             [ "Content:" write ] with-cell
  57                             [ output-stream get write-gadget ] with-cell
  58                         ] with-row
  59                     ] when*
  60                 ]
  61             } cleave
  62         ] tabular-output
  63     ] <pane-control> ;
  64
  65 GENERIC: make-slot-descriptions ( obj -- seq )
  66
  67 M: object make-slot-descriptions
  68     make-mirror [ <slot-description> ] { } assoc>map ;
  69
  70 M: hashtable make-slot-descriptions
  71     call-next-method [ key-string>> ] sort-with ;
  72
  73 : <inspector-table> ( model -- table )
  74     [ make-slot-descriptions ] <arrow> inspector-renderer <table>
  75         [ invoke-primary-operation ] >>action
  76         monospace-font >>font
  77         COLOR: dark-gray >>column-line-color
  78         6 >>gap
  79         15 >>min-rows
  80         15 >>max-rows
  81         40 >>min-cols
  82         40 >>max-cols ;
  83
  84 <PRIVATE
  85
  86 CONSTANT: object-color COLOR: aquamarine2
  87 CONSTANT: contents-color COLOR: orchid2
  88
  89 PRIVATE>
  90
  91 : <inspector-gadget> ( model -- gadget )
  92     vertical inspector-gadget new-track with-lines
  93         add-toolbar
  94         swap >>model
  95         dup model>> <inspector-table> >>table
  96         dup model>> <summary-gadget> margins white-interior "Object" object-color <labeled-gadget> f track-add
  97         dup table>> <scroller> white-interior "Contents" contents-color <labeled-gadget> 1 track-add ;
  98
  99 M: inspector-gadget focusable-child*
 100     table>> ;
 101
 102 : com-refresh ( inspector -- )
 103     model>> notify-connections ;
 104
 105 : com-push ( inspector -- obj )
 106     control-value ;
 107
 108 \ com-push H{ { +listener+ t } } define-command
 109
 110 : slot-editor-window ( close-hook update-hook assoc key key-string -- )
 111     [ <value-ref> <slot-editor> ]
 112     [
 113         <world-attributes>
 114             swap "Slot editor: " prepend >>title
 115             [ { dialog-window } append ] change-window-controls
 116     ] bi*
 117     open-status-window ;
 118
 119 : com-edit-slot ( inspector -- )
 120     [ close-window ] swap
 121     [ '[ _ com-refresh ] ]
 122     [ control-value make-mirror ]
 123     [ table>> (selected-row) ] tri [
 124         [ key>> ] [ key-string>> ] bi
 125         slot-editor-window
 126     ] [ 4drop ] if ;
 127
 128 : inspector-help ( -- ) "ui-inspector" com-browse ;
 129
 130 \ inspector-help H{ { +nullary+ t } } define-command
 131
 132 inspector-gadget "toolbar" f {
 133     { T{ update-object } com-refresh }
 134     { T{ key-down f f "p" } com-push }
 135     { T{ key-down f f "e" } com-edit-slot }
 136     { T{ key-down f f "F1" } inspector-help }
 137 } define-command-map
 138
 139 inspector-gadget "multi-touch" f {
 140     { up-action com-refresh }
 141 } define-command-map
 142
 143 : inspect-model ( model -- )
 144     <inspector-gadget> "Inspector" open-status-window ;
 145
 146 : inspector ( obj -- )
 147     <model> inspect-model ;
 148
 149 { 550 400 } inspector-gadget set-tool-dim