diff --git a/collects/framework/private/canvas.ss b/collects/framework/private/canvas.ss index 1fa2e249..3c319e6d 100644 --- a/collects/framework/private/canvas.ss +++ b/collects/framework/private/canvas.ss @@ -11,7 +11,8 @@ (unit/sig framework:canvas^ (import mred^ [preferences : framework:preferences^] - [frame : framework:frame^]) + [frame : framework:frame^] + [text : framework:text^]) (rename [-color% color%]) @@ -71,111 +72,111 @@ add-wide-snip add-tall-snip)) - ;; wx: this needs to collude with - ;; the edit, since the edit has the right callbacks. (define wide-snip-mixin (mixin (basic<%>) (wide-snip<%>) (inherit get-editor) - [define wide-snips null] - [define tall-snips null] - [define update-snip-size - (lambda (width?) - (lambda (s) - (let* ([width (box 0)] - [height (box 0)] - [leftm (box 0)] - [rightm (box 0)] - [topm (box 0)] - [bottomm (box 0)] - [left-edge-box (box 0)] - [top-edge-box (box 0)] - [snip-media (send s get-editor)] - [edit (get-editor)] - [get-width - (let ([bl (box 0)] - [br (box 0)]) - (lambda (s) - (send edit get-snip-location s bl #f #f) - (send edit get-snip-location s br #f #t) - (- (unbox br) (unbox bl))))] - [calc-after-width - (lambda (s) - (+ 4 ;; this is compensate for an autowrapping bug - (let loop ([s s]) - (cond - [(not s) 0] - [(member 'hard-newline (send s get-flags)) 0] - [(member 'newline (send s get-flags)) 0] - [else - (if s - (+ (get-width s) - 2 ;; for the caret - (loop (send s next))) - 0)]))))]) - (when edit - (send edit - run-after-edit-sequence - (lambda () - (let ([admin (send edit get-admin)]) - (send admin get-view #f #f width height) - (send s get-margin leftm topm rightm bottomm) - - - ;; when the width is to be maximized and there is a - ;; newline just behind the snip, we know that the left - ;; edge is zero. Special case for efficiency in the - ;; console printer - (let ([fallback - (lambda () - (send edit get-snip-location - s left-edge-box top-edge-box))]) - (cond - [(not width?) (fallback)] - [(let ([prev (send s previous)]) - (and prev - (member 'hard-newline (send prev get-flags)))) - (set-box! left-edge-box 0)] - [else (fallback)])) - - (if width? - (let* ([after-width (calc-after-width (send s next))] - [snip-width (max 0 (- (unbox width) - (unbox left-edge-box) - (unbox leftm) - (unbox rightm) - after-width - ;; this two is the space that - ;; the caret needs at the right of - ;; a buffer. - 2))]) - (send* s - (set-min-width snip-width) - (set-max-width snip-width)) - (when snip-media - (send snip-media set-max-width - (if (send snip-media auto-wrap) - snip-width - 0)))) - (let ([snip-height (max 0 (- (unbox height) - (unbox top-edge-box) - (unbox topm) - (unbox bottomm)))]) - (send* s - (set-min-height snip-height) - (set-max-height snip-height)))))))))))] - (public recalc-snips add-wide-snip add-tall-snip) - [define recalc-snips - (lambda () - (for-each (update-snip-size #t) wide-snips) - (for-each (update-snip-size #f) tall-snips))] - [define add-wide-snip - (lambda (snip) - (set! wide-snips (cons snip wide-snips)) - ((update-snip-size #t) snip))] - [define add-tall-snip - (lambda (snip) - (set! tall-snips (cons snip tall-snips)) - ((update-snip-size #f) snip))] + (define/private ((update-snip-size width?) s) + (let* ([width (box 0)] + [height (box 0)] + [leftm (box 0)] + [rightm (box 0)] + [topm (box 0)] + [bottomm (box 0)] + [left-edge-box (box 0)] + [top-edge-box (box 0)] + [snip-media (send s get-editor)] + [edit (get-editor)] + [get-width + (let ([bl (box 0)] + [br (box 0)]) + (lambda (s) + (send edit get-snip-location s bl #f #f) + (send edit get-snip-location s br #f #t) + (- (unbox br) (unbox bl))))] + [calc-after-width + (lambda (s) + (+ 4 ;; this is compensate for an autowrapping bug + (let loop ([s s]) + (cond + [(not s) 0] + [(member 'hard-newline (send s get-flags)) 0] + [(member 'newline (send s get-flags)) 0] + [else + (if s + (+ (get-width s) + 2 ;; for the caret + (loop (send s next))) + 0)]))))]) + (when edit + (send edit + run-after-edit-sequence + (lambda () + (let ([admin (send edit get-admin)]) + (send admin get-view #f #f width height) + (send s get-margin leftm topm rightm bottomm) + + + ;; when the width is to be maximized and there is a + ;; newline just behind the snip, we know that the left + ;; edge is zero. Special case for efficiency in the + ;; console printer + (let ([fallback + (lambda () + (send edit get-snip-location + s left-edge-box top-edge-box))]) + (cond + [(not width?) (fallback)] + [(let ([prev (send s previous)]) + (and prev + (member 'hard-newline (send prev get-flags)))) + (set-box! left-edge-box 0)] + [else (fallback)])) + + (if width? + (let* ([after-width (calc-after-width (send s next))] + [snip-width (max 0 (- (unbox width) + (unbox left-edge-box) + (unbox leftm) + (unbox rightm) + after-width + ;; this two is the space that + ;; the caret needs at the right of + ;; a buffer. + 2))]) + (send* s + (set-min-width snip-width) + (set-max-width snip-width)) + (when snip-media + (send snip-media set-max-width + (if (send snip-media auto-wrap) + snip-width + 0)))) + (let ([snip-height (max 0 (- (unbox height) + (unbox top-edge-box) + (unbox topm) + (unbox bottomm)))]) + (send* s + (set-min-height snip-height) + (set-max-height snip-height)))))))))) + (define/public (recalc-snips) + (let ([editor (get-editor)]) + (unless (is-a? editor text:wide-snip<%>) + (error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor)) + (when (eq? (send editor get-canvas) this) + (for-each (update-snip-size #t) (send editor get-wide-snips)) + (for-each (update-snip-size #f) (send editor get-tall-snips))))) + (define/public (add-wide-snip snip) + (let ([editor (get-editor)]) + (unless (is-a? editor text:wide-snip<%>) + (error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor)) + (send editor add-wide-snip snip)) + ((update-snip-size #t) snip)) + (define/public (add-tall-snip snip) + (let ([editor (get-editor)]) + (unless (is-a? editor text:wide-snip<%>) + (error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor)) + (send editor add-tall-snip snip)) + ((update-snip-size #f) snip)) (define/override (on-size width height) (recalc-snips) (super on-size width height)) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 31be22ec..79814a24 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -300,6 +300,7 @@ hide-caret/selection<%> nbsp->space<%> delegate<%> + wide-snip<%> searching<%> return<%> info<%> @@ -327,6 +328,7 @@ foreground-color-mixin hide-caret/selection-mixin nbsp->space-mixin + wide-snip-mixin delegate-mixin searching-mixin return-mixin diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 79169f0b..9b25cf60 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -429,7 +429,22 @@ WARNING: printf is rebound in the body of the unit to always (char=? cr-code code)) (return)) (super on-local-char key)))) - (super-instantiate ()))) + (super-new))) + + (define wide-snip<%> + (interface (basic<%>) + add-wide-snip + add-tall-snip)) + + (define wide-snip-mixin + (mixin (basic<%>) (wide-snip<%>) + (define wide-snips '()) + (define tall-snips '()) + (define/public (add-wide-snip s) (set! wide-snips (cons s wide-snips))) + (define/public (get-wide-snips) wide-snips) + (define/public (add-tall-snip s) (set! tall-snips (cons s tall-snips))) + (define/public (get-tall-snips) tall-snips) + (super-new))) (define delegate<%> (interface (basic<%>) get-delegate @@ -1772,7 +1787,7 @@ WARNING: printf is rebound in the body of the unit to always (define hide-caret/selection% (hide-caret/selection-mixin basic%)) (define nbsp->space% (nbsp->space-mixin basic%)) (define delegate% (delegate-mixin basic%)) - (define standard-style-list% (editor:standard-style-list-mixin basic%)) + (define standard-style-list% (editor:standard-style-list-mixin (wide-snip-mixin basic%))) (define -keymap% (editor:keymap-mixin standard-style-list%)) (define return% (return-mixin -keymap%)) (define autowrap% (editor:autowrap-mixin -keymap%))