klazuka's Factor UI tweaks

gistfile1.diff

diff --git a/basis/fonts/fonts.factor b/basis/fonts/fonts.factor
index fb89bdb..5806bec 100644
--- a/basis/fonts/fonts.factor
+++ b/basis/fonts/fonts.factor
@@ -9,7 +9,8 @@ size
 bold?
 italic?
 { foreground initial: COLOR: black }
-{ background initial: COLOR: white } ;
+{ background initial: COLOR: white }
+shadow ;
 
 : <font> ( -- font )
     font new ; inline
@@ -37,6 +38,7 @@ italic?
             [ [ italic?>> ] either? >>italic? ]
             [ [ foreground>> ] either? >>foreground ]
             [ [ background>> ] either? >>background ]
+            [ [ shadow>> ] either? >>shadow ]
         } 2cleave
     ] when* ;
 
@@ -56,7 +58,7 @@ italic?
         12 >>size ;
 
 : strip-font-colors ( font -- font' )
-    clone f >>background f >>foreground ;
+    clone f >>background f >>foreground f >>shadow ;
 
 TUPLE: metrics width ascent descent height leading cap-height x-height ;
 
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index 2270088..6e75adc 100644
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -87,7 +87,7 @@ ALIAS: $slot $snippet
 
 : ($code) ( presentation quot -- )
     [
-        snippet-style get [
+        code-char-style get [
             last-element off
             [ ($code-style) ] dip with-nesting
         ] with-style
@@ -307,7 +307,7 @@ M: f ($instance)
 
 : ($see) ( word quot -- )
     [
-        snippet-style get [
+        code-char-style get [
             code-style get swap with-nesting
         ] with-style
     ] ($block) ; inline
diff --git a/basis/help/stylesheet/stylesheet.factor b/basis/help/stylesheet/stylesheet.factor
index c7811a6..c729bf6 100644
--- a/basis/help/stylesheet/stylesheet.factor
+++ b/basis/help/stylesheet/stylesheet.factor
@@ -33,12 +33,14 @@ H{
     { font-size 18 }
     { font-style bold }
     { wrap-margin 500 }
-    { page-color COLOR: light-gray }
+    { foreground T{ rgba f 0.216 0.243 0.282 1.0 } }
+    { shadow COLOR: white }
+    { page-color T{ rgba f 0.94 0.94 0.91 1.0 } }
     { border-width 5 }
 } title-style set-global
 
 SYMBOL: help-path-style
-H{ { font-size 10 } } help-path-style set-global
+H{ { font-size 10 } { shadow f } } help-path-style set-global
 
 SYMBOL: heading-style
 H{
@@ -58,12 +60,19 @@ SYMBOL: snippet-style
 H{
     { font-name "monospace" }
     { font-size 12 }
-    { foreground COLOR: navy-blue }
+    { foreground COLOR: DarkOrange4 }
 } snippet-style set-global
 
+SYMBOL: code-char-style
+H{
+    { font-name "monospace" }
+    { font-size 12 }
+    { foreground COLOR: black }
+} code-char-style set-global
+
 SYMBOL: code-style
 H{
-    { page-color COLOR: gray80 }
+    { page-color T{ rgba f 0.94 0.94 0.91 1.0 } }
     { border-width 5 }
     { wrap-margin f }
 } code-style set-global
@@ -101,7 +110,7 @@ H{
 SYMBOL: table-style
 H{
     { table-gap { 5 5 } }
-    { table-border COLOR: light-gray }
+    { table-border T{ rgba f 0.94 0.94 0.91 1.0 } }
 } table-style set-global
 
 SYMBOL: list-style
diff --git a/basis/io/styles/styles-docs.factor b/basis/io/styles/styles-docs.factor
index 8fcf12a..d5219b5 100755
--- a/basis/io/styles/styles-docs.factor
+++ b/basis/io/styles/styles-docs.factor
@@ -121,6 +121,7 @@ ARTICLE: "character-styles" "Character styles"
 "Character styles for " { $link stream-format } " and " { $link with-style } ":"
 { $subsection foreground }
 { $subsection background }
+{ $subsection shadow }
 { $subsection font-name }
 { $subsection font-size }
 { $subsection font-style }
@@ -205,6 +206,18 @@ HELP: background
     }
 } ;
 
+HELP: shadow
+{ $description "Character style. An instance of " { $link color } ". See " { $link "colors" } "." }
+{ $examples
+    { $code
+        "\"Hello world\\n\""
+        "H{ { background COLOR: gray }"
+        "   { shadow COLOR: white }"
+        "   { font-size 72 }"
+        "} format"
+    }
+} ;
+
 HELP: font-name
 { $description "Character style. Font family named by a string." }
 { $examples
diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor
index 2d25016..7dbb90f 100644
--- a/basis/io/styles/styles.factor
+++ b/basis/io/styles/styles.factor
@@ -116,6 +116,7 @@ SYMBOL: bold-italic
 ! Character styles
 SYMBOL: foreground
 SYMBOL: background
+SYMBOL: shadow
 SYMBOL: font-name
 SYMBOL: font-size
 SYMBOL: font-style
diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
index 76cf880..18a006e 100644
--- a/basis/prettyprint/backend/backend.factor
+++ b/basis/prettyprint/backend/backend.factor
@@ -1,11 +1,12 @@
 ! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays byte-vectors continuations
-generic hashtables assocs kernel math namespaces make sequences
-strings sbufs vectors words prettyprint.config prettyprint.custom
-prettyprint.sections quotations io io.pathnames io.styles math.parser
-effects classes.tuple math.order classes.tuple.private classes
-combinators colors ;
+USING: accessors arrays assocs byte-arrays byte-vectors classes
+classes.tuple classes.tuple.private colors colors.constants
+combinators continuations effects generic hashtables io
+io.pathnames io.styles kernel make math math.order math.parser
+namespaces prettyprint.config prettyprint.custom
+prettyprint.sections quotations sbufs sequences strings vectors
+words words.symbol ;
 IN: prettyprint.backend
 
 M: effect pprint* effect>string "(" ")" surround text ;
@@ -23,10 +24,10 @@ M: effect pprint* effect>string "(" ")" surround text ;
 : word-style ( word -- style )
     dup "word-style" word-prop >hashtable [
         [
-            [ presented set ]
-            [
-                [ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
-                [ bold font-style set ] when
+            [ presented set ] [
+                [ parsing-word? ] [ delimiter? ] [ symbol? ] tri
+                or or [ COLOR: DarkSlateGray ] [ COLOR: black ] if
+                foreground set
             ] bi
         ] bind
     ] keep ;
@@ -85,7 +86,7 @@ M: f pprint* drop \ f pprint-word ;
 : string-style ( obj -- hash )
     [
         presented set
-        T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
+        COLOR: LightSalmon4 foreground set
     ] H{ } make-assoc ;
 
 : unparse-string ( str prefix suffix -- str )
@@ -108,7 +109,8 @@ M: pathname pprint*
     nesting-limit get dup [ pprinter-stack get length < ] when ;
 
 : present-text ( str obj -- )
-    presented associate styled-text ;
+    presented associate H{ { foreground COLOR: cornsilk4 } }
+    assoc-union styled-text ;
 
 : check-recursion ( obj quot -- )
     nesting-limit? [
diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor
index a28a6ae..7f0d827 100644
--- a/basis/ui/gadgets/buttons/buttons-docs.factor
+++ b/basis/ui/gadgets/buttons/buttons-docs.factor
@@ -7,7 +7,9 @@ HELP: button
 $nl
 "A button's appearance can vary depending on the state of the mouse button if the " { $snippet "interior" } " or " { $snippet "boundary" } " slots are set to instances of " { $link button-pen } "."
 $nl
-"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by " { $link checkbox } " instances to render themselves when they're checked." } ;
+"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by " { $link checkbox } " instances to render themselves when they're checked."
+$nl
+"A button can optionally display a message in the window's status bar whenever the mouse cursor hovers over the button. To enable this behavior, just set a string to the button's " { $snippet "tooltip" } " slot." } ;
 
 HELP: <button>
 { $values { "label" gadget } { "quot" { $quotation "( button -- )" } } { "button" "a new " { $link button } } }
diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor
index ec11bac..8233419 100644
--- a/basis/ui/gadgets/buttons/buttons.factor
+++ b/basis/ui/gadgets/buttons/buttons.factor
@@ -10,7 +10,7 @@ combinators.smart ;
 FROM: models => change-model ;
 IN: ui.gadgets.buttons
 
-TUPLE: button < border pressed? selected? quot ;
+TUPLE: button < border pressed? selected? quot tooltip ;
 
 <PRIVATE
 
@@ -35,6 +35,12 @@ PRIVATE>
     >>pressed?
     relayout-1 ;
 
+: button-enter ( button -- )
+    dup dup tooltip>> [ swap show-status ] [ drop ] if* button-update ;
+
+: button-leave ( button -- )
+    dup "" swap show-status button-update ;
+
 : button-clicked ( button -- )
     dup button-update
     dup button-rollover?
@@ -43,8 +49,8 @@ PRIVATE>
 button H{
     { T{ button-up } [ button-clicked ] }
     { T{ button-down } [ button-update ] }
-    { mouse-leave [ button-update ] }
-    { mouse-enter [ button-update ] }
+    { mouse-leave [ button-leave ] }
+    { mouse-enter [ button-enter ] }
 } set-gestures
 
 : new-button ( label quot class -- button )
@@ -132,11 +138,15 @@ CONSTANT: button-clicked-background
     }
     
 : <border-button-pen> ( -- pen )
-    "button" button-background COLOR: black <border-button-state-pen> dup
+    "button" button-background T{ rgba f 0.216 0.243 0.282 1.0 } <border-button-state-pen> dup
     "button-clicked" button-clicked-background COLOR: white <border-button-state-pen> dup dup
     <button-pen> ;
 
+: border-button-label-theme ( label -- )
+    font>> COLOR: white >>shadow t >>bold? drop ;
+
 : border-button-theme ( gadget -- gadget )
+    dup children>> first border-button-label-theme
     horizontal >>orientation
     <border-button-pen> >>interior
     dup dup interior>> pen-pref-dim >>min-dim
@@ -235,9 +245,12 @@ PRIVATE>
 : command-button-quot ( target command -- quot )
     '[ _ _ invoke-command ] ;
 
+: gesture>tooltip ( gesture -- str )
+    [ gesture>string "Shortcut: " prepend ] [ "Shortcut Unassigned" ] if* ;
+
 : <command-button> ( target gesture command -- button )
-    [ command-string swap ] keep command-button-quot
-    '[ drop @ ] <border-button> ;
+    swapd [ command-name swap ] keep command-button-quot
+    '[ drop @ ] <border-button> swap gesture>tooltip >>tooltip ;
 
 : <toolbar> ( target -- toolbar )
     <shelf>
diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor
index eb992f1..8cba3c1 100644
--- a/basis/ui/gadgets/labels/labels.factor
+++ b/basis/ui/gadgets/labels/labels.factor
@@ -4,7 +4,7 @@ USING: accessors arrays hashtables io kernel math math.functions
 namespaces make opengl sequences strings splitting ui.gadgets
 ui.gadgets.tracks ui.gadgets.packs fonts ui.render ui.pens.solid
 ui.baseline-alignment ui.text colors colors.constants models
-combinators ;
+combinators opengl.gl ;
 IN: ui.gadgets.labels
 
 ! A label gadget draws a string.
@@ -65,13 +65,29 @@ M: label baseline
 M: label cap-height
     label-metrics cap-height>> round ;
 
+: draw-text* ( font text fg bg -- )
+    [ rot ] dip
+    [ font-with-background ] when* swap
+    [ font-with-foreground ] when* swap
+    draw-text ;
+
+: draw-text-above-shadow ( font text -- )
+    foreground get transparent draw-text* ;