suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 200a1e4b21d946190a27bf171b8a6438baf3f221
This commit is contained in:
Matthew Flatt 2005-02-10 03:42:09 +00:00
parent 7c396dc378
commit db46b50542
11 changed files with 106 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mred/mred-sig.ss
View File

@ -132,6 +132,7 @@
mouse-event% mouse-event%
;; mred@ ;; mred@
mult-color<%> mult-color<%>
normal-control-font
open-input-graphical-file open-input-graphical-file
open-input-text-editor open-input-text-editor
pane% pane%
@ -161,6 +162,7 @@
separator-menu-item% separator-menu-item%
sleep/yield sleep/yield
slider% slider%
small-control-font
snip% snip%
snip-admin% snip-admin%
snip-class% snip-class%
@ -187,10 +189,12 @@
the-style-list the-style-list
the-x-selection-clipboard the-x-selection-clipboard
timer% timer%
tiny-control-font
top-level-window<%> top-level-window<%>
unregister-collecting-blit unregister-collecting-blit
vertical-pane% vertical-pane%
vertical-panel% vertical-panel%
view-control-font
window<%> window<%>
write-editor-global-footer write-editor-global-footer
write-editor-global-header write-editor-global-header

4
collects/mred/mred.ss
View File

@ -267,6 +267,10 @@
the-pen-list the-pen-list
the-font-list the-font-list
the-style-list the-style-list
normal-control-font
small-control-font
tiny-control-font
view-control-font
timer% timer%
readable-snip<%> readable-snip<%>
open-input-text-editor open-input-text-editor

7
collects/mred/private/check.ss
View File

@ -1,7 +1,8 @@
(module check mzscheme (module check mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(prefix wx: "kernel.ss") (prefix wx: "kernel.ss")
"wx.ss") "wx.ss"
"const.ss")
(provide (all-defined)) (provide (all-defined))
(define (who->name who) (define (who->name who)
@ -138,6 +139,10 @@
(memq label '(app caution stop))) (memq label '(app caution stop)))
(raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or icon symbol" label))) (raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or icon symbol" label)))
(define (check-font who f)
(unless (or (eq? f no-val) (f . is-a? . wx:font%))
(raise-type-error (who->name who) "font% object" f)))
(define (check-style who reqd other-allowed style) (define (check-style who reqd other-allowed style)
(unless (and (list? style) (andmap symbol? style)) (unless (and (list? style) (andmap symbol? style))
(raise-type-error (who->name who) "list of style symbols" style)) (raise-type-error (who->name who) "list of style symbols" style))

1
collects/mred/private/const.ss
View File

@ -31,6 +31,7 @@
;; indicates init arg not supplied ;; indicates init arg not supplied
(define no-val (gensym)) (define no-val (gensym))
(define (no-val->#f v) (if (eq? v no-val) #f v))
(define ibeam (make-object wx:cursor% 'ibeam)) (define ibeam (make-object wx:cursor% 'ibeam))
(define arrow-cursor (make-object wx:cursor% 'arrow)) (define arrow-cursor (make-object wx:cursor% 'arrow))

20
collects/mred/private/gdi.ss
View File

@ -14,7 +14,11 @@
post-script-dc% post-script-dc%
printer-dc% printer-dc%
get-window-text-extent get-window-text-extent
get-family-builtin-face) get-family-builtin-face
normal-control-font
view-control-font
small-control-font
tiny-control-font)
(define register-collecting-blit (define register-collecting-blit
(case-lambda (case-lambda
@ -143,4 +147,16 @@
[(modern) "Courier New"] [(modern) "Courier New"]
[(swiss) "Helvetica"] [(swiss) "Helvetica"]
[(script) "Apple Chancery"] [(script) "Apple Chancery"]
[(symbol) "Symbol"])]))) [(symbol) "Symbol"])]))
(define small-delta (case (system-type)
[(windows) 0]
[(macosx) 2]
[else 1]))
(define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system))
(define view-control-font (if (eq? 'macosx (system-type))
(make-object wx:font% 12 'system)
(make-object wx:font% (wx:get-control-font-size) 'system)))
(define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system))
(define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) 2 small-delta) 'system)))

6
collects/mred/private/kernel.ss
View File

@ -151,6 +151,7 @@
get-label get-label
command) command)
(define-class message% item% #f (define-class message% item% #f
get-font
set-label set-label
on-drop-file on-drop-file
pre-on-event pre-on-event
@ -640,6 +641,7 @@
set-screen-name set-screen-name
get-post-script-name get-post-script-name
get-screen-name) get-screen-name)
(define-function get-control-font-size)
(define-function get-the-font-name-directory) (define-function get-the-font-name-directory)
(define-function get-the-font-list) (define-function get-the-font-list)
(define-function get-the-pen-list) (define-function get-the-pen-list)
@ -1141,10 +1143,6 @@
copy copy
cut) cut)
(define-class panel% window% #f (define-class panel% window% #f
get-label-font
set-label-font
get-control-font
set-control-font
get-label-position get-label-position
set-label-position set-label-position
on-char on-char

39
collects/mred/private/mritem.ss
View File

@ -42,12 +42,15 @@
(define-local-member-name hidden-child? label-checker) (define-local-member-name hidden-child? label-checker)
(define-keywords control%-keywords (define-keywords control%-keywords
[font no-val]
window%-keywords window%-keywords
subarea%-keywords subarea%-keywords
area%-keywords) area%-keywords)
(define basic-control% (define basic-control%
(class100* (make-window% #f (make-subarea% area%)) (control<%>) (mk-wx mismatches lbl parent cb cursor) (class100* (make-window% #f (make-subarea% area%)) (control<%>) (mk-wx mismatches lbl parent cb cursor
;; for keyword use
[font no-val])
(rename [super-set-label set-label]) (rename [super-set-label set-label])
(private-field [label lbl][callback cb]) (private-field [label lbl][callback cb])
(override (override
@ -97,12 +100,13 @@
(let ([cwho '(constructor message)]) (let ([cwho '(constructor message)])
(check-label-string/bitmap/iconsym cwho label) (check-label-string/bitmap/iconsym cwho label)
(check-container-parent cwho parent) (check-container-parent cwho parent)
(check-style cwho #f '(deleted) style)) (check-style cwho #f '(deleted) style)
(check-font cwho font))
(as-entry (as-entry
(lambda () (lambda ()
(super-init (lambda () (make-object wx-message% this this (super-init (lambda () (make-object wx-message% this this
(mred->wx-container parent) (mred->wx-container parent)
label -1 -1 style)) label -1 -1 style (no-val->#f font)))
(lambda () (lambda ()
(let ([cwho '(constructor message)]) (let ([cwho '(constructor message)])
(check-container-ready cwho parent))) (check-container-ready cwho parent)))
@ -117,12 +121,13 @@
(check-label-string-or-bitmap cwho label) (check-label-string-or-bitmap cwho label)
(check-container-parent cwho parent) (check-container-parent cwho parent)
(check-callback cwho callback) (check-callback cwho callback)
(check-style cwho #f '(border deleted) style)) (check-style cwho #f '(border deleted) style)
(check-font cwho font))
(as-entry (as-entry
(lambda () (lambda ()
(super-init (lambda () (make-object wx-button% this this (super-init (lambda () (make-object wx-button% this this
(mred->wx-container parent) (wrap-callback callback) (mred->wx-container parent) (wrap-callback callback)
label -1 -1 -1 -1 style)) label -1 -1 -1 -1 style (no-val->#f font)))
(lambda () (lambda ()
(let ([cwho '(constructor button)]) (let ([cwho '(constructor button)])
(check-container-ready cwho parent))) (check-container-ready cwho parent)))
@ -135,7 +140,8 @@
(check-label-string-or-bitmap cwho label) (check-label-string-or-bitmap cwho label)
(check-container-parent cwho parent) (check-container-parent cwho parent)
(check-callback cwho callback) (check-callback cwho callback)
(check-style cwho #f '(deleted) style))) (check-style cwho #f '(deleted) style)
(check-font cwho font)))
(override (override
[label-checker (lambda () check-label-string-or-bitmap)]) ; module-local method [label-checker (lambda () check-label-string-or-bitmap)]) ; module-local method
(private-field (private-field
@ -149,7 +155,7 @@
(super-init (lambda () (super-init (lambda ()
(set! wx (make-object wx-check-box% this this (set! wx (make-object wx-check-box% this this
(mred->wx-container parent) (wrap-callback callback) (mred->wx-container parent) (wrap-callback callback)
label -1 -1 -1 -1 style)) label -1 -1 -1 -1 style (no-val->#f font)))
wx) wx)
(lambda () (lambda ()
(let ([cwho '(constructor check-box)]) (let ([cwho '(constructor check-box)])
@ -213,7 +219,7 @@
(super-init (lambda () (super-init (lambda ()
(set! wx (make-object wx-radio-box% this this (set! wx (make-object wx-radio-box% this this
(mred->wx-container parent) (wrap-callback callback) (mred->wx-container parent) (wrap-callback callback)
label -1 -1 -1 -1 chcs 0 style)) label -1 -1 -1 -1 chcs 0 style (no-val->#f font)))
wx) wx)
(lambda () (lambda ()
(let ([cwho '(constructor radio-box)]) (let ([cwho '(constructor radio-box)])
@ -240,7 +246,8 @@
(check-container-parent cwho parent) (check-container-parent cwho parent)
(check-callback cwho callback) (check-callback cwho callback)
(check-slider-integer cwho init-value) (check-slider-integer cwho init-value)
(check-style cwho '(vertical horizontal) '(plain vertical-label horizontal-label deleted) style))) (check-style cwho '(vertical horizontal) '(plain vertical-label horizontal-label deleted) style)
(check-font cwho font)))
(private-field (private-field
[wx #f]) [wx #f])
(public (public
@ -260,7 +267,7 @@
(super-init (lambda () (super-init (lambda ()
(set! wx (make-object wx-slider% this this (set! wx (make-object wx-slider% this this
(mred->wx-container parent) (wrap-callback callback) (mred->wx-container parent) (wrap-callback callback)
label init-value minv maxv style)) label init-value minv maxv style (no-val->#f font)))
wx) wx)
(lambda () (lambda ()
(let ([cwho '(constructor slider)]) (let ([cwho '(constructor slider)])
@ -300,7 +307,7 @@
(super-init (lambda () (super-init (lambda ()
(set! wx (make-object wx-gauge% this this (set! wx (make-object wx-gauge% this this
(mred->wx-container parent) (mred->wx-container parent)
label range style)) label range style (no-val->#f font)))
wx) wx)
(lambda () (lambda ()
(let ([cwho '(constructor gauge)]) (let ([cwho '(constructor gauge)])
@ -419,10 +426,11 @@
(let ([cwho '(constructor choice)]) (let ([cwho '(constructor choice)])
(check-list-control-args cwho label choices parent callback) (check-list-control-args cwho label choices parent callback)
(check-style cwho #f '(vertical-label horizontal-label deleted) style) (check-style cwho #f '(vertical-label horizontal-label deleted) style)
(check-non-negative-integer cwho selection)) (check-non-negative-integer cwho selection)
(check-font cwho font))
(super-init (lambda () (make-object wx-choice% this this (super-init (lambda () (make-object wx-choice% this this
(mred->wx-container parent) (wrap-callback callback) (mred->wx-container parent) (wrap-callback callback)
label -1 -1 -1 -1 choices style)) label -1 -1 -1 -1 choices style (no-val->#f font)))
(lambda () (lambda ()
(let ([cwho '(constructor choice)]) (let ([cwho '(constructor choice)])
(check-container-ready cwho parent) (check-container-ready cwho parent)
@ -441,7 +449,8 @@
(let ([cwho '(constructor list-box)]) (let ([cwho '(constructor list-box)])
(check-list-control-args cwho label choices parent callback) (check-list-control-args cwho label choices parent callback)
(check-style cwho '(single multiple extended) '(vertical-label horizontal-label deleted) style) (check-style cwho '(single multiple extended) '(vertical-label horizontal-label deleted) style)
(check-non-negative-integer/false cwho selection))) (check-non-negative-integer/false cwho selection)
(check-font cwho font)))
(rename [super-append append]) (rename [super-append append])
(override (override
[append (entry-point [append (entry-point
@ -508,7 +517,7 @@
(set! wx (make-object wx-list-box% this this (set! wx (make-object wx-list-box% this this
(mred->wx-container parent) (wrap-callback callback) (mred->wx-container parent) (wrap-callback callback)
label kind label kind
-1 -1 -1 -1 choices style))) -1 -1 -1 -1 choices style (no-val->#f font))))
wx) wx)
(lambda () (lambda ()
(let ([cwho '(constructor list-box)]) (let ([cwho '(constructor list-box)])

15
collects/mred/private/mrpanel.ss
View File

@ -101,14 +101,15 @@
(define tab-panel% (define tab-panel%
(class100*/kw vertical-panel% () (class100*/kw vertical-panel% ()
[(choices parent callback [style null]) panel%-keywords] [(choices parent callback [style null] [font no-val]) panel%-keywords]
(sequence (sequence
(let ([cwho '(constructor tab-panel)]) (let ([cwho '(constructor tab-panel)])
(unless (and (list? choices) (andmap label-string? choices)) (unless (and (list? choices) (andmap label-string? choices))
(raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices)) (raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices))
(check-callback cwho callback) (check-callback cwho callback)
(check-container-parent cwho parent) (check-container-parent cwho parent)
(check-style cwho #f '(deleted no-border) style)) (check-style cwho #f '(deleted no-border) style)
(check-font cwho font))
(super-init parent (if (memq 'deleted style) (super-init parent (if (memq 'deleted style)
'(deleted) '(deleted)
null))) null)))
@ -117,7 +118,8 @@
[tabs (make-object tab-group% #f choices this (lambda (c e) (callback this e)) [tabs (make-object tab-group% #f choices this (lambda (c e) (callback this e))
(if (memq 'no-border style) (if (memq 'no-border style)
null null
'(border)))]) '(border))
font)])
(sequence (sequence
(send (mred->wx this) set-first-child-is-hidden)) (send (mred->wx this) set-first-child-is-hidden))
@ -182,12 +184,13 @@
(define group-box-panel% (define group-box-panel%
(class100*/kw vertical-panel% () (class100*/kw vertical-panel% ()
[(label parent [style null]) panel%-keywords] [(label parent [style null] [font no-val]) panel%-keywords]
(sequence (sequence
(let ([cwho '(constructor group-box-panel)]) (let ([cwho '(constructor group-box-panel)])
(check-label-string cwho label) (check-label-string cwho label)
(check-container-parent cwho parent) (check-container-parent cwho parent)
(check-style cwho #f '(deleted) style)) (check-style cwho #f '(deleted) style)
(check-font cwho font))
;; Technically a bad way to change margin defaults, since it's ;; Technically a bad way to change margin defaults, since it's
;; implemented with an update after creation: ;; implemented with an update after creation:
@ -199,7 +202,7 @@
null))) null)))
(private-field (private-field
[gbox (make-object group-box% label this null)] [gbox (make-object group-box% label this null font)]
[lbl label]) [lbl label])
(sequence (sequence
(send (mred->wx this) set-first-child-is-hidden)) (send (mred->wx this) set-first-child-is-hidden))

15
collects/mred/private/mrtextfield.ss
View File

@ -26,7 +26,8 @@
parent parent
callback callback
init-value init-value
style req-styles) style req-styles
font)
(check-label-string/false cwho label) (check-label-string/false cwho label)
(when choices? (when choices?
(unless (and (list? choices) (andmap label-string? choices)) (unless (and (list? choices) (andmap label-string? choices))
@ -39,7 +40,8 @@
(append (append
(if choices? null '(hscroll password)) (if choices? null '(hscroll password))
'(vertical-label horizontal-label deleted)) '(vertical-label horizontal-label deleted))
(remq combo-flag style))) (remq combo-flag style))
(check-font cwho font))
(define text-field% (define text-field%
(class100*/kw basic-control% () (class100*/kw basic-control% ()
@ -50,7 +52,8 @@
label label
#f #f #f #f
parent callback init-value parent callback init-value
style '(single multiple))) style '(single multiple)
font))
(private-field (private-field
[wx #f]) [wx #f])
(public (public
@ -73,7 +76,8 @@
label init-value label init-value
(if (memq combo-flag style) (if (memq combo-flag style)
(cons 'combo (remq combo-flag style)) (cons 'combo (remq combo-flag style))
style))) style)
(no-val->#f font)))
wx) wx)
(lambda () (lambda ()
(let ([cwho '(constructor text-field)]) (let ([cwho '(constructor text-field)])
@ -90,7 +94,8 @@
label label
#f choices #f choices
parent callback init-value parent callback init-value
style #f)) style #f
font))
(public (public
[on-popup (lambda (e) [on-popup (lambda (e)
(let-values ([(w h) (get-size)] (let-values ([(w h) (get-size)]

32
collects/mred/private/wxitem.ss
View File

@ -218,7 +218,7 @@
#f #f)) #f #f))
(define wx-button% (make-window-glue% (define wx-button% (make-window-glue%
(class100 (make-simple-control% wx:button%) (parent cb label x y w h style) (class100 (make-simple-control% wx:button%) (parent cb label x y w h style font)
(inherit command) (inherit command)
(private-field [border? (memq 'border style)]) (private-field [border? (memq 'border style)])
(public [has-border? (lambda () border?)]) (public [has-border? (lambda () border?)])
@ -227,8 +227,8 @@
(as-exit (as-exit
(lambda () (lambda ()
(command (make-object wx:control-event% 'button)))))]) (command (make-object wx:control-event% 'button)))))])
(sequence (super-init style parent cb label x y w h style))))) (sequence (super-init style parent cb label x y w h style font)))))
(define wx-check-box% (class100 (make-window-glue% (make-simple-control% wx:check-box%)) (mred proxy parent cb label x y w h style) (define wx-check-box% (class100 (make-window-glue% (make-simple-control% wx:check-box%)) (mred proxy parent cb label x y w h style font)
(inherit set-value get-value command) (inherit set-value get-value command)
(override (override
[char-to (lambda () [char-to (lambda ()
@ -236,24 +236,24 @@
(lambda () (lambda ()
(set-value (not (get-value))) (set-value (not (get-value)))
(command (make-object wx:control-event% 'check-box)))))]) (command (make-object wx:control-event% 'check-box)))))])
(sequence (super-init mred proxy style parent cb label x y w h style)))) (sequence (super-init mred proxy style parent cb label x y w h style font))))
(define wx-choice% (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style) (define wx-choice% (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font)
(override (override
[handles-key-code [handles-key-code
(lambda (x alpha? meta?) (lambda (x alpha? meta?)
(or (memq x '(up down)) (or (memq x '(up down))
(and alpha? (not meta?))))]) (and alpha? (not meta?))))])
(sequence (super-init mred proxy style parent cb label x y w h choices style)))) (sequence (super-init mred proxy style parent cb label x y w h choices style font))))
(define wx-message% (class100 (make-window-glue% (make-simple-control% wx:message%)) (mred proxy parent label x y style) (define wx-message% (class100 (make-window-glue% (make-simple-control% wx:message%)) (mred proxy parent label x y style font)
(override [gets-focus? (lambda () #f)]) (override [gets-focus? (lambda () #f)])
(sequence (super-init mred proxy style parent label x y style)))) (sequence (super-init mred proxy style parent label x y style font))))
(define wx-gauge% (define wx-gauge%
(make-window-glue% (make-window-glue%
(class100 (make-control% wx:gauge% (class100 (make-control% wx:gauge%
const-default-x-margin const-default-y-margin const-default-x-margin const-default-y-margin
#f #f) #f #f)
(parent label range style) (parent label range style font)
(inherit get-client-size get-width get-height set-size (inherit get-client-size get-width get-height set-size
stretchable-in-x stretchable-in-y set-min-height set-min-width stretchable-in-x stretchable-in-y set-min-height set-min-width
get-parent) get-parent)
@ -262,7 +262,7 @@
;; # pixels per unit of value. ;; # pixels per unit of value.
[pixels-per-value 1]) [pixels-per-value 1])
(sequence (sequence
(super-init style parent label range -1 -1 -1 -1 style) (super-init style parent label range -1 -1 -1 -1 style font)
(let-values ([(client-width client-height) (get-two-int-values (let-values ([(client-width client-height) (get-two-int-values
(lambda (a b) (get-client-size a b)))]) (lambda (a b) (get-client-size a b)))])
@ -303,7 +303,7 @@
(make-window-glue% (make-window-glue%
(class100 (make-control% wx:list-box% (class100 (make-control% wx:list-box%
const-default-x-margin const-default-y-margin const-default-x-margin const-default-y-margin
#t #t) (parent cb label kind x y w h choices style) #t #t) (parent cb label kind x y w h choices style font)
(inherit get-first-item (inherit get-first-item
set-first-visible-item) set-first-visible-item)
(private (private
@ -328,11 +328,11 @@
[(wheel-up) (scroll -1) #t] [(wheel-up) (scroll -1) #t]
[(wheel-down) (scroll 1) #t] [(wheel-down) (scroll 1) #t]
[else #f])))]) [else #f])))])
(sequence (super-init style parent cb label kind x y w h choices style))))) (sequence (super-init style parent cb label kind x y w h choices style font)))))
(define wx-radio-box% (define wx-radio-box%
(make-window-glue% (make-window-glue%
(class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style) (class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font)
(inherit number orig-enable set-selection command) (inherit number orig-enable set-selection command)
(override (override
[enable [enable
@ -356,7 +356,7 @@
(set-selection i) (set-selection i)
(command (make-object wx:control-event% 'radio-box)))))]) (command (make-object wx:control-event% 'radio-box)))))])
(sequence (super-init style parent cb label x y w h choices major style)) (sequence (super-init style parent cb label x y w h choices major style font))
(private-field [enable-vector (make-vector (number) #t)])))) (private-field [enable-vector (make-vector (number) #t)]))))
@ -365,7 +365,7 @@
(class100 (make-control% wx:slider% (class100 (make-control% wx:slider%
const-default-x-margin const-default-y-margin const-default-x-margin const-default-y-margin
#f #f) #f #f)
(parent func label value min-val max-val style) (parent func label value min-val max-val style font)
(inherit set-min-width set-min-height stretchable-in-x stretchable-in-y (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y
get-client-size get-width get-height get-parent) get-client-size get-width get-height get-parent)
(private-field (private-field
@ -376,7 +376,7 @@
;; which looks bad. ;; which looks bad.
(sequence (sequence
(super-init style parent func label value min-val max-val -1 -1 -1 style) (super-init style parent func label value min-val max-val -1 -1 -1 style font)
(let-values ([(client-w client-h) (get-two-int-values (lambda (a b) (let-values ([(client-w client-h) (get-two-int-values (lambda (a b)
(get-client-size a b)))]) (get-client-size a b)))])

22
collects/mred/private/wxtextfield.ss
View File

@ -6,6 +6,7 @@
"const.ss" "const.ss"
"check.ss" "check.ss"
"helper.ss" "helper.ss"
"gdi.ss"
"wx.ss" "wx.ss"
"wxwindow.ss" "wxwindow.ss"
"wxitem.ss" "wxitem.ss"
@ -67,11 +68,12 @@
(super-init mred proxy parent -1 -1 100 30 #f style 100 #f)))) (super-init mred proxy parent -1 -1 100 30 #f style 100 #f))))
(define wx-text-field% (define wx-text-field%
(class100 wx-horizontal-panel% (mred proxy parent fun label value style) (class100 wx-horizontal-panel% (mred proxy parent fun label value style _font)
;; Make text field first because we'll have to exit ;; Make text field first because we'll have to exit
;; for keymap initializer ;; for keymap initializer
(private-field (private-field
[func fun] [func fun]
[font (or _font normal-control-font)]
[without-callback #f] [without-callback #f]
[callback-ready #f] [callback-ready #f]
[e (make-object text-field-text% [e (make-object text-field-text%
@ -88,7 +90,7 @@
(as-exit (as-exit
(lambda () (lambda ()
((current-text-keymap-initializer) (send e get-keymap))))) ((current-text-keymap-initializer) (send e get-keymap)))))
(inherit alignment stretchable-in-y get-control-font area-parent (inherit alignment stretchable-in-y area-parent
get-min-size set-min-width set-min-height) get-min-size set-min-width set-min-height)
(rename [super-place-children place-children]) (rename [super-place-children place-children])
(public (public
@ -146,7 +148,7 @@
(unless multi? (stretchable-in-y #f))) (unless multi? (stretchable-in-y #f)))
(private-field (private-field
[l (and label [l (and label
(make-object wx-message% #f proxy p label -1 -1 null))] (make-object wx-message% #f proxy p label -1 -1 null font))]
[c (make-object wx-text-editor-canvas% #f proxy this p [c (make-object wx-text-editor-canvas% #f proxy this p
(append (append
'(control-border) '(control-border)
@ -166,7 +168,7 @@
(send e set-line-spacing 0) (send e set-line-spacing 0)
(send e set-paste-text-only #t) (send e set-paste-text-only #t)
(send e auto-wrap (and multi? (not (memq 'hscroll style)))) (send e auto-wrap (and multi? (not (memq 'hscroll style))))
(let ([f (get-control-font)] (let ([f font]
[s (send (send e get-style-list) find-named-style "Standard")]) [s (send (send e get-style-list) find-named-style "Standard")])
(send s set-delta (let ([d (font->delta f)]) (send s set-delta (let ([d (font->delta f)])
(if (memq 'password style) (if (memq 'password style)
@ -188,28 +190,28 @@
[hbox (box 0)] [hbox (box 0)]
[ybox (box 0)] [ybox (box 0)]
[abox (box 0)]) [abox (box 0)])
; To bottom of first line ;; To bottom of first line
(send (send e get-admin) get-dc #f ybox) (send (send e get-admin) get-dc #f ybox)
(set! dy (+ (abs (unbox ybox)) (send e line-location 0 #f))) (set! dy (+ (abs (unbox ybox)) (send e line-location 0 #f)))
; Add diff for client size ;; Add diff for client size
(send c get-client-size wbox hbox) (send c get-client-size wbox hbox)
(let ([d (- (send c get-height) (unbox hbox))]) (let ([d (- (send c get-height) (unbox hbox))])
(set! dy (+ dy (quotient d 2)))) (set! dy (+ dy (quotient d 2))))
; Subtract descent of canvas-drawn text ;; Subtract descent of canvas-drawn text
(let ([font (send (send (send e get-style-list) find-named-style "Standard") get-font)]) (let ([font (send (send (send e get-style-list) find-named-style "Standard") get-font)])
(send c get-text-extent "hi" wbox hbox ybox #f font) (send c get-text-extent "hi" wbox hbox ybox #f font)
(set! dy (- dy (unbox ybox)))) (set! dy (- dy (unbox ybox))))
; Subtract ascent of label ;; Subtract ascent of label
(send l get-text-extent "hi" wbox hbox ybox abox) (send l get-text-extent "hi" wbox hbox ybox abox)
(set! dy (- dy (- (unbox hbox) (unbox ybox)))) (set! dy (- dy (- (unbox hbox) (unbox ybox))))
; Subtract space above label ;; Subtract space above label
(set! dy (- dy (quotient (- (send l get-height) (unbox hbox)) 2))) (set! dy (- dy (quotient (- (send l get-height) (unbox hbox)) 2)))
; Exact ;; Exact
(set! dy (inexact->exact dy)))) (set! dy (inexact->exact dy))))
(when value (when value