add the right-click-menu argument to switchable-button%

Author: rfindler

gui-doc/mrlib/scribblings/switchable-button.scrbl

@@ -24,7 +24,8 @@
                               [callback (-> (is-a?/c switchable-button%) any/c)]
                               [alternate-bitmap (is-a?/c bitmap%) bitmap]
                               [vertical-tight? boolean? #f]
-                              [min-width-includes-label? boolean? #f])]{
+                              [min-width-includes-label? boolean? #f]
+                              [right-click-menu (or/c #f (list/c string? (-> any)))])]{
     The @racket[callback] is called when the button
     is pressed. The @racket[label] and @racket[bitmap] are
     used as discussed above.
@@ -39,7 +40,14 @@
     If the @racket[min-width-includes-label?] is @racket[#t], then the minimum
     width includes both the bitmap and the label. Otherwise, it includes
     only the bitmap.
-  }
+
+  If @racket[right-click-menu] is not @racket[#f], then right
+  click (or control click on some platforms) opens a context
+  sensitive menu under the button with one menu item whose
+  label is the string and whose callback is the thunk.
+
+    @history[#:changed "1.76" @list{Added the @racket[right-click-menu] argument}]
+}
 
   @defmethod[(set-label-visible [visible? boolean?]) void?]{
     Sets the visibility of the string part of the label.

gui-lib/info.rkt

@@ -34,7 +34,7 @@
 
 (define pkg-authors '(mflatt robby))
 
-(define version "1.75")
+(define version "1.76")
 
 (define license
   '(Apache-2.0 OR MIT))

gui-lib/mrlib/switchable-button.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
 (require racket/gui/base
+         racket/contract
          racket/class
          "private/panel-wob.rkt")
 
@@ -63,7 +64,8 @@
                 callback
                 [alternate-bitmap bitmap]
                 [vertical-tight? #f]
-                [min-width-includes-label? #f])
+                [min-width-includes-label? #f]
+                [right-click-menu #f])
 
     (define/public (get-button-label) label)
     (define/override (set-label l)
@@ -75,6 +77,12 @@
                (not (send label ok?)))
       (error 'switchable-button% "label bitmap is not ok?"))
 
+    (let ([rcb-pred (or/c #f (list/c string? (procedure-arity-includes/c 0)))])
+      (unless (rcb-pred right-click-menu)
+        (error 'switchable-button% "contract violation\n  expected: ~s\n  got: ~e"
+               (contract-name rcb-pred)
+               right-click-menu)))
+
     (define/override (get-label) label)
 
     (define disable-bitmap (make-dull-mask bitmap))
@@ -85,7 +93,7 @@
           (make-dull-mask alternate-bitmap)))
 
     (inherit get-dc min-width min-height get-client-size refresh
-	     client->screen get-top-level-window)
+	     client->screen get-top-level-window popup-menu)
 
     (define down? #f)
     (define in? #f)
@@ -130,6 +138,18 @@
                     (not disabled?))
            (update-float #f)
            (callback this))]
+        [(send evt button-up?)
+         (set! down? #f)
+         (refresh)]
+        [(send evt button-down? 'right)
+         (when right-click-menu
+           (define m (new popup-menu%))
+           (new menu-item%
+                [label (list-ref right-click-menu 0)]
+                [parent m]
+                [callback (λ (_1 _2) ((list-ref right-click-menu 1)))])
+           (define-values (cw ch) (get-client-size))
+           (popup-menu m 0 ch))]
         [(send evt entering?)
          (set! in? #t)
          (update-float #t)