61 lines
1.5 KiB
Racket
61 lines
1.5 KiB
Racket
#lang racket/base
|
|
|
|
;; Implements a button with alternatives.
|
|
|
|
(require racket/class
|
|
racket/list
|
|
mrlib/name-message
|
|
framework)
|
|
|
|
(provide button-with-alternatives%)
|
|
|
|
|
|
|
|
;; Most of this is stolen from the custom controls written in
|
|
;; drracket/private/unit.rkt. It might be good to generalize this
|
|
;; so it's easier to use.
|
|
(define button-with-alternatives%
|
|
(class name-message%
|
|
(init-field parent)
|
|
(init-field choices-thunk)
|
|
|
|
(define currently-selected
|
|
(let ([choices (choices-thunk)])
|
|
(cond
|
|
[(empty? choices)
|
|
#f]
|
|
[else
|
|
(first (choices-thunk))])))
|
|
|
|
(define/public (get-selection)
|
|
currently-selected)
|
|
|
|
(define/public (get-choices)
|
|
(choices-thunk))
|
|
|
|
(define/override (fill-popup menu reset)
|
|
(for ([ch (choices-thunk)])
|
|
(make-menu-item menu ch)))
|
|
|
|
(define (make-menu-item menu ch)
|
|
(define item
|
|
(new (if (and currently-selected
|
|
(string=? ch currently-selected))
|
|
menu:can-restore-checkable-menu-item%
|
|
menu:can-restore-menu-item%)
|
|
[label (gui-utils:quote-literal-label ch)]
|
|
[parent menu]
|
|
[callback (lambda (menu-item control-event)
|
|
(set! currently-selected ch))]))
|
|
(when (string=? ch currently-selected)
|
|
(send item check #t))
|
|
item)
|
|
|
|
(super-new [parent parent]
|
|
[label ""])))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|