Merge branch 'ui-tweaks' of git://github.com/klazuka/factor

basis/colors/constants/constants-docs.factor

@@ -23,7 +23,7 @@ HELP: COLOR:
 } ;
 
 ARTICLE: "colors.constants" "Standard color database"
-"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and provides words for looking up color values."
+"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and Factor's " { $snippet "factor-colors.txt" } " theme database to provide words for looking up color values by name."
 { $subsection named-color }
 { $subsection named-colors }
 { $subsection POSTPONE: COLOR: } ;

basis/colors/constants/constants.factor

@@ -19,7 +19,9 @@ IN: colors.constants
     [ parse-color ] H{ } map>assoc ;
 
 MEMO: rgb.txt ( -- assoc )
-    "resource:basis/colors/constants/rgb.txt" utf8 file-lines parse-rgb.txt ;
+    "resource:basis/colors/constants/rgb.txt"
+    "resource:basis/colors/constants/factor-colors.txt"
+    [ utf8 file-lines parse-rgb.txt ] bi@ assoc-union ;
 
 PRIVATE>
 

basis/colors/constants/factor-colors.txt

@@ -0,0 +1,5 @@
+! Factor UI theme colors
+227 226 219		FactorLightTan
+172 167 147		FactorDarkTan
+ 81  91 105		FactorLightSlateBlue
+ 55  62  72		FactorDarkSlateBlue

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

basis/help/stylesheet/stylesheet.factor

@@ -17,7 +17,7 @@ H{
 
 SYMBOL: link-style
 H{
-    { foreground COLOR: dark-blue }
+    { foreground COLOR: DodgerBlue4 }
     { font-style bold }
 } link-style set-global
 
@@ -33,7 +33,8 @@ H{
     { font-size 18 }
     { font-style bold }
     { wrap-margin 500 }
-    { page-color COLOR: light-gray }
+    { foreground COLOR: FactorDarkSlateBlue }
+    { page-color COLOR: FactorLightTan }
     { border-width 5 }
 } title-style set-global
 
@@ -58,12 +59,18 @@ 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 }
+} code-char-style set-global
+
 SYMBOL: code-style
 H{
-    { page-color COLOR: gray80 }
+    { page-color COLOR: FactorLightTan }
     { border-width 5 }
     { wrap-margin f }
 } code-style set-global
@@ -74,7 +81,7 @@ H{ { font-style bold } } input-style set-global
 SYMBOL: url-style
 H{
     { font-name "monospace" }
-    { foreground COLOR: blue }
+    { foreground COLOR: DodgerBlue4 }
 } url-style set-global
 
 SYMBOL: warning-style
@@ -101,7 +108,7 @@ H{
 SYMBOL: table-style
 H{
     { table-gap { 5 5 } }
-    { table-border COLOR: light-gray }
+    { table-border COLOR: FactorLightTan }
 } table-style set-global
 
 SYMBOL: list-style

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
+USING: accessors arrays assocs byte-arrays byte-vectors classes
-generic hashtables assocs kernel math namespaces make sequences
+classes.tuple classes.tuple.private colors colors.constants
-strings sbufs vectors words prettyprint.config prettyprint.custom
+combinators continuations effects generic hashtables io
-prettyprint.sections quotations io io.pathnames io.styles math.parser
+io.pathnames io.styles kernel make math math.order math.parser
-effects classes.tuple math.order classes.tuple.private classes
+namespaces prettyprint.config prettyprint.custom
-combinators colors ;
+prettyprint.sections prettyprint.stylesheet quotations sbufs
+sequences strings vectors words words.symbol ;
 IN: prettyprint.backend
 
 M: effect pprint* effect>string "(" ")" surround text ;
@@ -20,17 +21,6 @@ M: effect pprint* effect>string "(" ")" surround text ;
     ?effect-height 0 < [ end-group ] when ;
 
 ! Atoms
-: 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
-            ] bi
-        ] bind
-    ] keep ;
-
 : word-name* ( word -- str )
     name>> "( no name )" or ;
 
@@ -59,6 +49,9 @@ M: real pprint* number>string text ;
 
 M: f pprint* drop \ f pprint-word ;
 
+: pprint-effect ( effect -- )
+    [ effect>string ] [ effect-style ] bi styled-text ;
+
 ! Strings
 : ch>ascii-escape ( ch -- str )
     H{
@@ -82,12 +75,6 @@ M: f pprint* drop \ f pprint-word ;
         ] when
     ] when ;
 
-: string-style ( obj -- hash )
-    [
-        presented set
-        T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
-    ] H{ } make-assoc ;
-
 : unparse-string ( str prefix suffix -- str )
     [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
 

basis/prettyprint/stylesheet/stylesheet.factor

@@ -0,0 +1,34 @@
+! Copyright (C) 2009 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: colors.constants hashtables io.styles kernel namespaces
+words words.symbol ;
+IN: prettyprint.stylesheet
+
+: word-style ( word -- style )
+    dup "word-style" word-prop >hashtable [
+        [
+            [ presented set ] [
+                [ parsing-word? ] [ delimiter? ] [ symbol? ] tri
+                or or [ COLOR: DarkSlateGray ] [ COLOR: black ] if
+                foreground set
+            ] bi
+        ] bind
+    ] keep ;
+
+: string-style ( obj -- style )
+    [
+        presented set
+        COLOR: LightSalmon4 foreground set
+    ] H{ } make-assoc ;
+
+: vocab-style ( vocab -- style )
+    [
+        presented set
+        COLOR: cornsilk4 foreground set
+    ] H{ } make-assoc ;
+
+: effect-style ( effect -- style )
+    [
+        presented set
+        COLOR: DarkGreen foreground set
+    ] H{ } make-assoc ;

basis/see/see.factor

@@ -39,7 +39,7 @@ M: word print-stack-effect? drop t ;
 
 : stack-effect. ( word -- )
     [ print-stack-effect? ] [ stack-effect ] bi and
-    [ effect>string comment. ] when* ;
+    [ pprint-effect ] when* ;
 
 <PRIVATE
 

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 } } }

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-leave [ button-leave ] }
-    { mouse-enter [ button-update ] }
+    { mouse-enter [ button-enter ] }
 } set-gestures
 
 : new-button ( label quot class -- button )
@@ -113,30 +119,18 @@ PRIVATE>
         [ append theme-image ] tri-curry@ tri
     ] 2dip <tile-pen> ;
 
-CONSTANT: button-background
+CONSTANT: button-background COLOR: FactorLightTan
-    T{ rgba
+CONSTANT: button-clicked-background COLOR: FactorDarkSlateBlue
-         f
-         0.8901960784313725
-         0.8862745098039215
-         0.8588235294117647
-         1.0
-    }
 
-CONSTANT: button-clicked-background
-    T{ rgba
-         f
-         0.2156862745098039
-         0.2431372549019608
-         0.2823529411764706
-         1.0
-    }
-    
 : <border-button-pen> ( -- pen )
-    "button" button-background COLOR: black <border-button-state-pen> dup
+    "button" button-background button-clicked-background
-    "button-clicked" button-clicked-background COLOR: white <border-button-state-pen> dup dup
+    <border-button-state-pen> dup
+    "button-clicked" button-clicked-background COLOR: white
+    <border-button-state-pen> dup dup
     <button-pen> ;
 
 : border-button-theme ( gadget -- gadget )
+    dup children>> first font>> t >>bold? drop
     horizontal >>orientation
     <border-button-pen> >>interior
     dup dup interior>> pen-pref-dim >>min-dim
@@ -235,9 +229,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
+    swapd [ command-name swap ] keep command-button-quot
-    '[ drop @ ] <border-button> ;
+    '[ drop @ ] <border-button> swap gesture>tooltip >>tooltip ;
 
 : <toolbar> ( target -- toolbar )
     <shelf>

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.

basis/ui/gadgets/status-bar/status-bar.factor

@@ -1,13 +1,23 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors models models.delay models.arrow
+USING: accessors calendar colors colors.constants fonts kernel
-sequences ui.gadgets.labels ui.gadgets.tracks
+models models.arrow models.delay sequences summary ui
-ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ;
+ui.gadgets ui.gadgets.labels ui.gadgets.tracks
+ui.gadgets.worlds ui.pens.solid ui.private ;
 IN: ui.gadgets.status-bar
 
+: status-bar-font ( -- font )
+    sans-serif-font clone
+    COLOR: FactorDarkSlateBlue >>background
+    COLOR: white >>foreground ;
+
+: status-bar-theme ( label -- label )
+    status-bar-font >>font
+    COLOR: FactorDarkSlateBlue <solid> >>interior ;
+
 : <status-bar> ( model -- gadget )
     1/10 seconds <delay> [ "" like ] <arrow> <label-control>
-    reverse-video-theme
+    status-bar-theme
     t >>root? ;
 
 : open-status-window ( gadget title/attributes -- )

basis/ui/tools/browser/browser.factor

@@ -11,7 +11,7 @@ ui.gadgets.viewports ui.tools.common ui.tools.browser.popups
 ui.tools.browser.history ;
 IN: ui.tools.browser
 
-TUPLE: browser-gadget < tool history pane scroller search-field popup ;
+TUPLE: browser-gadget < tool history scroller search-field popup ;
 
 { 650 400 } browser-gadget set-tool-dim
 
@@ -59,9 +59,8 @@ M: browser-gadget set-history-value
         dup <history> >>history
         dup <search-field> >>search-field
         dup <browser-toolbar> { 3 3 } <border> { 1 0 } >>fill f track-add
-        dup <help-pane> >>pane
+        dup dup <help-pane> { 10 0 } <border> { 1 1 } >>fill
-        dup pane>> <scroller> >>scroller
+        <scroller> >>scroller scroller>> 1 track-add ;
-        dup scroller>> 1 track-add ;
 
 M: browser-gadget graft*
     [ add-definition-observer ] [ call-next-method ] bi ;

basis/vocabs/prettyprint/prettyprint.factor

@@ -1,12 +1,13 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sorting sequences vocabs io io.styles arrays assocs
+USING: accessors arrays assocs colors colors.constants fry io
-namespaces sets parser colors prettyprint.backend prettyprint.sections
+io.styles kernel make math.order namespaces parser
-vocabs.parser make fry math.order ;
+prettyprint.backend prettyprint.sections prettyprint.stylesheet
+sequences sets sorting vocabs vocabs.parser ;
 IN: vocabs.prettyprint
 
 : pprint-vocab ( vocab -- )
-    [ vocab-name ] [ vocab ] bi present-text ;
+    [ vocab-name ] [ vocab vocab-style ] bi styled-text ;
 
 : pprint-in ( vocab -- )
     [ \ IN: pprint-word pprint-vocab ] with-pprint ;
@@ -85,7 +86,7 @@ PRIVATE>
         "To avoid doing this in the future, add the following forms" print
         "at the top of the source file:" print nl
     ] with-style
-    { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } }
+    { { page-color COLOR: FactorLightTan } }
     [ manifest get pprint-manifest ] with-nesting
     nl nl
 ] print-use-hook set-global