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 inspector namespaces kernel models fry
   4 models.filter prettyprint sequences mirrors assocs classes
   5 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
   8 ui.gestures ui.gadgets.buttons ui.gadgets.tables
   9 ui.gadgets.status-bar ui.gadgets.labeled
  10 ui.tools.common ui ;
  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                     [ "Class:" write ] with-cell
  37                     [ class . ] with-cell
  38                 ] with-row
  39             ]
  40             [
  41                 [
  42                     [ "Object:" write ] with-cell
  43                     [ short. ] with-cell
  44                 ] with-row
  45             ]
  46             [
  47                 [
  48                     [ "Summary:" write ] with-cell
  49                     [ summary. ] with-cell
  50                 ] with-row
  51             ] tri
  52         ] tabular-output
  53     ] <pane-control> ;
  54
  55 GENERIC: make-slot-descriptions ( obj -- seq )
  56
  57 M: object make-slot-descriptions
  58     make-mirror [ <slot-description> ] { } assoc>map ;
  59
  60 M: hashtable make-slot-descriptions
  61     call-next-method [ [ key-string>> ] compare ] sort ;
  62
  63 : <inspector-table> ( model -- table )
  64     [ make-slot-descriptions ] <filter> inspector-renderer <table>
  65         [ dup primary-operation invoke-command ] >>action
  66         monospace-font >>font
  67         15 >>min-rows
  68         15 >>max-rows
  69         40 >>min-cols
  70         40 >>max-cols ;
  71
  72 : <inspector-gadget> ( model -- gadget )
  73     vertical inspector-gadget new-track
  74         { 3 3 } >>gap
  75         add-toolbar
  76         swap >>model
  77         dup model>> <inspector-table> >>table
  78         dup model>> <summary-gadget> "Object" <labeled-gadget> f track-add
  79         dup table>> <scroller> "Contents" <labeled-gadget> 1 track-add ;
  80
  81 M: inspector-gadget focusable-child*
  82     table>> ;
  83
  84 : com-refresh ( inspector -- )
  85     model>> notify-connections ;
  86
  87 : com-push ( inspector -- obj )
  88     control-value ;
  89
  90 \ com-push H{ { +listener+ t } } define-command
  91
  92 : slot-editor-window ( close-hook update-hook assoc key key-string -- )
  93     [ <value-ref> <slot-editor> ] [ "Slot editor: " prepend ] bi*
  94     open-window ;
  95
  96 : com-edit-slot ( inspector -- )
  97     [ close-window ] swap
  98     [ '[ _ com-refresh ] ]
  99     [ control-value make-mirror ]
 100     [ table>> (selected-row) ] tri [
 101         [ key>> ] [ key-string>> ] bi
 102         slot-editor-window
 103     ] [ 2drop 2drop ] if ;
 104
 105 : inspector-help ( -- ) "ui-inspector" com-follow ;
 106
 107 \ inspector-help H{ { +nullary+ t } } define-command
 108
 109 inspector-gadget "toolbar" f {
 110     { T{ update-object } com-refresh }
 111     { T{ key-down f f "p" } com-push }
 112     { T{ key-down f f "e" } com-edit-slot }
 113     { T{ key-down f f "F1" } inspector-help }
 114 } define-command-map
 115
 116 inspector-gadget "multi-touch" f {
 117     { up-action com-refresh }
 118 } define-command-map
 119
 120 : inspect-model ( model -- )
 121     <inspector-gadget> "Inspector" open-status-window ;
 122
 123 : inspector ( obj -- )
 124     <model> inspect-model ;