New look for labeled gadgets

basis/ui/gadgets/labelled/labelled.factor

@@ -1,25 +1,57 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gadgets.buttons ui.gadgets.borders
+USING: accessors kernel sequences colors fonts ui.gadgets
-ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.frames ui.gadgets.grids ui.gadgets.icons ui.gadgets.labels
-ui.gadgets.tracks ui.gadgets.theme io kernel math models namespaces
+ui.gadgets.theme ui.gadgets.borders ui.pens.image ;
-sequences sequences words classes.tuple ui.gadgets ui.render
-colors colors.constants accessors ;
 IN: ui.gadgets.labelled
 
-TUPLE: labelled-gadget < track content ;
+TUPLE: labelled-gadget < frame content ;
 
-: <labelled-gadget> ( gadget title -- newgadget )
+<PRIVATE
-    vertical labelled-gadget new-track
+
-        swap <label> reverse-video-theme f track-add
+: labelled-image ( name -- image )
-        swap >>content
+    "labeled-block-" prepend theme-image ;
-        dup content>> 1 track-add ;
+
+: labelled-icon ( name -- icon )
+    labelled-image <icon> dup interior>> t >>fill? drop ;
+
+
+CONSTANT: labelled-title-background
+    T{ rgba f
+        0.7843137254901961
+        0.7686274509803922
+        0.7176470588235294
+        1.0
+    }
+
+: <labelled-title> ( gadget -- label )
+    >label
+    [ labelled-title-background font-with-background ] change-font
+    { 0 2 } <border>
+    "title-middle" labelled-image
+    <image-pen> t >>fill? >>interior ;
+
+: /-FOO-\ ( title labelled -- labelled )
+    "title-left" labelled-icon @top-left grid-add
+    swap <labelled-title> @top grid-add
+    "title-right" labelled-icon @top-right grid-add ;
+
+: |-----| ( gadget labelled -- labelled )
+    "left-edge" labelled-icon @left grid-add
+    swap [ >>content ] [ @center grid-add ] bi
+    "right-edge" labelled-icon @right grid-add ;
+
+: \-----/ ( labelled -- labelled )
+    "bottom-left" labelled-icon @bottom-left grid-add
+    "bottom-middle" labelled-icon @bottom grid-add
+    "bottom-right" labelled-icon @bottom-right grid-add ;
 
 M: labelled-gadget focusable-child* content>> ;
 
-: <labelled-scroller> ( gadget title -- gadget )
+PRIVATE>
-    [ <scroller> ] dip <labelled-gadget> ;
 
-: <labelled-pane> ( model quot scrolls? title -- gadget )
+: <labelled-gadget> ( gadget title -- newgadget )
-    [ [ <pane-control> ] dip >>scrolls? ] dip
+    labelled-gadget new-frame
-    <labelled-scroller> ;
+        /-FOO-\
+        |-----|
+        \-----/ ;

basis/ui/tools/debugger/debugger.factor

@@ -1,13 +1,14 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays hashtables io kernel math models
-namespaces sequences sequences words continuations debugger
+colors.constants namespaces sequences sequences words continuations
-prettyprint help editors fonts ui ui.commands ui.gestures ui.gadgets
+debugger prettyprint help editors fonts ui ui.commands ui.gestures
-ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
+ui.gadgets ui.pens.solid ui.gadgets.worlds ui.gadgets.packs
-ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
+ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes
-ui.gadgets.viewports ui.gadgets.tables ui.gadgets.tracks
+ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables
-ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.borders
+ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
-ui.gadgets.status-bar ui.tools.traceback ui.tools.inspector ;
+ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
+ui.tools.inspector ;
 IN: ui.tools.debugger
 
 TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
@@ -51,7 +52,8 @@ PRIVATE>
         swap >>error
         add-toolbar
         dup <restart-list> >>restart-list
-        dup <error-display> f track-add ;
+        dup <error-display> f track-add
+        COLOR: white <solid> >>interior ;
 
 M: debugger focusable-child*
     dup restart-hook>> [ restart-list>> ] [ drop t ] if ;

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

@@ -45,10 +45,10 @@ M: history-completion completion-element drop one-line-elt ;
 
 GENERIC: completion-banner ( completion-mode -- string )
 
-M: word-completion completion-banner drop "Words:" ;
+M: word-completion completion-banner drop "Words" ;
-M: vocab-completion completion-banner drop "Vocabularies:" ;
+M: vocab-completion completion-banner drop "Vocabularies" ;
-M: char-completion completion-banner drop "Unicode code point names:" ;
+M: char-completion completion-banner drop "Unicode code point names" ;
-M: history-completion completion-banner drop "Input history:" ;
+M: history-completion completion-banner drop "Input history" ;
 
 GENERIC: completion-popup-width ( interactor completion-mode -- x )
 
@@ -152,14 +152,14 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
 : <completion-scroller> ( completion-popup -- scroller )
     [ table>> ] [ interactor>> ] [ completion-mode>> ] tri completion-popup-width
     [ <limited-scroller> ] [ 120 2array ] bi*
-    [ >>min-dim ] [ >>max-dim ] bi ;
+    [ >>min-dim ] [ >>max-dim ] bi
+    COLOR: white <solid> >>interior ;
 
 : <completion-popup> ( interactor completion-mode -- popup )
     [ vertical completion-popup new-track ] 2dip
     [ [ >>interactor ] [ >>completion-mode ] bi* ] [ <completion-table> >>table ] 2bi
     dup [ <completion-scroller> ] [ completion-mode>> completion-banner ] bi
-    <labelled-gadget> 1 track-add
+    <labelled-gadget> 1 track-add ;
-    COLOR: white <solid> >>interior ;
 
 completion-popup H{
     { T{ key-down f f "TAB" } [ table>> row-action ] }

basis/ui/tools/listener/listener.factor

@@ -294,8 +294,6 @@ M: object accept-completion-hook 2drop ;
 :: <debugger-popup> ( interactor error continuation -- popup )
     error continuation error compute-restarts
     [ interactor hide-popup ] <debugger>
-    COLOR: white <solid> >>interior
-    COLOR: black <solid> >>boundary
     "Error" <labelled-gadget> ;
 
 : debugger-popup ( interactor error continuation -- )

basis/ui/tools/traceback/traceback.factor

@@ -3,7 +3,7 @@
 USING: accessors continuations kernel models namespaces arrays
 fry prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
 ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
-ui.gadgets.status-bar ui.gadgets.scrollers
+ui.gadgets.status-bar ui.gadgets.scrollers ui.gadgets.borders
 ui.gadgets.tables ui.gestures sequences inspector
 models.filter fonts ;
 QUALIFIED-WITH: ui.tools.inspector i
@@ -33,7 +33,8 @@ M: stack-entry-renderer row-value drop object>> ;
 
 : <callstack-display> ( model -- gadget )
     [ [ call>> callstack. ] when* ]
-    t "Call stack" <labelled-pane> ;
+    <pane-control> t >>scrolls? <scroller>
+    "Call stack" <labelled-gadget> ;
 
 : <datastack-display> ( model -- gadget )
     [ data>> ] "Data stack" <stack-display> ;
@@ -46,15 +47,22 @@ TUPLE: traceback-gadget < track ;
 M: traceback-gadget pref-dim* drop { 550 600 } ;
 
 : <traceback-gadget> ( model -- gadget )
-    [ vertical traceback-gadget new-track ] dip
+    [
+        vertical traceback-gadget new-track
+        { 3 3 } >>gap
+    ] dip
     [ >>model ]
     [
-        [ horizontal <track> ] dip
+        [ vertical <track> { 3 3 } >>gap ] dip
-        [ <datastack-display> 1/2 track-add ]
+        [
-        [ <retainstack-display> 1/2 track-add ] bi
+            [ horizontal <track> { 3 3 } >>gap ] dip
-        1/3 track-add
+            [ <datastack-display> 1/2 track-add ]
-    ]
+            [ <retainstack-display> 1/2 track-add ] bi
-    [ <callstack-display> 2/3 track-add ] tri
+            1/3 track-add
+        ]
+        [ <callstack-display> 2/3 track-add ] bi
+        { 3 3 } <filled-border> 1 track-add
+    ] bi
     add-toolbar ;
 
 : variables ( traceback -- )