388 lines
12 KiB
Racket
388 lines
12 KiB
Racket
#lang syndicate
|
|
|
|
(provide gui-eventspace
|
|
gui-callback
|
|
qc
|
|
spawn-frame
|
|
spawn-horizontal-pane
|
|
spawn-horizontal-panel
|
|
spawn-vertical-pane
|
|
spawn-text-field
|
|
spawn-button
|
|
spawn-choice
|
|
spawn-gauge
|
|
spawn-slider
|
|
spawn-list-box
|
|
spawn-dialog
|
|
(struct-out frame@)
|
|
(struct-out show)
|
|
(struct-out horizontal-pane@)
|
|
(struct-out horizontal-panel@)
|
|
(struct-out vertical-pane@)
|
|
(struct-out text-field@)
|
|
(struct-out set-text-field)
|
|
(struct-out button@)
|
|
(struct-out button-press)
|
|
(struct-out set-text-field-background)
|
|
(struct-out text-field-update)
|
|
(struct-out text-field-enter)
|
|
(struct-out choice@)
|
|
(struct-out choice-selection)
|
|
(struct-out set-selection)
|
|
(struct-out enable)
|
|
(struct-out gauge@)
|
|
(struct-out set-gauge-value)
|
|
(struct-out slider@)
|
|
(struct-out slider-update)
|
|
(struct-out list-box@)
|
|
(struct-out list-box-selection)
|
|
(struct-out set-list-box-choices)
|
|
(struct-out popup-menu)
|
|
(struct-out no-popdown-selected)
|
|
(struct-out popdown-item-selected)
|
|
(struct-out dialog@))
|
|
|
|
(require (only-in racket/class
|
|
new
|
|
send
|
|
make-object))
|
|
(require racket/gui/base)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Eventspace Shennanigans
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define gui-eventspace (make-parameter (make-eventspace)))
|
|
|
|
(define (gui-callback thnk)
|
|
(parameterize ([current-eventspace (gui-eventspace)])
|
|
(queue-callback thnk)))
|
|
|
|
(define-syntax-rule (qc expr ...)
|
|
(gui-callback (lambda () expr ...)))
|
|
|
|
|
|
;; an ID is a (Sealof Any)
|
|
;; an Alignment is a (List (U 'left 'center 'right) (U 'top 'center 'bottom))
|
|
|
|
(message-struct enable (id val))
|
|
|
|
(assertion-struct frame@ (id))
|
|
(message-struct show (id value))
|
|
(message-struct popup-menu (parent-id id title x y items))
|
|
(message-struct no-popdown-selected (id))
|
|
(message-struct popdown-item-selected (id item))
|
|
|
|
(assertion-struct horizontal-pane@ (id))
|
|
(assertion-struct vertical-pane@ (id))
|
|
(assertion-struct horizontal-panel@ (id))
|
|
|
|
(assertion-struct text-field@ (id value))
|
|
(message-struct set-text-field (id value))
|
|
(message-struct set-text-field-background (id color))
|
|
(message-struct text-field-update (id value))
|
|
(message-struct text-field-enter (id value))
|
|
|
|
(assertion-struct button@ (id))
|
|
(message-struct button-press (id))
|
|
|
|
(assertion-struct choice@ (id selection))
|
|
(message-struct choice-selection (id val))
|
|
(message-struct set-selection (id idx))
|
|
|
|
(assertion-struct gauge@ (id))
|
|
(message-struct set-gauge-value (id value))
|
|
|
|
(assertion-struct slider@ (id value))
|
|
(message-struct slider-update (id value))
|
|
|
|
(assertion-struct list-box@ (id idx))
|
|
(message-struct list-box-selection (id idx))
|
|
(message-struct set-list-box-choices (id choices))
|
|
|
|
(assertion-struct dialog@ (id))
|
|
|
|
(define (enable/disable-handler self my-id)
|
|
(on (message (enable my-id $val))
|
|
(qc (send self enable val))))
|
|
|
|
;; String -> ID
|
|
(define (spawn-frame #:label label
|
|
#:width [width #f]
|
|
#:height [height #f])
|
|
(define frame
|
|
(parameterize ((current-eventspace (gui-eventspace)))
|
|
(new frame%
|
|
[label label]
|
|
[width width]
|
|
[height height])))
|
|
(define id (seal frame))
|
|
|
|
(define ((on-popdown! pid) self evt)
|
|
(when (eq? (send evt get-event-type) 'menu-popdown-none)
|
|
(send-ground-message (no-popdown-selected pid))))
|
|
(define ((popdown-item! pid i) . _x)
|
|
(send-ground-message (popdown-item-selected pid i)))
|
|
|
|
(spawn
|
|
(assert (frame@ id))
|
|
(on (message (show id $val))
|
|
(qc (send frame show val)))
|
|
(on (message (popup-menu id $pid $title $x $y $items))
|
|
(define pm (new popup-menu% [title title] [popdown-callback (on-popdown! pid)]))
|
|
(for ([i (in-list items)])
|
|
(new menu-item% [parent pm] [label i] [callback (popdown-item! pid i)]))
|
|
(qc (send frame popup-menu pm x y))
|
|
(react (stop-when (message (inbound (no-popdown-selected pid))) (send! (no-popdown-selected pid)))
|
|
(stop-when (message (inbound (popdown-item-selected pid $i))) (send! (popdown-item-selected pid i))))))
|
|
id)
|
|
|
|
;; ID ... -> ID
|
|
(define (spawn-horizontal-pane #:parent parent
|
|
#:border [border 0]
|
|
#:min-height [min-height #f]
|
|
#:alignment [alignment '(left center)])
|
|
(define parent-component (seal-contents parent))
|
|
(define pane (new horizontal-pane%
|
|
[parent parent-component]
|
|
[border border]
|
|
[min-height min-height]
|
|
[alignment alignment]))
|
|
(define id (seal pane))
|
|
|
|
(spawn
|
|
(assert (horizontal-pane@ id)))
|
|
|
|
id)
|
|
|
|
;; ID ... -> ID
|
|
(define (spawn-horizontal-panel #:parent parent
|
|
#:border [border 0]
|
|
#:min-height [min-height #f]
|
|
#:alignment [alignment '(left center)])
|
|
(define parent-component (seal-contents parent))
|
|
(define panel (new horizontal-panel%
|
|
[parent parent-component]
|
|
[border border]
|
|
[min-height min-height]
|
|
[alignment alignment]))
|
|
(define id (seal panel))
|
|
|
|
(spawn
|
|
(assert (horizontal-panel@ id)))
|
|
|
|
id)
|
|
|
|
;; ID Alignment -> ID
|
|
(define (spawn-vertical-pane #:parent parent
|
|
#:alignment [alignment '(center top)])
|
|
(define parent-component (seal-contents parent))
|
|
(define pane (new vertical-pane%
|
|
[parent parent-component]
|
|
[alignment alignment]))
|
|
(define id (seal pane))
|
|
|
|
(spawn
|
|
(assert (vertical-pane@ id)))
|
|
|
|
id)
|
|
|
|
; ID String String Bool Nat -> ID
|
|
(define (spawn-text-field #:parent parent
|
|
#:label label
|
|
#:init-value init
|
|
#:enabled [enabled? #t]
|
|
#:min-width [min-width #f]
|
|
#:min-height [min-height #f])
|
|
(define parent-component (seal-contents parent))
|
|
|
|
(define (inject-text-field-update! _ evt)
|
|
(case (send evt get-event-type)
|
|
[(text-field)
|
|
(send-ground-message (text-field-update id (send tf get-value)))]
|
|
[(text-field-enter)
|
|
(send-ground-message (text-field-enter id (send tf get-value)))]))
|
|
|
|
(define tf (new text-field%
|
|
[parent parent-component]
|
|
[label label]
|
|
[init-value init]
|
|
[enabled enabled?]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[callback inject-text-field-update!]))
|
|
(define id (seal tf))
|
|
|
|
(spawn
|
|
(field [val (send tf get-value)])
|
|
(assert (text-field@ id (val)))
|
|
(enable/disable-handler tf id)
|
|
(on (message (set-text-field id $value))
|
|
(qc (send tf set-value value))
|
|
(val value))
|
|
(on (message (set-text-field-background id $color))
|
|
(define c (make-object color% color))
|
|
(qc (send tf set-field-background c)))
|
|
(on (message (inbound (text-field-update id $value)))
|
|
(val value)
|
|
(send! (text-field-update id value)))
|
|
(on (message (inbound (text-field-enter id $value)))
|
|
(val value)
|
|
(send! (text-field-enter id value))))
|
|
|
|
id)
|
|
|
|
;; ID String -> ID
|
|
(define (spawn-button #:parent parent
|
|
#:label label)
|
|
(define (inject-button-press! b e)
|
|
(send-ground-message (button-press id)))
|
|
(define parent-component (seal-contents parent))
|
|
(define but (new button%
|
|
[parent parent-component]
|
|
[label label]
|
|
[callback inject-button-press!]))
|
|
(define id (seal but))
|
|
|
|
(spawn
|
|
(assert (button@ id))
|
|
(enable/disable-handler but id)
|
|
;; NOTE - this assumes we are one level away from ground
|
|
(on (message (inbound (button-press id)))
|
|
(send! (button-press id))))
|
|
|
|
id)
|
|
|
|
;; ID String (Listof String) -> ID
|
|
(define (spawn-choice #:parent parent
|
|
#:label label
|
|
#:choices choices)
|
|
(define (inject-selection! c e)
|
|
(send-ground-message (choice-selection id (send ch get-string-selection))))
|
|
(define parent-component (seal-contents parent))
|
|
(define ch (new choice%
|
|
[parent parent-component]
|
|
[label label]
|
|
[choices choices]
|
|
[callback inject-selection!]))
|
|
(define id (seal ch))
|
|
|
|
(spawn
|
|
(field [selection (send ch get-string-selection)])
|
|
(assert (choice@ id (selection)))
|
|
|
|
(enable/disable-handler ch id)
|
|
(on (message (inbound (choice-selection id $val)))
|
|
(selection val)
|
|
(send! (choice-selection id val)))
|
|
(on (message (set-selection id $idx))
|
|
(qc (send ch set-selection idx))
|
|
(selection (send ch get-string-selection))))
|
|
|
|
id)
|
|
|
|
;; ID String Bool Nat -> ID
|
|
(define (spawn-gauge #:parent parent
|
|
#:label label
|
|
#:enabled [enabled? #t]
|
|
#:range [range 100])
|
|
(define parent-component (seal-contents parent))
|
|
(define g (new gauge%
|
|
[parent parent-component]
|
|
[label label]
|
|
[enabled enabled?]
|
|
[range range]))
|
|
(define id (seal g))
|
|
|
|
(spawn
|
|
(assert (gauge@ id))
|
|
(on (message (set-gauge-value id $v))
|
|
(qc (send g set-value v))))
|
|
|
|
id)
|
|
|
|
;; ID String Nat Nat -> ID
|
|
(define (spawn-slider #:parent parent
|
|
#:label label
|
|
#:min-value min-value
|
|
#:max-value max-value
|
|
#:init-value [init-value min-value])
|
|
(define (inject-slider-event! self evt)
|
|
(send-ground-message (slider-update id (get))))
|
|
|
|
(define parent-component (seal-contents parent))
|
|
(define s (new slider%
|
|
[parent parent-component]
|
|
[label label]
|
|
[min-value min-value]
|
|
[max-value max-value]
|
|
[init-value init-value]
|
|
[callback inject-slider-event!]))
|
|
(define id (seal s))
|
|
|
|
(define (get) (send s get-value))
|
|
|
|
(spawn
|
|
(field [current (get)])
|
|
(assert (slider@ id (current)))
|
|
(on (message (inbound (slider-update id $val)))
|
|
(current val)
|
|
(send! (slider-update id val))))
|
|
|
|
id)
|
|
|
|
;; ID (U String #f) (Listof String) ... -> ID
|
|
(define (spawn-list-box #:parent parent
|
|
#:label label
|
|
#:choices choices
|
|
#:min-width [min-width #f]
|
|
#:min-height [min-height #f])
|
|
(define (inject-list-box-selection! self evt)
|
|
(send-ground-message (list-box-selection id (get))))
|
|
(define parent-component (seal-contents parent))
|
|
(define lb (new list-box%
|
|
[parent parent-component]
|
|
[label label]
|
|
[choices choices]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[callback inject-list-box-selection!]))
|
|
(define id (seal lb))
|
|
(define (get)
|
|
(send lb get-selection))
|
|
|
|
(spawn
|
|
(field [selection (get)])
|
|
(assert (list-box@ id (selection)))
|
|
(on (message (inbound (list-box-selection id $val)))
|
|
(selection val)
|
|
(send! (list-box-selection id val)))
|
|
(on (message (set-list-box-choices id $val))
|
|
(qc (send lb set val))
|
|
(selection (get))))
|
|
|
|
id)
|
|
|
|
(define (spawn-dialog #:label label
|
|
#:parent [parent #f]
|
|
#:style [style null])
|
|
(define parent-component (and parent (seal-contents parent)))
|
|
(define evt-spc (if parent-component
|
|
(send parent-component get-eventspace)
|
|
(make-eventspace) #;(gui-eventspace)))
|
|
(define d (parameterize ((current-eventspace evt-spc))
|
|
(new dialog%
|
|
[label label]
|
|
[parent parent-component]
|
|
[style style])))
|
|
(define id (seal d))
|
|
|
|
(spawn
|
|
(assert (dialog@ id))
|
|
|
|
(on (message (show id $show?))
|
|
(qc (send d show show?))
|
|
(unless show? (stop-current-facet))))
|
|
|
|
id)
|