From 614c0a9e8db5fe741f5a053c217c90dd777e6e7f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 29 Mar 2001 21:45:05 +0000 Subject: [PATCH] no message original commit: 4398b7e60e92fd77bf49d28429dadf08b8b9f2d4 --- collects/framework/private/editor.ss | 14 +- collects/framework/private/frame.ss | 4 - .../{ => private}/gen-standard-menus.ss | 0 collects/framework/private/group.ss | 2 +- collects/framework/private/scheme.ss | 245 +++--- collects/framework/private/text.ss | 790 +++++++++--------- 6 files changed, 534 insertions(+), 521 deletions(-) rename collects/framework/{ => private}/gen-standard-menus.ss (100%) mode change 100755 => 100644 diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 3f2d2a4a..dd8e40f4 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -109,7 +109,7 @@ (rename [super-begin-edit-sequence begin-edit-sequence] [super-end-edit-sequence end-edit-sequence]) - (private + (private-field [edit-sequence-count 0]) (override [begin-edit-sequence @@ -126,7 +126,7 @@ (super-end-edit-sequence))]) (public - [on-close void] + [on-close (lambda () (void))] [get-top-level-window (lambda () (let loop ([text this]) @@ -143,7 +143,7 @@ (public [editing-this-file? (lambda () #f)]) - (private + (private-field [edit-sequence-queue null] [edit-sequence-ht (make-hash-table)]) @@ -277,7 +277,7 @@ (auto-wrap (preferences:get 'framework:auto-set-wrap?))) - (private + (private-field [remove-callback (preferences:add-callback 'framework:auto-set-wrap? @@ -398,7 +398,7 @@ (lambda () (super-on-close) (remove-autosave) - (set! autosave? (lambda () #f)))] + (set! do-autosave? #f))] [on-change (lambda () (super-on-change) @@ -410,8 +410,10 @@ (set! auto-save-out-of-date? #t) (remove-autosave))) (super-set-modified modified?))]) + (private-field + [do-autosave? #t]) (public - [autosave? (lambda () #t)] + [autosave? (lambda () do-autosave?)] [do-autosave (lambda () (when (and (autosave?) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 5aa8826e..5a2f5dd5 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1330,10 +1330,6 @@ [pos (if (eq? searching-direction 'forward) (send replacee-edit get-start-position) (send replacee-edit get-end-position))] - [get-pos - (if (eq? searching-direction 'forward) - (ivar replacee-edit get-end-position) - (ivar replacee-edit get-start-position))] [done? (if (eq? 'forward searching-direction) (lambda (x) (>= x (send replacee-edit last-position))) (lambda (x) (<= x 0)))]) diff --git a/collects/framework/gen-standard-menus.ss b/collects/framework/private/gen-standard-menus.ss old mode 100755 new mode 100644 similarity index 100% rename from collects/framework/gen-standard-menus.ss rename to collects/framework/private/gen-standard-menus.ss diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss index a3739a29..497e8a74 100644 --- a/collects/framework/private/group.ss +++ b/collects/framework/private/group.ss @@ -98,7 +98,7 @@ (let* ([set-close-menu-item-state! (lambda (frame state) (when (is-a? frame frame:standard-menus<%>) - (let ([close-menu-item (ivar frame file-menu:close-menu)]) + (let ([close-menu-item (send frame file-menu:get-close-menu)]) (when close-menu-item (send close-menu-item enable state)))))]) (if (eq? (length frames) 1) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 7a447131..19f6b775 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -829,124 +829,133 @@ (define setup-keymap (lambda (keymap) - - (let ([add-pos-function - (lambda (name ivar-sym) - (send keymap add-function name - (lambda (edit event) - ((ivar/proc edit ivar-sym) - (send edit get-start-position)))))]) - (add-pos-function "remove-sexp" 'remove-sexp) - (add-pos-function "forward-sexp" 'forward-sexp) - (add-pos-function "backward-sexp" 'backward-sexp) - (add-pos-function "up-sexp" 'up-sexp) - (add-pos-function "down-sexp" 'down-sexp) - (add-pos-function "flash-backward-sexp" 'flash-backward-sexp) - (add-pos-function "flash-forward-sexp" 'flash-forward-sexp) - (add-pos-function "remove-parens-forward" 'remove-parens-forward) - (add-pos-function "transpose-sexp" 'transpose-sexp)) - - (let ([add-edit-function - (lambda (name ivar-sym) - (send keymap add-function name - (lambda (edit event) - ((ivar/proc edit ivar-sym)))))]) - (add-edit-function "select-forward-sexp" 'select-forward-sexp) - (add-edit-function "select-backward-sexp" 'select-backward-sexp) - (add-edit-function "select-down-sexp" 'select-down-sexp) - (add-edit-function "select-up-sexp" 'select-up-sexp) - (add-edit-function "tabify-at-caret" 'tabify-selection) - (add-edit-function "do-return" 'insert-return) - (add-edit-function "comment-out" 'comment-out-selection) - (add-edit-function "uncomment" 'uncomment-selection)) - - (send keymap add-function "balance-parens" - (lambda (edit event) - (send edit balance-parens event))) - (send keymap add-function "balance-quotes" - (lambda (edit event) - (send edit balance-quotes event))) - - (send keymap map-function "TAB" "tabify-at-caret") - - (send keymap map-function "return" "do-return") - (send keymap map-function "s:return" "do-return") - (send keymap map-function "s:c:return" "do-return") - (send keymap map-function "a:return" "do-return") - (send keymap map-function "s:a:return" "do-return") - (send keymap map-function "c:a:return" "do-return") - (send keymap map-function "c:s:a:return" "do-return") - (send keymap map-function "c:return" "do-return") - (send keymap map-function "d:return" "do-return") - - (send keymap map-function ")" "balance-parens") - (send keymap map-function "]" "balance-parens") - (send keymap map-function "}" "balance-parens") - (send keymap map-function "\"" "balance-quotes") - (send keymap map-function "|" "balance-quotes") - - ;(send keymap map-function "c:up" "up-sexp") ;; paragraph - ;(send keymap map-function "s:c:up" "select-up-sexp") - - ;(send keymap map-function "c:down" "down-sexp") ;; paragraph - ;(send keymap map-function "s:c:down" "select-down-sexp") - - (let ([map-meta - (lambda (key func) - (keymap:send-map-function-meta keymap key func))] - [map - (lambda (key func) - (send keymap map-function key func))]) - - (map-meta "up" "up-sexp") - (map-meta "c:u" "up-sexp") - (map "a:up" "up-sexp") - (map-meta "s:up" "select-up-sexp") - (map "a:s:up" "select-up-sexp") - (map-meta "s:c:u" "select-up-sexp") - - (map-meta "down" "down-sexp") - (map "a:down" "down-sexp") - (map-meta "c:down" "down-sexp") - (map-meta "s:down" "select-down-sexp") - (map "a:s:down" "select-down-sexp") - (map-meta "s:c:down" "select-down-sexp") - - (map-meta "right" "forward-sexp") - (map "a:right" "forward-sexp") - (map-meta "s:right" "select-forward-sexp") - (map "a:s:right" "select-forward-sexp") - - (map-meta "left" "backward-sexp") - (map "a:left" "backward-sexp") - (map-meta "s:left" "select-backward-sexp") - (map "a:s:left" "select-backward-sexp") - - (map-meta "return" "do-return") - (map-meta "s:return" "do-return") - (map-meta "s:c:return" "do-return") - (map-meta "a:return" "do-return") - (map-meta "s:a:return" "do-return") - (map-meta "c:a:return" "do-return") - (map-meta "c:s:a:return" "do-return") - (map-meta "c:return" "do-return") - - (map-meta "c:semicolon" "comment-out") - (map-meta "c:=" "uncomment") - (map-meta "c:k" "remove-sexp") - - (map-meta "c:f" "forward-sexp") - (map-meta "s:c:f" "select-forward-sexp") - - (map-meta "c:b" "backward-sexp") - (map-meta "s:c:b" "select-backward-sexp") - - (map-meta "c:p" "flash-backward-sexp") - (map-meta "s:c:n" "flash-forward-sexp") - - (map-meta "c:space" "select-forward-sexp") - (map-meta "c:t" "transpose-sexp")) - (send keymap map-function "c:c;c:b" "remove-parens-forward"))) + + (let ([add-pos-function + (lambda (name call-method) + (send keymap add-function name + (lambda (edit event) + (call-method + edit + (send edit get-start-position)))))]) + (add-pos-function "remove-sexp" (lambda (e p) (send e remove-sexp p))) + (add-pos-function "forward-sexp" (lambda (e p) (send e forward-sexp p))) + (add-pos-function "backward-sexp" (lambda (e p) (send e backward-sexp p))) + (add-pos-function "up-sexp" (lambda (e p) (send e up-sexp p))) + (add-pos-function "down-sexp" (lambda (e p) (send e down-sexp p))) + (add-pos-function "flash-backward-sexp" (lambda (e p) (send e flash-backward-sexp p))) + (add-pos-function "flash-forward-sexp" (lambda (e p) (send e flash-forward-sexp p))) + (add-pos-function "remove-parens-forward" (lambda (e p) (send e remove-parens-forward p))) + (add-pos-function "transpose-sexp" (lambda (e p) (send e transpose-sexp p)))) + + (let ([add-edit-function + (lambda (name call-method) + (send keymap add-function name + (lambda (edit event) + (call-method edit))))]) + (add-edit-function "select-forward-sexp" + (lambda (x) (send x select-forward-sexp))) + (add-edit-function "select-backward-sexp" + (lambda (x) (send x select-backward-sexp))) + (add-edit-function "select-down-sexp" + (lambda (x) (send x select-down-sexp))) + (add-edit-function "select-up-sexp" + (lambda (x) (send x select-up-sexp))) + (add-edit-function "tabify-at-caret" + (lambda (x) (send x tabify-selection))) + (add-edit-function "do-return" + (lambda (x) (send x insert-return))) + (add-edit-function "comment-out" + (lambda (x) (send x comment-out-selection))) + (add-edit-function "uncomment" + (lambda (x) (send x uncomment-selection)))) + + (send keymap add-function "balance-parens" + (lambda (edit event) + (send edit balance-parens event))) + (send keymap add-function "balance-quotes" + (lambda (edit event) + (send edit balance-quotes event))) + + (send keymap map-function "TAB" "tabify-at-caret") + + (send keymap map-function "return" "do-return") + (send keymap map-function "s:return" "do-return") + (send keymap map-function "s:c:return" "do-return") + (send keymap map-function "a:return" "do-return") + (send keymap map-function "s:a:return" "do-return") + (send keymap map-function "c:a:return" "do-return") + (send keymap map-function "c:s:a:return" "do-return") + (send keymap map-function "c:return" "do-return") + (send keymap map-function "d:return" "do-return") + + (send keymap map-function ")" "balance-parens") + (send keymap map-function "]" "balance-parens") + (send keymap map-function "}" "balance-parens") + (send keymap map-function "\"" "balance-quotes") + (send keymap map-function "|" "balance-quotes") + + ;(send keymap map-function "c:up" "up-sexp") ;; paragraph + ;(send keymap map-function "s:c:up" "select-up-sexp") + + ;(send keymap map-function "c:down" "down-sexp") ;; paragraph + ;(send keymap map-function "s:c:down" "select-down-sexp") + + (let ([map-meta + (lambda (key func) + (keymap:send-map-function-meta keymap key func))] + [map + (lambda (key func) + (send keymap map-function key func))]) + + (map-meta "up" "up-sexp") + (map-meta "c:u" "up-sexp") + (map "a:up" "up-sexp") + (map-meta "s:up" "select-up-sexp") + (map "a:s:up" "select-up-sexp") + (map-meta "s:c:u" "select-up-sexp") + + (map-meta "down" "down-sexp") + (map "a:down" "down-sexp") + (map-meta "c:down" "down-sexp") + (map-meta "s:down" "select-down-sexp") + (map "a:s:down" "select-down-sexp") + (map-meta "s:c:down" "select-down-sexp") + + (map-meta "right" "forward-sexp") + (map "a:right" "forward-sexp") + (map-meta "s:right" "select-forward-sexp") + (map "a:s:right" "select-forward-sexp") + + (map-meta "left" "backward-sexp") + (map "a:left" "backward-sexp") + (map-meta "s:left" "select-backward-sexp") + (map "a:s:left" "select-backward-sexp") + + (map-meta "return" "do-return") + (map-meta "s:return" "do-return") + (map-meta "s:c:return" "do-return") + (map-meta "a:return" "do-return") + (map-meta "s:a:return" "do-return") + (map-meta "c:a:return" "do-return") + (map-meta "c:s:a:return" "do-return") + (map-meta "c:return" "do-return") + + (map-meta "c:semicolon" "comment-out") + (map-meta "c:=" "uncomment") + (map-meta "c:k" "remove-sexp") + + (map-meta "c:f" "forward-sexp") + (map-meta "s:c:f" "select-forward-sexp") + + (map-meta "c:b" "backward-sexp") + (map-meta "s:c:b" "select-backward-sexp") + + (map-meta "c:p" "flash-backward-sexp") + (map-meta "s:c:n" "flash-forward-sexp") + + (map-meta "c:space" "select-forward-sexp") + (map-meta "c:t" "transpose-sexp")) + (send keymap map-function "c:c;c:b" "remove-parens-forward"))) (define keymap (make-object keymap:aug-keymap%)) (setup-keymap keymap) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index d89006ef..aeb91b52 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -39,307 +39,306 @@ (define basic-mixin (mixin (editor:basic<%> (class->interface text%)) (basic<%>) args - (inherit get-canvases get-admin split-snip get-snip-position - begin-edit-sequence end-edit-sequence - set-autowrap-bitmap - delete find-snip invalidate-bitmap-cache - set-file-format get-file-format - get-style-list is-modified? change-style set-modified - position-location get-extent) - - (private - [b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)] - [b4 (box 0)] - [range-rectangles null] - - [invalidate-rectangles - (lambda (rectangles) - (let-values - ([(min-left max-right) - (let loop ([left #f] - [right #f] - [canvases (get-canvases)]) - (cond - [(null? canvases) - (values left right)] - [else - (let-values ([(this-left this-right) - (send (car canvases) - call-as-primary-owner - (lambda () - (send (get-admin) get-view b1 b2 b3 b4) - (let* ([this-left (unbox b1)] - [this-width (unbox b3)] - [this-right (+ this-left this-width)]) - (values this-left - this-right))))]) - (if (and left right) - (loop (min this-left left) - (max this-right right) - (cdr canvases)) - (loop this-left - this-right - (cdr canvases))))]))]) - (when (and min-left max-right) - (let loop ([left #f] - [top #f] - [right #f] - [bottom #f] - [rectangles rectangles]) - (cond - [(null? rectangles) - (when left - (let ([width (- right left)] - [height (- bottom top)]) - (when (and (> width 0) - (> height 0)) - (invalidate-bitmap-cache left top width height))))] - [else (let* ([r (car rectangles)] - - [rleft (rectangle-left r)] - [rright (rectangle-right r)] - [rtop (rectangle-top r)] - [rbottom (rectangle-bottom r)] - - [this-left (if (number? rleft) - rleft - min-left)] - [this-right (if (number? rright) - rright - max-right)] - [this-bottom rbottom] - [this-top rtop]) - (if (and left top right bottom) - (loop (min this-left left) - (min this-top top) - (max this-right right) - (max this-bottom bottom) - (cdr rectangles)) - (loop this-left - this-top - this-right - this-bottom - (cdr rectangles))))])))))] - - [recompute-range-rectangles - (lambda () - (let ([new-rectangles - (lambda (range) - (let* ([start (range-start range)] - [end (range-end range)] - [b/w-bitmap (range-b/w-bitmap range)] - [color (range-color range)] - [caret-space? (range-caret-space? range)] - [start-eol? #f] - [end-eol? (if (= start end) - start-eol? - #t)]) - (let-values ([(start-x top-start-y) - (begin - (position-location start b1 b2 #t start-eol? #t) - (values (if caret-space? - (+ 1 (unbox b1)) - (unbox b1)) - (unbox b2)))] - [(end-x top-end-y) - (begin (position-location end b1 b2 #t end-eol? #t) - (values (unbox b1) (unbox b2)))] - [(bottom-start-y) - (begin (position-location start b1 b2 #f start-eol? #t) - (unbox b2))] - [(bottom-end-y) - (begin (position-location end b1 b2 #f end-eol? #t) - (unbox b2))]) - (cond - [(= top-start-y top-end-y) - (list - (make-rectangle start-x - top-start-y - (if (= end-x start-x) - (+ end-x 1) - end-x) - bottom-start-y - b/w-bitmap - color))] - [else - (list - (make-rectangle start-x - top-start-y - 'right-edge - bottom-start-y - b/w-bitmap - color) - (make-rectangle 'left-edge - bottom-start-y - 'max-width - top-end-y - b/w-bitmap - color) - (make-rectangle 'left-edge - top-end-y - end-x - bottom-end-y - b/w-bitmap - color))]))))] - [old-rectangles range-rectangles]) - - (set! range-rectangles - (foldl (lambda (x l) (append (new-rectangles x) l)) - null ranges))))] - [ranges null] - [pen (make-object pen% "BLACK" 0 'solid)] - [brush (make-object brush% "black" 'solid)]) - (public + (inherit get-canvases get-admin split-snip get-snip-position + begin-edit-sequence end-edit-sequence + set-autowrap-bitmap + delete find-snip invalidate-bitmap-cache + set-file-format get-file-format + get-style-list is-modified? change-style set-modified + position-location get-extent) + + (private-field + [b1 (box 0)] + [b2 (box 0)] + [b3 (box 0)] + [b4 (box 0)] + [range-rectangles null] + [ranges null] + [pen (make-object pen% "BLACK" 0 'solid)] + [brush (make-object brush% "black" 'solid)]) + (private + [invalidate-rectangles + (lambda (rectangles) + (let-values + ([(min-left max-right) + (let loop ([left #f] + [right #f] + [canvases (get-canvases)]) + (cond + [(null? canvases) + (values left right)] + [else + (let-values ([(this-left this-right) + (send (car canvases) + call-as-primary-owner + (lambda () + (send (get-admin) get-view b1 b2 b3 b4) + (let* ([this-left (unbox b1)] + [this-width (unbox b3)] + [this-right (+ this-left this-width)]) + (values this-left + this-right))))]) + (if (and left right) + (loop (min this-left left) + (max this-right right) + (cdr canvases)) + (loop this-left + this-right + (cdr canvases))))]))]) + (when (and min-left max-right) + (let loop ([left #f] + [top #f] + [right #f] + [bottom #f] + [rectangles rectangles]) + (cond + [(null? rectangles) + (when left + (let ([width (- right left)] + [height (- bottom top)]) + (when (and (> width 0) + (> height 0)) + (invalidate-bitmap-cache left top width height))))] + [else (let* ([r (car rectangles)] + + [rleft (rectangle-left r)] + [rright (rectangle-right r)] + [rtop (rectangle-top r)] + [rbottom (rectangle-bottom r)] + + [this-left (if (number? rleft) + rleft + min-left)] + [this-right (if (number? rright) + rright + max-right)] + [this-bottom rbottom] + [this-top rtop]) + (if (and left top right bottom) + (loop (min this-left left) + (min this-top top) + (max this-right right) + (max this-bottom bottom) + (cdr rectangles)) + (loop this-left + this-top + this-right + this-bottom + (cdr rectangles))))])))))] + + [recompute-range-rectangles + (lambda () + (let ([new-rectangles + (lambda (range) + (let* ([start (range-start range)] + [end (range-end range)] + [b/w-bitmap (range-b/w-bitmap range)] + [color (range-color range)] + [caret-space? (range-caret-space? range)] + [start-eol? #f] + [end-eol? (if (= start end) + start-eol? + #t)]) + (let-values ([(start-x top-start-y) + (begin + (position-location start b1 b2 #t start-eol? #t) + (values (if caret-space? + (+ 1 (unbox b1)) + (unbox b1)) + (unbox b2)))] + [(end-x top-end-y) + (begin (position-location end b1 b2 #t end-eol? #t) + (values (unbox b1) (unbox b2)))] + [(bottom-start-y) + (begin (position-location start b1 b2 #f start-eol? #t) + (unbox b2))] + [(bottom-end-y) + (begin (position-location end b1 b2 #f end-eol? #t) + (unbox b2))]) + (cond + [(= top-start-y top-end-y) + (list + (make-rectangle start-x + top-start-y + (if (= end-x start-x) + (+ end-x 1) + end-x) + bottom-start-y + b/w-bitmap + color))] + [else + (list + (make-rectangle start-x + top-start-y + 'right-edge + bottom-start-y + b/w-bitmap + color) + (make-rectangle 'left-edge + bottom-start-y + 'max-width + top-end-y + b/w-bitmap + color) + (make-rectangle 'left-edge + top-end-y + end-x + bottom-end-y + b/w-bitmap + color))]))))] + [old-rectangles range-rectangles]) + + (set! range-rectangles + (foldl (lambda (x l) (append (new-rectangles x) l)) + null ranges))))]) + (public ;; the bitmap is used in b/w and the color is used in color. - [highlight-range - (opt-lambda (start end color bitmap [caret-space? #f] [priority 'low]) - (let ([l (make-range start end bitmap color caret-space?)]) - (unless (or (eq? priority 'high) (eq? priority 'low)) - (error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e" - priority)) - (invalidate-rectangles range-rectangles) - (set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l)))) - (recompute-range-rectangles) - (invalidate-rectangles range-rectangles) - (lambda () - (let ([old-rectangles range-rectangles]) - (set! ranges - (let loop ([r ranges]) - (cond - [(null? r) r] - [else (if (eq? (car r) l) - (cdr r) - (cons (car r) (loop (cdr r))))]))) - (recompute-range-rectangles) - (invalidate-rectangles old-rectangles)))))]) - (rename [super-on-paint on-paint]) - (override - [on-paint - (lambda (before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) - (super-on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) - (recompute-range-rectangles) - (for-each - (lambda (rectangle) - (let-values ([(view-x view-y view-width view-height) - (begin - (send (get-admin) get-view b1 b2 b3 b4) - (values (unbox b1) - (unbox b2) - (unbox b3) - (unbox b4)))]) - (let* ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)] - [b/w-bitmap (rectangle-b/w-bitmap rectangle)] - [color (let* ([rc (rectangle-color rectangle)] - [tmpc (make-object color% 0 0 0)]) - (if rc - (begin (send dc try-color rc tmpc) - (if (<= (color-model:rgb-color-distance - (send rc red) - (send rc green) - (send rc blue) - (send tmpc red) - (send tmpc green) - (send tmpc blue)) - 18) - rc - #f)) - rc))] - [first-number (lambda (x y) (if (number? x) x y))] - [left (max left-margin (first-number (rectangle-left rectangle) view-x))] - [top (max top-margin (rectangle-top rectangle))] - [right (min right-margin - (if (number? (rectangle-right rectangle)) - (rectangle-right rectangle) - (+ view-x view-width)))] - [bottom (min bottom-margin (rectangle-bottom rectangle))] - [width (max 0 (- right left))] - [height (max 0 (- bottom top))]) - (let/ec k - (cond - [(and before color) - (send pen set-color color) - (send brush set-color color)] - [(and (not before) (not color) b/w-bitmap) - (send pen set-stipple b/w-bitmap) - (send brush set-stipple b/w-bitmap)] - [else (k (void))]) - (send dc set-pen pen) - (send dc set-brush brush) - (send dc draw-rectangle - (+ left dx) - (+ top dy) - width - height) - (send dc set-pen old-pen) - (send dc set-brush old-brush))))) - range-rectangles))]) - - (private - [styles-fixed? #f] - [styles-fixed-edit-modified? #f]) - (public - [get-styles-fixed (lambda () styles-fixed?)] - [set-styles-fixed (lambda (b) (set! styles-fixed? b))]) - (rename - [super-on-change-style on-change-style] - [super-after-change-style after-change-style] - [super-on-insert on-insert] - [super-after-insert after-insert]) - (override - [on-change-style - (lambda (start len) - (when styles-fixed? - (set! styles-fixed-edit-modified? (is-modified?))) - (super-on-change-style start len))] - [on-insert - (lambda (start len) - (begin-edit-sequence) - (super-on-insert start len))] - [after-insert - (lambda (start len) - (when styles-fixed? - (change-style (send (get-style-list) find-named-style "Standard") - start - (+ start len))) - (super-after-insert start len) - (end-edit-sequence))] - [after-change-style - (lambda (start len) - (super-after-change-style start len) - (when styles-fixed? - (set-modified styles-fixed-edit-modified?)))]) - - (public - [move/copy-to-edit - (lambda (dest-edit start end dest-position) - (let ([insert-edit (ivar dest-edit insert)]) - (split-snip start) - (split-snip end) - (let loop ([snip (find-snip end 'before)]) - (cond - [(or (not snip) (< (get-snip-position snip) start)) - (void)] - [else - (let ([prev (send snip previous)] - [released/copied (if (send snip release-from-owner) - snip - (let* ([copy (send snip copy)] - [snip-start (get-snip-position snip)] - [snip-end (+ snip-start (send snip get-count))]) - (delete snip-start snip-end) - snip))]) - (insert-edit released/copied dest-position dest-position) - (loop prev))]))))]) - - (public - [initial-autowrap-bitmap (lambda () (icon:get-autowrap-bitmap))]) - - (sequence - (apply super-init args) - (set-autowrap-bitmap (initial-autowrap-bitmap))))) + [highlight-range + (opt-lambda (start end color bitmap [caret-space? #f] [priority 'low]) + (let ([l (make-range start end bitmap color caret-space?)]) + (unless (or (eq? priority 'high) (eq? priority 'low)) + (error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e" + priority)) + (invalidate-rectangles range-rectangles) + (set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l)))) + (recompute-range-rectangles) + (invalidate-rectangles range-rectangles) + (lambda () + (let ([old-rectangles range-rectangles]) + (set! ranges + (let loop ([r ranges]) + (cond + [(null? r) r] + [else (if (eq? (car r) l) + (cdr r) + (cons (car r) (loop (cdr r))))]))) + (recompute-range-rectangles) + (invalidate-rectangles old-rectangles)))))]) + (rename [super-on-paint on-paint]) + (override + [on-paint + (lambda (before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) + (super-on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) + (recompute-range-rectangles) + (for-each + (lambda (rectangle) + (let-values ([(view-x view-y view-width view-height) + (begin + (send (get-admin) get-view b1 b2 b3 b4) + (values (unbox b1) + (unbox b2) + (unbox b3) + (unbox b4)))]) + (let* ([old-pen (send dc get-pen)] + [old-brush (send dc get-brush)] + [b/w-bitmap (rectangle-b/w-bitmap rectangle)] + [color (let* ([rc (rectangle-color rectangle)] + [tmpc (make-object color% 0 0 0)]) + (if rc + (begin (send dc try-color rc tmpc) + (if (<= (color-model:rgb-color-distance + (send rc red) + (send rc green) + (send rc blue) + (send tmpc red) + (send tmpc green) + (send tmpc blue)) + 18) + rc + #f)) + rc))] + [first-number (lambda (x y) (if (number? x) x y))] + [left (max left-margin (first-number (rectangle-left rectangle) view-x))] + [top (max top-margin (rectangle-top rectangle))] + [right (min right-margin + (if (number? (rectangle-right rectangle)) + (rectangle-right rectangle) + (+ view-x view-width)))] + [bottom (min bottom-margin (rectangle-bottom rectangle))] + [width (max 0 (- right left))] + [height (max 0 (- bottom top))]) + (let/ec k + (cond + [(and before color) + (send pen set-color color) + (send brush set-color color)] + [(and (not before) (not color) b/w-bitmap) + (send pen set-stipple b/w-bitmap) + (send brush set-stipple b/w-bitmap)] + [else (k (void))]) + (send dc set-pen pen) + (send dc set-brush brush) + (send dc draw-rectangle + (+ left dx) + (+ top dy) + width + height) + (send dc set-pen old-pen) + (send dc set-brush old-brush))))) + range-rectangles))]) + + (private-field + [styles-fixed? #f] + [styles-fixed-edit-modified? #f]) + (public + [get-styles-fixed (lambda () styles-fixed?)] + [set-styles-fixed (lambda (b) (set! styles-fixed? b))]) + (rename + [super-on-change-style on-change-style] + [super-after-change-style after-change-style] + [super-on-insert on-insert] + [super-after-insert after-insert]) + (override + [on-change-style + (lambda (start len) + (when styles-fixed? + (set! styles-fixed-edit-modified? (is-modified?))) + (super-on-change-style start len))] + [on-insert + (lambda (start len) + (begin-edit-sequence) + (super-on-insert start len))] + [after-insert + (lambda (start len) + (when styles-fixed? + (change-style (send (get-style-list) find-named-style "Standard") + start + (+ start len))) + (super-after-insert start len) + (end-edit-sequence))] + [after-change-style + (lambda (start len) + (super-after-change-style start len) + (when styles-fixed? + (set-modified styles-fixed-edit-modified?)))]) + + (public + [move/copy-to-edit + (lambda (dest-edit start end dest-position) + (split-snip start) + (split-snip end) + (let loop ([snip (find-snip end 'before)]) + (cond + [(or (not snip) (< (get-snip-position snip) start)) + (void)] + [else + (let ([prev (send snip previous)] + [released/copied (if (send snip release-from-owner) + snip + (let* ([copy (send snip copy)] + [snip-start (get-snip-position snip)] + [snip-end (+ snip-start (send snip get-count))]) + (delete snip-start snip-end) + snip))]) + (send dest-edit insert released/copied dest-position dest-position) + (loop prev))])))]) + + (public + [initial-autowrap-bitmap (lambda () (icon:get-autowrap-bitmap))]) + + (sequence + (apply super-init args) + (set-autowrap-bitmap (initial-autowrap-bitmap))))) (define searching<%> (interface (editor:keymap<%> basic<%>))) (define searching-mixin @@ -366,75 +365,81 @@ (define return<%> (interface ((class->interface text%)))) (define return-mixin - (mixin ((class->interface text%)) (return<%>) (return . args) - (rename [super-on-local-char on-local-char]) - (override - [on-local-char - (lambda (key) - (let ([cr-code #\return] - [lf-code #\newline] - [code (send key get-key-code)]) - (or (and (char? code) - (or (char=? lf-code code) - (char=? cr-code code)) - (return)) - (super-on-local-char key))))]) - (sequence - (apply super-init args)))) + (mixin ((class->interface text%)) (return<%>) (_return . args) + (rename [super-on-local-char on-local-char]) + (private-field [return _return]) + (override + [on-local-char + (lambda (key) + (let ([cr-code #\return] + [lf-code #\newline] + [code (send key get-key-code)]) + (or (and (char? code) + (or (char=? lf-code code) + (char=? cr-code code)) + (return)) + (super-on-local-char key))))]) + (sequence + (apply super-init args)))) (define info<%> (interface (basic<%>))) (define info-mixin (mixin (editor:keymap<%> basic<%>) (info<%>) args - (inherit get-start-position get-end-position get-canvas - run-after-edit-sequence) - (rename [super-after-set-position after-set-position] - [super-after-edit-sequence after-edit-sequence] - [super-on-edit-sequence on-edit-sequence] - [super-after-insert after-insert] - [super-after-delete after-delete] - [super-set-overwrite-mode set-overwrite-mode] - [super-set-anchor set-anchor]) - (private - [enqueue-for-frame - (lambda (ivar-sym tag) - (run-after-edit-sequence - (rec from-enqueue-for-frame - (lambda () - (let ([canvas (get-canvas)]) - (when canvas - (let ([frame (send canvas get-top-level-window)]) - (when (is-a? frame frame:text-info<%>) - ((ivar/proc frame ivar-sym)))))))) - tag))]) - (override - [set-anchor - (lambda (x) - (super-set-anchor x) - (enqueue-for-frame 'anchor-status-changed - 'framework:anchor-status-changed))] - [set-overwrite-mode - (lambda (x) - (super-set-overwrite-mode x) - (enqueue-for-frame 'overwrite-status-changed - 'framework:overwrite-status-changed))] - [after-set-position - (lambda () - (super-after-set-position) - (enqueue-for-frame 'editor-position-changed - 'framework:editor-position-changed))] - [after-insert - (lambda (start len) - (super-after-insert start len) - (enqueue-for-frame 'editor-position-changed - 'framework:editor-position-changed))] - [after-delete - (lambda (start len) - (super-after-delete start len) - (enqueue-for-frame 'editor-position-changed - 'framework:editor-position-changed))]) - (sequence - (apply super-init args)))) + (inherit get-start-position get-end-position get-canvas + run-after-edit-sequence) + (rename [super-after-set-position after-set-position] + [super-after-edit-sequence after-edit-sequence] + [super-on-edit-sequence on-edit-sequence] + [super-after-insert after-insert] + [super-after-delete after-delete] + [super-set-overwrite-mode set-overwrite-mode] + [super-set-anchor set-anchor]) + (private + [enqueue-for-frame + (lambda (call-method tag) + (run-after-edit-sequence + (rec from-enqueue-for-frame + (lambda () + (let ([canvas (get-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (when (is-a? frame frame:text-info<%>) + (call-method frame))))))) + tag))]) + (override + [set-anchor + (lambda (x) + (super-set-anchor x) + (enqueue-for-frame + (lambda (x) (send x anchor-status-changed)) + 'framework:anchor-status-changed))] + [set-overwrite-mode + (lambda (x) + (super-set-overwrite-mode x) + (enqueue-for-frame + (lambda (x) (send x overwrite-status-changed)) + 'framework:overwrite-status-changed))] + [after-set-position + (lambda () + (super-after-set-position) + (enqueue-for-frame + (lambda (x) (send x editor-position-changed)) + 'framework:editor-position-changed))] + [after-insert + (lambda (start len) + (super-after-insert start len) + (enqueue-for-frame + (lambda (x) (send x editor-position-changed)) + 'framework:editor-position-changed))] + [after-delete + (lambda (start len) + (super-after-delete start len) + (enqueue-for-frame + (lambda (x) (send x editor-position-changed)) + 'framework:editor-position-changed))]) + (sequence + (apply super-init args)))) (define clever-file-format<%> (interface ((class->interface text%)))) @@ -442,35 +447,36 @@ (mixin ((class->interface text%)) (clever-file-format<%>) args (inherit get-file-format set-file-format find-first-snip) (rename [super-on-save-file on-save-file]) + (private + [all-string-snips + (lambda () + (let loop ([s (find-first-snip)]) + (cond + [(not s) #t] + [(is-a? s string-snip%) + (loop (send s next))] + [else #f])))]) (override - [on-save-file - (let ([all-string-snips - (lambda () - (let loop ([s (find-first-snip)]) - (cond - [(not s) #t] - [(is-a? s string-snip%) - (loop (send s next))] - [else #f])))]) - (lambda (name format) - (let ([all-strings? (all-string-snips)]) - (cond - [(and all-strings? - (or (eq? format 'same) (eq? format 'copy)) - (eq? 'standard (get-file-format)) - (or (not (preferences:get 'framework:verify-change-format)) - (gui-utils:get-choice - "Save this file as plain text?" "Yes" "No"))) - (set-file-format 'text)] - [(and (not all-strings?) - (or (eq? format 'same) (eq? format 'copy)) - (eq? 'text (get-file-format)) - (or (not (preferences:get 'framework:verify-change-format)) - (gui-utils:get-choice - "Save this file in drscheme-specific non-text format?" "Yes" "No"))) - (set-file-format 'standard)] - [else (void)])) - (super-on-save-file name format)))]) + [on-save-file + (lambda (name format) + (let ([all-strings? (all-string-snips)]) + (cond + [(and all-strings? + (or (eq? format 'same) (eq? format 'copy)) + (eq? 'standard (get-file-format)) + (or (not (preferences:get 'framework:verify-change-format)) + (gui-utils:get-choice + "Save this file as plain text?" "Yes" "No"))) + (set-file-format 'text)] + [(and (not all-strings?) + (or (eq? format 'same) (eq? format 'copy)) + (eq? 'text (get-file-format)) + (or (not (preferences:get 'framework:verify-change-format)) + (gui-utils:get-choice + "Save this file in drscheme-specific non-text format?" "Yes" "No"))) + (set-file-format 'standard)] + [else (void)])) + (super-on-save-file name format))]) (sequence (apply super-init args))))