645 lines
20 KiB
Scheme
645 lines
20 KiB
Scheme
(unit/sig framework:preferences^
|
|
(import mred^
|
|
[prefs-file : framework:prefs-file^]
|
|
[exn : framework:exn^]
|
|
[exit : framework:exit^]
|
|
[panel : framework:panel^]
|
|
[mzlib:pretty-print : mzlib:pretty-print^]
|
|
[mzlib:function : mzlib:function^])
|
|
|
|
(rename [-read read])
|
|
|
|
(define default-preferences-filename
|
|
(build-path (collection-path "defaults") "prefs.ss"))
|
|
|
|
;; preferences : sym -o> (union marshalled pref)
|
|
(define preferences (make-hash-table))
|
|
|
|
;; marshall-unmarshall : sym -o> un/marshall
|
|
(define marshall-unmarshall (make-hash-table))
|
|
|
|
;; callbacks : sym -o> (listof (sym TST -> boolean))
|
|
(define callbacks (make-hash-table))
|
|
|
|
;; saved-defaults : sym -o> (union marshalled pref)
|
|
(define saved-defaults (make-hash-table))
|
|
|
|
;; defaults : sym -o> default
|
|
(define defaults (make-hash-table))
|
|
|
|
(define-struct un/marshall (marshall unmarshall))
|
|
(define-struct marshalled (data))
|
|
(define-struct pref (value))
|
|
(define-struct default (value checker))
|
|
|
|
(define guard
|
|
(lambda (when p value thunk failure)
|
|
(let ([h
|
|
(lambda (x)
|
|
(let ([msg
|
|
(format "exception raised ~a for ~a with ~a: ~a~n"
|
|
when p value
|
|
(exn-message x))])
|
|
(failure x)))])
|
|
(with-handlers ([(lambda (x) #t) h])
|
|
(thunk)))))
|
|
|
|
(define (unmarshall p marshalled)
|
|
(let/ec k
|
|
(let* ([data (marshalled-data marshalled)]
|
|
[unmarshall-fn (un/marshall-unmarshall
|
|
(hash-table-get marshall-unmarshall
|
|
p
|
|
(lambda () (k data))))])
|
|
(guard "unmarshalling" p marshalled
|
|
(lambda () (unmarshall-fn data))
|
|
(lambda (exn)
|
|
(begin0
|
|
(hash-table-get
|
|
defaults
|
|
p
|
|
(lambda ()
|
|
(raise exn)))
|
|
(message-box (format "Error unmarshalling ~a preference" p)
|
|
(if (exn? exn)
|
|
(exn-message exn)
|
|
(format "~s" exn)))))))))
|
|
|
|
(define get-callbacks
|
|
(lambda (p)
|
|
(hash-table-get callbacks
|
|
p
|
|
(lambda () null))))
|
|
|
|
(define add-callback
|
|
(lambda (p callback)
|
|
(hash-table-put! callbacks p (append (get-callbacks p) (list callback)))
|
|
(lambda ()
|
|
(hash-table-put!
|
|
callbacks
|
|
p
|
|
(let loop ([callbacks (get-callbacks p)])
|
|
(cond
|
|
[(null? callbacks) null]
|
|
[else (if (eq? (car callbacks) callback)
|
|
(loop (cdr callbacks))
|
|
(cons (car callbacks) (loop (cdr callbacks))))]))))))
|
|
|
|
(define check-callbacks
|
|
(lambda (p value)
|
|
(andmap (lambda (x)
|
|
(guard "calling callback" p value
|
|
(lambda () (x p value))
|
|
raise))
|
|
(get-callbacks p))))
|
|
|
|
(define (get p)
|
|
(let ([ans (hash-table-get preferences p
|
|
(lambda ()
|
|
(raise (exn:make-unknown-preference
|
|
(format "attempted to get unknown preference: ~a" p)
|
|
(current-continuation-marks)))))])
|
|
(cond
|
|
[(marshalled? ans)
|
|
(let* ([default-s
|
|
(hash-table-get
|
|
defaults p
|
|
(lambda ()
|
|
(error 'preferences:get
|
|
"no default pref for: ~a~n"
|
|
p)))]
|
|
[default (default-value default-s)]
|
|
[checker (default-checker default-s)]
|
|
[unmarshalled (let ([unmarsh (unmarshall p ans)])
|
|
(if (checker unmarsh)
|
|
unmarsh
|
|
default))]
|
|
[pref (if (check-callbacks p unmarshalled)
|
|
unmarshalled
|
|
default)])
|
|
(hash-table-put! preferences p (make-pref pref))
|
|
pref)]
|
|
[(pref? ans)
|
|
(pref-value ans)]
|
|
[else (error 'prefs.ss "robby error.1: ~a" ans)])))
|
|
|
|
(define (set p value)
|
|
(let* ([pref (hash-table-get preferences p (lambda () #f))])
|
|
(cond
|
|
[(pref? pref)
|
|
(when (check-callbacks p value)
|
|
(set-pref-value! pref value))]
|
|
[(or (marshalled? pref)
|
|
(not pref))
|
|
(when (check-callbacks p value)
|
|
(hash-table-put! preferences p (make-pref value)))]
|
|
[else
|
|
(error 'prefs.ss "robby error.0: ~a" pref)])))
|
|
|
|
(define set-un/marshall
|
|
(lambda (p marshall unmarshall)
|
|
(when (hash-table-get defaults p (lambda () #f))
|
|
(error 'set-un/marshall "must call set-default for ~s before calling set-un/marshall for ~s"
|
|
p p))
|
|
(hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall))))
|
|
|
|
(define restore-defaults
|
|
(lambda ()
|
|
(hash-table-for-each
|
|
defaults
|
|
(lambda (p v) (set p v)))))
|
|
|
|
;; set-default : (sym TST (TST -> boolean) -> void
|
|
(define (set-default p in-default-value checker)
|
|
(let* ([default-value
|
|
(let/ec k
|
|
(let ([saved-default
|
|
(hash-table-get saved-defaults p (lambda ()
|
|
(k in-default-value)))])
|
|
(cond
|
|
[(marshalled? saved-default)
|
|
(let* ([unmarsh (unmarshall p saved-default)]
|
|
[unmarshalled
|
|
(if (checker unmarsh)
|
|
unmarsh
|
|
(begin
|
|
'(printf
|
|
"WARNING: rejected saved default ~s for ~s; using ~s instead"
|
|
unmarsh p in-default-value)
|
|
in-default-value))]
|
|
[pref (if (check-callbacks p unmarshalled)
|
|
unmarshalled
|
|
in-default-value)])
|
|
(hash-table-put! saved-defaults p (make-pref pref))
|
|
pref)]
|
|
[(pref? saved-default)
|
|
(pref-value saved-default)])))]
|
|
[default-okay? (checker default-value)])
|
|
(unless default-okay?
|
|
(error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n"
|
|
p checker default-okay? default-value))
|
|
(hash-table-get preferences p
|
|
(lambda ()
|
|
(hash-table-put! preferences p (make-pref default-value))))
|
|
(hash-table-put! defaults p (make-default default-value checker))))
|
|
|
|
(define save
|
|
(let ([marshall-pref
|
|
(lambda (p ht-value)
|
|
(cond
|
|
[(marshalled? ht-value) (list p (marshalled-data ht-value))]
|
|
[(pref? ht-value)
|
|
(let* ([value (pref-value ht-value)]
|
|
[marshalled
|
|
(let/ec k
|
|
(guard "marshalling" p value
|
|
(lambda ()
|
|
((un/marshall-marshall
|
|
(hash-table-get marshall-unmarshall p
|
|
(lambda ()
|
|
(k value))))
|
|
value))
|
|
raise))])
|
|
(list p marshalled))]
|
|
[else (error 'prefs.ss "robby error.2: ~a" ht-value)]))])
|
|
(lambda ()
|
|
(with-handlers ([(lambda (x) #t)
|
|
(lambda (exn)
|
|
(message-box
|
|
"Error saving preferences"
|
|
(exn-message exn)))])
|
|
(call-with-output-file (prefs-file:get-preferences-filename)
|
|
(lambda (p)
|
|
(mzlib:pretty-print:pretty-print
|
|
(hash-table-map preferences marshall-pref) p))
|
|
'truncate 'text)))))
|
|
|
|
(define (for-each-pref-in-file parse-pref preferences-filename)
|
|
(let/ec k
|
|
(let ([err
|
|
(lambda (input msg)
|
|
(message-box "Preferences"
|
|
(let* ([max-len 150]
|
|
[s1 (format "~s" input)]
|
|
[ell "..."]
|
|
[s2 (if (<= (string-length s1) max-len)
|
|
s1
|
|
(string-append
|
|
(substring s1 0 (- max-len
|
|
(string-length ell)))
|
|
ell))])
|
|
(format "found bad pref in ~a: ~a~n~a"
|
|
preferences-filename msg s2))))])
|
|
(let ([input (with-handlers
|
|
([(lambda (exn) #t)
|
|
(lambda (exn)
|
|
(message-box
|
|
"Error reading preferences"
|
|
(format "Error reading preferences~n~a"
|
|
(exn-message exn)))
|
|
(k #f))])
|
|
(call-with-input-file preferences-filename
|
|
read
|
|
'text))])
|
|
(if (eof-object? input)
|
|
(void)
|
|
(let loop ([input input])
|
|
(cond
|
|
[(pair? input)
|
|
(let ([err-msg
|
|
(let/ec k
|
|
(let ([first (car input)])
|
|
(unless (pair? first)
|
|
(k "expected pair of pair"))
|
|
(let ([arg1 (car first)]
|
|
[t1 (cdr first)])
|
|
(unless (pair? t1)
|
|
(k "expected pair of two pairs"))
|
|
(let ([arg2 (car t1)]
|
|
[t2 (cdr t1)])
|
|
(unless (null? t2)
|
|
(k "expected null after two pairs"))
|
|
(parse-pref arg1 arg2)
|
|
(k #f)))))])
|
|
(when err-msg
|
|
(err input err-msg)))
|
|
(loop (cdr input))]
|
|
[(null? input) (void)]
|
|
[else (err input "expected a pair")])))))))
|
|
|
|
;; read-from-file-to-ht : string hash-table -> void
|
|
(define (read-from-file-to-ht filename ht)
|
|
(let* ([parse-pref
|
|
(lambda (p marshalled)
|
|
(let* ([ht-pref (hash-table-get ht p (lambda () #f))]
|
|
[unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))])
|
|
(cond
|
|
[unmarshall-struct
|
|
(set p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
|
|
|
|
;; in this case, assume that no marshalling/unmarshalling
|
|
;; is going to take place with the pref, since an unmarshalled
|
|
;; pref was already there.
|
|
[(pref? ht-pref)
|
|
(set p marshalled)]
|
|
|
|
[(marshalled? ht-pref)
|
|
(set-marshalled-data! ht-pref marshalled)]
|
|
[(and (not ht-pref) unmarshall-struct)
|
|
(set p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
|
|
[(not ht-pref)
|
|
(hash-table-put! ht p (make-marshalled marshalled))]
|
|
[else (error 'prefs.ss "robby error.3: ~a" ht-pref)])))])
|
|
(when (file-exists? filename)
|
|
(for-each-pref-in-file parse-pref filename))))
|
|
|
|
;; read : -> void
|
|
(define (-read)
|
|
(read-from-file-to-ht (prefs-file:get-preferences-filename) preferences))
|
|
|
|
|
|
;; read in the saved defaults. These should override the
|
|
;; values used with set-default.
|
|
(read-from-file-to-ht default-preferences-filename saved-defaults)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; ;;;
|
|
;;; preferences dialog ;;;
|
|
;;; ;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(define-struct ppanel (title container panel))
|
|
|
|
(define ppanels null)
|
|
|
|
(define (add-general-panel)
|
|
(add-panel
|
|
"General"
|
|
(lambda (parent)
|
|
(let* ([main (make-object vertical-panel% parent)]
|
|
[make-check
|
|
(lambda (pref title bool->pref pref->bool)
|
|
(let* ([callback
|
|
(lambda (check-box _)
|
|
(set pref (bool->pref (send check-box get-value))))]
|
|
[pref-value (get pref)]
|
|
[initial-value (pref->bool pref-value)]
|
|
[c (make-object check-box% title main callback)])
|
|
(send c set-value initial-value)
|
|
(add-callback pref
|
|
(lambda (p v)
|
|
(send c set-value (pref->bool v))))))]
|
|
[id (lambda (x) x)])
|
|
(send main set-alignment 'left 'center)
|
|
(make-check 'framework:highlight-parens "Highlight between matching parens" id id)
|
|
(make-check 'framework:fixup-parens "Correct parens" id id)
|
|
(make-check 'framework:paren-match "Flash paren match" id id)
|
|
(make-check 'framework:autosaving-on? "Auto-save files" id id)
|
|
(make-check 'framework:delete-forward? "Map delete to backspace" not not)
|
|
|
|
;; not exposed to the user anymore. Only left in for automated testing.
|
|
;(make-check 'framework:file-dialogs "Use platform-specific file dialogs"
|
|
;(lambda (x) (if x 'std 'common))
|
|
;(lambda (x) (eq? x 'std)))
|
|
|
|
(make-check 'framework:verify-exit "Verify exit" id id)
|
|
(make-check 'framework:verify-change-format "Ask before changing save format" id id)
|
|
(make-check 'framework:auto-set-wrap? "Wrap words in editor buffers" id id)
|
|
|
|
(make-check 'framework:show-status-line "Show status-line" id id)
|
|
(make-check 'framework:line-offsets "Count line and column numbers from one" id id)
|
|
(make-check 'framework:display-line-numbers "Display line numbers in buffer; not character offsets" id id)
|
|
(make-check 'framework:menu-bindings "Enable keybindings in menus" id id)
|
|
(unless (eq? (system-type) 'unix)
|
|
(make-check 'framework:print-output-mode "Automatically print to postscript file"
|
|
(lambda (b)
|
|
(if b 'postscript 'standard))
|
|
(lambda (n) (eq? 'postscript n))))
|
|
|
|
|
|
'(when (eq? (system-type) 'windows)
|
|
(make-check 'framework:windows-mdi "Use MDI Windows" id id))
|
|
(make-check 'framework:search-using-dialog?
|
|
"Use separate dialog for searching"
|
|
id id)
|
|
|
|
main)))
|
|
(set! add-general-panel void))
|
|
|
|
(define (add-font-panel)
|
|
(let* ([font-families-name/const
|
|
(list (list "Default" 'default)
|
|
(list "Decorative" 'decorative)
|
|
(list "Modern" 'modern)
|
|
(list "Roman" 'roman)
|
|
(list "Script" 'script)
|
|
(list "Swiss" 'swiss))]
|
|
|
|
[font-families (map car font-families-name/const)]
|
|
|
|
[font-size-entry "defaultFontSize"]
|
|
[font-default-string "Default Value"]
|
|
[font-default-size (case (system-type)
|
|
[(windows) 10]
|
|
[else 12])]
|
|
[font-section "mred"]
|
|
[build-font-entry (lambda (x) (string-append "Screen" x "__"))]
|
|
[font-file (find-graphical-system-path 'setup-file)]
|
|
[build-font-preference-symbol
|
|
(lambda (family)
|
|
(string->symbol (string-append "framework:" family)))]
|
|
|
|
[set-default
|
|
(lambda (build-font-entry default pred)
|
|
(lambda (family)
|
|
(let ([name (build-font-preference-symbol family)]
|
|
[font-entry (build-font-entry family)])
|
|
(set-default name
|
|
default
|
|
(cond
|
|
[(string? default) string?]
|
|
[(number? default) number?]
|
|
[else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
|
|
(add-callback
|
|
name
|
|
(lambda (p new-value)
|
|
(write-resource
|
|
font-section
|
|
font-entry
|
|
(if (and (string? new-value)
|
|
(string=? font-default-string new-value))
|
|
""
|
|
new-value)
|
|
font-file))))))])
|
|
|
|
(for-each (set-default build-font-entry font-default-string string?)
|
|
font-families)
|
|
((set-default (lambda (x) x)
|
|
font-default-size
|
|
number?)
|
|
font-size-entry)
|
|
(add-panel
|
|
"Default Fonts"
|
|
(lambda (parent)
|
|
(letrec ([font-size-pref-sym (build-font-preference-symbol font-size-entry)]
|
|
[ex-string "The quick brown fox jumped over the lazy dogs."]
|
|
[main (make-object vertical-panel% parent)]
|
|
[fonts (cons font-default-string (get-face-list))]
|
|
[make-family-panel
|
|
(lambda (name)
|
|
(let* ([pref-sym (build-font-preference-symbol name)]
|
|
[family-const-pair (assoc name font-families-name/const)]
|
|
|
|
[edit (make-object text%)]
|
|
[_ (send edit insert ex-string)]
|
|
[set-edit-font
|
|
(lambda (size)
|
|
(let ([delta (make-object style-delta% 'change-size size)]
|
|
[face (get pref-sym)])
|
|
(if (and (string=? face font-default-string)
|
|
family-const-pair)
|
|
(send delta set-family (cadr family-const-pair))
|
|
(send delta set-delta-face (get pref-sym)))
|
|
|
|
(send edit change-style delta 0 (send edit last-position))))]
|
|
|
|
[horiz (make-object horizontal-panel% main '(border))]
|
|
[label (make-object message% name horiz)]
|
|
|
|
[message (make-object message%
|
|
(let ([b (box "")])
|
|
(if (and (get-resource
|
|
font-section
|
|
(build-font-entry name)
|
|
b)
|
|
(not (string=? (unbox b)
|
|
"")))
|
|
(unbox b)
|
|
font-default-string))
|
|
horiz)]
|
|
[button
|
|
(make-object button%
|
|
"Change"
|
|
horiz
|
|
(lambda (button evt)
|
|
(let ([new-value
|
|
(get-choices-from-user
|
|
"Fonts"
|
|
(format "Please choose a new ~a font"
|
|
name)
|
|
fonts)])
|
|
(when new-value
|
|
(set pref-sym (list-ref fonts (car new-value)))
|
|
(set-edit-font (get font-size-pref-sym))))))]
|
|
[canvas (make-object editor-canvas% horiz
|
|
edit
|
|
(list 'hide-hscroll
|
|
'hide-vscroll))])
|
|
(set-edit-font (get font-size-pref-sym))
|
|
(add-callback
|
|
pref-sym
|
|
(lambda (p new-value)
|
|
(send horiz change-children
|
|
(lambda (l)
|
|
(let ([new-message (make-object message%
|
|
new-value
|
|
horiz)])
|
|
(set! message new-message)
|
|
(update-message-sizes font-message-get-widths
|
|
font-message-user-min-sizes)
|
|
(list label
|
|
new-message
|
|
button
|
|
canvas))))))
|
|
(send canvas set-line-count 1)
|
|
(vector set-edit-font
|
|
(lambda () (send message get-width))
|
|
(lambda (width) (send message min-width width))
|
|
(lambda () (send label get-width))
|
|
(lambda (width) (send label min-width width)))))]
|
|
[set-edit-fonts/messages (map make-family-panel font-families)]
|
|
[collect (lambda (n) (map (lambda (x) (vector-ref x n))
|
|
set-edit-fonts/messages))]
|
|
[set-edit-fonts (collect 0)]
|
|
[font-message-get-widths (collect 1)]
|
|
[font-message-user-min-sizes (collect 2)]
|
|
[category-message-get-widths (collect 3)]
|
|
[category-message-user-min-sizes (collect 4)]
|
|
[update-message-sizes
|
|
(lambda (gets sets)
|
|
(let ([width (mzlib:function:foldl (lambda (x l) (max l (x))) 0 gets)])
|
|
(for-each (lambda (set) (set width)) sets)))]
|
|
[size-panel (make-object horizontal-panel% main '(border))]
|
|
[initial-font-size
|
|
(let ([b (box 0)])
|
|
(if (get-resource font-section
|
|
font-size-entry
|
|
b)
|
|
(unbox b)
|
|
font-default-size))]
|
|
[size-slider
|
|
(make-object slider%
|
|
"Size"
|
|
1 127
|
|
size-panel
|
|
(lambda (slider evt)
|
|
(set font-size-pref-sym (send slider get-value)))
|
|
initial-font-size)])
|
|
(update-message-sizes font-message-get-widths font-message-user-min-sizes)
|
|
(update-message-sizes category-message-get-widths category-message-user-min-sizes)
|
|
(add-callback
|
|
font-size-pref-sym
|
|
(lambda (p value)
|
|
(for-each (lambda (f) (f value)) set-edit-fonts)
|
|
(unless (= value (send size-slider get-value))
|
|
(send size-slider set-value value))
|
|
#t))
|
|
(for-each (lambda (f) (f initial-font-size)) set-edit-fonts)
|
|
(make-object message% "Restart to see font changes" main)
|
|
main))))
|
|
(set! add-font-panel void))
|
|
|
|
(define preferences-dialog #f)
|
|
|
|
(define add-panel
|
|
(lambda (title container)
|
|
(set! ppanels
|
|
(append ppanels (list (make-ppanel title container #f))))
|
|
(when preferences-dialog
|
|
(send preferences-dialog added-pane))))
|
|
|
|
(define hide-dialog
|
|
(lambda ()
|
|
(when preferences-dialog
|
|
(send preferences-dialog show #f))))
|
|
|
|
(define show-dialog
|
|
(lambda ()
|
|
(save)
|
|
(if preferences-dialog
|
|
(send preferences-dialog show #t)
|
|
(set! preferences-dialog
|
|
(make-preferences-dialog)))))
|
|
|
|
(define make-preferences-dialog
|
|
(lambda ()
|
|
(letrec ([frame
|
|
(make-object (class-asi frame%
|
|
(public
|
|
[added-pane
|
|
(lambda ()
|
|
(ensure-constructed)
|
|
(refresh-menu)
|
|
(unless (null? ppanels)
|
|
(send popup-menu set-selection (sub1 (length ppanels)))
|
|
(send single-panel active-child
|
|
(ppanel-panel
|
|
(car
|
|
(list-tail ppanels
|
|
(sub1 (length ppanels))))))))]))
|
|
"Preferences")]
|
|
[panel (make-object vertical-panel% frame)]
|
|
[popup-callback
|
|
(lambda (choice command-event)
|
|
(unless (null? ppanels)
|
|
(send single-panel active-child
|
|
(ppanel-panel (list-ref ppanels (send choice get-selection))))))]
|
|
[make-popup-menu
|
|
(lambda ()
|
|
(let ([menu (make-object choice% "Category"
|
|
(map ppanel-title ppanels)
|
|
panel popup-callback)])
|
|
(send menu stretchable-width #f)
|
|
menu))]
|
|
[popup-menu (make-popup-menu)]
|
|
[single-panel (make-object panel:single%
|
|
panel '(border))]
|
|
[bottom-panel (make-object horizontal-panel% panel)]
|
|
[ensure-constructed
|
|
(lambda ()
|
|
(for-each (lambda (ppanel)
|
|
(unless (ppanel-panel ppanel)
|
|
(let ([panel ((ppanel-container ppanel) single-panel)])
|
|
(unless (and (object? panel)
|
|
(is-a? panel area-container<%>))
|
|
(error 'preferences-dialog
|
|
"expected the result of the function passed to preferences:add-panel to implement the area-container% interface. Got ~a~n"
|
|
panel))
|
|
(set-ppanel-panel! ppanel panel))))
|
|
ppanels)
|
|
(send single-panel change-children (lambda (l) (map ppanel-panel ppanels)))
|
|
(unless (null? ppanels)
|
|
(send single-panel active-child (ppanel-panel (car ppanels)))))]
|
|
[refresh-menu
|
|
(lambda ()
|
|
(let ([new-popup (make-popup-menu)]
|
|
[old-selection (send popup-menu get-selection)])
|
|
(when old-selection
|
|
(send new-popup set-selection old-selection))
|
|
(set! popup-menu new-popup)
|
|
(send panel change-children
|
|
(lambda (l) (list new-popup
|
|
single-panel
|
|
bottom-panel)))))]
|
|
[ok-callback (lambda args
|
|
(save)
|
|
(hide-dialog))]
|
|
[ok-button (make-object button% "OK" bottom-panel ok-callback '(border))]
|
|
[cancel-callback (lambda args
|
|
(hide-dialog)
|
|
(-read))]
|
|
[cancel-button (make-object button% "Cancel" bottom-panel cancel-callback)]
|
|
[grow-box-space (make-object grow-box-spacer-pane% bottom-panel)])
|
|
(send ok-button min-width (send cancel-button get-width))
|
|
(send* bottom-panel
|
|
(stretchable-height #f)
|
|
(set-alignment 'right 'center))
|
|
(ensure-constructed)
|
|
(unless (null? ppanels)
|
|
(send popup-menu set-selection 0))
|
|
(send popup-menu focus)
|
|
(send frame show #t)
|
|
frame))))
|