From db5b82c1f72a43d00867148a66b3b1efc06088c7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 16 Apr 1999 23:06:44 +0000 Subject: [PATCH] ... original commit: 4019c61727371ac44e0db0e12ec0771998084c06 --- collects/framework/canvas.ss | 1 - collects/framework/frame.ss | 146 ++++++++++++++++++++++++++++++----- collects/framework/prefs.ss | 2 +- collects/framework/text.ss | 84 +------------------- 4 files changed, 131 insertions(+), 102 deletions(-) diff --git a/collects/framework/canvas.ss b/collects/framework/canvas.ss index 5ccf58da..9d587908 100644 --- a/collects/framework/canvas.ss +++ b/collects/framework/canvas.ss @@ -17,7 +17,6 @@ [tall-snips null] [update-snip-size (lambda (width?) - (printf "update-snip-size: ~a~n" width?) (lambda (s) (let* ([width (box 0)] [height (box 0)] diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index d509b94f..bbfed1ae 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -389,6 +389,110 @@ '(set! old-search-highlight (send edit highlight-range position position color #f)))))) + (define find-string-embedded + (let ([default-direction 'forward] + [default-start 'start] + [default-end 'eof] + [default-get-start #t] + [default-case-sensitive? #t] + [default-pop-out? #t]) + (case-lambda + [(edit str) + (find-string-embedded edit str default-direction default-start default-end default-get-start default-case-sensitive? default-pop-out?)] + [(edit str direction) + (find-string-embedded edit str direction default-start default-end default-get-start default-case-sensitive? default-pop-out?)] + [(edit str direction start) + (find-string-embedded edit str direction start default-end default-get-start default-case-sensitive? default-pop-out?)] + [(edit str direction start end) + (find-string-embedded edit str direction start end default-get-start default-case-sensitive? default-pop-out?)] + [(edit str direction start end get-start) + (find-string-embedded edit str direction start end get-start default-case-sensitive? default-pop-out?)] + [(edit str direction start end get-start case-sensitive?) + (find-string-embedded edit str direction start end get-start case-sensitive? default-pop-out?)] + [(edit str direction start end get-start case-sensitive? pop-out?) + (unless (member direction '(forward backward)) + (error 'find-string-embedded + "expected ~e or ~e as first argument, got: ~e" 'forward 'backward direction)) + (let/ec k + (let* ([start (if (eq? start 'start) + (send edit get-start-position) + start)] + [end (if (eq? 'eof end) + (if (eq? direction 'forward) + (send edit last-position) + 0) + end)] + [flat (send edit find-string str direction + start end get-start + case-sensitive?)] + [pop-out + (lambda () + (let ([admin (send edit get-admin)]) + (if (is-a? admin editor-snip-editor-admin%) + (let* ([snip (send admin get-snip)] + [edit-above (send (send snip get-admin) get-editor)] + [pos (send edit-above get-snip-position snip)] + [pop-out-pos (if (eq? direction 'forward) (add1 pos) pos)]) + (printf "popping out to ~a~n" pop-out-pos) + (find-string-embedded + edit-above + str + direction + pop-out-pos + (if (eq? direction 'forward) 'eof 0) + get-start + case-sensitive? + pop-out?)) + (values edit #f))))]) + (printf "flat: ~a start: ~a end: ~a~n" flat start end) + (let loop ([current-snip (send edit find-snip start + (if (eq? direction 'forward) + 'after-or-none + 'before-or-none))]) + (printf "searching snips: ~s ~s~n" current-snip + (and current-snip (send current-snip get-text 0 (send current-snip get-count)))) + (let ([next-loop + (lambda () + (if (eq? direction 'forward) + (loop (send current-snip next)) + (loop (send current-snip previous))))]) + (cond + [(or (not current-snip) + (and flat + (let* ([start (send edit 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 (and (not flat) pop-out?) + (pop-out) + (values edit flat))] + [(is-a? current-snip original:editor-snip%) + (printf "found embedded editor~n") + (let-values ([(embedded embedded-pos) + (let ([media (send current-snip get-editor)]) + (if (and media + (is-a? media original:text%)) + (begin + (printf "searching in embedded editor~n") + (find-string-embedded + media + str + direction + (if (eq? 'forward direction) + 0 + (send media last-position)) + 'eof + get-start case-sensitive?)) + (values #f #f)))]) + (printf "embedded: ~a embedded-pos ~a~n" embedded embedded-pos) + (if (not embedded-pos) + (next-loop) + (values embedded embedded-pos)))] + [else (next-loop)])))))]))) + (define find-text% (class-asi text% (inherit get-text) @@ -408,7 +512,13 @@ (opt-lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t]) (when searching-frame (let* ([string (get-text)] - [searching-edit (get-searching-edit)] + [top-searching-edit (get-searching-edit)] + + [searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)]) + (if focus-snip + (send focus-snip get-editor) + top-searching-edit))] + [not-found (lambda (found-edit) (send found-edit set-position search-anchor) @@ -420,32 +530,32 @@ (let ([last-pos ((if (eq? searching-direction 'forward) + -) first-pos (string-length string))]) (send* edit - (set-caret-owner #f 'display) - (set-position - (min first-pos last-pos) - (max first-pos last-pos))) + (set-caret-owner #f 'display) + (set-position + (min first-pos last-pos) + (max first-pos last-pos))) #t))]) (unless (string=? string "") (when reset-search-anchor? (reset-search-anchor searching-edit)) (let-values ([(found-edit first-pos) - (send searching-edit - find-string-embedded - string - searching-direction - search-anchor - 'eof #t #t #t)]) + (find-string-embedded + searching-edit + string + searching-direction + search-anchor + 'eof #t #t #t)]) (cond [(not first-pos) (if wrap? (let-values ([(found-edit pos) - (send searching-edit - find-string-embedded - string - searching-direction - (if (eq? 'forward searching-direction) - 0 - (send searching-edit last-position)))]) + (find-string-embedded + searching-edit + string + searching-direction + (if (eq? 'forward searching-direction) + 0 + (send searching-edit last-position)))]) (if (not pos) (not-found found-edit) (found found-edit pos))) diff --git a/collects/framework/prefs.ss b/collects/framework/prefs.ss index 2c7e051a..3f20a76f 100644 --- a/collects/framework/prefs.ss +++ b/collects/framework/prefs.ss @@ -103,7 +103,7 @@ (if (checker unmarsh) unmarsh (begin - (printf "WARNING: ~s rejecting invalid pref ~s in favor of ~s (pred: ~s)~n" + '(printf "WARNING: ~s rejecting invalid pref ~s in favor of ~s (pred: ~s)~n" p unmarsh default checker) default)))] [pref (if (check-callbacks p unmarshalled) diff --git a/collects/framework/text.ss b/collects/framework/text.ss index ad110942..68486387 100644 --- a/collects/framework/text.ss +++ b/collects/framework/text.ss @@ -302,9 +302,7 @@ (apply super-init args) (set-autowrap-bitmap (initial-autowrap-bitmap))))) - (define searching<%> - (interface () - find-string-embedded)) + (define searching<%> (interface (editor:keymap<%> basic<%>))) (define searching-mixin (mixin (editor:keymap<%> basic<%>) (searching<%>) args (inherit get-end-position get-start-position last-position @@ -316,85 +314,7 @@ (if (eq? type 'text) (make-object editor-snip% (make-object searching%)) (super-on-new-box)))]) - (public - [find-string-embedded - (opt-lambda (str [direction 'forward] [start 'start] - [end 'eof] [get-start #t] - [case-sensitive? #t] [pop-out? #t]) - (unless (member direction '(forward backward)) - (error 'find-string-embedded - "expected ~e or ~e as first argument, got: ~e" 'forward 'backward 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-editor)] - [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))]) - (printf "searching snips: ~a~n" current-snip) - (let ([next-loop - (lambda () - (if (eq? direction 'forward) - (loop (send current-snip next)) - (loop (send current-snip previous))))]) - (cond - [(or (not current-snip) - (and 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 (and (not flat) pop-out?) - (pop-out) - (values this flat))] - [(is-a? current-snip original:editor-snip%) - (printf "found embedded editor~n") - (let-values ([(embedded embedded-pos) - (let ([media (send current-snip get-editor)]) - (if (and media - (is-a? media searching<%>)) - (begin - (printf "searching in embedded editor~n") - (send media find-string-embedded str - direction - (if (eq? 'forward direction) - 0 - (send media last-position)) - 'eof - get-start case-sensitive?)) - (values #f #f)))]) - (printf "embedded: ~a embedded-pos ~a~n" embedded embedded-pos) - (if (not embedded-pos) - (next-loop) - (values embedded embedded-pos)))] - [else (next-loop)]))))))]) + (public) (rename [super-get-keymaps get-keymaps]) (override