Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

working on the tool ui

  • Loading branch information...
commit 91265dad43fd186de8ae43286a086ae237dd5aed 1 parent 809b546
Danny Yoo authored
Showing with 113 additions and 42 deletions.
  1. +53 −42 tool/button-with-alternatives.rkt
  2. +60 −0 tool/tool-ui.rkt
95 tool/button-with-alternatives.rkt
View
@@ -2,48 +2,59 @@
;; Implements a button with alternatives.
-(require racket/gui/base
- racket/class)
-
-(define (whalesong-tool-ui parent-widget
- #:on-browser (on-browser
- (lambda ()
- (void)))
- #:on-build-package (on-build-package
- (lambda ()
- (void))))
- (define container (new horizontal-pane%
- [parent parent-widget]))
- (define b (new button%
- [label "Whalesong"]
- [callback (lambda (b ce)
- (define selection
- (send ch get-selection))
- (cond
- [(= selection 0)
- (on-browser)]
- [(= selection 1)
- (on-build-package)]
- [else
- (void)]))]
- [parent container]))
- (define ch (new choice%
- [label ""]
- [choices (list "Run in browser"
- "Build smartphone package")]
- [style '(horizontal-label)]
- [parent container]))
- container)
+(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 f (new frame% [label "test frame"]))
-(whalesong-tool-ui f
- #:on-browser
- (lambda ()
- (printf "on-browser\n"))
+ (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 ""])))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- #:on-build-package
- (lambda ()
- (printf "on-build-package\n")))
-(send f show #t)
60 tool/tool-ui.rkt
View
@@ -0,0 +1,60 @@
+#lang racket
+(require "button-with-alternatives.rkt"
+ racket/gui/base)
+
+;; Defines the Whalesong tool user interface. We add a button
+;; with choices to either run the program in the browser, or
+;; build a package.
+
+
+(define (whalesong-tool-ui parent-widget
+ #:label (label "Run Whalesong")
+ #:on-browser (on-browser
+ (lambda ()
+ (void)))
+ #:on-build-package (on-build-package
+ (lambda ()
+ (void))))
+ (define container (new horizontal-pane%
+ [parent parent-widget]))
+
+ (define b
+ (new button%
+ [label label]
+ [callback (lambda (b ce)
+ (define selection
+ (send alternatives get-selection))
+ (cond
+ [(string=? selection "Run in browser")
+ (on-browser)]
+ [(string=? selection "Build smartphone package")
+ (on-build-package)]
+ [else
+ (void)]))]
+ [parent container]))
+
+ (define alternatives
+ (new button-with-alternatives%
+ [parent container]
+ [choices-thunk (lambda () (list "Run in browser"
+ "Build smartphone package"))]))
+ #;(define ch (new choice%
+ [label ""]
+ [choices (list "Run in browser"
+ "Build smartphone package")]
+ [style '(horizontal-label)]
+ [parent container]))
+ container)
+
+
+(define (test)
+ (define f (new frame% [label "test frame"]))
+ (whalesong-tool-ui f
+ #:on-browser
+ (lambda ()
+ (printf "on-browser\n"))
+
+ #:on-build-package
+ (lambda ()
+ (printf "on-build-package\n")))
+ (send f show #t))
Please sign in to comment.
Something went wrong with that request. Please try again.