From b588d16de8b45d400fe4a750a4b212fc8feda892 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 18 Feb 1999 20:46:34 +0000 Subject: [PATCH] ... original commit: b8eec9ad84cfde135910f68a6e484d140785415f --- collects/framework/frame.ss | 38 +- collects/framework/text.ss | 957 ++++++++++++++++++------------------ 2 files changed, 496 insertions(+), 499 deletions(-) diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index 081b6548..bfd4f15a 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -309,7 +309,7 @@ move-to-search-or-reverse-search search)) (define search-anchor 0) - (define searching-direction 1) + (define searching-direction 'forward) (define old-search-highlight void) (define get-active-embedded-edit (lambda (edit) @@ -328,7 +328,7 @@ (lambda (edit) (old-search-highlight) (let ([position - (if (= 1 searching-direction) + (if (eq? 'forward searching-direction) (send edit get-end-position) (send edit get-start-position))]) (set! search-anchor position) @@ -363,7 +363,7 @@ #f)] [found (lambda (edit first-pos) - (let ([last-pos (+ first-pos (* searching-direction + (let ([last-pos (+ first-pos (* (if (eq? searching-direction 'forward) 1 -1) (string-length string)))]) (send* edit (set-caret-owner #f 'display) @@ -379,22 +379,22 @@ string searching-direction search-anchor - -1 #t #t #t)]) + 'eof #t #t #t)]) (cond - [(= -1 first-pos) + [(not first-pos) (if wrap? (let-values ([(found-edit pos) (send searching-edit find-string-embedded string searching-direction - (if (= 1 searching-direction) + (if (eq? 'forward searching-direction) 0 (send searching-edit last-position)))]) - (if (= -1 pos) + (if (not pos) (not-found found-edit) (found found-edit - ((if (= searching-direction 1) + ((if (eq? searching-direction 'forward) + -) pos @@ -518,14 +518,14 @@ [replace-all (lambda () (let* ([replacee-edit (get-text-to-search)] - [pos (if (= searching-direction 1) + [pos (if (eq? searching-direction 'forward) (send replacee-edit get-start-position) (send replacee-edit get-end-position))] [get-pos - (if (= searching-direction 1) + (if (eq? searching-direction 'forward) (ivar replacee-edit get-end-position) (ivar replacee-edit get-start-position))] - [done? (if (= 1 searching-direction) + [done? (if (eq? 'forward searching-direction) (lambda (x) (>= x (send replacee-edit last-position))) (lambda (x) (<= x 0)))]) (send* replacee-edit @@ -558,9 +558,9 @@ (lambda () (unhide-search) (send (cond - [(send find-canvas is-focus-on?) + [(send find-canvas has-focus?) replace-canvas] - [(send replace-canvas is-focus-on?) + [(send replace-canvas has-focus?) (send (get-text-to-search) get-canvas)] [else find-canvas]) @@ -568,15 +568,15 @@ [move-to-search-or-search (lambda () (unhide-search) - (if (or (send find-canvas is-focus-on?) - (send replace-canvas is-focus-on?)) + (if (or (send find-canvas has-focus?) + (send replace-canvas has-focus?)) (search 1) (send find-canvas focus)))] [move-to-search-or-reverse-search (lambda () (unhide-search) - (if (or (send find-canvas is-focus-on?) - (send replace-canvas is-focus-on?)) + (if (or (send find-canvas has-focus?) + (send replace-canvas has-focus?)) (search -1) (send find-canvas focus)))] [search @@ -620,8 +620,8 @@ middle-right-panel (lambda (dir-radio evt) (let ([forward (if (= 0 (send evt get-command-int)) - 1 - -1)]) + 'forward + 'backward)]) (set-search-direction forward) (reset-search-anchor (get-text-to-search)))))] [close-button (make-object button% "Hide" diff --git a/collects/framework/text.ss b/collects/framework/text.ss index cf923844..1fbfa0ed 100644 --- a/collects/framework/text.ss +++ b/collects/framework/text.ss @@ -5,15 +5,15 @@ [keymap : framework:keymap^] [gui-utils : framework:gui-utils^] [mzlib:function : mzlib:function^]) - + (rename [-keymap% keymap%]) - + (define-struct range (start end b/w-bitmap color caret-space?)) (define-struct rectangle (left top right bottom b/w-bitmap color)) - + ;; wx: `default-wrapping?', add as the initial value for auto-wrap bitmap, ;; unless matthew makes it primitive - + (define basic<%> (interface (text<%>) highlight-range @@ -21,502 +21,499 @@ set-styles-fixed move/copy-to-edit initial-autowrap-bitmap)) - + (define basic-mixin (mixin (editor:basic<%> text<%>) (basic<%>) args - (inherit get-canvases get-admin split-snip get-snip-position - delete find-snip invalidate-bitmap-cache - set-autowrap-bitmap - 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] - [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))]) + (inherit get-canvases get-admin split-snip get-snip-position + delete find-snip invalidate-bitmap-cache + set-autowrap-bitmap + 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] + [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))]))))] + + [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))))]))]) + (let loop ([left #f] + [top #f] + [right #f] + [bottom #f] + [rectangles rectangles]) + (cond + [(null? rectangles) + (when left + (invalidate-bitmap-cache left top (- right left) (- bottom top)))] + [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))))]))))] + [old-rectangles range-rectangles]) + + (set! range-rectangles + (mzlib:function:foldl (lambda (x l) (append (new-rectangles x) l)) + null ranges)) + (invalidate-rectangles (append old-rectangles + range-rectangles))))] + [ranges null] + [pen (make-object pen% "BLACK" 0 'solid)] + [brush (make-object brush% "black" 'solid)]) + (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]) + (let ([l (make-range start end bitmap color caret-space?)]) + (set! ranges (cons l ranges)) + (recompute-range-rectangles) + (lambda () + (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))))]) + (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) + (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) + (and (<= (max (abs (- (send rc red) (send tmpc red))) + (abs (- (send rc blue) (send tmpc blue))) + (abs (- (send rc green) (send tmpc green)))) + 15) + rc)) + 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 - [(= 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))]))))] - - [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))))]))]) - (let loop ([left #f] - [top #f] - [right #f] - [bottom #f] - [rectangles rectangles]) - (cond - [(null? rectangles) - (when left - (invalidate-bitmap-cache left top (- right left) (- bottom top)))] - [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))))]))))] - [old-rectangles range-rectangles]) - - (set! range-rectangles - (mzlib:function:foldl (lambda (x l) (append (new-rectangles x) l)) - null ranges)) - (invalidate-rectangles (append old-rectangles - range-rectangles))))] - [ranges null] - [pen (make-object pen% "BLACK" 0 'solid)] - [brush (make-object brush% "black" 'solid)]) - (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]) - (let ([l (make-range start end bitmap color caret-space?)]) - (set! ranges (cons l ranges)) - (recompute-range-rectangles) - (lambda () - (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))))]) - (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) - (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) - (and (<= (max (abs (- (send rc red) (send tmpc red))) - (abs (- (send rc blue) (send tmpc blue))) - (abs (- (send rc green) (send tmpc green)))) - 15) - rc)) - 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 + [(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-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))] + [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))] + [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 - [(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-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))] - [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))] - [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 () #f)]) - - (sequence - (apply super-init args) - (set-autowrap-bitmap (initial-autowrap-bitmap))))) + [(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 () #f)]) + + (sequence + (apply super-init args) + (set-autowrap-bitmap (initial-autowrap-bitmap))))) (define searching<%> (interface () find-string-embedded)) (define searching-mixin (mixin (editor:keymap<%> basic<%>) (searching<%>) args - (inherit get-end-position get-start-position last-position - find-string get-snip-position get-admin find-snip) - (public - [find-string-embedded - (opt-lambda (str [direction 1] [start -1] - [end -1] [get-start #t] - [case-sensitive? #t] [pop-out? #f]) - (let/ec k - (let* ([start (if (= -1 start) - (if (= direction 1) - (get-end-position) - (get-start-position)) - start)] - [end (if (= -1 end) - (if (= direction 1) - (last-position) - 0) - end)] - [flat (find-string str direction - start end get-start - case-sensitive?)] - [end-test - (lambda (snip) - (cond - [(null? snip) flat] - [(and (not (= -1 flat)) - (let* ([start (get-snip-position snip)] - [end (+ start (send snip get-count))]) - (if (= direction 1) - (and (<= start flat) - (< flat end)) - (and (< start flat) - (<= flat end))))) - flat] - [else #f]))] - [pop-out - (lambda () - (let ([admin (get-admin)]) - (if (is-a? admin editor-snip-editor-admin%) - (let* ([snip (send admin get-snip)] - [edit-above (send (send snip get-admin) get-media)] - [pos (send edit-above get-snip-position snip)]) - (send edit-above - find-string-embedded - str - direction - (if (= direction 1) (add1 pos) pos) - -1 get-start - case-sensitive? pop-out?)) - (values this -1))))]) - (let loop ([current-snip (find-snip start - (if (= direction 1) - 'after-or-none - 'before-or-none))]) - (let ([next-loop - (lambda () - (if (= direction 1) - (loop (send current-snip next)) - (loop (send current-snip previous))))]) - (cond - [(end-test current-snip) => - (lambda (x) - (if (and (= x -1) pop-out?) - (pop-out) - (values this x)))] - [(is-a? current-snip original:editor-snip%) - (let-values ([(embedded embedded-pos) - (let ([media (send current-snip get-this-media)]) - (and (not (null? media)) - (send media find-string-embedded str - direction - (if (= 1 direction) - 0 - (send media last-position)) - -1 - get-start case-sensitive?)))]) - (if (= -1 embedded-pos) - (next-loop) - (values embedded embedded-pos)))] - [else (next-loop)]))))))]) - - (rename [super-get-keymaps get-keymaps]) - (override - [get-keymaps - (lambda () - (cons (keymap:get-search) (super-get-keymaps)))]) - - (sequence - (apply super-init args)))) + (inherit get-end-position get-start-position last-position + find-string get-snip-position get-admin find-snip) + (public + [find-string-embedded + (opt-lambda (str [direction 'forward] [start 'start] + [end 'eof] [get-start #t] + [case-sensitive? #t] [pop-out? #f]) + (unless (member direction '(forward backward)) + (error 'find-string-embedded + "expected 'forward or 'backward as first argument, got: ~e" direction)) + (let/ec k + (let* ([start (if (eq? start 'start) + (get-start-position) + start)] + [end (if (eq? 'eof end) + (if (eq? direction 'forward) + (last-position) + 0) + end)] + [flat (find-string str direction + start end get-start + case-sensitive?)] + [pop-out + (lambda () + (let ([admin (get-admin)]) + (if (is-a? admin editor-snip-editor-admin%) + (let* ([snip (send admin get-snip)] + [edit-above (send (send snip get-admin) get-media)] + [pos (send edit-above get-snip-position snip)]) + (send edit-above + find-string-embedded + str + direction + (if (eq? direction 'forward) (add1 pos) pos) + 'eof get-start + case-sensitive? pop-out?)) + (values this #f))))]) + (let loop ([current-snip (find-snip start + (if (eq? direction 'forward) + 'after-or-none + 'before-or-none))]) + (let ([next-loop + (lambda () + (if (eq? direction 'forward) + (loop (send current-snip next)) + (loop (send current-snip previous))))]) + (cond + [(not current-snip) + (if (and (not flat) pop-out?) + (pop-out) + (values this flat))] + [(and (not flat) + (let* ([start (get-snip-position current-snip)] + [end (+ start (send current-snip get-count))]) + (if (eq? direction 'forward) + (and (<= start flat) + (< flat end)) + (and (< start flat) + (<= flat end))))) + (if pop-out? + (pop-out) + (values this #f))] + [(is-a? current-snip original:editor-snip%) + (let-values ([(embedded embedded-pos) + (let ([media (send current-snip get-this-media)]) + (and (not (null? media)) + (send media find-string-embedded str + direction + (if (eq? 'forward direction) + 0 + (send media last-position)) + 'eof + get-start case-sensitive?)))]) + (if (not embedded-pos) + (next-loop) + (values embedded embedded-pos)))] + [else (next-loop)]))))))]) + + (rename [super-get-keymaps get-keymaps]) + (override + [get-keymaps + (lambda () + (cons (keymap:get-search) (super-get-keymaps)))]) + + (sequence + (apply super-init args)))) (define return<%> (interface (text<%>))) - + (define return-mixin (mixin (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)))) - + (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)))) + (define info<%> (interface (editor:basic<%> text<%>))) - + (define info-mixin (mixin (editor:keymap<%> text<%>) (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 - ((ivar/proc (send canvas get-top-level-window) 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 (ivar-sym tag) + (run-after-edit-sequence + (rec from-enqueue-for-frame + (lambda () + (let ([canvas (get-canvas)]) + (when canvas + ((ivar/proc (send canvas get-top-level-window) 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)))) + (define clever-file-format<%> (interface (text<%>))) - + (define clever-file-format-mixin (mixin (text<%>) (clever-file-format<%>) args - (inherit get-file-format set-file-format find-first-snip) - (rename [super-on-save-file on-save-file] - [super-after-save-file after-save-file]) - - (private [restore-file-format void]) - - (override - [after-save-file - (lambda (success) - (restore-file-format) - (super-after-save-file success))] - [on-save-file - (let ([has-non-string-snips - (lambda () - (let loop ([s (find-first-snip)]) - (cond - [(null? s) #f] - [(is-a? s original:string-snip%) - (loop (send s next))] - [else #t])))]) - (lambda (name format) - (when (and (or (eq? format 'same) - (eq? format 'copy)) - (not (eq? (get-file-format) - 'standard))) - (cond - [(eq? format 'copy) - (set! restore-file-format - (let ([f (get-file-format)]) - (lambda () - (set! restore-file-format void) - (set-file-format f)))) - (set-file-format 'standard)] - [(and (has-non-string-snips) - (or (not (preferences:get 'framework:verify-change-format)) - (gui-utils:get-choice "Save this file as plain text?" "No" "Yes"))) - (set-file-format 'standard)] - [else (void)])) - (or (super-on-save-file name format) - (begin - (restore-file-format) - #f))))]) - (sequence (apply super-init args)))) - + (inherit get-file-format set-file-format find-first-snip) + (rename [super-on-save-file on-save-file] + [super-after-save-file after-save-file]) + + (private [restore-file-format void]) + + (override + [after-save-file + (lambda (success) + (restore-file-format) + (super-after-save-file success))] + [on-save-file + (let ([has-non-string-snips + (lambda () + (let loop ([s (find-first-snip)]) + (cond + [(not s) #f] + [(is-a? s original:string-snip%) + (loop (send s next))] + [else #t])))]) + (lambda (name format) + (when (and (or (eq? format 'same) + (eq? format 'copy)) + (not (eq? (get-file-format) + 'standard))) + (cond + [(eq? format 'copy) + (set! restore-file-format + (let ([f (get-file-format)]) + (lambda () + (set! restore-file-format void) + (set-file-format f)))) + (set-file-format 'standard)] + [(and (has-non-string-snips) + (or (not (preferences:get 'framework:verify-change-format)) + (gui-utils:get-choice "Save this file as plain text?" "No" "Yes"))) + (set-file-format 'standard)] + [else (void)])) + (or (super-on-save-file name format) + (begin + (restore-file-format) + #f))))]) + (sequence (apply super-init args)))) + (define basic% (basic-mixin (editor:basic-mixin text%))) (define -keymap% (editor:keymap-mixin basic%)) (define return% (return-mixin -keymap%))