ui.gadgets.tables: add support for column headers

ui.gadgets.search-tables: use Joe's X icon

basis/ui/gadgets/line-support/line-support.factor

@@ -65,14 +65,16 @@ GENERIC: draw-line ( line index gadget -- )
     [ -1/0. or * ] [ 1/.0 or * ] bi-curry* bi
     [ max ] [ min ] bi* ;
 
+: em ( font -- x ) "m" text-width ;
+
+PRIVATE>
+
 : line-gadget-width ( pref-dim gadget -- w )
-    [ first ] [ [ font>> "m" text-width ] [ min-cols>> ] [ max-cols>> ] tri ] bi* clamp ;
+    [ first ] [ [ font>> em ] [ min-cols>> ] [ max-cols>> ] tri ] bi* clamp ;
 
 : line-gadget-height ( pref-dim gadget -- h )
     [ second ] [ [ line-height ] [ min-rows>> ] [ max-rows>> ] tri ] bi* clamp ;
 
-PRIVATE>
-
 M: line-gadget pref-viewport-dim
     [ pref-dim ] keep
     [ line-gadget-width ]

basis/ui/gadgets/search-tables/search-tables.factor

@@ -1,10 +1,9 @@
 ! Copyright (C) 2008, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel delegate fry sequences
+USING: accessors kernel delegate fry sequences models models.search
-models models.search models.delay calendar locals
+models.delay calendar locals ui.pens ui.pens.image ui.gadgets.editors
-ui.gadgets.editors ui.gadgets.labels ui.gadgets.scrollers
+ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.tables
-ui.gadgets.tables ui.gadgets.tracks ui.gadgets.borders
+ui.gadgets.tracks ui.gadgets.borders ui.gadgets.buttons ui.gadgets ;
-ui.gadgets.buttons ui.gadgets ;
 IN: ui.gadgets.search-tables
 
 TUPLE: search-field < track field ;
@@ -12,14 +11,20 @@ TUPLE: search-field < track field ;
 : clear-search-field ( search-field -- )
     field>> editor>> clear-editor ;
 
+: <clear-button-pen> ( -- pen )
+    "clear-button" theme-image <image-pen> dup
+    "clear-button-clicked" theme-image <image-pen> dup dup <button-pen> ;
+
 : <clear-button> ( search-field -- button )
-    "X" swap '[ drop _ clear-search-field ] <roll-button> ;
+    [ f ] dip '[ drop _ clear-search-field ] <button>
+    <clear-button-pen> >>interior
+    dup dup interior>> pen-pref-dim >>min-dim ;
 
 : <search-field> ( model -- gadget )
     horizontal search-field new-track
         { 5 5 } >>gap
         +baseline+ >>align
-        swap <model-field> 10 >>min-width >>field
+        swap <model-field> 10 >>min-cols >>field
         dup field>> "Search:" label-on-left 1 track-add
         dup <clear-button> f track-add ;
 
@@ -28,27 +33,32 @@ TUPLE: search-table < track table field ;
 ! A protocol with customizable slots
 SLOT-PROTOCOL: table-protocol
 renderer
-filled-column
-column-alignment
 action
 hook
 font
+gap
 selection-color
 focus-border-color
 mouse-color
 column-line-color
 selection-required?
-selected-value ;
+single-click?
+selected-value
+min-rows
+min-cols
+max-rows
+max-cols ;
 
 CONSULT: table-protocol search-table table>> ;
 
-:: <search-table> ( values quot -- gadget )
+:: <search-table> ( values renderer quot -- gadget )
     f <model> :> search
     vertical search-table new-track
         values >>model
         search <search-field> >>field
         dup field>> { 2 2 } <filled-border> f track-add
-        values search 500 milliseconds <delay> quot <search> <table> >>table
+        values search 500 milliseconds <delay> quot <search>
+        renderer <table> >>table
         dup table>> <scroller> 1 track-add ;
 
 M: search-table model-changed

basis/ui/gadgets/tables/tables-tests.factor

@@ -0,0 +1,22 @@
+IN: ui.gadgets.tables.tests
+USING: ui.gadgets.tables ui.gadgets.scrollers accessors
+models namespaces tools.test kernel ;
+
+SINGLETON: test-renderer
+
+M: test-renderer row-columns drop ;
+
+M: test-renderer column-titles drop { "First" "Last" } ;
+
+[ ] [
+    {
+        { "Britney" "Spears" }
+        { "Justin" "Timberlake" }
+        { "Don" "Stewart" }
+    } <model> test-renderer <table>
+    "table" set
+] unit-test
+
+[ ] [
+    "table" get <scroller> "scroller" set
+] unit-test

basis/ui/gadgets/tables/tables.factor

@@ -3,27 +3,34 @@
 USING: accessors arrays colors colors.constants fry kernel math
 math.rectangles math.order math.vectors namespaces opengl sequences
 ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
-ui.gadgets.worlds ui.gestures ui.render ui.text ui.commands
+ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text ui.commands
 ui.images ui.gadgets.menus ui.gadgets.line-support math.rectangles
 models math.ranges sequences combinators fonts locals strings ;
 IN: ui.gadgets.tables
 
 ! Row rendererer protocol
 GENERIC: prototype-row ( renderer -- columns )
+GENERIC: column-alignment ( renderer -- alignment )
+GENERIC: filled-column ( renderer -- n )
+GENERIC: column-titles ( renderer -- strings )
+
 GENERIC: row-columns ( row renderer -- columns )
 GENERIC: row-value ( row renderer -- object )
 GENERIC: row-color ( row renderer -- color )
 
 SINGLETON: trivial-renderer
 
-M: trivial-renderer row-columns drop ;
 M: object prototype-row drop { "" } ;
+M: object column-alignment drop f ;
+M: object filled-column drop f ;
+M: object column-titles drop f ;
+
+M: trivial-renderer row-columns drop ;
 M: object row-value drop ;
 M: object row-color 2drop f ;
 
 TUPLE: table < line-gadget
 { renderer initial: trivial-renderer }
-filled-column column-alignment
 { action initial: [ drop ] }
 single-click?
 { hook initial: [ ] }
@@ -37,8 +44,9 @@ selected-index selected-value
 mouse-index
 focused? ;
 
-: <table> ( rows -- table )
+: <table> ( rows renderer -- table )
     table new-line-gadget
+        swap >>renderer
         swap >>model
         f <model> >>selected-value
         sans-serif-font >>font
@@ -64,22 +72,30 @@ M: image-name draw-cell nip draw-image ;
 : column-offsets ( widths gap -- x xs )
     [ 0 ] dip '[ _ + + ] accumulate ;
 
-: initial-widths ( rows -- widths )
+CONSTANT: column-title-background COLOR: light-gray
-    first length 0 <repetition> ;
 
-: row-column-widths ( font row -- widths )
+: column-title-font ( font -- font' )
-    [ cell-width ] with map ;
+    column-title-background font-with-background t >>bold? ;
 
-: (compute-column-widths) ( gap font rows -- total widths )
+: initial-widths ( table rows -- widths )
-    [ 2drop 0 { } ] [
+    over renderer>> column-titles dup
-        [ nip initial-widths ] 2keep
+    [ [ drop font>> ] dip [ text-width ] with map ]
+    [ drop nip first length 0 <repetition> ]
+    if ;
+
+: row-column-widths ( table row -- widths )
+    [ font>> ] dip [ cell-width ] with map ;
+
+: compute-total-width ( gap widths -- total )
+    swap [ column-offsets drop ] keep - ;
+
+: compute-column-widths ( table -- total widths )
+    dup table-rows [ drop 0 { } ] [
+        [ drop gap>> ] [ initial-widths ] [ ] 2tri
         [ row-column-widths vmax ] with each
-        [ swap [ column-offsets drop ] keep - ] keep
+        [ compute-total-width ] keep
     ] if-empty ;
 
-: compute-column-widths ( table -- total-width column-widths )
-    [ gap>> ] [ font>> ] [ table-rows ] tri (compute-column-widths) ;
-
 : update-cached-widths ( table -- )
     dup compute-column-widths
     [ >>total-width ] [ >>column-widths ] bi*
@@ -90,7 +106,7 @@ M: image-name draw-cell nip draw-image ;
 
 : update-filled-column ( table -- )
     [ filled-column-width ]
-    [ filled-column>> ]
+    [ renderer>> filled-column ]
     [ column-widths>> ] tri
     2dup empty? not and
     [ [ + ] change-nth ] [ 3drop ] if ;
@@ -158,8 +174,8 @@ M: table layout*
         ] dip
     ] dip translate-column ;
 
-: column-alignment ( table -- seq )
+: table-column-alignment ( table -- seq )
-    dup column-alignment>>
+    dup renderer>> column-alignment
     [ ] [ column-widths>> length 0 <repetition> ] ?if ;
 
 :: row-font ( row index table -- font )
@@ -167,17 +183,20 @@ M: table layout*
     row table renderer>> row-color [ >>foreground ] when*
     index table selected-index>> = [ table selection-color>> >>background ] when ;
 
+: draw-columns ( columns widths alignment font gap -- )
+    '[ [ _ ] 3dip _ draw-column ] 3each ;
+
 M: table draw-line ( row index table -- )
     [
         nip
         [ renderer>> row-columns ]
         [ column-widths>> ]
-        [ column-alignment ]
+        [ table-column-alignment ]
         tri
     ]
     [ row-font ]
     [ 2nip gap>> ] 3tri
-    '[ [ _ ] 3dip _ draw-column ] 3each ;
+    draw-columns ;
 
 M: table draw-gadget*
     dup control-value empty? [ drop ] [
@@ -346,4 +365,31 @@ table "row" f {
     { T{ key-down f f "PAGE_DOWN" } next-page }
 } define-command-map
 
+TUPLE: column-headers < gadget table ;
+
+: <column-headers> ( table -- gadget )
+    column-headers new
+        swap >>table
+        column-title-background <solid> >>interior ;
+
+: draw-column-titles ( table -- )
+    {
+        [ renderer>> column-titles ]
+        [ column-widths>> ]
+        [ table-column-alignment ]
+        [ font>> column-title-font ]
+        [ gap>> ]
+    } cleave
+    draw-columns ;
+
+M: column-headers draw-gadget*
+    table>> draw-column-titles ;
+
+M: column-headers pref-dim*
+    table>> [ pref-dim first ] [ font>> "" text-height ] bi 2array ;
+
+M: table viewport-column-header
+    dup renderer>> column-titles
+    [ <column-headers> ] [ drop f ] if ;
+
 PRIVATE>

basis/ui/tools/debugger/debugger.factor

@@ -21,10 +21,9 @@ M: restart-renderer row-columns
     drop [ name>> ] [ "Abort" ] if* "• " prepend 1array ;
 
 : <restart-list> ( debugger -- gadget )
-    dup restarts>> f prefix <model> <table>
+    dup restarts>> f prefix <model> restart-renderer <table>
         [ [ \ restart invoke-command ] when* ] >>action
         swap restart-hook>> >>hook
-        restart-renderer >>renderer
         t >>selection-required?
         t >>single-click? ; inline
 

basis/ui/tools/inspector/inspector.factor

@@ -27,6 +27,9 @@ M: inspector-renderer row-columns
 M: inspector-renderer row-value
     drop value>> ;
 
+M: inspector-renderer column-titles
+    drop { "Key" "Value" } ;
+
 : <summary-gadget> ( model -- gadget )
     [
         standard-table-style [
@@ -60,13 +63,13 @@ M: hashtable make-slot-descriptions
     call-next-method [ [ key-string>> ] compare ] sort ;
 
 : <inspector-table> ( model -- table )
-    [ make-slot-descriptions ] <filter> <table>
+    [ make-slot-descriptions ] <filter> inspector-renderer <table>
         [ dup primary-operation invoke-command ] >>action
-        inspector-renderer >>renderer
         monospace-font >>font ;
 
 : <inspector-gadget> ( model -- gadget )
     vertical inspector-gadget new-track
+        { 3 3 } >>gap
         add-toolbar
         swap >>model
         dup model>> <inspector-table> >>table

basis/ui/tools/listener/completion/completion.factor

@@ -136,8 +136,7 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
 
 : <completion-table> ( interactor completion-mode -- table )
     [ completion-element ] [ completion-quot ] [ nip ] 2tri
-    [ <completion-model> <table> ] dip
+    [ <completion-model> ] dip <table>
-        >>renderer
         monospace-font >>font
         t >>selection-required?
         t >>single-click?

basis/ui/tools/profiler/profiler.factor

@@ -35,14 +35,25 @@ M: profiler-renderer row-value
 M: vocab-renderer row-value
     call-next-method dup [ vocab ] when ;
 
+M: profiler-renderer column-alignment drop { 0 1 } ;
+M: profiler-renderer filled-column drop 0 ;
+
+M: word-renderer column-titles drop { "Word" "Count" } ;
+M: vocab-renderer column-titles drop { "Vocabulary" "Count" } ;
+
 SINGLETON: method-renderer
 
+M: method-renderer column-alignment drop { 0 1 } ;
+M: method-renderer filled-column drop 0 ;
+
 ! 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 ;
 
+M: method-renderer column-titles drop { "Method" "Count" } ;
+
 : <profiler-model> ( values profiler -- model )
     [ [ filter-counts ] <filter> ] [ sort>> ] bi* <sort> ;
 
@@ -61,10 +72,8 @@ M: method-renderer row-value drop first ;
 : match? ( pair/f str -- ? )
     swap dup [ first present subseq? ] [ 2drop t ] if ;
 
-: <profiler-table> ( model -- table )
+: <profiler-table> ( model renderer -- table )
-    [ match? ] <search-table>
+    [ match? ] <search-table> ;
-        { 0 1 } >>column-alignment
-        0 >>filled-column ;
 
 : <profiler-filter-model> ( counts profiler -- model' )
     [ <model> ] dip <profiler-model> [ f prefix ] <filter> ;
@@ -115,13 +124,11 @@ M: method-renderer row-value drop first ;
 :: <words-tab> ( profiler -- gadget )
     horizontal <track>
         { 3 3 } >>gap
-        profiler vocabs>> <profiler-table>
+        profiler vocabs>> vocab-renderer <profiler-table>
             profiler vocab>> >>selected-value
-            vocab-renderer >>renderer
         "Vocabularies" <labeled-gadget>
     1/2 track-add
-        profiler <words-model> <profiler-table>
+        profiler <words-model> word-renderer <profiler-table>
-            word-renderer >>renderer
         "Words" <labeled-gadget>
     1/2 track-add ;
 
@@ -130,19 +137,16 @@ M: method-renderer row-value drop first ;
         { 3 3 } >>gap
         horizontal <track>
             { 3 3 } >>gap
-            profiler <generic-model> <profiler-table>
+            profiler <generic-model> word-renderer <profiler-table>
                 profiler generic>> >>selected-value
-                word-renderer >>renderer
             "Generic words" <labeled-gadget>
         1/2 track-add
-            profiler <class-model> <profiler-table>
+            profiler <class-model> word-renderer <profiler-table>
                 profiler class>> >>selected-value
-                word-renderer >>renderer
             "Classes" <labeled-gadget>
         1/2 track-add
     1/2 track-add
-        profiler methods>> <profiler-table>
+        profiler methods>> method-renderer <profiler-table>
-            method-renderer >>renderer
         "Methods" <labeled-gadget>
     1/2 track-add ;
 

basis/ui/tools/traceback/traceback.factor

@@ -21,10 +21,9 @@ M: stack-entry-renderer row-columns drop string>> 1array ;
 M: stack-entry-renderer row-value drop object>> ;
 
 : <stack-table> ( model -- table )
-    [ [ <stack-entry> ] map ] <filter> <table>
+    [ [ <stack-entry> ] map ] <filter> stack-entry-renderer <table>
         monospace-font >>font
         [ i:inspector ] >>action
-        stack-entry-renderer >>renderer
         t >>single-click? ;
 
 : <stack-display> ( model quot title -- gadget )