Add right-click menu to tables, row-value word

basis/ui/gadgets/tables/tables.factor

@@ -3,16 +3,18 @@
 USING: accessors arrays colors fry io.styles kernel math
 math.geometry.rect math.order math.vectors namespaces opengl
 sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
-ui.gadgets.worlds ui.gadgets.theme ui.gestures ui.render models
-math.ranges sequences combinators ;
+ui.gadgets.worlds ui.gadgets.theme ui.gestures ui.render
+ui.gadgets.menus models math.ranges sequences combinators ;
 IN: ui.gadgets.tables
 
 ! Row rendererer protocol
 GENERIC: row-columns ( row renderer -- columns )
+GENERIC: row-value ( row renderer -- object )
 
 SINGLETON: trivial-renderer
 
 M: trivial-renderer row-columns drop ;
+M: object row-value drop ;
 
 TUPLE: table < gadget
 renderer filled-column column-alignment action
@@ -172,10 +174,11 @@ M: table pref-dim*
     over [ control-value nth ] [ 2drop f ] if ;
 
 : selected-row ( table -- value/f )
-    [ selected-index>> ] keep nth-row ;
+    [ selected-index>> ] keep [ nth-row ] keep
+    over [ renderer>> row-value ] [ drop ] if ;
 
 : update-selected-value ( table -- )
-    [ selected-row ] keep selected-value>> set-model ;
+    [ selected-row ] [ selected-value>> ] bi set-model ;
 
 M: table model-changed
     nip
@@ -228,21 +231,37 @@ M: table model-changed
 : hide-mouse-help ( table -- )
     f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
 
+: valid-row? ( row table -- ? )
+    control-value length 1- 0 swap between? ;
+
+: show-row-summary ( row table -- )
+    [ renderer>> row-value ] keep show-summary ;
+
+: if-mouse-row ( table true false -- )
+    [ [ mouse-row ] keep 2dup valid-row? ]
+    [ ] [ '[ nip @ ] ] tri* if ; inline
+
 : show-mouse-help ( table -- )
-    [ mouse-row ] keep
-    2dup control-value length 1- 0 swap between? [
+    [
         [ swap >>mouse-index relayout-1 ]
         [
             [ nth-row ] keep
-            over [ show-summary ] [ 2drop ] if
+            over [ show-row-summary ] [ 2drop ] if
         ] 2bi
-    ] [ nip hide-mouse-help ] if ;
+    ] [ hide-mouse-help ] if-mouse-row ;
+
+: table-operations-menu ( table -- )
+    [
+        [ nth-row ] keep [ renderer>> row-value ] keep
+        swap show-operations-menu
+    ] [ drop ] if-mouse-row ;
 
 table H{
     { T{ mouse-enter } [ show-mouse-help ] }
     { T{ mouse-leave } [ hide-mouse-help ] }
     { T{ motion } [ show-mouse-help ] }
     { T{ button-down } [ table-button-down ] }
+    { T{ button-down f f 3 } [ table-operations-menu ] }
     { T{ button-up } [ table-button-up ] }
     { T{ gain-focus } [ t >>focused? drop ] }
     { T{ lose-focus } [ f >>focused? drop ] }

basis/ui/tools/inspector/inspector.factor

@@ -21,6 +21,9 @@ SINGLETON: inspector-renderer
 M: inspector-renderer row-columns
     drop [ key-string>> ] [ value-string>> ] bi 2array ;
 
+M: inspector-renderer row-value
+    drop value>> ;
+
 : <summary-gadget> ( model -- gadget )
     [
         standard-table-style [
@@ -52,7 +55,7 @@ DEFER: inspector
 
 : <inspector-table> ( model -- table )
     [ make-slot-descriptions ] <filter> <table>
-        [ value>> inspector ] >>action
+        [ inspector ] >>action
         inspector-renderer >>renderer
         monospace-font >>font ;
 
@@ -88,5 +91,9 @@ inspector-gadget "toolbar" f {
     { T{ key-down f f "F1" } inspector-help }
 } define-command-map
 
+inspector-gadget "multi-touch" f {
+    { T{ up-action } com-refresh }
+} define-command-map
+
 : inspector ( obj -- )
     <inspector-gadget> "Inspector" open-status-window ;

basis/ui/tools/profiler/profiler.factor

@@ -1,13 +1,14 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: ui.tools.browser kernel quotations accessors fry
+USING: kernel quotations accessors fry
 assocs present math.order math.vectors arrays locals
 models.search models.sort models sequences vocabs
-tools.profiler ui ui.commands ui.gadgets ui.gadgets.panes
-ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
+tools.profiler words prettyprint ui ui.commands ui.gadgets
+ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
 ui.gadgets.buttons ui.gadgets.tables ui.gadgets.search-tables
 ui.gadgets.labelled ui.gadgets.buttons ui.gadgets.packs
-ui.gadgets.labels ui.gadgets.tabbed words prettyprint ;
+ui.gadgets.labels ui.gadgets.tabbed ui.gadgets.status-bar
+ui.tools.browser ;
 FROM: models.filter => <filter> ;
 FROM: models.compose => <compose> ;
 IN: ui.tools.profiler
@@ -25,19 +26,23 @@ SINGLETON: word-renderer
 M: word-renderer row-columns
     drop [ [ present ] map ] [ { "All" "" } ] if* ;
 
+M: word-renderer row-value drop first ;
+
 SINGLETON: method-renderer
 
 ! Value is a { method-body count } pair
 M: method-renderer row-columns
     drop [ first synopsis ] [ second present ] bi 2array ;
 
+M: method-renderer row-value drop first ;
+
 : <profiler-model> ( values profiler -- model )
     [ [ filter-counts ] <filter> ] [ sort>> ] bi* <sort> ;
 
 : <words-model> ( profiler -- model )
     [
         [ words>> ] [ vocab>> ] bi
-        [ [ [ first vocabulary>> ] [ first ] bi* = ] when* ] <search>
+        [ [ [ first vocabulary>> ] dip = ] when* ] <search>
     ] keep <profiler-model> ;
 
 : match? ( pair/f str -- ? )
@@ -62,7 +67,7 @@ M: method-renderer row-columns
     [ class-counters ] dip <profiler-filter-model> ;
 
 : method-matches? ( method generic class -- ? )
-    [ dup [ first ] when ] tri@
+    [ first ] 2dip
     [ drop dup [ subwords memq? ] [ 2drop t ] if ]
     [ nip dup [ swap "method-class" word-prop = ] [ 2drop t ] if ]
     3bi and ;
@@ -145,6 +150,6 @@ profiler-gadget "toolbar" f {
 } define-command-map
 
 : profiler-window ( -- )
-    <profiler-gadget> "Profiling results" open-window ;
+    <profiler-gadget> "Profiling results" open-status-window ;
 
 MAIN: profiler-window