diff --git a/collects/mred/private/editor.ss b/collects/mred/private/editor.ss index 894dedf7..a3b13cb4 100644 --- a/collects/mred/private/editor.ss +++ b/collects/mred/private/editor.ss @@ -409,7 +409,8 @@ ((void) on-set-size-constraint) ((void) after-set-size-constraint) ((void) after-split-snip s) - ((void) after-merge-snips s)) + ((void) after-merge-snips s) + ((void) on-reflow)) (super-make-object line-spacing tab-stops) (when aw? diff --git a/collects/mred/private/gdi.ss b/collects/mred/private/gdi.ss index be4426a3..6c7cdb59 100644 --- a/collects/mred/private/gdi.ss +++ b/collects/mred/private/gdi.ss @@ -181,7 +181,8 @@ (define get-window-text-extent (let ([bm #f][dc #f]) (case-lambda - [(string font) + [(string font) (get-window-text-extent string font #f)] + [(string font combine?) (check-string 'get-window-text-extent string) (check-instance 'get-window-text-extent wx:font% 'font% #f font) (unless bm @@ -190,7 +191,7 @@ (send dc set-bitmap bm)) (unless (send bm ok?) (error 'get-window-text-extent "couldn't allocate sizing bitmap")) - (let-values ([(w h d a) (send dc get-text-extent string font)]) + (let-values ([(w h d a) (send dc get-text-extent string font combine?)]) (values (inexact->exact w) (inexact->exact h)))]))) diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index 0d0da4a7..fd96e820 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -809,6 +809,7 @@ set-clickback set-wordbreak-func set-autowrap-bitmap + on-reflow on-new-tab-snip on-new-string-snip caret-hidden? diff --git a/collects/mred/private/mritem.ss b/collects/mred/private/mritem.ss index b2f5f3f2..226d144d 100644 --- a/collects/mred/private/mritem.ss +++ b/collects/mred/private/mritem.ss @@ -6,6 +6,7 @@ "lock.ss" "const.ss" "kw.ss" + "gdi.ss" "check.ss" "helper.ss" "wx.ss" @@ -97,10 +98,53 @@ (cb (wx->proxy w) e))) cb)) + (define zero-bitmap #f) + (define message% - (class100*/kw basic-control% () [(label parent [style null]) control%-keywords] + (class100*/kw basic-control% () [(label parent [style null]) control%-keywords [auto-resize #f]] + (sequence ; abuse of `sequence'! + (inherit/super [super-min-width min-width] + [super-min-height min-height] + [super-get-label get-label] + [super-get-font get-font])) + (private-field + [do-auto-resize? auto-resize] + [orig-font (or (no-val->#f font) + normal-control-font)] + [dx 0] + [dy 0]) (override - [label-checker (lambda () check-label-string-or-bitmap)]) ; module-local method + [label-checker (lambda () check-label-string-or-bitmap)] ; module-local method + [set-label (entry-point + (lambda (l) + (super set-label l) + (when do-auto-resize? + (do-auto-resize))))]) + (private + [strip-amp (lambda (s) (if (string? s) + (regexp-replace* #rx"&(.)" s "\\1") + s))] + [do-auto-resize (lambda () + (let ([s (strip-amp (super-get-label))]) + (cond + [(symbol? s) (void)] + [(string? s) + (let-values ([(mw mh) (get-window-text-extent s orig-font #t)]) + (super-min-width (+ dx mw)) + (super-min-height (+ dy mh)))] + [(s . is-a? . wx:bitmap%) + (super-min-width (+ dx (send s get-width))) + (super-min-height (+ dy (send s get-height)))])))]) + (public + [(auto-resize-parm auto-resize) + (case-lambda + [() do-auto-resize?] + [(on?) + (as-entry + (lambda () + (set! do-auto-resize? (and #t)) + (when on? + (do-auto-resize))))])]) (sequence (let ([cwho '(constructor message)]) (check-label-string/bitmap/iconsym cwho label) @@ -109,13 +153,51 @@ (check-font cwho font)) (as-entry (lambda () - (super-init (lambda () (make-object wx-message% this this - (mred->wx-container parent) - label -1 -1 style (no-val->#f font))) + (super-init (lambda () + (let ([m (make-object wx-message% this this + (mred->wx-container parent) + (if do-auto-resize? + (cond + [(string? label) ""] + [(label . is-a? . wx:bitmap%) + (unless zero-bitmap + (set! zero-bitmap (make-object wx:bitmap% 1 1))) + zero-bitmap] + [else label]) + label) + -1 -1 style (no-val->#f font))]) + ;; Record dx & dy: + (let ([w (box 0)] [h (box 0)]) + (send m get-size w h) + (let-values ([(mw mh) (cond + [(string? label) + (let ([s (if do-auto-resize? + "" + (strip-amp label))] + [font orig-font]) + (if (equal? s "") + (let-values ([(w h) (get-window-text-extent " " font)]) + (values 0 h)) + (get-window-text-extent s font)))] + [(label . is-a? . wx:bitmap%) + (if do-auto-resize? + (values 1 1) + (values (send label get-width) + (send label get-height)))] + [else (values 0 0)])]) + (set! dx (- (unbox w) mw)) + (set! dy (- (unbox h) mh)))) + ;; If auto-resize, install label now: + (when (and do-auto-resize? + (not (symbol? label))) + (send m set-label label)) + m)) (lambda () (let ([cwho '(constructor message)]) (check-container-ready cwho parent))) - label parent void #f)))))) + label parent void #f) + (when do-auto-resize? + (do-auto-resize))))))) (define button% (class100*/kw basic-control% () [(label parent [callback (lambda (b e) (void))] [style null]) control%-keywords] diff --git a/collects/scribblings/gui/button-class.scrbl b/collects/scribblings/gui/button-class.scrbl index ab4aac5d..6065cf4b 100644 --- a/collects/scribblings/gui/button-class.scrbl +++ b/collects/scribblings/gui/button-class.scrbl @@ -12,7 +12,7 @@ Whenever a button is clicked by the user, the button's callback (is-a?/c panel%) (is-a?/c pane%))] [callback ((is-a?/c button%) (is-a?/c control-event%) . -> . any) (lambda (b e) (void))] [style (one-of/c 'border 'deleted) null] - [font (is-a?/c font%) @scheme[normal-control-font]] + [font (is-a?/c font%) normal-control-font] [enabled any/c #t] [vert-margin (integer-in 0 1000) 2] [horiz-margin (integer-in 0 1000) 2] diff --git a/collects/scribblings/gui/check-box-class.scrbl b/collects/scribblings/gui/check-box-class.scrbl index f2aeb059..c701b94a 100644 --- a/collects/scribblings/gui/check-box-class.scrbl +++ b/collects/scribblings/gui/check-box-class.scrbl @@ -19,7 +19,7 @@ Whenever a check box is clicked by the user, the check box's value is [callback ((is-a?/c check-box%) (is-a?/c control-event%) . -> . any) (lambda (c e) (void))] [style (listof (one-of/c 'deleted)) null] [value any/c #f] - [font (is-a?/c font%) @scheme[normal-control-font]] + [font (is-a?/c font%) normal-control-font] [enabled any/c #t] [vert-margin (integer-in 0 1000) 2] [horiz-margin (integer-in 0 1000) 2] diff --git a/collects/scribblings/gui/choice-class.scrbl b/collects/scribblings/gui/choice-class.scrbl index 0b80212d..ba154348 100644 --- a/collects/scribblings/gui/choice-class.scrbl +++ b/collects/scribblings/gui/choice-class.scrbl @@ -26,7 +26,7 @@ See also 'deleted)) null] [selection nonnegative-exact-integer? 0] - [font (is-a?/c font%) @scheme[normal-control-font]] + [font (is-a?/c font%) normal-control-font] [enabled any/c #t] [vert-margin (integer-in 0 1000) 2] [horiz-margin (integer-in 0 1000) 2] diff --git a/collects/scribblings/gui/combo-field-class.scrbl b/collects/scribblings/gui/combo-field-class.scrbl index 1462aafb..fcbbbe41 100644 --- a/collects/scribblings/gui/combo-field-class.scrbl +++ b/collects/scribblings/gui/combo-field-class.scrbl @@ -22,7 +22,7 @@ A @scheme[combo-field%] object is a @scheme[text-field%] [style (listof (one-of/c 'horizontal-label 'vertical-label 'deleted)) null] - [font (is-a?/c font%) @scheme[normal-control-font]] + [font (is-a?/c font%) normal-control-font] [enabled any/c #t] [vert-margin (integer-in 0 1000) 2] [horiz-margin (integer-in 0 1000) 2] diff --git a/collects/scribblings/gui/gauge-class.scrbl b/collects/scribblings/gui/gauge-class.scrbl index cca9d21c..a9f1f4a0 100644 --- a/collects/scribblings/gui/gauge-class.scrbl +++ b/collects/scribblings/gui/gauge-class.scrbl @@ -18,7 +18,7 @@ of the gauge. 'vertical-label 'horizontal-label 'deleted)) '(horizontal)] - [font (is-a?/c font%) @scheme[normal-control-font]] + [font (is-a?/c font%) normal-control-font] [enabled any/c #t] [vert-margin (integer-in 0 1000) 2] [horiz-margin (integer-in 0 1000) 2] diff --git a/collects/scribblings/gui/group-box-panel-class.scrbl b/collects/scribblings/gui/group-box-panel-class.scrbl index f3f0371b..4f7593ef 100644 --- a/collects/scribblings/gui/group-box-panel-class.scrbl +++ b/collects/scribblings/gui/group-box-panel-class.scrbl @@ -15,7 +15,7 @@ Unlike most panel classes, a group-box panel's horizontal and vertical [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) (is-a?/c panel%) (is-a?/c pane%))] [style (listof (one-of/c 'deleted)) null] - [font (is-a?/c font%) @scheme[small-control-font]] + [font (is-a?/c font%) small-control-font] [enabled any/c #t] [vert-margin (integer-in 0 1000) 2] [horiz-margin (integer-in 0 1000) 2] diff --git a/collects/scribblings/gui/list-box-class.scrbl b/collects/scribblings/gui/list-box-class.scrbl index 60c12844..c9600c83 100644 --- a/collects/scribblings/gui/list-box-class.scrbl +++ b/collects/scribblings/gui/list-box-class.scrbl @@ -33,8 +33,8 @@ See also @scheme[choice%]. 'deleted)) '(single)] [selection (or/c nonnegative-exact-integer? false/c) #f] - [font (is-a?/c font%) @scheme[view-control-font]] - [label-font (is-a?/c font%) @scheme[normal-control-font]] + [font (is-a?/c font%) view-control-font] + [label-font (is-a?/c font%) normal-control-font] [enabled any/c #t] [vert-margin (integer-in 0 1000) 2] [horiz-margin (integer-in 0 1000) 2] diff --git a/collects/scribblings/gui/message-class.scrbl b/collects/scribblings/gui/message-class.scrbl index 64419877..f3aa0693 100644 --- a/collects/scribblings/gui/message-class.scrbl +++ b/collects/scribblings/gui/message-class.scrbl @@ -13,14 +13,15 @@ A message control is a static line of text or a static bitmap. The [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) (is-a?/c panel%) (is-a?/c pane%))] [style (listof (one-of/c 'deleted)) null] - [font (is-a?/c font%) @scheme[normal-control-font]] + [font (is-a?/c font%) normal-control-font] [enabled any/c #t] [vert-margin (integer-in 0 1000) 2] [horiz-margin (integer-in 0 1000) 2] [min-width (integer-in 0 10000) _graphical-minimum-width] [min-height (integer-in 0 10000) _graphical-minimum-height] [stretchable-width any/c #f] - [stretchable-height any/c #f])]{ + [stretchable-height any/c #f] + [auto-resize any/c #f])]{ Creates a string or bitmap message initially showing @scheme[label]. @bitmaplabeluse[label] An @indexed-scheme['app], @@ -36,6 +37,20 @@ Creates a string or bitmap message initially showing @scheme[label]. @FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[] +If @scheme[auto-resize] is not @scheme[#f], then automatic resizing is +initially enanbled (see @method[message% auto-resize]), and the +@scheme[message%] object's @tech{graphical minimum size} is as small as +possible. + +} + +@defmethod*[([(auto-resize) boolean?] + [(auto-resize [on? any/c]) void?])]{ + +Reports or sets whether the @scheme[message%]'s @method[area<%> min-width] and +@method[area<%> min-height] are automatically set when the label is changed +via @method[message% set-label]. + } @defmethod[#:mode override diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index 4631d557..c68b4684 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -186,14 +186,16 @@ following expression gets a command line for starting a browser: See also @scheme[write-resource].} @defproc[(get-window-text-extent [string string] - [font (is-a?/c font%)]) + [font (is-a?/c font%)] + [combine? any/c #f]) (values nonnegative-exact-integer? nonnegative-exact-integer?)]{ Returns the pixel size of a string drawn as a window's label or value -when drawn with the given font. +when drawn with the given font. The optional @scheme[combine?] +argument is as for @xmethod[dc<%> get-text-extent]. -See also @method[dc<%> get-text-extent]. +See also @xmethod[dc<%> get-text-extent]. } @defproc[(graphical-read-eval-print-loop [eval-eventspace eventspace #f] diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl index 275b6688..a80d59cb 100644 --- a/collects/scribblings/gui/text-class.scrbl +++ b/collects/scribblings/gui/text-class.scrbl @@ -1456,6 +1456,18 @@ Returns a @scheme[tab-snip%] instance. }} +@defmethod[#:mode pubment + (on-reflow) + void?]{ + +@methspec{ +Called after @tech{locations} have changed and are recomputed for the editor. +} +@methimpl{ + +Does nothing. +}} + @defmethod[#:mode pubment (on-set-size-constraint) void?]{ diff --git a/collects/scribblings/gui/text-field-class.scrbl b/collects/scribblings/gui/text-field-class.scrbl index e8d1140b..3456d20a 100644 --- a/collects/scribblings/gui/text-field-class.scrbl +++ b/collects/scribblings/gui/text-field-class.scrbl @@ -47,7 +47,7 @@ The keymap for the text field's editor is initialized by calling the 'vertical-label 'horizontal-label 'deleted)) '(single)] - [font (is-a?/c font%) @scheme[normal-control-font]] + [font (is-a?/c font%) normal-control-font] [enabled any/c #t] [vert-margin (integer-in 0 1000) 2] [horiz-margin (integer-in 0 1000) 2] diff --git a/collects/tests/mred/item.ss b/collects/tests/mred/item.ss index cfe7a5f7..25fe3a15 100644 --- a/collects/tests/mred/item.ss +++ b/collects/tests/mred/item.ss @@ -338,6 +338,10 @@ (sequence (apply super-init name args)))) +(define (auto-mixin c% v) + (class c% + (super-new [auto-resize v]))) + (define return-bmp (make-object bitmap2% (icons-path "return.xbm") 'xbm)) (define bb-bmp @@ -352,7 +356,7 @@ (cons 'vertical-label l) l)) -(define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy? alt-inits? font) +(define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy? alt-inits? msg-auto? font) (define-values (l il) (let ([p (make-object horizontal-panel% ip)]) @@ -360,8 +364,8 @@ (send p stretchable-height stretchy?) (let () - (define l (make-object (trace-mixin message%) "L\u03B9&st" #;"Messag&\u03A3" p null ($ font))) ; \u03A3 is eta - (define il (make-object (trace-mixin message%) return-bmp p null ($ font))) + (define l (make-object (trace-mixin (auto-mixin message% msg-auto?)) "L\u03B9&st" p null ($ font))) + (define il (make-object (trace-mixin (auto-mixin message% msg-auto?)) return-bmp p null ($ font))) (add-testers "Message" l) (add-change-label "Message" l lp #f OTHER-LABEL) @@ -544,7 +548,7 @@ (define float-frame? #f) (define no-caption? #f) -(define (big-frame h-radio? v-label? null-label? stretchy? font initially-disabled? alternate-init?) +(define (big-frame h-radio? v-label? null-label? stretchy? font initially-disabled? alternate-init? msg-auto?) (define f (make-frame (if use-dialogs? active-dialog% active-frame%) @@ -586,7 +590,7 @@ (send tp set-label "Sub-sub panel") (add-testers "Sub-sub-panel" tp) - (let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy? alternate-init? font)]) + (let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy? alternate-init? msg-auto? font)]) (add-focus-note f ep) (send f set-info ep) @@ -598,7 +602,7 @@ (set! prev-frame f) f) -(define (med-frame plain-slider? label-h? null-label? stretchy? font initially-disabled? alternate-init?) +(define (med-frame plain-slider? label-h? null-label? stretchy? font initially-disabled? alternate-init? msg-auto?) (define f2 (make-frame (if use-dialogs? active-dialog% active-frame%) @@ -2218,7 +2222,7 @@ (lambda (b e) (choose-next l))))) (define make-selector-and-runner - (lambda (p1 p2 radios? size maker) + (lambda (p1 p2 radios? msg? size maker) (define (make-radio-box lbl choices panel cb) (let ([g (instantiate group-box-panel% (lbl panel))]) (if (= (length choices) 2) @@ -2265,10 +2269,19 @@ special-font) (send font-radio get-selection)) (positive? (send enabled-radio get-selection)) - (positive? (send selection-radio get-selection)))))) + (positive? (send selection-radio get-selection)) + (and message-auto + (send message-auto get-value)))))) + + (define message-auto + (and msg? + (new check-box% + [parent p2] + [label "Auto-Size Message"]))) + #t)) -(make-selector-and-runner bp1 bp2 #t "Big" big-frame) -(make-selector-and-runner mp1 mp2 #f "Medium" med-frame) +(make-selector-and-runner bp1 bp2 #t #t "Big" big-frame) +(make-selector-and-runner mp1 mp2 #f #f "Medium" med-frame) (send selector show #t)