From 9bae5a3536595945093874d97ae6b19a21966fee Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Tue, 27 Sep 2016 00:21:02 -0400
Subject: [PATCH] "Clip" shrinkable pushbuttons better. Still needs lots of
 work.

---
 gui.rkt | 18 ++++++++++--------
 1 file changed, 10 insertions(+), 8 deletions(-)

diff --git a/gui.rkt b/gui.rkt
index 2c3a9e7..613457d 100644
--- a/gui.rkt
+++ b/gui.rkt
@@ -387,7 +387,7 @@
   ;; TODO: figure out what it is about (define (f #:x x) x) that
   ;; mandates begin-for-declarations to hide it from syndicate/lang's
   ;; local-expansion here :-(
-  (define (pushbutton label-str x y
+  (define (pushbutton label-str x y [w #f] [h #f]
                       #:shrink-x [shrink-x 0]
                       #:id id
                       #:parent parent-id
@@ -399,8 +399,11 @@
     (define/query-value touching? #f (inbound (touching id)) #t)
     (on #:when (touching?) (message (inbound (mouse-event trigger-event $s)))
         (send! (button-click id s)))
-    (assert (outbound (c 0 (rectangle (x) (y) (*width i) (*height i)))))
-    (box-size (sizing (*width i) 0 shrink-x) (sizing (*height i) 0 0))))
+    (assert (outbound (c 0 (rectangle (x)
+                                      (y)
+                                      (or (and w (w)) (*width i))
+                                      (or (and h (h)) (*height i))))))
+    (box-size (sizing (*width i) 0 (* shrink-x (*width i))) (sizing (*height i) 0 0))))
 
 ;;---------------------------------------------------------------------------
 
@@ -517,18 +520,17 @@
 (actor #:name 'window-list-monitor
        (during/actor (window-state $id $title _)
          #:name (list 'window-list id)
-         (field [x 0] [y 0])
+         (field [x 0] [y 0] [width #f] [height #f])
          (define reqsize
            (parameterize ((theme-button-y-padding 8)
                           (theme-button-min-height 0)
                           (theme-button-background-color (hsv->color 240 1 0.6)))
-             (pushbutton title x y #:id (list 'window-list id) #:parent 'toolbar
-                         #:shrink-x weak-fill
+             (pushbutton title x y width height #:id (list 'window-list id) #:parent 'toolbar
+                         #:shrink-x 1
                          #:trigger-event 'left-down)))
          (during (layout-solution 'toolbar (horizontal-layout `(-5.0 ,id)) reqsize
                                   (rectangle $l $t $w $h))
-           (x l)
-           (y t)
+           (begin (x l) (y t) (width w) (height h))
            (during (top-widget id)
              (assert (outbound (sprite #:id (list 'window-list id 'highlight)
                                        #:parent (list 'window-list id)