steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

ui.gadgets.buttons: add button quot effect.

db4
John Benediktsson 2015-07-14 15:29:06 -07:00
parent a5fbd7e3f8
commit 098a07ed59
1 changed files with 9 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
basis/ui/gadgets/buttons/buttons.factor
View File

@ -56,7 +56,7 @@ button H{
: new-button ( label quot class -- button ) : new-button ( label quot class -- button )
[ swap >label ] dip new-border swap >>quot ; inline [ swap >label ] dip new-border swap >>quot ; inline
: <button> ( label quot -- button ) : <button> ( label quot: ( button -- ) -- button )
button new-button ; button new-button ;
TUPLE: button-pen TUPLE: button-pen
@ -110,7 +110,7 @@ M: button-pen pen-foreground
PRIVATE> PRIVATE>
: <roll-button> ( label quot -- button ) : <roll-button> ( label quot: ( button -- ) -- button )
<button> roll-button-theme ; <button> roll-button-theme ;
<PRIVATE <PRIVATE
@ -143,7 +143,7 @@ CONSTANT: button-clicked-background COLOR: FactorDarkSlateBlue
PRIVATE> PRIVATE>
: <border-button> ( label quot -- button ) : <border-button> ( label quot: ( button -- ) -- button )
<button> border-button-theme ; <button> border-button-theme ;
TUPLE: repeat-button < button ; TUPLE: repeat-button < button ;
@ -154,7 +154,7 @@ repeat-button H{
{ T{ button-up } [ button-update ] } { T{ button-up } [ button-update ] }
} set-gestures } set-gestures
: <repeat-button> ( label quot -- button ) : <repeat-button> ( label quot: ( button -- ) -- button )
#! Button that calls the quotation every 100ms as long as #! Button that calls the quotation every 100ms as long as
#! the mouse is held down. #! the mouse is held down.
repeat-button new-button border-button-theme ; repeat-button new-button border-button-theme ;
@ -237,9 +237,11 @@ PRIVATE>
: gesture>tooltip ( gesture -- str/f ) : gesture>tooltip ( gesture -- str/f )
gesture>string dup [ "Shortcut: " prepend ] when ; gesture>string dup [ "Shortcut: " prepend ] when ;
: <command-button> ( target gesture command -- button ) :: <command-button> ( target gesture command -- button )
swapd [ command-name swap ] keep command-button-quot command command-name
'[ drop @ ] <border-button> swap gesture>tooltip >>tooltip ; target command command-button-quot
'[ drop @ ] <border-button>
gesture gesture>tooltip >>tooltip ; inline
: <toolbar> ( target -- toolbar ) : <toolbar> ( target -- toolbar )
<shelf> <shelf>