suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refined searching

Browse Source 
svn: r11581
This commit is contained in:
Robby Findler 2008-09-09 03:43:57 +00:00
parent b6b0d96bb8
commit 805d4eb73f
17 changed files with 956 additions and 368 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/framework/private/comment-box.ss
View File

@ -1,12 +1,18 @@
#lang scheme/unit
#lang scheme/base
(require mzlib/class
mzlib/etc
mred
"sig.ss"
"../decorated-editor-snip.ss"
mrlib/include-bitmap
string-constants)
(require (for-syntax scheme/base)
scheme/unit
scheme/class
scheme/gui/base
scheme/runtime-path
"sig.ss"
"../decorated-editor-snip.ss"
string-constants)
(define-runtime-path semicolon-bitmap-path '(lib "icons/semicolon.gif"))
(provide comment-box@)
(define-unit comment-box@
(import [prefix text: framework:text^]
[prefix scheme: framework:scheme^]
@ -24,7 +30,7 @@
(send snipclass set-classname (format "~s" '(lib "comment-snip.ss" "framework")))
(send (get-the-snip-class-list) add snipclass)
(define bm (include-bitmap (lib "icons/semicolon.gif")))
(define bm (make-object bitmap% semicolon-bitmap-path))
(define (editor-keymap-mixin %)
(class %
@ -54,13 +60,12 @@
(define/override (get-corner-bitmap) bm)
(define/override (get-position) 'left-top)
(define/override get-text
(opt-lambda (offset num [flattened? #t])
(let* ([super-res (super get-text offset num flattened?)]
[replaced (string-append "; " (regexp-replace* "\n" super-res "\n; "))])
(if (char=? #\newline (string-ref replaced (- (string-length replaced) 1)))
replaced
(string-append replaced "\n")))))
(define/override (get-text offset num [flattened? #t])
(let* ([super-res (super get-text offset num flattened?)]
[replaced (string-append "; " (regexp-replace* "\n" super-res "\n; "))])
(if (char=? #\newline (string-ref replaced (- (string-length replaced) 1)))
replaced
(string-append replaced "\n"))))
(define/override (get-menu)
@ -121,4 +126,4 @@
(make-special-comment "comment"))
(super-instantiate ())
(inherit set-snipclass)
(set-snipclass snipclass)))
(set-snipclass snipclass))))

383
collects/framework/private/frame.ss
View File

@ -8,6 +8,7 @@
"../preferences.ss"
"../gui-utils.ss"
"bday.ss"
mrlib/close-icon
mred/mred-sig
scheme/path)
@ -177,8 +178,9 @@
(when after-init?
(change-children (λ (l) (remq child l)))
(error 'frame:basic-mixin
"do not add children directly to a frame:basic (unless using make-root-area-container); use the get-area-container method instead"
))))
(string-append
"do not add children directly to a frame:basic (unless using make-root-area-container); "
"use the get-area-container method instead")))))
(define/public get-area-container% (λ () vertical-panel%))
(define/public get-menu-bar% (λ () menu-bar%))
@ -461,14 +463,15 @@
(label msg-txt))
id))
(field [eventspace-main-thread (current-thread)]) ;; replace by using new primitive in 203.5 called eventspace-main-thread
(inherit get-eventspace)
(define/private (do-main-thread t)
(if (eq? (current-thread) eventspace-main-thread)
(t)
(parameterize ([current-eventspace (get-eventspace)])
;; need high priority callbacks to ensure ordering wrt other callbacks
(queue-callback t #t))))
(let ([c-eventspace (current-eventspace)])
(if (and (eq? c-eventspace (get-eventspace))
(eq? (current-thread) (eventspace-handler-thread c-eventspace)))
(t)
(parameterize ([current-eventspace c-eventspace])
;; need high priority callbacks to ensure ordering wrt other callbacks
(queue-callback t #t)))))
(super-new)))
@ -1668,20 +1671,21 @@
(send super-root change-children (λ (l) (list rest-panel)))))))
(define searchable<%> (interface (basic<%>)
search
search-replace
search-skip
replace-all
get-text-to-search
set-text-to-search
search-hidden?
hide-search
unhide-search
search-hidden?
search-results-changed
get-case-sensitive-search?
search
replace&search
replace-all
can-replace?))
search-hits-changed
))
(define old-search-highlight void)
(define (clear-search-highlight)
@ -1723,42 +1727,36 @@
(define find-text%
(class find/replace-text%
(inherit get-canvas get-text last-position insert find-first-snip
get-admin invalidate-bitmap-cache
get-admin invalidate-bitmap-cache run-after-edit-sequence
begin-edit-sequence end-edit-sequence get-top-level-window)
(define/private (get-case-sensitive-search?)
(let ([frame (get-top-level-window)])
(and frame
(send frame get-case-sensitive-search?))))
;; search-yellow : (or/c #f (-> void))
;; if #f, that means the editor does not have the focus
;; if a function, then this is a callback that removes the yellow
;; highlighting from the text-to-search (if any).
(define search-yellow #f)
(define/override (on-focus on?)
(let ([frame (get-top-level-window)])
(when frame
(let ([text-to-search (send frame get-text-to-search)])
(when text-to-search
(cond
[on?
(set! search-yellow void)
(send text-to-search set-search-anchor (send text-to-search get-start-position))]
[else
(when search-yellow
(search-yellow)
(set! search-yellow #f))])))))
(when on?
(send text-to-search set-search-anchor (send text-to-search get-start-position)))))))
(super on-focus on?))
(define/augment (after-insert x y)
(update-searching-str)
(trigger-jump)
(run-after-edit-sequence
(λ ()
(update-searching-str)
(trigger-jump))
'searching)
(inner (void) after-insert x y))
(define/augment (after-delete x y)
(update-searching-str)
(trigger-jump)
(run-after-edit-sequence
(λ ()
(update-searching-str)
(trigger-jump))
'searching)
(inner (void) after-delete x y))
(define/private (trigger-jump)
@ -1779,7 +1777,11 @@
(let ([frame (get-top-level-window)])
(and frame
(send frame get-text-to-search))))
(define/public (search [searching-direction 'forward] [beep? #t] [wrap? #t] [move-anchor? #t] [search-start-position #f])
(define/public (search [searching-direction 'forward]
[beep? #t]
[wrap? #t]
[move-anchor? #t]
[search-start-position #f])
(let* ([string (get-text)]
[top-searching-edit (get-searching-text)])
(when top-searching-edit
@ -1824,11 +1826,6 @@
#f
bottom-pos))))
(when search-yellow
(search-yellow)
(set! search-yellow
(send text highlight-range start-pos end-pos "khaki" #f 'low 'ellipse)))
(when move-anchor?
(when (is-a? text text:searching<%>)
(send text set-search-anchor
@ -1840,8 +1837,6 @@
#t))])
(update-searching-str)
(if (string=? string "")
(not-found top-searching-edit #t)
(let-values ([(found-edit first-pos)
@ -1884,30 +1879,7 @@
(define/private (update-searching-str)
(let ([tlw (get-top-level-window)])
(when tlw
(let ([txt (send tlw get-text-to-search)])
(when txt
(update-searching-str/cs txt (get-case-sensitive-search?)))))))
(define/public (text-to-search-changed old new)
(when old
(send old set-searching-str #f))
(when new
(update-searching-str/cs new (get-case-sensitive-search?))))
(define/public (case-sensitivity-changed)
(update-searching-str))
(define/private (update-searching-str/cs txt cs?)
(when search-yellow
(search-yellow))
(let ([str (get-text)])
(send txt set-searching-str
(if (equal? str "") #f str)
cs?))
(let ([tlw (get-top-level-window)])
(when tlw
(send tlw search-results-changed))))
(send tlw search-string-changed))))
(define/override (on-paint before dc left top right bottom dx dy draw-caret?)
(super on-paint before dc left top right bottom dx dy draw-caret?)
@ -1951,12 +1923,14 @@
[replace-txt (send (send text get-top-level-window) get-replace-edit)])
(cond
[(eq? find-txt text)
(send replace-txt set-position 0 (send replace-txt last-position))
(send (send replace-txt get-canvas) focus)]
[(eq? replace-txt text)
(send find-txt set-position 0 (send find-txt last-position))
(send (send find-txt get-canvas) focus)]))))
(send search/replace-keymap map-function "return" "find")
(send search/replace-keymap add-function "find"
(send search/replace-keymap map-function "return" "next")
(send search/replace-keymap add-function "next"
(λ (text evt)
(send (send text get-top-level-window) search 'forward)))
@ -2006,7 +1980,8 @@
(define-local-member-name
update-matches
get-find-edit
get-replace-edit)
get-replace-edit
search-string-changed)
(define searchable-mixin
(mixin (standard-menus<%>) (searchable<%>)
@ -2014,7 +1989,8 @@
(define case-sensitive-search? (preferences:get 'framework:case-sensitive-search?))
(define/public (get-case-sensitive-search?) case-sensitive-search?)
(define replace-visible? (preferences:get 'framework:replace-visible?))
(define/override (edit-menu:find-callback menu evt)
(cond
[hidden?
@ -2036,26 +2012,17 @@
(define/override (edit-menu:find-again-backwards-callback menu evt) (search 'backward) #t)
(define/override (edit-menu:create-find-again-backwards?) #t)
(define/override (edit-menu:replace-and-find-again-callback menu evt) (replace&search 'forward) #t)
(define/override (edit-menu:replace-and-find-again-on-demand item) (send item enable (can-replace?)))
(define/override (edit-menu:create-replace-and-find-again?) #t)
(define/override (edit-menu:replace-and-find-again-backwards-callback menu evt) (replace&search 'backward) #t)
(define/override (edit-menu:replace-and-find-again-backwards-on-demand item)
(send item enable (can-replace?)))
(define/override edit-menu:create-replace-and-find-again-backwards? (λ () #t))
(define/override (edit-menu:find-case-sensitive-callback menu evt)
(set! case-sensitive-search? (not case-sensitive-search?))
(preferences:set 'framework:case-sensitive-search? case-sensitive-search?)
(when find-edit
(unless hidden?
(send find-edit case-sensitivity-changed))))
(search-string-changed))))
(define/override (edit-menu:find-case-sensitive-on-demand item) (send item check case-sensitive-search?))
(define/override (edit-menu:create-find-case-sensitive?) #t)
(define/override (edit-menu:replace-all-callback menu evt) (replace-all) #t)
(define/override (edit-menu:replace-all-on-demand item) (send item enable (can-replace?)))
(define/override (edit-menu:replace-all-on-demand item) (send item enable (not hidden?)))
(define/override (edit-menu:create-replace-all?) #t)
(define/override make-root-area-container
@ -2068,93 +2035,108 @@
root)))
(define text-to-search #f)
(define/public (set-text-to-search new)
(define/public-final (get-text-to-search) text-to-search)
(define/public-final (set-text-to-search new)
(unless (eq? new text-to-search)
(let ([old text-to-search])
(set! text-to-search new)
(when find-edit
(unless hidden?
(send find-edit text-to-search-changed old new))))))
(unless hidden?
(when find-edit
(when old
(send old set-searching-state #f #f #f))
(when new
(search-parameters-changed)))))))
(define/public-final (get-text-to-search) text-to-search)
(define/public (search-results-changed)
(define/public-final (search-hits-changed)
(when find-edit
(when text-to-search
(let ([new-hits (send text-to-search get-search-hits)])
(update-matches new-hits)
(let-values ([(before-caret-new-hits new-hits) (send text-to-search get-search-hit-count)])
(update-matches before-caret-new-hits new-hits)
(let ([is-red? (and (zero? new-hits)
(not (zero? (send find-edit last-position))))])
(send find-canvas set-red is-red?))))))
(define/public-final (search-string-changed) (search-parameters-changed))
(define/public-final (search-text-changed) (search-parameters-changed))
(define/private (search-parameters-changed)
(let ([str (send find-edit get-text)])
(send text-to-search set-searching-state
(if (equal? str "") #f str)
case-sensitive-search?
(and replace-visible? (send text-to-search get-start-position))))
(search-hits-changed))
(define/public (search-hidden?) hidden?)
(define/public (hide-search)
(set! hidden? #t)
(when search-gui-built?
(when text-to-search
(send text-to-search set-searching-state #f #f #f))
(send super-root change-children
(λ (l)
(remove search/replace-panel l)))
(clear-search-highlight)
(send find-edit text-to-search-changed text-to-search #f)
(when text-to-search
(send text-to-search set-search-anchor #f)
(let ([canvas (send text-to-search get-canvas)])
(when canvas
(send canvas focus)))))
(set! hidden? #t))
(send canvas focus))))))
(define/public (unhide-search focus?)
(when hidden?
(set! hidden? #f)
(build-search-gui-in-frame)
(send find-edit text-to-search-changed #f text-to-search)
(unless (memq search/replace-panel (send super-root get-children))
(send super-root add-child search/replace-panel))
(search-parameters-changed)
(when focus?
(send find-edit set-position 0 (send find-edit last-position))
(send (send find-edit get-canvas) focus))))
(define/public (can-replace?)
(let ([tx (get-text-to-search)])
(or hidden? ;; can always use the menus to unhide the search thingy
(and
tx
replace-edit
(let ([cmp
(if case-sensitive-search?
string=?
string-ci=?)])
(cmp
(send tx get-text (send tx get-start-position) (send tx get-end-position))
(send find-edit get-text 0 (send find-edit last-position))))))))
(define/public (search searching-direction)
(unhide-search #f)
(send find-edit search searching-direction #t))
(define/public (replace&search dir)
(unhide-search #f)
(let ([text (get-text-to-search)])
(when text
(send text begin-edit-sequence)
(when (replace)
(search dir))
(send text end-edit-sequence))))
(define/private (replace)
(let ([replacee-text (let ([txt (get-text-to-search)])
(and txt
(find-embedded-focus-editor txt)))])
(and replacee-text
(can-replace?)
(let* ([replacee-start (send replacee-text get-start-position)]
[replacee-end (send replacee-text get-end-position)])
(send replacee-text begin-edit-sequence)
(send replacee-text delete replacee-start replacee-end)
(copy-over replace-edit 0 (send replacee-text last-position) replacee-text replacee-start)
(send replacee-text end-edit-sequence)
#t))))
(define/public (search-replace) (skip/replace #t))
(define/public (search-skip) (skip/replace #f))
(define/private (skip/replace replace?)
(let ([text-to-search (get-text-to-search)])
(when text-to-search
(let ([replacee-start (send text-to-search get-replace-search-hit)])
(when replacee-start
(let ([replacee-end (+ replacee-start (send find-edit last-position))])
(send text-to-search begin-edit-sequence)
(send text-to-search set-position replacee-end replacee-end)
(when replace?
(send text-to-search delete replacee-start replacee-end)
(copy-over replace-edit 0 (send replace-edit last-position) text-to-search replacee-start))
(let ([str (send find-edit get-text)])
(send text-to-search set-searching-state
(if (equal? str "") #f str)
case-sensitive-search?
;; the start position will have moved (but to the right place),
;; if a relacement has happened.
(send text-to-search get-start-position))
;; move the insertion point to the start of the editor if there are
;; more replacements to do starting there
(let-values ([(before-caret-hits hits) (send text-to-search get-search-hit-count)])
(unless (zero? hits)
(unless (send text-to-search get-replace-search-hit)
(send text-to-search set-position 0 0))))
(search-hits-changed))
(send text-to-search end-edit-sequence)
(let ([next-hit (send text-to-search get-replace-search-hit)])
(when next-hit
(send text-to-search scroll-to-position next-hit)))
#t))))))
(define/private (copy-over src-txt src-start src-end dest-txt dest-pos)
(send src-txt split-snip src-start)
(send src-txt split-snip src-end)
@ -2185,15 +2167,14 @@
#f
case-sensitive-search?
#t)])
(cond
[found-pos
(unless (hash-ref ht txt #f)
(hash-set! ht txt #t)
(send txt begin-edit-sequence))
(send found-txt set-position (- found-pos (string-length search-str)) found-pos)
(replace)
(loop found-txt (send found-txt get-end-position))]
[else (void)])))
(when found-pos
(unless (hash-ref ht found-txt #f)
(hash-set! ht found-txt #t)
(send txt begin-edit-sequence))
(let ([start (- found-pos (send find-edit last-position))])
(send found-txt delete start found-pos)
(copy-over replace-edit 0 (send replace-edit last-position) found-txt start)
(loop found-txt (+ start (send replace-edit last-position)))))))
(hash-for-each ht (λ (txt _) (send txt end-edit-sequence)))))))
(define/private (pop-all-the-way-out txt)
@ -2229,6 +2210,13 @@
(inherit begin-container-sequence end-container-sequence)
(define/public (get-replace-visible?) replace-visible?)
(define/public (set-replace-visible? r?)
(unless (equal? replace-visible? r?)
(set! replace-visible? r?)
(preferences:set 'framework:replace-visible? r?)
(search-parameters-changed)))
(define/private (build-search-gui-in-frame)
(unless search-gui-built?
(set! search-gui-built? #t)
@ -2265,11 +2253,11 @@
[stretchable-width #t])))
(define search-button (new button%
[label (string-constant find)]
[vert-margin 0]
[parent search-panel]
[callback (λ (x y) (search 'forward))]
[font small-control-font]))
[label (string-constant search-next)]
[vert-margin 0]
[parent search-panel]
[callback (λ (x y) (search 'forward))]
[font small-control-font]))
(define hits-panel (new vertical-panel%
[parent search-panel]
@ -2284,48 +2272,97 @@
[font tiny-control-font]
[parent hits-panel]))
(define matches-msg (new message%
[label "Matches"]
[label (string-constant search-matches)]
[vert-margin 0]
[font tiny-control-font]
[parent hits-panel]))
(define _6 (set! update-matches
(λ (m)
(let ([number
(list->string
(reverse
(let loop ([chars (reverse (string->list (format "~a" m)))])
(cond
[(<= (length chars) 3)
chars]
[else (list* (list-ref chars 0)
(list-ref chars 1)
(list-ref chars 2)
#\,
(loop (cdddr chars)))]))))])
(send num-msg set-label number)
(send matches-msg set-label (if (= m 1) "Match" "Matches"))))))
(λ (before-caret-m m)
(cond
[(zero? m)
(send num-msg set-label "0")]
[else
(let ([number (number->str/comma m)]
[bc-number (number->str/comma before-caret-m)])
(send num-msg set-label (format "~a/~a" bc-number number)))])
(send matches-msg set-label (if (= m 1)
(string-constant search-match)
(string-constant search-matches))))))
(define replace&search-button
(define replace-button
(new button%
[label (string-constant replace&find)]
[label (string-constant search-replace)]
[vert-margin 0]
[parent replace-panel]
[font small-control-font]
[callback (λ (x y) (replace&search 'forward))]))
[callback (λ (x y) (search-replace))]))
(define skip-button
(new button%
[label (string-constant search-skip)]
[vert-margin 0]
[parent replace-panel]
[font small-control-font]
[callback (λ (x y) (search-skip))]))
(define hide-button (new button%
[label (string-constant hide)]
[vert-margin 0]
[parent search/replace-panel]
[font small-control-font]
[callback (λ (x y) (hide-search))]))
(define show-replace-button
(new button%
[label (string-constant search-show-replace)]
[font small-control-font]
[callback (λ (a b)
(set-replace-visible? #t)
(show/hide-replace))]
[parent replace-panel]))
(define hide-replace-button
(new button%
[label (string-constant search-hide-replace)]
[font small-control-font]
[callback (λ (a b)
(set-replace-visible? #f)
(show/hide-replace))]
[parent replace-panel]))
(void))
(define (show/hide-replace)
(send replace-panel begin-container-sequence)
(cond
[replace-visible?
(send replace-panel change-children (λ (l) all-replace-children))
(send replace-panel stretchable-width #t)]
[else
(send replace-panel change-children (λ (l) (list show-replace-button)))
(send replace-panel stretchable-width #f)])
(send replace-panel end-container-sequence))
(define all-replace-children
(list replace-canvas
replace-button
skip-button
hide-replace-button))
(define hide-button
(new close-icon%
[callback (λ () (hide-search))]
[vertical-pad 0]
[parent search/replace-panel]))
(show/hide-replace))
(end-container-sequence)))
(super-new)))
(define (number->str/comma m)
(list->string
(reverse
(let loop ([chars (reverse (string->list (format "~a" m)))])
(cond
[(<= (length chars) 3)
chars]
[else (list* (list-ref chars 0)
(list-ref chars 1)
(list-ref chars 2)
#\,
(loop (cdddr chars)))])))))
(define searchable-text<%> (interface (searchable<%> text<%>)))
(define searchable-text-mixin

92
collects/framework/private/icon.ss
View File

@ -1,53 +1,79 @@
#lang scheme/unit
(require (for-syntax scheme/base)
scheme/promise
mzlib/class
mrlib/include-bitmap
"bday.ss"
"sig.ss"
mred/mred-sig)
#lang scheme/base
(require (for-syntax scheme/base)
scheme/unit
scheme/promise
scheme/class
scheme/runtime-path
"bday.ss"
"sig.ss"
mred/mred-sig)
(provide icon@)
(define-runtime-path eof-bitmap-path '(lib "eof.gif" "icons"))
(define-runtime-path anchor-bitmap-path '(lib "anchor.gif" "icons"))
(define-runtime-path lock-bitmap-path '(lib "lock.gif" "icons"))
(define-runtime-path unlock-bitmap-path '(lib "unlock.gif" "icons"))
(define-runtime-path return-bitmap-path '(lib "return.xbm" "icons"))
(define-runtime-path paren-bitmap-path '(lib "paren.xbm" "icons"))
(define-runtime-path mrf-bitmap-path '(lib "mrf.png" "icons"))
(define-runtime-path gc-on-bitmap-path '(lib "recycle.png" "icons"))
(define-runtime-path up-down-mask-path '(lib "up-down-mask.xbm" "icons"))
(define-runtime-path up-down-csr-path '(lib "up-down-cursor.xbm" "icons"))
(define-runtime-path left-right-mask-path '(lib "left-right-mask.xbm" "icons"))
(define-runtime-path left-right-csr-path '(lib "left-right-cursor.xbm" "icons"))
(define-unit icon@
(import mred^)
(export framework:icon^)
(define eof-bitmap (delay (include-bitmap (lib "icons/eof.gif"))))
(define eof-bitmap (delay (let ([bm (make-object bitmap% eof-bitmap-path)])
(unless (send bm ok?)
(error 'eof-bitmap "not ok ~s\n" eof-bitmap-path))
bm)))
(define (get-eof-bitmap) (force eof-bitmap))
(define anchor-bitmap (delay (include-bitmap (lib "icons/anchor.gif"))))
(define anchor-bitmap (delay (make-object bitmap% anchor-bitmap-path)))
(define (get-anchor-bitmap) (force anchor-bitmap))
(define lock-bitmap (delay (include-bitmap (lib "icons/lock.gif"))))
(define lock-bitmap (delay (make-object bitmap% lock-bitmap-path)))
(define (get-lock-bitmap) (force lock-bitmap))
(define unlock-bitmap (delay (include-bitmap (lib "icons/unlock.gif"))))
(define unlock-bitmap (delay (make-object bitmap% unlock-bitmap-path)))
(define (get-unlock-bitmap) (force unlock-bitmap))
(define autowrap-bitmap (delay (include-bitmap (lib "icons/return.xbm"))))
(define autowrap-bitmap (delay (make-object bitmap% return-bitmap-path)))
(define (get-autowrap-bitmap) (force autowrap-bitmap))
(define paren-highlight-bitmap (delay (include-bitmap (lib "icons/paren.xbm"))))
(define paren-highlight-bitmap (delay (make-object bitmap% paren-bitmap-path)))
(define (get-paren-highlight-bitmap) (force paren-highlight-bitmap))
(define-syntax (make-get-cursor stx)
(syntax-case stx ()
[(_ name mask fallback)
[(_ id mask-path csr-path fallback)
(syntax
(let ([ans (delay
(let* ([msk-b (include-bitmap (lib mask "icons"))]
[csr-b (include-bitmap (lib name "icons"))])
(if (and (send msk-b ok?)
(send csr-b ok?))
(let ([csr (make-object cursor% msk-b csr-b 7 7)])
(if (send csr ok?)
csr
(make-object cursor% fallback)))
(make-object cursor% fallback))))])
(λ ()
(force ans))))]))
(begin
(define id
(let ([ans (delay
(let* ([msk-b (make-object bitmap% mask-path)]
[csr-b (make-object bitmap% csr-path)])
(if (and (send msk-b ok?)
(send csr-b ok?))
(let ([csr (make-object cursor% msk-b csr-b 7 7)])
(if (send csr ok?)
csr
(make-object cursor% fallback)))
(make-object cursor% fallback))))])
(λ () (force ans))))))]))
(define get-up/down-cursor (make-get-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s))
(define get-left/right-cursor (make-get-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w))
(make-get-cursor get-up/down-cursor up-down-mask-path up-down-csr-path 'size-n/s)
(make-get-cursor get-left/right-cursor left-right-mask-path left-right-csr-path 'size-e/w)
(define mrf-on-bitmap (delay (include-bitmap (lib "icons/mrf.png"))))
(define gc-on-bitmap (delay (include-bitmap (lib "icons/recycle.png"))))
(define mrf-on-bitmap (delay (make-object bitmap% mrf-bitmap-path)))
(define gc-on-bitmap (delay (make-object bitmap% gc-on-bitmap-path)))
(define (make-off-bitmap onb)
(let* ([bitmap (make-object bitmap%
@ -71,4 +97,4 @@
(force
(if (mrf-bday?)
mrf-off-bitmap
gc-off-bitmap)))
gc-off-bitmap))))

1
collects/framework/private/main.ss
View File

@ -20,6 +20,7 @@
(application-preferences-handler (λ () (preferences:show-dialog)))
(preferences:set-default 'framework:replace-visible? #f boolean?)
(preferences:set-default 'framework:anchored-search #f boolean?)
(let ([search/replace-string-predicate

415
collects/framework/private/text.ss
View File

@ -362,22 +362,29 @@ WARNING: printf is rebound in the body of the unit to always
(λ (x) (and (integer? x) (exact? x) (x . >= . 0)))])
(and (exact-pos-int? start)
(exact-pos-int? end)))
(error 'highlight-range "expected first two arguments to be non-negative exact integers, got: ~e ~e"
start end))
(error 'highlight-range
"expected first two arguments to be non-negative exact integers, got: ~e ~e"
start
end))
(unless (<= start end)
(error 'highlight-range "expected start to be less than end, got ~e ~e" start end))
(error 'highlight-range
"expected start to be less than end, got ~e ~e" start end))
(unless (or (eq? priority 'high) (eq? priority 'low))
(error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e"
(error 'highlight-range
"expected priority argument to be either 'high or 'low, got: ~e"
priority))
(unless (or (is-a? color color%)
(and (string? color)
(send the-color-database find-color color)))
(error 'highlight-range "expected a color or a string in the the-color-database for the third argument, got ~e" color))
(error 'highlight-range
"expected a color or a string in the the-color-database for the third argument, got ~e" color))
(unless (memq style '(rectangle hollow-ellipse ellipse dot))
(error 'highlight-range "expected one of 'rectangle, 'ellipse 'hollow-ellipse, or 'dot as the style, got ~e" style))
(error 'highlight-range
"expected one of 'rectangle, 'ellipse 'hollow-ellipse, or 'dot as the style, got ~e" style))
(when (eq? style 'dot)
(unless (= start end)
(error 'highlight-range "when the style is 'dot, the start and end regions must be the same")))
(error 'highlight-range
"when the style is 'dot, the start and end regions must be the same")))
(let* ([color (if (is-a? color color%)
color
@ -408,19 +415,37 @@ WARNING: printf is rebound in the body of the unit to always
(invalidate-rectangles (append old-rectangles range-rectangles))))
(define/public (unhighlight-range start end color [caret-space? #f] [style 'rectangle])
(let ([new-todo
(λ ()
(hash-remove! ranges (make-range start end caret-space? style color))
(set! ranges-list #f))])
(cond
[delayed-highlights?
(set! todo
(let ([old-todo todo])
(λ ()
(old-todo)
(new-todo))))]
[else
(redraw-highlights new-todo)])))
(let ([candidate (make-range start end
caret-space?
style
(if (is-a? color color%)
color
(send the-color-database find-color color)))])
(let ([new-todo
(λ ()
(unless (hash-ref ranges candidate #f)
(error 'unhighlight-range
"range not found; start: ~e end: ~e color: ~a caret-space?: ~e style: ~e"
start end
(if (string? color)
(format "~s" color)
(format "(red: ~a green: ~a blue: ~a)"
(send color red)
(send color green)
(send color blue)))
caret-space?
style))
(hash-remove! ranges candidate)
(set! ranges-list #f))])
(cond
[delayed-highlights?
(set! todo
(let ([old-todo todo])
(λ ()
(old-todo)
(new-todo))))]
[else
(redraw-highlights new-todo)]))))
(define/override (on-paint 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)
@ -568,8 +593,8 @@ WARNING: printf is rebound in the body of the unit to always
first-line-currently-drawn-specially?
is-special-first-line?))
(define dark-color (make-object color% 50 0 50))
(define dark-wob-color (make-object color% 255 200 255))
(define dark-first-line-color (make-object color% 50 0 50))
(define dark-wob-first-line-color (make-object color% 255 200 255))
(define first-line-mixin
(mixin ((class->interface text%)) (first-line<%>)
@ -695,7 +720,7 @@ WARNING: printf is rebound in the body of the unit to always
[end 0]
[steps 10])
(send dc set-pen
(if w-o-b? dark-wob-color dark-color)
(if w-o-b? dark-wob-first-line-color dark-first-line-color)
1
'solid)
(let loop ([i steps])
@ -794,21 +819,139 @@ WARNING: printf is rebound in the body of the unit to always
(define searching<%>
(interface (editor:keymap<%> basic<%>)
set-searching-str
set-searching-state
set-search-anchor
get-search-hits))
get-search-bubbles
get-search-hit-count))
(define dim-plum
(let ([plum (send the-color-database find-color "plum")]
[f (λ (x) (+ x (floor (* (- 255 x) 2/3))))])
(make-object color%
(f (send plum red))
(f (send plum green))
(f (send plum blue)))))
(define (get-search-highlight-colors)
(values dim-plum
"plum"
"mediumorchid"))
(define searching-mixin
(mixin (editor:keymap<%> basic<%>) (searching<%>)
(inherit run-after-edit-sequence invalidate-bitmap-cache
get-start-position)
(inherit invalidate-bitmap-cache
get-start-position get-end-position
unhighlight-range highlight-range
run-after-edit-sequence begin-edit-sequence end-edit-sequence
find-string)
(define/override (get-keymaps)
(cons (keymap:get-search) (super get-keymaps)))
(define searching-str #f)
(define case-sensitive? #f)
(define search-hits 0)
;; replace-start (or/c false/c number?)
;; #f if replace isn't visible, otherwise the position just
;; before a search hit where replacement should start
(define replace-start #f)
;; search-bubble-table : hash-table[(cons number number) -o> (or/c color% string)]
(define search-bubble-table (make-hash))
;; to-replace-highlight : (or/c false/c (list/c number number (or/c color% string)))
(define to-replace-highlight #f)
;; get-replace-search-hit : -> (or/c number #f)
;; returns the nearest search hit after `replace-start'
(define/public (get-replace-search-hit)
(and replace-start
searching-str
(do-search searching-str replace-start 'eof)))
(define/public (set-replace-start n)
(cond
[(and (not n) (not replace-start))
;; nothing to do, since it didn't change
(void)]
[(not searching-str)
;; there is no searching setup, so just do nothing
(void)]
[(equal? (get-replace-search-hit)
(do-search searching-str n 'eof))
;; the search reference changed, but the nearest search hit didn't.
;; just record the new replace-start and do nothing else
;; (possibly, even recording the new replace-start isn't even useful
(set! replace-start n)]
[else
;; here the bubbles change
(begin-edit-sequence)
(let-values ([(light-color normal-color dark-color) (get-search-highlight-colors)])
;; remove search highlight when it was separate from a bubble
(when to-replace-highlight
(unhighlight-range (list-ref to-replace-highlight 0)
(list-ref to-replace-highlight 1)
(list-ref to-replace-highlight 2)
#f
'hollow-ellipse)
(set! to-replace-highlight #f))
;; remove old search highlight when it was a bubble
;; (need to add in the dim color since the bubble needs to stay)
(let ([old-search-hit (get-replace-search-hit)])
(when old-search-hit
(let* ([old-search-hit-end (+ old-search-hit (string-length searching-str))]
[color (hash-ref search-bubble-table (cons old-search-hit old-search-hit-end) #f)])
(when color
(unhighlight-range old-search-hit
old-search-hit-end
color
#f
'hollow-ellipse)
(highlight-range old-search-hit
old-search-hit-end
light-color
#f
'low
'hollow-ellipse)
(hash-set! search-bubble-table (cons old-search-hit old-search-hit-end) light-color)))))
(set! replace-start n)
(let ([new-search-hit (get-replace-search-hit)])
(when new-search-hit
(let* ([new-search-hit-end (+ new-search-hit (string-length searching-str))]
[color (hash-ref search-bubble-table (cons new-search-hit new-search-hit-end) #f)])
(cond
[color
(unhighlight-range new-search-hit
new-search-hit-end
color
#f
'hollow-ellipse)
(hash-set! search-bubble-table (cons new-search-hit new-search-hit-end) dark-color)
(highlight-range new-search-hit
new-search-hit-end
dark-color
#f
'low
'hollow-ellipse)]
[else
(set! to-replace-highlight (list new-search-hit
new-search-hit-end
dark-color))
(highlight-range (list-ref to-replace-highlight 0)
(list-ref to-replace-highlight 1)
(list-ref to-replace-highlight 2)
#f
'low
'hollow-ellipse)])))))
(end-edit-sequence)]))
(define search-hit-count 0)
(define before-caret-search-hit-count 0)
(define anchor-pos #f)
(define/public (get-anchor-pos) anchor-pos)
@ -829,22 +972,38 @@ WARNING: printf is rebound in the body of the unit to always
(set! clear-anchor void)
(set! anchor-pos #f)]))
(define/public (get-search-hits) search-hits)
(define/public (get-search-hit-count) (values before-caret-search-hit-count search-hit-count))
(define/public (set-searching-str s [cs? #t])
(define/public (set-searching-state s cs? rs)
(unless (and (equal? searching-str s)
(equal? case-sensitive? cs?))
(equal? case-sensitive? cs?)
(equal? replace-start rs))
(set! searching-str s)
(set! case-sensitive? cs?)
(set! replace-start rs)
(redo-search)))
(define/augment (on-insert start len)
(begin-edit-sequence)
(clear-all-regions)
(update-yellow)
(inner (void) on-insert start len))
(define/augment (after-insert start len)
(unless updating-search?
(content-changed))
(inner (void) after-insert start len))
(inner (void) after-insert start len)
(end-edit-sequence))
(define/augment (on-delete start len)
(begin-edit-sequence)
(clear-all-regions)
(inner (void) on-delete start len))
(define/augment (after-delete start len)
(unless updating-search?
(content-changed))
(inner (void) after-delete start len))
(update-yellow)
(inner (void) after-delete start len)
(end-edit-sequence))
(define updating-search? #f)
@ -863,57 +1022,189 @@ WARNING: printf is rebound in the body of the unit to always
(let ([tlw (get-top-level-window)])
(when (and tlw
(is-a? tlw frame:searchable<%>))
(send tlw search-results-changed)))
(send tlw search-text-changed)))
(set! updating-search? #f))
'framework:search-results-changed))]
[just-once? #t])))
(send timer start 500 #t)))
(send timer stop)
(send timer start 200 #t)))
(inherit get-top-level-window)
(define/override (on-focus on?)
(let ([f (get-top-level-window)])
(when (is-a? f frame:searchable<%>)
(when on?
(send f set-text-to-search this))))
(send f set-text-to-search this)
(clear-yellow)
(set! clear-yellow void))
(set! do-yellow?
(and (not on?)
(eq? (send f get-text-to-search) this)))
(update-yellow)))
(super on-focus on?))
(inherit highlight-range begin-edit-sequence end-edit-sequence find-string)
(define clear-regions void)
(define do-yellow? #f)
(define clear-yellow void)
(define/augment (after-set-position)
(update-yellow)
(when replace-start
(set-replace-start (get-start-position)))
(when searching-str
(let loop ([pos 0]
[count 0])
(cond
[(do-search searching-str pos 'eof)
=>
(λ (next)
(cond
[(< next (get-start-position))
(loop (+ next 1)
(+ count 1))]
[else
(update-before-caret-search-hit-count count)]))]
[else
(update-before-caret-search-hit-count count)])))
(inner (void) after-set-position))
(define/private (update-before-caret-search-hit-count c)
(unless (equal? before-caret-search-hit-count c)
(set! before-caret-search-hit-count c)
(let ([tlw (get-top-level-window)])
(when (is-a? tlw frame:searchable<%>)
(send tlw search-hits-changed)))))
(define/private (update-yellow)
(when do-yellow?
(let ([start (get-start-position)]
[end (get-end-position)])
(unless (= start end)
(begin-edit-sequence)
(clear-yellow)
(set! clear-yellow void)
(when searching-str
(when (do-search searching-str start end)
(set! clear-yellow (highlight-range start end "khaki" #f 'low 'ellipse))))
(end-edit-sequence)))))
(define/public (get-search-bubbles)
(sort (hash-map search-bubble-table
(λ (x y) (if (is-a? y color%)
(list x (list (send y red)
(send y green)
(send y blue)))
(list x y))))
(λ (x y) (string<=? (format "~s" (car x))
(format "~s" (car y))))))
(define/private (redo-search)
(begin-edit-sequence)
(set! search-hits 0)
(clear-regions)
(set! search-hit-count 0)
(set! before-caret-search-hit-count 0)
(clear-all-regions)
(cond
[searching-str
(let loop ([pos 0]
[n 0])
(let ([next (do-search searching-str pos 'eof)])
(when next
(let-values ([(end counts) (find-end (+ next (string-length searching-str))
searching-str)])
(set! search-hits (+ search-hits counts))
(let ([old clear-regions]
[new (highlight-range next end "plum" #f 'low 'hollow-ellipse)])
(set! clear-regions (λ () (old) (new))))
(loop end (+ n 1))))))]
(let ([to-replace (get-replace-search-hit)]
[found-to-replace? #f]
[first-hit (do-search searching-str 0 'eof)])
(let-values ([(dim-color regular-color dark-color) (get-search-highlight-colors)])
(when first-hit
(set! before-caret-search-hit-count 1)
(let loop ([bubble-start first-hit]
[bubble-end (+ first-hit (string-length searching-str))]
[pos (+ first-hit 1)])
(set! search-hit-count (+ search-hit-count 1))
(let ([next (do-search searching-str pos 'eof)])
(when (and next (< next (get-start-position)))
(set! before-caret-search-hit-count (+ 1 before-caret-search-hit-count)))
(cond
[(and next ; a
(<= next bubble-end)) ; b
;; continue this bubble when
;; a) there is a search hit and
;; b) the hit overlaps or touches the previous part of the bubble
(loop bubble-start
(+ next (string-length searching-str))
(+ next 1))]
[else
;; end this bubble
(let ([color (if replace-start
(if (and (equal? bubble-start to-replace)
(equal? bubble-end (+ to-replace (string-length searching-str))))
(begin (set! found-to-replace? #t)
dark-color)
dim-color)
regular-color)])
(highlight-range bubble-start bubble-end color #f 'low 'hollow-ellipse)
(hash-set! search-bubble-table (cons bubble-start bubble-end) color))
(when next
;; start a new one if there is another hit
(loop next
(+ next (string-length searching-str))
(+ next 1)))]))))
(unless found-to-replace?
(when to-replace
(set! to-replace-highlight (list to-replace
(+ to-replace (string-length searching-str))
dark-color))
(highlight-range (list-ref to-replace-highlight 0)
(list-ref to-replace-highlight 1)
(list-ref to-replace-highlight 2)
#f
'low
'hollow-ellipse)))))]
[else
(set! clear-regions void)
(invalidate-bitmap-cache)])
(end-edit-sequence))
(end-edit-sequence)
;; stopping the timer ensures that when there is both an edit to the buffer *and*
;; there is a call to (something that calls) redo-search during a single edit
;; sequence, that the search is only done once.
(when timer (send timer stop)))
(define/private (find-end pos searching-str)
(define/private (clear-all-regions)
(when to-replace-highlight
(unhighlight-range (list-ref to-replace-highlight 0)
(list-ref to-replace-highlight 1)
(list-ref to-replace-highlight 2)
#f
'hollow-ellipse)
(set! to-replace-highlight #f))
;; this 'unless' is just here to avoid allocation in case this function is called a lot
(unless (zero? (hash-count search-bubble-table))
(hash-for-each
search-bubble-table
(λ (k v) (unhighlight-range (car k) (cdr k) v #f 'hollow-ellipse)))
(set! search-bubble-table (make-hash))))
(define/private (find-end pos to-replace searching-str)
(let loop ([pos pos]
[count 1])
(cond
[(do-search searching-str pos (+ pos (string-length searching-str)))
[(do-search searching-str
pos
(+ pos (string-length searching-str)))
=>
(λ (pos)
;; if find-string returns #t here, then we know that we've found two of the search strings in a row, so just coalesce them
(loop (+ pos (string-length searching-str))
(+ count 1)))]
(λ (next-pos)
;; if find-string returns non-#f here, then we know that we've found
;; two of the search strings in a row, so coalesce them (unless
;; we are in replace mode and the next thing to be replaced is here).
(cond
[(and to-replace
(<= pos to-replace next-pos))
(values pos pos count)]
[else
(loop (+ next-pos (string-length searching-str))
(+ count 1))]))]
[else
(values pos count)])))
(values pos pos count)])))
(define/private (do-search str start end) (find-string str 'forward start end #t case-sensitive?))

BIN
collects/icons/close.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.0 KiB

121
collects/mrlib/close-icon.ss Normal file
View File

@ -0,0 +1,121 @@
#lang scheme/base
(require scheme/gui/base
scheme/class
scheme/runtime-path
(for-syntax scheme/base))
(provide close-icon%)
(define-runtime-path icon-path '(lib "close.png" "icons"))
(define icon 'icon-not-yet-init)
(define mask1 'mask-not-yet-init)
(define mask2 'mask-not-yet-init)
(define mask3 'mask-not-yet-init)
(define (init-masks)
(define (for-each/b bytes r g b)
(let loop ([i 0])
(when (< i (bytes-length bytes))
(bytes-set! bytes (+ i 1) (r (bytes-ref bytes (+ i 1))))
(bytes-set! bytes (+ i 2) (g (bytes-ref bytes (+ i 2))))
(bytes-set! bytes (+ i 3) (b (bytes-ref bytes (+ i 3))))
(loop (+ i 4)))))
(define stupid-internal-define-syntax1
(set! icon (make-object bitmap% icon-path 'png/mask)))
(define stupid-internal-define-syntax2
(set! mask1 (send icon get-loaded-mask)))
(define bytes (make-bytes (* (send icon get-width) (send icon get-width) 4)))
(define bdc (make-object bitmap-dc% mask1))
(set! mask2 (make-object bitmap% (send mask1 get-width) (send mask1 get-height)))
(set! mask3 (make-object bitmap% (send mask1 get-width) (send mask1 get-height)))
(send bdc get-argb-pixels 0 0 (send mask1 get-width) (send mask1 get-height) bytes)
(send bdc set-bitmap mask2)
(for-each/b bytes
(λ (x) (- 255 (floor (* (- 255 x) 2/3))))
values
values)
(send bdc set-argb-pixels 0 0 (send mask1 get-width) (send mask1 get-height) bytes)
(send bdc set-bitmap mask1)
(send bdc get-argb-pixels 0 0 (send mask1 get-width) (send mask1 get-height) bytes)
(send bdc set-bitmap mask3)
(for-each/b bytes
(λ (x) (- 255 (floor (* (- 255 x) 1/4))))
values
values)
(send bdc set-argb-pixels 0 0 (send mask1 get-width) (send mask1 get-height) bytes)
(send bdc set-bitmap #f))
(define close-icon%
(class canvas%
(inherit get-dc min-width min-height stretchable-width stretchable-height
get-client-size refresh)
(init-field [callback void])
(init [horizontal-pad 4]
[vertical-pad 4])
(init-masks)
(define mouse-in? #f)
(define mouse-down? #f)
(define/override (on-event evt)
(cond
[(send evt leaving?)
(set! mouse-in? #f)
(refresh)]
[(send evt entering?)
(set! mouse-in? #t)
(refresh)]
[(send evt button-down?)
(set! mouse-down? #t)
(refresh)]
[(send evt button-up?)
(set! mouse-down? #f)
(refresh)
(when mouse-in?
(callback))]
[(send evt moving?)
(let ([new-mouse-in?
(and (<= (send evt get-x)
(send icon get-width))
(<= (send evt get-y)
(send icon get-height)))])
(unless (equal? new-mouse-in? mouse-in?)
(set! mouse-in? new-mouse-in?)
(refresh)))]))
(define/override (on-paint)
(let ([dc (get-dc)])
(let-values ([(cw ch) (get-client-size)])
(send dc draw-bitmap icon
(- (/ cw 2) (/ (send icon get-width) 2))
(- (/ ch 2) (/ (send icon get-height) 2))
'solid
(send the-color-database find-color "black")
(cond
[(and mouse-in?
mouse-down?)
mask3]
[(and mouse-in?
(not mouse-down?))
mask2]
[else
mask1])))))
(super-new [style '(transparent)])
(min-width (+ horizontal-pad horizontal-pad (send icon get-width)))
(min-height (+ vertical-pad vertical-pad (send icon get-height)))
(stretchable-width #f)
(stretchable-height #f)))
#;
(begin
(define f (new frame% [label "test"]))
(define c (new close-icon% [parent f] [callback (λ () (printf "hi\n"))]))
(define gb (new grow-box-spacer-pane% [parent f]))
(send f show #t))

20
collects/mrlib/scribblings/close-icon.scrbl Normal file
View File

@ -0,0 +1,20 @@
#lang scribble/doc
@(require "common.ss"
(for-label mrlib/close-icon
scheme/gui
scheme/runtime-path
scheme/include))
@title{Close Icon}
@defmodule[mrlib/close-icon]{The @scheme[close-icon%] class
provides a clickable close button icon.}
@defclass[close-icon% canvas% ()]{
@defconstructor[([parent (is-a? area-container<%>)]
[callback (-> any) void]
[horizontal-pad positive-integer? 4]
[vertical-pad positive-integer? 4])]{
The @scheme[callback] is called when the close icon is clicked.
}
}

1
collects/mrlib/scribblings/mrlib.scrbl
View File

@ -8,6 +8,7 @@
@include-section["aligned-pasteboard/aligned-pasteboard.scrbl"]
@include-section["bitmap-label.scrbl"]
@include-section["cache-image-snip.scrbl"]
@include-section["close-icon.scrbl"]
@include-section["gif.scrbl"]
@include-section["graph/graph.scrbl"]
@include-section["hierlist/hierlist.scrbl"]

83
collects/scribblings/framework/frame.scrbl
View File

@ -884,6 +884,7 @@ framework)) @(require (for-label scheme/gui)) @(require
}
@definterface[frame:searchable<%> (frame:basic<%>)]{
Frames that implement this interface support searching.
@defmethod[(search (direction (symbols 'forward 'backward))) void?]{
Searches for the text in the search edit in the result of
@method[frame:searchable<%> get-text-to-search].
@ -891,27 +892,25 @@ framework)) @(require (for-label scheme/gui)) @(require
If the text is found and it sets the selection to the
found text.
}
@defmethod*[(((replace&search) boolean?))]{
If the selection is currently active and set to a
region that matches the search string, this method
replaces the selected region with the contents of
the replace editor and then does another search.
@defmethod[(search-replace) boolean?]{
If there is a dark purple bubble (ie, if the replace portion
of the search bar is visible and there is a search hit after
the insertion point), then this will replace it with the
contents of the replace editor and move the insertion point
to just after that, or to the end of the editor (if there
are no more search hits after the insertion point, but there are
search hits before it).
}
@defmethod*[(((replace-all) void?))]{
@defmethod[(search-skip) boolean?]{
Just like @method[frame:searchable<%> search-replace],
but does not do the replace.
}
@defmethod[(replace-all) void?]{
Loops through the text from the beginning to the end, replacing
all occurrences of the search string with the contents of the replace
edit.
}
@defmethod*[(((can-replace?) boolean?))]{
Returns @scheme[#t] if a replace command would succeed
in replacing the current selection with the replace string.
Specifically, returns @scheme[#t] when the selected text
in the result of @method[frame:searchable<%>
get-text-to-search] is the same as the text in the find
text and the replace editor is visible.
}
@defmethod*[(((get-text-to-search) (is-a?/c (subclass?/c text%))))]{
@defmethod[(get-text-to-search) (is-a?/c text%)]{
Returns the last value passed to
@method[frame:searchable<%> set-text-to-search].
}
@ -921,30 +920,28 @@ framework)) @(require (for-label scheme/gui)) @(require
@defmethod[(search-hidden?) boolean?]{
Returns @scheme[#t] if the search subwindow is visiable and @scheme[#f] otherwise.
}
@defmethod*[(((hide-search) void))]{
@defmethod[(hide-search) void?]{
This method hides the searching information on the bottom of the
frame.
}
@defmethod*[(((unhide-search [move-focus? boolean? #f]) void))]{
@defmethod[(unhide-search [move-focus? boolean? #f]) void?]{
When the searching sub window is hidden, makes it visible. If
@scheme[move-focus?] is @scheme[#f], the focus is not moved,
but if it is any other value, the focus is moved to the find
window.
}
@defmethod[(get-case-sensitive-search?) boolean?]{
Returns @scheme[#t] if the search is currently case-sensitive.
(This method's value depends on the preference
@scheme['framework:case-sensitive-search?], but
the preference is only consulted when the frame is created.)
}
@defmethod[(search-results-changed) void?]{
This method is called to notify the frame when the
search results have changed somehow. It triggers an
update to the red highlighting in the search window (if
there are no hits, but yet there is a string to search
for) and to the number of matches reported.
@defmethod[#:mode public-final (search-hits-changed) void?]{
This method is called when the number of search matches changes and
it updates the GUI.
}
}
@ -979,47 +976,15 @@ framework)) @(require (for-label scheme/gui)) @(require
returns @scheme[#t].
}
@defmethod*[#:mode override (((edit-menu:replace-and-find-again-callback) boolean?))]{
Calls @method[frame:searchable unhide-search] and then
calls @method[frame:searchable<%> replace&search].
}
@defmethod*[#:mode override (((edit-menu:replace-and-find-again-on-demand (item menu-item%)) void))]{
Disables @scheme[item] when
@method[frame:searchable<%> can-replace?]
returns @scheme[#f] and enables it when that method returns
@scheme[#t].
}
@defmethod*[#:mode override (((edit-menu:create-replace-and-find-again?) boolean?))]{
returns @scheme[#t].
}
@defmethod*[#:mode override (((edit-menu:replace-and-find-again-backwards-callback) boolean?))]{
Calls @method[frame:searchable unhide-search] and then
calls @method[frame:searchable<%> replace&search].
}
@defmethod*[#:mode override (((edit-menu:replace-and-find-again-backwards-on-demand (item menu-item%)) void))]{
Disables @scheme[item] when
@method[frame:searchable<%> can-replace?]
returns @scheme[#f] and enables it when that method returns
@scheme[#t].
}
@defmethod*[#:mode override (((edit-menu:create-replace-and-find-again-backwards?) boolean?))]{
returns @scheme[#t].
}
@defmethod*[#:mode override (((edit-menu:replace-all-callback) boolean?))]{
Calls @method[frame:searchable<%> replace-all].
}
@defmethod*[#:mode override (((edit-menu:replace-all-on-demand (item menu-item%)) void))]{
Disables @scheme[item] when
@method[frame:searchable<%> can-replace?]
returns @scheme[#f] and enables it when that method returns
@scheme[#t].
@method[frame:searchable<%> search-hidden?]
returns @scheme[#t] and enables it when that method returns
@scheme[#f].
}
@defmethod*[#:mode override (((edit-menu:create-replace-all?) boolean?))]{
returns @scheme[#t].

55
collects/scribblings/framework/text.scrbl
View File

@ -305,7 +305,17 @@
@definterface[text:searching<%> (editor:keymap<%> text:basic<%>)]{
Any object matching this interface can be searched.
@defmethod[(set-searching-str [str (or/c false/c string?)] [cs? boolean? #t]) void?]{
Searches using this class has a non-traditional feature
for performance reasons. Specifically, multiple adjacent
hits are coalesced into a single search results when
bubbles are drawn. This means, for example, that searching
for a space in a file with 80,000 spaces (as one file in
the PLT Scheme code base has) is still tractable, since
many of those spaces will be next to each other and thus
there will be far fewer bubbles (the file in question has
only 20,000 such bubbles).
@defmethod[(set-searching-state [str (or/c false/c string?)] [cs? boolean?] [replace-start (or/c false/c number?)]) void?]{
If @scheme[str] is not @scheme[#f], then this method highlights
every occurrence of @scheme[str] in the editor. If @scheme[str] is
@ -313,15 +323,50 @@
If @scheme[cs?] is @scheme[#f], the search is case-insensitive, and
otherwise it is case-sensitive.
}
@defmethod[(get-search-hits) number?]{
Returns the number of hits for the search in the buffer, based on the
count found last time that a search happened.
If the @scheme[replace-start] argument is @scheme[#f],
then the search is not in replacement mode. If it is a
number, then the first search hit after that position in
the editor is where the next replacement will take place.
}
@defmethod[(set-search-anchor [position (or/c false/c number?)]) void?]{
Sets the anchor's position in the editor. Only takes effect if
the @scheme['framework:anchored-search] preference is on.
}
@defmethod[(get-search-hit-count) number?]{
Returns the number of hits for the search in the buffer, based on the
count found last time that a search happened.
}
@defmethod[(set-replace-start [pos (or/c false/c number?)]) void?]{
Sets the position where replacement next occurs. This is equivalent
to calling @method[text:searching<%> set-searching-state] with
a new @scheme[replace-start] argument, but the other arguments the same
as the last call to @method[text:searching<%> set-searching-state],
but is more efficient (since @method[text:searching<%> set-searching-state]
will search the entire buffer and re-build all of the bubbles).
}
@defmethod[(get-search-bubbles)
(listof (list/c (cons/c number number)
(list/c number number number)))]{
Returns information about the search bubbles in the editor. Each
item in the outermost list corresponds to a single bubble. The pair
of numbers is the range of the bubble and the triple of numbers is
the color of the bubble, in RGB coordinates.
If @tt{replace-start} has been set (via
@method[text:searching<%> set-replace-start]) and the
closest search hit following @tt{replace-start} does not
collapse with an adjacent bubble,the result will include
that bubble. If the the closest search hit after
@tt{replace-start} is collpased with another bubble, then
the search hit is not reflected in the result.
This method is intended for use in test suites.
}
}
@defmixin[text:searching-mixin (editor:keymap<%> text:basic<%>) (text:searching<%>)]{
This

26
collects/string-constants/english-string-constants.ss
View File

@ -501,18 +501,22 @@ please adhere to these guidelines:
(repl-value-color "Values")
(repl-error-color "Errors")
;;; find/replace
(find-and-replace "Find and Replace")
(find "Find")
(replace "Replace")
(dock "Dock")
(undock "Undock")
(replace&find "Replace && Find") ;;; need double & to get a single &
(forward "Forward")
(backward "Backward")
(hide "Hide")
(find-case-sensitive "Case sensitive") ;; the check box in both the docked & undocked search
;;; find/replace
(search-next "Next")
(search-match "Match") ;;; this one and the next one are singular/plural variants of each other
(search-matches "Matches")
(search-replace "Replace")
(search-skip "Skip")
(search-show-replace "Show Replace")
(search-hide-replace "Hide Replace")
(find-case-sensitive "Case sensitive") ;; the check box in both the docked & undocked search
(find-anchor-based "Search using anchors")
;; these string constants used to be used by searching,
;; but aren't anymore. They are still used by other tools, tho.
(hide "Hide")
(dock "Dock")
(undock "Undock")
;;; multi-file-search
(mfs-multi-file-search-menu-item "Search in Files...")

4
collects/tests/framework/README
View File

@ -57,6 +57,10 @@ signal failures when there aren't any.
| This tests the misc (non-scheme) keybindings
- searching: |# search.ss #|
| This tests the search results
- group tests: |# group-test.ss #|
| make sure that mred:the-frame-group records frames correctly.

2
collects/tests/framework/framework-test-engine.ss
View File

@ -27,7 +27,7 @@
(lambda (x)
(printf "test suite thread died: ~a\n"
(if (exn? x)
(exn-message x)
(exception->string x)
(format "~s" x))))])
(let ([port (call-with-input-file
(build-path (find-system-path 'temp-dir)

4
collects/tests/framework/main.ss
View File

@ -80,8 +80,8 @@
(lambda (exn)
(debug-printf schedule "~a\n"
(if (exn? exn)
(exn-message exn)
exn)))])
(exn->str exn)
exn)))])
(debug-printf schedule "beginning ~a test suite\n" x)
(dynamic-require `(lib ,x "tests" "framework") #f)
(set! jumped-out-tests (remq x jumped-out-tests))

60
collects/tests/framework/search.ss Normal file
View File

@ -0,0 +1,60 @@
#lang scheme
(require "test-suite-utils.ss")
(define-syntax (test-search stx)
(syntax-case stx ()
[(_ args ...)
(with-syntax ([line (syntax-line stx)])
#'(test-search/proc line args ...))]))
(define (test-search/proc line txt string cs? rs bubble-table)
(test
(string->symbol (format "search.ss: line ~a" line))
(lambda (x) (equal? bubble-table x))
(lambda ()
(send-sexp-to-mred
`(let ([t (new (text:searching-mixin (editor:keymap-mixin text:basic%)))]
[normalize
(λ (ht) (sort (hash-table-map ht list)
(λ (x y) (string<=? (format "~s" (car x))
(format "~s" (car y))))))])
(send t insert ,txt)
(send t set-searching-state ,string ,cs? ,rs)
(send t get-search-bubbles))))))
(define default-color "plum")
(define light-color '(243 223 243))
(define dark-color "mediumorchid")
(test-search "" "aba" #t #f '())
(test-search "aba" "aba" #t #f
`(((0 . 3) ,default-color)))
(test-search "aba aba" "aba" #t #f
`(((0 . 3) ,default-color)
((4 . 7) ,default-color)))
(test-search "abaaba" "aba" #t #f
`(((0 . 6) ,default-color)))
(test-search "abababa" "aba" #t #f
`(((0 . 7) ,default-color)))
(test-search "Aba" "aba" #t #f '())
(test-search "Aba" "aba" #f #f `(((0 . 3) ,default-color)))
(test-search "" "aba" #t 0 '())
(test-search "aba" "aba" #f 0 `(((0 . 3) ,dark-color)))
(test-search "abababa" "aba" #f 0
`(((0 . 7) ,light-color)))
(test-search "aba aba aba" "aba" #f 2
`(((0 . 3) ,light-color)
((4 . 7) ,dark-color)
((8 . 11) ,light-color)))
(test-search "abababa" "aba" #f 2
`(((0 . 7) ,light-color)))

18
collects/tests/framework/test-suite-utils.ss
View File

@ -31,7 +31,9 @@
set-section-name!
set-only-these-tests!
get-only-these-tests
debug-printf)
debug-printf
exn->str)
(define section-jump void)
(define (set-section-jump! _s) (set! section-jump _s))
@ -147,7 +149,7 @@
(or (regexp-match re:tcp-read-error (exn-message exn))
(regexp-match re:tcp-write-error (exn-message exn))))
(namespace-require 'scheme/base) ;; in order to make the eval below work right.
(namespace-require 'scheme) ;; in order to make the eval below work right.
(define (send-sexp-to-mred sexp)
(let/ec k
(let ([show-text
@ -194,7 +196,7 @@
eof
(list 'cant-read
(string-append
(exn-message x)
(exn->str x)
"; rest of string: "
(format
"~s"
@ -238,7 +240,7 @@
(with-handlers ([exn:fail?
(lambda (x)
(if (exn? x)
(exn-message x)
(exn->str x)
x))])
(if (procedure? sexp/proc)
(sexp/proc)
@ -249,7 +251,7 @@
(string-append
"passed? test raised exn: "
(if (exn? x)
(exn-message x)
(exn->str x)
(format "~s" x))))])
(not (passed? result)))])
(when failed
@ -260,6 +262,12 @@
[(continue) (void)]
[else (jump)])))))]))
(define (exn->str exn)
(let ([sp (open-output-string)])
(parameterize ([current-error-port sp])
((error-display-handler) (exn-message exn) exn))
(get-output-string sp)))
(define (wait-for/wrapper wrapper sexp)
(let ([timeout 10]
[pause-time 1/2])