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 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.tables ui.gadgets.status-bar
   9 ui.gadgets.labeled ui.tools.common ui combinators ;
  10 IN: ui.tools.inspector
  11
  12 TUPLE: inspector-gadget < tool table ;
  13
  14 TUPLE: slot-description key key-string value value-string ;
  15
  16 : <slot-description> ( key value -- slot-description )
  17     [ dup unparse-short ] bi@ slot-description boa ;
  18
  19 SINGLETON: inspector-renderer
  20
  21 M: inspector-renderer row-columns
  22     drop [ key-string>> ] [ value-string>> ] bi 2array ;
  23
  24 M: inspector-renderer row-value
  25     drop value>> ;
  26
  27 M: inspector-renderer column-titles
  28     drop { "Key" "Value" } ;
  29
  30 : <summary-gadget> ( model -- gadget )
  31     [
  32         standard-table-style [
  33             {
  34                 [
  35                     [
  36                         [ "Class:" write ] with-cell
  37                         [ class-of pprint ] with-cell
  38                     ] with-row
  39                 ]
  40                 [
  41                     [
  42                         [ "Object:" write ] with-cell
  43                         [ pprint-short ] with-cell
  44                     ] with-row
  45                 ]
  46                 [
  47                     [
  48                         [ "Summary:" write ] with-cell
  49                         [ print-summary ] with-cell
  50                     ] with-row
  51                 ]
  52                 [
  53                     content-gadget [
  54                         [
  55                             [ "Content:" write ] with-cell
  56                             [ output-stream get write-gadget ] with-cell
  57                         ] with-row
  58                     ] when*
  59                 ]
  60             } cleave
  61         ] tabular-output
  62     ] <pane-control> ;
  63
  64 GENERIC: make-slot-descriptions ( obj -- seq )
  65
  66 M: object make-slot-descriptions
  67     make-mirror [ <slot-description> ] { } assoc>map ;
  68
  69 M: hashtable make-slot-descriptions
  70     call-next-method [ key-string>> ] sort-with ;
  71
  72 : <inspector-table> ( model -- table )
  73     [ make-slot-descriptions ] <arrow> inspector-renderer <table>
  74         [ invoke-primary-operation ] >>action
  75         monospace-font >>font
  76         COLOR: dark-gray >>column-line-color
  77         6 >>gap
  78         15 >>min-rows
  79         15 >>max-rows
  80         40 >>min-cols
  81         40 >>max-cols ;
  82
  83 : <inspector-gadget> ( model -- gadget )
  84     vertical inspector-gadget new-track
  85         { 3 3 } >>gap
  86         add-toolbar
  87         swap >>model
  88         dup model>> <inspector-table> >>table
  89         dup model>> <summary-gadget> "Object" <labeled-gadget> f track-add
  90         dup table>> <scroller> "Contents" <labeled-gadget> 1 track-add ;
  91
  92 M: inspector-gadget focusable-child*
  93     table>> ;
  94
  95 : com-refresh ( inspector -- )
  96     model>> notify-connections ;
  97
  98 : com-push ( inspector -- obj )
  99     control-value ;
 100
 101 \ com-push H{ { +listener+ t } } define-command
 102
 103 : slot-editor-window ( close-hook update-hook assoc key key-string -- )
 104     [ <value-ref> <slot-editor> ] [ "Slot editor: " prepend ] bi*
 105     open-status-window ;
 106
 107 : com-edit-slot ( inspector -- )
 108     [ close-window ] swap
 109     [ '[ _ com-refresh ] ]
 110     [ control-value make-mirror ]
 111     [ table>> (selected-row) ] tri [
 112         [ key>> ] [ key-string>> ] bi
 113         slot-editor-window
 114     ] [ 4drop ] if ;
 115
 116 : inspector-help ( -- ) "ui-inspector" com-browse ;
 117
 118 \ inspector-help H{ { +nullary+ t } } define-command
 119
 120 inspector-gadget "toolbar" f {
 121     { T{ update-object } com-refresh }
 122     { T{ key-down f f "p" } com-push }
 123     { T{ key-down f f "e" } com-edit-slot }
 124     { T{ key-down f f "F1" } inspector-help }
 125 } define-command-map
 126
 127 inspector-gadget "multi-touch" f {
 128     { up-action com-refresh }
 129 } define-command-map
 130
 131 : inspect-model ( model -- )
 132     <inspector-gadget> "Inspector" open-status-window ;
 133
 134 : inspector ( obj -- )
 135     <model> inspect-model ;
 136
 137 { 550 400 } inspector-gadget set-tool-dim