From 098a07ed59b143ec45e197d82b1c32de6f0a84ee Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Tue, 14 Jul 2015 15:29:06 -0700
Subject: [PATCH] ui.gadgets.buttons: add button quot effect.

---
 basis/ui/gadgets/buttons/buttons.factor | 16 +++++++++-------
 1 file changed, 9 insertions(+), 7 deletions(-)

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