From 9c51eaa4514ad3cffa08c15efe9a78c8c5fa0850 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 14 Feb 2009 00:45:10 -0600
Subject: [PATCH] New look for labeled gadgets
---
basis/ui/gadgets/labelled/labelled.factor | 64 ++++++++++++++-----
basis/ui/tools/debugger/debugger.factor | 18 +++---
.../listener/completion/completion.factor | 14 ++--
basis/ui/tools/listener/listener.factor | 2 -
basis/ui/tools/traceback/traceback.factor | 26 +++++---
5 files changed, 82 insertions(+), 42 deletions(-)
diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor
index dea3ec0ec0..8b17ec8c0c 100644
--- a/basis/ui/gadgets/labelled/labelled.factor
+++ b/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
-ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.tracks ui.gadgets.theme io kernel math models namespaces
-sequences sequences words classes.tuple ui.gadgets ui.render
-colors colors.constants accessors ;
+USING: accessors kernel sequences colors fonts ui.gadgets
+ui.gadgets.frames ui.gadgets.grids ui.gadgets.icons ui.gadgets.labels
+ui.gadgets.theme ui.gadgets.borders ui.pens.image ;
IN: ui.gadgets.labelled
-TUPLE: labelled-gadget < track content ;
+TUPLE: labelled-gadget < frame content ;
-: <labelled-gadget> ( gadget title -- newgadget )
- vertical labelled-gadget new-track
- swap <label> reverse-video-theme f track-add
- swap >>content
- dup content>> 1 track-add ;
+<PRIVATE
+
+: labelled-image ( name -- image )
+ "labeled-block-" prepend theme-image ;
+
+: 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 )
- [ <scroller> ] dip <labelled-gadget> ;
+PRIVATE>
-: <labelled-pane> ( model quot scrolls? title -- gadget )
- [ [ <pane-control> ] dip >>scrolls? ] dip
- <labelled-scroller> ;
+: <labelled-gadget> ( gadget title -- newgadget )
+ labelled-gadget new-frame
+ /-FOO-\
+ |-----|
+ \-----/ ;
diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor
index 581b7dabe2..65f6e3def2 100644
--- a/basis/ui/tools/debugger/debugger.factor
+++ b/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
-prettyprint help editors fonts ui ui.commands ui.gestures ui.gadgets
-ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
-ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
-ui.gadgets.viewports ui.gadgets.tables ui.gadgets.tracks
-ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.borders
-ui.gadgets.status-bar ui.tools.traceback ui.tools.inspector ;
+colors.constants namespaces sequences sequences words continuations
+debugger prettyprint help editors fonts ui ui.commands ui.gestures
+ui.gadgets ui.pens.solid ui.gadgets.worlds ui.gadgets.packs
+ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes
+ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables
+ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
+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 ;
diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor
index e6f27cb764..aaed8d17a5 100644
--- a/basis/ui/tools/listener/completion/completion.factor
+++ b/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: vocab-completion completion-banner drop "Vocabularies:" ;
-M: char-completion completion-banner drop "Unicode code point names:" ;
-M: history-completion completion-banner drop "Input history:" ;
+M: word-completion completion-banner drop "Words" ;
+M: vocab-completion completion-banner drop "Vocabularies" ;
+M: char-completion completion-banner drop "Unicode code point names" ;
+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
- COLOR: white <solid> >>interior ;
+ <labelled-gadget> 1 track-add ;
completion-popup H{
{ T{ key-down f f "TAB" } [ table>> row-action ] }
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 8a8581b3b3..4c09baa997 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/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 -- )
diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor
index 965461bf06..34ccfcc762 100644
--- a/basis/ui/tools/traceback/traceback.factor
+++ b/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
- [ <datastack-display> 1/2 track-add ]
- [ <retainstack-display> 1/2 track-add ] bi
- 1/3 track-add
- ]
- [ <callstack-display> 2/3 track-add ] tri
+ [ vertical <track> { 3 3 } >>gap ] dip
+ [
+ [ horizontal <track> { 3 3 } >>gap ] dip
+ [ <datastack-display> 1/2 track-add ]
+ [ <retainstack-display> 1/2 track-add ] bi
+ 1/3 track-add
+ ]
+ [ <callstack-display> 2/3 track-add ] bi
+ { 3 3 } <filled-border> 1 track-add
+ ] bi
add-toolbar ;
: variables ( traceback -- )