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

improved searching (docs not yet quite done, but I want to test on other platforms ... another commit to follow)

Browse Source 
svn: r10921
This commit is contained in:
Robby Findler 2008-07-26 20:06:23 +00:00
parent bd2d93096e
commit a3c0e93324
28 changed files with 3011 additions and 2979 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/drscheme/private/debug.ss
View File

@ -726,7 +726,7 @@ profile todo:
(< (send from-text get-snip-position snip) para-end-pos))
(send to-text insert (send snip copy))
(loop (send snip next))))
(send to-text highlight-range (max 0 (- from-start 1)) from-end (get-error-color) #f #f 'high)
(send to-text highlight-range (max 0 (- from-start 1)) from-end (get-error-color) #f 'high)
to-text))
;; get-filename : debug-source -> string

30
collects/drscheme/private/frame.ss
View File

@ -93,22 +93,20 @@
[(opt) "a:"]))
(send item get-shortcut-prefix))))
[define/private copy-hash-table
(λ (ht)
(let ([res (make-hasheq)])
(hash-for-each
ht
(λ (x y) (hash-set! res x y)))
res))]
[define/private can-show-keybindings?
(λ ()
(let ([edit-object (get-edit-target-object)])
(and edit-object
(is-a? edit-object editor<%>)
(let ([keymap (send edit-object get-keymap)])
(is-a? keymap keymap:aug-keymap<%>)))))]
(define/private (copy-hash-table ht)
(let ([res (make-hasheq)])
(hash-for-each
ht
(λ (x y) (hash-set! res x y)))
res))
(define/private (can-show-keybindings?)
(let ([edit-object (get-edit-target-object)])
(and edit-object
(is-a? edit-object editor<%>)
(let ([keymap (send edit-object get-keymap)])
(is-a? keymap keymap:aug-keymap<%>)))))
[define/private (show-keybindings)
(define/private (show-keybindings)
(if (can-show-keybindings?)
(let* ([edit-object (get-edit-target-object)]
[keymap (send edit-object get-keymap)]
@ -124,7 +122,7 @@
w/menus
(λ (x y) (string-ci<=? (cadr x) (cadr y))))])
(show-keybindings-to-user structured-list this))
(bell))]
(bell)))
(define/private (bound-by-menu? binding menu-table)
(ormap (λ (constituent)

33
collects/drscheme/private/rep.ss
View File

@ -295,34 +295,6 @@ TODO
(λ (frame)
(send frame execute-callback)))))
(let ([shift-focus
(λ (adjust frame)
(let ([candidates (adjust (append
(send frame get-definitions-canvases)
(send frame get-interactions-canvases)))])
(let loop ([cs candidates])
(cond
[(null? cs) (send (car candidates) focus)]
[else
(let ([c (car cs)])
(if (send c has-focus?)
(send (if (null? (cdr cs))
(car candidates)
(cadr cs))
focus)
(loop (cdr cs))))]))))])
(send drs-bindings-keymap add-function
"toggle-focus-between-definitions-and-interactions"
(λ (obj evt)
(with-drs-frame
obj
(λ (frame) (shift-focus values frame)))))
(send drs-bindings-keymap add-function
"toggle-focus-between-definitions-and-interactions backwards"
(λ (obj evt)
(with-drs-frame
obj
(λ (frame) (shift-focus reverse frame))))))
(send drs-bindings-keymap add-function
"next-tab"
(λ (obj evt)
@ -336,9 +308,6 @@ TODO
obj
(λ (frame) (send frame prev-tab))))))
(send drs-bindings-keymap map-function "c:x;o" "toggle-focus-between-definitions-and-interactions")
(send drs-bindings-keymap map-function "c:x;p" "toggle-focus-between-definitions-and-interactions backwards")
(send drs-bindings-keymap map-function "c:f6" "toggle-focus-between-definitions-and-interactions")
(send drs-bindings-keymap map-function "f5" "execute")
(send drs-bindings-keymap map-function "f1" "search-help-desk")
(send drs-bindings-keymap map-function "c:tab" "next-tab")
@ -732,7 +701,7 @@ TODO
[start (- (srcloc-position loc) 1)]
[span (srcloc-span loc)]
[finish (+ start span)])
(send file highlight-range start finish (drscheme:debug:get-error-color) #f #f 'high)))
(send file highlight-range start finish (drscheme:debug:get-error-color) #f 'high)))
locs)])
(when (and definitions-text error-arrows)

21
collects/drscheme/private/unit.ss
View File

@ -1622,10 +1622,11 @@ module browser threading seems wrong.
(drscheme:language-configuration:language-settings-settings settings))
""
(string-append " " (string-constant custom)))))
(let ([label (send scheme-menu get-label)]
[new-label (send language capability-value 'drscheme:language-menu-title)])
(unless (equal? label new-label)
(send scheme-menu set-label new-label)))))
(when (is-a? scheme-menu menu%)
(let ([label (send scheme-menu get-label)]
[new-label (send language capability-value 'drscheme:language-menu-title)])
(unless (equal? label new-label)
(send scheme-menu set-label new-label))))))
(define/public (get-language-menu) scheme-menu)
@ -2982,6 +2983,7 @@ module browser threading seems wrong.
(super file-menu:between-print-and-close file-menu))
(define/override (edit-menu:between-find-and-preferences edit-menu)
(super edit-menu:between-find-and-preferences edit-menu)
(new menu-item%
[label (string-constant complete-word)]
[shortcut #\/]
@ -2994,7 +2996,6 @@ module browser threading seems wrong.
(is-a? ed text:autocomplete<%>)))))]
[callback (λ (x y)
(send (get-edit-target-object) auto-complete))])
(super edit-menu:between-find-and-preferences edit-menu)
(add-modes-submenu edit-menu))
;; capability-menu-items : hash-table[menu -o> (listof (list menu-item number key)))
@ -3009,13 +3010,12 @@ module browser threading seems wrong.
(hash-set! capability-menu-items menu (cons this-one old-ones)))))
(define/private (update-items/capability menu)
(let ([new-items (get-items/capability menu)])
(let ([new-items (begin '(get-items/capability menu)
(send menu get-items))])
(for-each (λ (i) (send i delete)) (send menu get-items))
(for-each (λ (i) (send i restore)) new-items)))
(define/private (get-items/capability menu)
(let loop ([capability-items
(reverse
(hash-ref capability-menu-items menu (λ () '())))]
(let loop ([capability-items (reverse (hash-ref capability-menu-items menu '()))]
[all-items (send menu get-items)]
[i 0])
(cond
@ -3161,7 +3161,8 @@ module browser threading seems wrong.
(method text)))))]
[show/hide-capability-menus
(λ ()
(for-each (λ (menu) (update-items/capability menu)) (send (get-menu-bar) get-items)))])
(for-each (λ (menu) (update-items/capability menu))
(send (get-menu-bar) get-items)))])
(make-object menu:can-restore-menu-item%
(string-constant choose-language-menu-item-label)

3
collects/framework/private/color.ss
View File

@ -537,9 +537,6 @@ added get-regions
(if (is-a? color color%)
color
(if color mismatch-color (get-match-color)))
(and (send (icon:get-paren-highlight-bitmap)
ok?)
(icon:get-paren-highlight-bitmap))
(= caret-pos (+ start-pos start)))])
(set! clear-old-locations
(let ([old clear-old-locations])

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

File diff suppressed because it is too large Load Diff

6
collects/framework/private/gen-standard-menus.ss
View File

@ -1,6 +1,6 @@
#reader scribble/reader
#lang scheme
(provide main)
(require scheme/pretty
scheme/runtime-path)
(require "standard-menus-items.ss")
@ -66,7 +66,9 @@
(parent ,(menu-item-menu-name item))
(help-string (,(an-item->help-string-name item)))
(demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item))))
`(new (get-menu-item%)
`(new ,(if (a-checkable-item? item)
'(get-checkable-menu-item%)
'(get-menu-item%))
(label (,(an-item->string-name item)))
(parent ,(menu-item-menu-name item))
(callback (let ([,callback-name (λ (item evt) (,callback-name item evt))])

38
collects/framework/private/keymap.ss
View File

@ -956,6 +956,31 @@
(send text insert "\n")
#t)]
[shift-focus
(λ (adjust)
(λ (text event)
(when (is-a? text editor:basic<%>)
(let ([frame (send text get-top-level-window)])
(let ([found-one? #f])
(let/ec k
(let ([go
(λ ()
(let loop ([obj frame])
(cond
[(and found-one? (is-a? obj editor-canvas%))
(send obj focus)
(k (void))]
[(and (is-a? obj window<%>) (send obj has-focus?))
(set! found-one? #t)]
[(is-a? obj area-container<%>)
(for-each loop (adjust (send obj get-children)))])))])
(go)
;;; when we get here, we either didn't find the focus anywhere,
;;; or the last editor-canvas had the focus. either way,
;;; the next thing should get the focus
(set! found-one? #t)
(go))))))))]
[TeX-compress
(let* ([biggest (apply max (map (λ (x) (string-length (car x))) tex-shortcut-table))])
(λ (text event)
@ -992,6 +1017,9 @@
(λ (txt evt) (send txt insert c)))))
(string->list (string-append greek-letters Greek-letters)))
(add "shift-focus" (shift-focus values))
(add "shift-focus-backwards" (shift-focus reverse))
(add "TeX compress" TeX-compress)
(add "newline" newline)
(add "down-into-embedded-editor" down-into-embedded-editor)
@ -1262,6 +1290,12 @@
(map ":rightbuttonseq" "mouse-popup-menu")
(map "c:c;c:r" "make-read-only")
(map "c:x;o" "shift-focus")
(map "c:x;p" "shift-focus-backwards")
(map "c:f6" "shift-focus")
(map "a:tab" "shift-focus")
(map "a:s:tab" "shift-focus-backwards")
))))
(define setup-search
@ -1292,9 +1326,7 @@
(send kmap add-function name func))])
(add "move-to-search-or-search"
(send-frame (λ (f) (send f move-to-search-or-search)))) ;; key 1
(add "move-to-search-or-reverse-search"
(send-frame (λ (f) (send f move-to-search-or-reverse-search)))) ;; key 1b, backwards
(send-frame (λ (f) (send f move-to-search-or-back)))) ;; key 1
(add "find-string-again"
(send-frame (λ (f) (send f search-again)))) ;; key 2
(add "toggle-search-focus"

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

@ -20,6 +20,29 @@
(application-preferences-handler (λ () (preferences:show-dialog)))
(let ([search/replace-string-predicate
(λ (l)
(and (list? l)
(andmap
(λ (x) (or (string? x) (is-a? x snip%)))
l)))])
(preferences:set-default 'framework:search-string
'()
search/replace-string-predicate)
(preferences:set-default 'framework:replace-string
'()
search/replace-string-predicate))
;; marshalling for this one will just lose information. Too bad.
(preferences:set-un/marshall 'framework:search-string
(λ (l)
(map (λ (x)
(if (is-a? x snip%)
(send x get-text 0 (send x get-count))
x))
l))
values)
(preferences:set-default 'framework:paren-color-scheme 'basic-grey symbol?)
(preferences:set-default 'framework:square-bracket:cond/offset

99
collects/framework/private/search.ss Normal file
View File

@ -0,0 +1,99 @@
#lang scheme/base
(require scheme/contract
scheme/class
scheme/gui/base)
(provide/contract
[find-string-embedded
(->* ((is-a?/c text%)
string?)
((symbols 'forward 'backward)
(or/c (symbols 'start) number?)
(or/c (symbols 'eof) number?)
boolean?
boolean?
boolean?)
(values (is-a?/c editor<%>)
(or/c false/c number?)))])
(define find-string-embedded
(lambda (edit
str
[direction 'forward]
[start 'start]
[end 'eof]
[get-start #t]
[case-sensitive? #t]
[pop-out? #f])
(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
(λ ()
(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)])
(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))))])
(let loop ([current-snip (send edit find-snip start
(if (eq? direction 'forward)
'after-or-none
'before-or-none))])
(let ([next-loop
(λ ()
(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 editor-snip%)
(let-values ([(embedded embedded-pos)
(let ([media (send current-snip get-editor)])
(if (and media
(is-a? media text%))
(begin
(find-string-embedded
media
str
direction
(if (eq? 'forward direction)
0
(send media last-position))
'eof
get-start case-sensitive?))
(values #f #f)))])
(if (not embedded-pos)
(next-loop)
(values embedded embedded-pos)))]
[else (next-loop)])))))))

42
collects/framework/private/standard-menus-items.ss
View File

@ -21,6 +21,7 @@
(struct-out between)
(struct-out an-item)
(struct-out a-checkable-item)
(struct-out a-submenu-item)
;; an-item -> symbol
@ -78,6 +79,7 @@
on-demand
create))
(define-struct (a-submenu-item an-item) ())
(define-struct (a-checkable-item an-item) ())
(define (an-item->callback-name item)
(string->symbol
@ -357,22 +359,46 @@
'(string-constant find-menu-item)
edit-menu:edit-target-on-demand
#f)
(make-an-item 'edit-menu 'find-again
'(string-constant find-again-info)
(make-an-item 'edit-menu 'find-backwards
'(string-constant find-backwards-info)
'(λ (item control) (void))
#\f
'(cons 'shift (get-default-shortcut-prefix))
'(string-constant find-backwards-menu-item)
edit-menu:edit-target-on-demand
#f)
(make-an-item 'edit-menu 'replace-and-find
'(string-constant replace-and-find-info)
'(λ (item control) (void))
#\g
'(get-default-shortcut-prefix)
'(string-constant find-again-menu-item)
'(string-constant replace-and-find-menu-item)
edit-menu:edit-target-on-demand
#f)
(make-an-item 'edit-menu 'replace-and-find-again
'(string-constant replace-and-find-again-info)
(make-an-item 'edit-menu 'replace-and-find-backwards
'(string-constant replace-and-find-backwards-info)
'(λ (item control) (void))
'(if (eq? (system-type) 'macosx) #f #\h)
'(get-default-shortcut-prefix)
'(string-constant replace-and-find-again-menu-item)
#\g
'(cons 'shift (get-default-shortcut-prefix))
'(string-constant replace-and-find-backwards-menu-item)
edit-menu:edit-target-on-demand
#f)
(make-an-item 'edit-menu 'replace-all
'(string-constant replace-all-info)
'(λ (item control) (void))
#f
'(get-default-shortcut-prefix)
'(string-constant replace-all-menu-item)
edit-menu:edit-target-on-demand
#f)
(make-a-checkable-item 'edit-menu 'find-case-sensitive
'(string-constant find-case-sensitive-info)
'(λ (item control) (void))
#f
'(get-default-shortcut-prefix)
'(string-constant find-case-sensitive-menu-item)
edit-menu:edit-target-on-demand
#f)
(make-between 'edit-menu 'find 'preferences 'nothing-with-standard-menus)
(make-an-item 'edit-menu 'preferences

209
collects/framework/private/standard-menus.ss
View File

@ -122,18 +122,36 @@
edit-menu:find-help-string
edit-menu:find-on-demand
edit-menu:create-find?
edit-menu:find-again-callback
edit-menu:get-find-again-item
edit-menu:find-again-string
edit-menu:find-again-help-string
edit-menu:find-again-on-demand
edit-menu:create-find-again?
edit-menu:replace-and-find-again-callback
edit-menu:get-replace-and-find-again-item
edit-menu:replace-and-find-again-string
edit-menu:replace-and-find-again-help-string
edit-menu:replace-and-find-again-on-demand
edit-menu:create-replace-and-find-again?
edit-menu:find-backwards-callback
edit-menu:get-find-backwards-item
edit-menu:find-backwards-string
edit-menu:find-backwards-help-string
edit-menu:find-backwards-on-demand
edit-menu:create-find-backwards?
edit-menu:replace-and-find-callback
edit-menu:get-replace-and-find-item
edit-menu:replace-and-find-string
edit-menu:replace-and-find-help-string
edit-menu:replace-and-find-on-demand
edit-menu:create-replace-and-find?
edit-menu:replace-and-find-backwards-callback
edit-menu:get-replace-and-find-backwards-item
edit-menu:replace-and-find-backwards-string
edit-menu:replace-and-find-backwards-help-string
edit-menu:replace-and-find-backwards-on-demand
edit-menu:create-replace-and-find-backwards?
edit-menu:replace-all-callback
edit-menu:get-replace-all-item
edit-menu:replace-all-string
edit-menu:replace-all-help-string
edit-menu:replace-all-on-demand
edit-menu:create-replace-all?
edit-menu:find-case-sensitive-callback
edit-menu:get-find-case-sensitive-item
edit-menu:find-case-sensitive-string
edit-menu:find-case-sensitive-help-string
edit-menu:find-case-sensitive-on-demand
edit-menu:create-find-case-sensitive?
edit-menu:between-find-and-preferences
edit-menu:preferences-callback
edit-menu:get-preferences-item
@ -161,8 +179,7 @@
'framework:menu-bindings
(λ (p v)
(let loop ((menu (get-menu-bar)))
(when (is-a? menu menu:can-restore<%>)
(if v (send menu restore-keybinding) (send menu set-shortcut #f)))
(when (is-a? menu menu:can-restore<%>) (if v (send menu restore-keybinding) (send menu set-shortcut #f)))
(when (is-a? menu menu:can-restore-underscore<%>)
(if v (send menu restore-underscores) (send menu erase-underscores)))
(when (is-a? menu menu-item-container<%>) (for-each loop (send menu get-items)))))))
@ -232,9 +249,7 @@
(define/public (file-menu:get-quit-item) file-menu:quit-item)
(define/public
(file-menu:quit-string)
(if (eq? (system-type) 'windows)
(string-constant quit-menu-item-windows)
(string-constant quit-menu-item-others)))
(if (eq? (system-type) 'windows) (string-constant quit-menu-item-windows) (string-constant quit-menu-item-others)))
(define/public (file-menu:quit-help-string) (string-constant quit-info))
(define/public file-menu:quit-on-demand (λ (menu-item) (void)))
(define/public (file-menu:create-quit?) (not (current-eventspace-has-standard-menus?)))
@ -367,27 +382,48 @@
(define/public (edit-menu:find-help-string) (string-constant find-info))
(define/public
edit-menu:find-on-demand
(λ (item)
(send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
(λ (item) (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
(define/public (edit-menu:create-find?) #f)
(define/public edit-menu:find-again-callback (λ (item control) (void)))
(define/public (edit-menu:get-find-again-item) edit-menu:find-again-item)
(define/public (edit-menu:find-again-string) (string-constant find-again-menu-item))
(define/public (edit-menu:find-again-help-string) (string-constant find-again-info))
(define/public edit-menu:find-backwards-callback (λ (item control) (void)))
(define/public (edit-menu:get-find-backwards-item) edit-menu:find-backwards-item)
(define/public (edit-menu:find-backwards-string) (string-constant find-backwards-menu-item))
(define/public (edit-menu:find-backwards-help-string) (string-constant find-backwards-info))
(define/public
edit-menu:find-again-on-demand
(λ (item)
(send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
(define/public (edit-menu:create-find-again?) #f)
(define/public edit-menu:replace-and-find-again-callback (λ (item control) (void)))
(define/public (edit-menu:get-replace-and-find-again-item) edit-menu:replace-and-find-again-item)
(define/public (edit-menu:replace-and-find-again-string) (string-constant replace-and-find-again-menu-item))
(define/public (edit-menu:replace-and-find-again-help-string) (string-constant replace-and-find-again-info))
edit-menu:find-backwards-on-demand
(λ (item) (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
(define/public (edit-menu:create-find-backwards?) #f)
(define/public edit-menu:replace-and-find-callback (λ (item control) (void)))
(define/public (edit-menu:get-replace-and-find-item) edit-menu:replace-and-find-item)
(define/public (edit-menu:replace-and-find-string) (string-constant replace-and-find-menu-item))
(define/public (edit-menu:replace-and-find-help-string) (string-constant replace-and-find-info))
(define/public
edit-menu:replace-and-find-again-on-demand
(λ (item)
(send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
(define/public (edit-menu:create-replace-and-find-again?) #f)
edit-menu:replace-and-find-on-demand
(λ (item) (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
(define/public (edit-menu:create-replace-and-find?) #f)
(define/public edit-menu:replace-and-find-backwards-callback (λ (item control) (void)))
(define/public (edit-menu:get-replace-and-find-backwards-item) edit-menu:replace-and-find-backwards-item)
(define/public (edit-menu:replace-and-find-backwards-string) (string-constant replace-and-find-backwards-menu-item))
(define/public (edit-menu:replace-and-find-backwards-help-string) (string-constant replace-and-find-backwards-info))
(define/public
edit-menu:replace-and-find-backwards-on-demand
(λ (item) (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
(define/public (edit-menu:create-replace-and-find-backwards?) #f)
(define/public edit-menu:replace-all-callback (λ (item control) (void)))
(define/public (edit-menu:get-replace-all-item) edit-menu:replace-all-item)
(define/public (edit-menu:replace-all-string) (string-constant replace-all-menu-item))
(define/public (edit-menu:replace-all-help-string) (string-constant replace-all-info))
(define/public
edit-menu:replace-all-on-demand
(λ (item) (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
(define/public (edit-menu:create-replace-all?) #f)
(define/public edit-menu:find-case-sensitive-callback (λ (item control) (void)))
(define/public (edit-menu:get-find-case-sensitive-item) edit-menu:find-case-sensitive-item)
(define/public (edit-menu:find-case-sensitive-string) (string-constant find-case-sensitive-menu-item))
(define/public (edit-menu:find-case-sensitive-help-string) (string-constant find-case-sensitive-info))
(define/public
edit-menu:find-case-sensitive-on-demand
(λ (item) (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
(define/public (edit-menu:create-find-case-sensitive?) #f)
(define/public
edit-menu:between-find-and-preferences
(λ (menu) (unless (current-eventspace-has-standard-menus?) (make-object separator-menu-item% menu))))
@ -417,8 +453,7 @@
(label (file-menu:new-string))
(parent file-menu)
(callback
(let ((file-menu:new-callback (λ (item evt) (file-menu:new-callback item evt))))
file-menu:new-callback))
(let ((file-menu:new-callback (λ (item evt) (file-menu:new-callback item evt)))) file-menu:new-callback))
(shortcut #\n)
(shortcut-prefix (get-default-shortcut-prefix))
(help-string (file-menu:new-help-string))
@ -431,8 +466,7 @@
(label (file-menu:open-string))
(parent file-menu)
(callback
(let ((file-menu:open-callback (λ (item evt) (file-menu:open-callback item evt))))
file-menu:open-callback))
(let ((file-menu:open-callback (λ (item evt) (file-menu:open-callback item evt)))) file-menu:open-callback))
(shortcut #\o)
(shortcut-prefix (get-default-shortcut-prefix))
(help-string (file-menu:open-help-string))
@ -467,8 +501,7 @@
(label (file-menu:save-string))
(parent file-menu)
(callback
(let ((file-menu:save-callback (λ (item evt) (file-menu:save-callback item evt))))
file-menu:save-callback))
(let ((file-menu:save-callback (λ (item evt) (file-menu:save-callback item evt)))) file-menu:save-callback))
(shortcut #\s)
(shortcut-prefix (get-default-shortcut-prefix))
(help-string (file-menu:save-help-string))
@ -522,8 +555,7 @@
(label (file-menu:quit-string))
(parent file-menu)
(callback
(let ((file-menu:quit-callback (λ (item evt) (file-menu:quit-callback item evt))))
file-menu:quit-callback))
(let ((file-menu:quit-callback (λ (item evt) (file-menu:quit-callback item evt)))) file-menu:quit-callback))
(shortcut #\q)
(shortcut-prefix (get-default-shortcut-prefix))
(help-string (file-menu:quit-help-string))
@ -536,8 +568,7 @@
(label (edit-menu:undo-string))
(parent edit-menu)
(callback
(let ((edit-menu:undo-callback (λ (item evt) (edit-menu:undo-callback item evt))))
edit-menu:undo-callback))
(let ((edit-menu:undo-callback (λ (item evt) (edit-menu:undo-callback item evt)))) edit-menu:undo-callback))
(shortcut #\z)
(shortcut-prefix (get-default-shortcut-prefix))
(help-string (edit-menu:undo-help-string))
@ -549,13 +580,10 @@
(label (edit-menu:redo-string))
(parent edit-menu)
(callback
(let ((edit-menu:redo-callback (λ (item evt) (edit-menu:redo-callback item evt))))
edit-menu:redo-callback))
(let ((edit-menu:redo-callback (λ (item evt) (edit-menu:redo-callback item evt)))) edit-menu:redo-callback))
(shortcut (if (eq? (system-type) 'windows) #\y #\z))
(shortcut-prefix
(if (eq? (system-type) 'windows)
(get-default-shortcut-prefix)
(cons 'shift (get-default-shortcut-prefix))))
(if (eq? (system-type) 'windows) (get-default-shortcut-prefix) (cons 'shift (get-default-shortcut-prefix))))
(help-string (edit-menu:redo-help-string))
(demand-callback (λ (menu-item) (edit-menu:redo-on-demand menu-item))))))
(edit-menu:between-redo-and-cut (get-edit-menu))
@ -566,8 +594,7 @@
(label (edit-menu:cut-string))
(parent edit-menu)
(callback
(let ((edit-menu:cut-callback (λ (item evt) (edit-menu:cut-callback item evt))))
edit-menu:cut-callback))
(let ((edit-menu:cut-callback (λ (item evt) (edit-menu:cut-callback item evt)))) edit-menu:cut-callback))
(shortcut #\x)
(shortcut-prefix (get-default-shortcut-prefix))
(help-string (edit-menu:cut-help-string))
@ -580,8 +607,7 @@
(label (edit-menu:copy-string))
(parent edit-menu)
(callback
(let ((edit-menu:copy-callback (λ (item evt) (edit-menu:copy-callback item evt))))
edit-menu:copy-callback))
(let ((edit-menu:copy-callback (λ (item evt) (edit-menu:copy-callback item evt)))) edit-menu:copy-callback))
(shortcut #\c)
(shortcut-prefix (get-default-shortcut-prefix))
(help-string (edit-menu:copy-help-string))
@ -636,39 +662,78 @@
(label (edit-menu:find-string))
(parent edit-menu)
(callback
(let ((edit-menu:find-callback (λ (item evt) (edit-menu:find-callback item evt))))
edit-menu:find-callback))
(let ((edit-menu:find-callback (λ (item evt) (edit-menu:find-callback item evt)))) edit-menu:find-callback))
(shortcut #\f)
(shortcut-prefix (get-default-shortcut-prefix))
(help-string (edit-menu:find-help-string))
(demand-callback (λ (menu-item) (edit-menu:find-on-demand menu-item))))))
(define edit-menu:find-again-item
(and (edit-menu:create-find-again?)
(define edit-menu:find-backwards-item
(and (edit-menu:create-find-backwards?)
(new
(get-menu-item%)
(label (edit-menu:find-again-string))
(label (edit-menu:find-backwards-string))
(parent edit-menu)
(callback
(let ((edit-menu:find-again-callback (λ (item evt) (edit-menu:find-again-callback item evt))))
edit-menu:find-again-callback))
(let ((edit-menu:find-backwards-callback (λ (item evt) (edit-menu:find-backwards-callback item evt))))
edit-menu:find-backwards-callback))
(shortcut #\f)
(shortcut-prefix (cons 'shift (get-default-shortcut-prefix)))
(help-string (edit-menu:find-backwards-help-string))
(demand-callback (λ (menu-item) (edit-menu:find-backwards-on-demand menu-item))))))
(define edit-menu:replace-and-find-item
(and (edit-menu:create-replace-and-find?)
(new
(get-menu-item%)
(label (edit-menu:replace-and-find-string))
(parent edit-menu)
(callback
(let ((edit-menu:replace-and-find-callback (λ (item evt) (edit-menu:replace-and-find-callback item evt))))
edit-menu:replace-and-find-callback))
(shortcut #\g)
(shortcut-prefix (get-default-shortcut-prefix))
(help-string (edit-menu:find-again-help-string))
(demand-callback (λ (menu-item) (edit-menu:find-again-on-demand menu-item))))))
(define edit-menu:replace-and-find-again-item
(and (edit-menu:create-replace-and-find-again?)
(help-string (edit-menu:replace-and-find-help-string))
(demand-callback (λ (menu-item) (edit-menu:replace-and-find-on-demand menu-item))))))
(define edit-menu:replace-and-find-backwards-item
(and (edit-menu:create-replace-and-find-backwards?)
(new
(get-menu-item%)
(label (edit-menu:replace-and-find-again-string))
(label (edit-menu:replace-and-find-backwards-string))
(parent edit-menu)
(callback
(let ((edit-menu:replace-and-find-again-callback
(λ (item evt) (edit-menu:replace-and-find-again-callback item evt))))
edit-menu:replace-and-find-again-callback))
(shortcut (if (eq? (system-type) 'macosx) #f #\h))
(let ((edit-menu:replace-and-find-backwards-callback
(λ (item evt) (edit-menu:replace-and-find-backwards-callback item evt))))
edit-menu:replace-and-find-backwards-callback))
(shortcut #\g)
(shortcut-prefix (cons 'shift (get-default-shortcut-prefix)))
(help-string (edit-menu:replace-and-find-backwards-help-string))
(demand-callback (λ (menu-item) (edit-menu:replace-and-find-backwards-on-demand menu-item))))))
(define edit-menu:replace-all-item
(and (edit-menu:create-replace-all?)
(new
(get-menu-item%)
(label (edit-menu:replace-all-string))
(parent edit-menu)
(callback
(let ((edit-menu:replace-all-callback (λ (item evt) (edit-menu:replace-all-callback item evt))))
edit-menu:replace-all-callback))
(shortcut #f)
(shortcut-prefix (get-default-shortcut-prefix))
(help-string (edit-menu:replace-and-find-again-help-string))
(demand-callback (λ (menu-item) (edit-menu:replace-and-find-again-on-demand menu-item))))))
(help-string (edit-menu:replace-all-help-string))
(demand-callback (λ (menu-item) (edit-menu:replace-all-on-demand menu-item))))))
(define edit-menu:find-case-sensitive-item
(and (edit-menu:create-find-case-sensitive?)
(new
(get-checkable-menu-item%)
(label (edit-menu:find-case-sensitive-string))
(parent edit-menu)
(callback
(let ((edit-menu:find-case-sensitive-callback
(λ (item evt) (edit-menu:find-case-sensitive-callback item evt))))
edit-menu:find-case-sensitive-callback))
(shortcut #f)
(shortcut-prefix (get-default-shortcut-prefix))
(help-string (edit-menu:find-case-sensitive-help-string))
(demand-callback (λ (menu-item) (edit-menu:find-case-sensitive-on-demand menu-item))))))
(edit-menu:between-find-and-preferences (get-edit-menu))
(define edit-menu:preferences-item
(and (edit-menu:create-preferences?)

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

@ -16,7 +16,6 @@ WARNING: printf is rebound in the body of the unit to always
mred/mred-sig
mrlib/interactive-value-port
mzlib/list
mzlib/etc
setup/dirs
mzlib/string
(prefix-in srfi1: srfi/1))
@ -46,8 +45,8 @@ WARNING: printf is rebound in the body of the unit to always
(apply fprintf original-output-port args)
(void))
(define-struct range (start end b/w-bitmap color caret-space?) #:inspector #f)
(define-struct rectangle (left top right bottom b/w-bitmap color) #:inspector #f)
(define-struct range (start end caret-space? style color) #:inspector #f)
(define-struct rectangle (left top right bottom style color) #:inspector #f)
(define-values (register-port-name! lookup-port-name)
;; port-name->editor-ht: (hashof symbol (weakboxof editor:basic<%>))
@ -92,12 +91,13 @@ WARNING: printf is rebound in the body of the unit to always
(mixin (editor:basic<%> (class->interface text%)) (basic<%>)
(inherit get-canvas get-canvases get-admin split-snip get-snip-position
begin-edit-sequence end-edit-sequence
set-autowrap-bitmap
set-autowrap-bitmap last-position
delete find-snip invalidate-bitmap-cache
set-file-format get-file-format
get-style-list is-modified? change-style set-modified
position-location position-locations
get-extent get-filename)
position-line line-start-position line-end-position
get-extent get-filename run-after-edit-sequence)
(define port-name-identifier #f)
(define/public (get-port-name)
@ -120,8 +120,6 @@ WARNING: printf is rebound in the body of the unit to always
(symbol? id)
(equal? port-name-identifier id)))))
(define highlight-pen #f)
(define highlight-brush #f)
(define highlight-tmp-color #f)
(define range-rectangles null)
@ -132,7 +130,17 @@ WARNING: printf is rebound in the body of the unit to always
(define/public-final (get-highlighted-ranges)
(unless ranges-list
(set! ranges-list (hash-map ranges (λ (x y) x))))
(set! ranges-list
(map car (sort (hash-map ranges cons) (λ (x y) (> (cdr x) (cdr y))))))
(let loop ([ranges-list ranges-list]
[i 0])
(cond
[(null? ranges-list)
(set! ranges-low i)
(set! ranges-high 1)]
[else
(hash-set! ranges (car ranges-list) i)
(loop (cdr ranges-list) (- i 1))])))
ranges-list)
(define/public (get-fixed-style)
(send (get-style-list) find-named-style "Standard"))
@ -197,19 +205,18 @@ WARNING: printf is rebound in the body of the unit to always
(invalidate-bitmap-cache left top width height))))]
[else (let* ([r (car rectangles)]
[rleft (rectangle-left r)]
[rright (rectangle-right r)]
[rtop (rectangle-top r)]
[rbottom (rectangle-bottom r)]
[this-left (if (number? rleft)
rleft
[adjust (λ (w f)
(+ w (f (case (rectangle-style r)
[(ellipse) 8]
[else 0]))))]
[this-left (if (number? (rectangle-left r))
(adjust (rectangle-left r) -)
min-left)]
[this-right (if (number? rright)
rright
[this-right (if (number? (rectangle-right r))
(adjust (rectangle-right r) +)
max-right)]
[this-bottom rbottom]
[this-top rtop])
[this-top (adjust (rectangle-top r) -)]
[this-bottom (adjust (rectangle-bottom r) +)])
(if (and left top right bottom)
(loop (min this-left left)
(min this-top top)
@ -230,30 +237,31 @@ WARNING: printf is rebound in the body of the unit to always
(λ (range rst)
(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 bottom-start-y)
(begin
(send this position-locations start b1 b2 #f b3 start-eol? #t)
(values (if caret-space?
(+ 1 (unbox b1))
(unbox b1))
(unbox b2)
(unbox b3)))]
[(end-x top-end-y bottom-end-y)
(begin (send this position-locations end b1 b2 #f b3 end-eol? #t)
(values (unbox b1)
(unbox b2)
(unbox b3)))])
[style (range-style range)]
[color (range-color range)]
[lp (last-position)])
(let*-values ([(start-eol? end-eol?)
(if (= start end)
(values #f #f)
(values #f #t))]
[(start-x top-start-y bottom-start-y)
(begin
(position-locations start b1 b2 #f b3 start-eol? #t)
(values (if caret-space?
(+ 1 (unbox b1))
(unbox b1))
(unbox b2)
(unbox b3)))]
[(end-x top-end-y bottom-end-y)
(begin (position-locations end b1 b2 #f b3 end-eol? #t)
(values (unbox b1)
(unbox b2)
(unbox b3)))])
(cond
;; the position-location values can be strange when
;; this condition is true, so we just bail out.
[(or (> start lp) (> end lp)) '()]
[(= top-start-y top-end-y)
(cons
(make-rectangle start-x
@ -262,37 +270,73 @@ WARNING: printf is rebound in the body of the unit to always
(+ end-x 1)
end-x)
bottom-start-y
b/w-bitmap
style
color)
rst)]
[(eq? style 'ellipse)
(let ([end-line (position-line end end-eol?)])
;; for this loop,
;; we don't need to consider the first or the last line,
;; since they are already covered
;; by `start-x' and `end-x'
(let loop ([l start-x]
[r end-x]
[line (+ (position-line start start-eol?) 1)])
(cond
[(>= line end-line)
;; techincally, the > should not be needed, but we
;; would rather have bad drawing than an infinite loop
;; in the case that there is a bug ...
(cons
(make-rectangle l
top-start-y
r
bottom-end-y
style
color)
rst)]
[else
(let ([line-start (line-start-position line)]
[line-end (line-end-position line)])
(position-location line-start b1 #f #t)
(position-location line-end b2 #f #t)
(loop (min (unbox b1) l)
(max (unbox b2) r)
(+ line 1)))])))]
[else
(list*
(make-rectangle start-x
top-start-y
'right-edge
bottom-start-y
b/w-bitmap
style
color)
(make-rectangle 'left-edge
bottom-start-y
'max-width
'right-edge
top-end-y
b/w-bitmap
style
color)
(make-rectangle 'left-edge
top-end-y
end-x
bottom-end-y
b/w-bitmap
style
color)
rst)]))))]
[old-rectangles range-rectangles])
rst)]))))])
(set! range-rectangles
(foldl new-rectangles
null
(get-highlighted-ranges)))))
(define/augment (on-reflow)
(run-after-edit-sequence
(λ () (recompute-range-rectangles))
'framework:recompute-range-rectangles)
(inner void on-reflow))
(define delayed-highlights? #f)
(define todo void)
@ -308,145 +352,144 @@ WARNING: printf is rebound in the body of the unit to always
(set! todo void))
(inner (void) after-edit-sequence))
(define/public highlight-range
(opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low])
(unless (let ([exact-pos-int?
(λ (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))
(unless (or (eq? priority 'high) (eq? priority 'low))
(error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e"
priority))
(unless (is-a? color color%)
(error 'highlight-range "expected a color for the third argument, got ~s" color))
(let* ([l (make-range start end bitmap color caret-space?)]
[update-one
(λ ()
(set! ranges-list #f)
(hash-set! ranges l (if (eq? priority 'high) (+ ranges-high 1) (- ranges-low 1)))
(if (eq? priority 'high)
(set! ranges-high (+ ranges-high 1))
(set! ranges-low (- ranges-low 1))))])
(cond
[delayed-highlights?
(set! todo
(let ([old-todo todo])
(λ ()
(old-todo)
(update-one))))]
[else
(redraw-highlights update-one)])
(λ () (unhighlight-range start end color bitmap caret-space?)))))
(define/public (highlight-range start end color [caret-space? #f] [priority 'low] [style 'rectangle])
(unless (let ([exact-pos-int?
(λ (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))
(unless (<= 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"
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 ~s" color))
(let* ([color (if (is-a? color color%)
color
(send the-color-database find-color color))]
[l (make-range start end caret-space? style color)]
[update-one
(λ ()
(set! ranges-list #f)
(hash-set! ranges l (if (eq? priority 'high) (+ ranges-high 1) (- ranges-low 1)))
(if (eq? priority 'high)
(set! ranges-high (+ ranges-high 1))
(set! ranges-low (- ranges-low 1))))])
(cond
[delayed-highlights?
(set! todo
(let ([old-todo todo])
(λ ()
(old-todo)
(update-one))))]
[else
(redraw-highlights update-one)])
(λ () (unhighlight-range start end color caret-space? style))))
(define/private (redraw-highlights todo)
(let ([old-rectangles range-rectangles])
(todo)
(recompute-range-rectangles)
(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
[(> (hash-count ranges) 20)
(invalidate-bitmap-cache)]
[delayed-highlights?
(set! todo
(let ([old-todo todo])
(λ ()
(old-todo)
(new-todo))))]
[else
(recompute-range-rectangles)
(invalidate-rectangles (append old-rectangles range-rectangles))])))
(define/public unhighlight-range
(opt-lambda (start end color [bitmap #f] [caret-space? #f])
(let ([new-todo
(λ ()
(hash-remove! ranges (make-range start end bitmap color caret-space?))
(set! ranges-list #f))])
(cond
[delayed-highlights?
(set! todo
(let ([old-todo todo])
(λ ()
(old-todo)
(new-todo))))]
[else
(redraw-highlights new-todo)]))))
(define/private (matching-rectangle? r start end color bitmap caret-space?)
(and (equal? start (range-start r))
(equal? end (range-end r))
(eq? bitmap (range-b/w-bitmap r))
(equal? color (range-color r))
(equal? caret-space? (range-caret-space? r))))
(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)
(when before (recompute-range-rectangles)) ;; assume this result cannot change between before & after
(let-values ([(view-x view-y view-width view-height)
(let ([b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)]
[b4 (box 0)])
(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)]
[last-color #f])
(for-each
(λ (rectangle)
(let* ([b/w-bitmap (rectangle-b/w-bitmap rectangle)]
[color (let ([rc (rectangle-color rectangle)])
(cond
[(and last-color (eq? last-color rc))
rc]
[rc
(set! last-color #f)
(unless highlight-tmp-color
(set! highlight-tmp-color (make-object color% 0 0 0)))
(send dc try-color rc highlight-tmp-color)
(if (<= (color-model:rgb-color-distance
(send rc red)
(send rc green)
(send rc blue)
(send highlight-tmp-color red)
(send highlight-tmp-color green)
(send highlight-tmp-color blue))
18)
(begin (set! last-color rc)
rc)
#f)]
[else
(set! last-color #f)
rc]))]
[first-number (λ (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
(first-number
(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 ([skip-it? #f])
(cond
[(and before color)
(send dc set-pen (send the-pen-list find-or-create-pen color 0 'solid))
(send dc set-brush (send the-brush-list find-or-create-brush color 'solid))]
[(and (not before) (not color) b/w-bitmap)
(unless highlight-pen
(set! highlight-pen (make-object pen% "BLACK" 0 'solid)))
(unless highlight-brush
(set! highlight-brush (make-object brush% "black" 'solid)))
(send highlight-pen set-stipple b/w-bitmap)
(send highlight-brush set-stipple b/w-bitmap)
(send dc set-pen highlight-pen)
(send dc set-brush highlight-brush)]
[else (set! skip-it? #t)])
(unless skip-it?
(send dc draw-rectangle (+ left dx) (+ top dy) width height)))))
range-rectangles)
(send dc set-pen old-pen)
(send dc set-brush old-brush))))
(when before
(let-values ([(view-x view-y view-width view-height)
(let ([b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)]
[b4 (box 0)])
(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)]
[old-smoothing (send dc get-smoothing)]
[last-color #f]
[color-rectangle
(λ (rectangle)
(let* ([left (if (number? (rectangle-left rectangle))
(rectangle-left rectangle)
view-x)]
[top (rectangle-top rectangle)]
[right (if (number? (rectangle-right rectangle))
(rectangle-right rectangle)
(+ view-x view-width))]
[bottom (rectangle-bottom rectangle)]
[width (max 0 (- right left))]
[height (max 0 (- bottom top))])
(when (and (or (<= left-margin left right-margin)
(<= left-margin (+ left width) right-margin)
(<= left left-margin right-margin (+ left width)))
(or (<= top-margin top bottom-margin)
(<= top-margin (+ top height) bottom-margin)
(<= top top-margin bottom-margin (+ top height))))
(let ([color (let ([rc (rectangle-color rectangle)])
(cond
[(and last-color (eq? last-color rc))
rc]
[rc
(set! last-color #f)
(unless highlight-tmp-color
(set! highlight-tmp-color (make-object color% 0 0 0)))
(send dc try-color rc highlight-tmp-color)
(if (<= (color-model:rgb-color-distance
(send rc red)
(send rc green)
(send rc blue)
(send highlight-tmp-color red)
(send highlight-tmp-color green)
(send highlight-tmp-color blue))
18)
(begin (set! last-color rc)
rc)
#f)]
[else
(set! last-color #f)
rc]))])
(when color
(case (rectangle-style rectangle)
[(ellipse)
(send dc set-pen color 3 'solid)
(send dc set-brush "black" 'transparent)
(send dc draw-ellipse
(+ dx left -4)
(+ dy top -4)
(+ width 8)
(+ height 8))]
[(rectangle)
(send dc set-pen color 1 'transparent)
(send dc set-brush color 'solid)
(send dc draw-rectangle (+ left dx) (+ top dy) width height)]))))))])
(send dc set-smoothing 'aligned)
(for-each color-rectangle range-rectangles)
(send dc set-smoothing old-smoothing)
(send dc set-pen old-pen)
(send dc set-brush old-brush)))))
(define styles-fixed? #f)
(public get-styles-fixed set-styles-fixed)
@ -462,8 +505,7 @@ WARNING: printf is rebound in the body of the unit to always
(inner (void) after-insert start len)
(end-edit-sequence))
(public move/copy-to-edit)
(define (move/copy-to-edit dest-edit start end dest-position)
(define/public (move/copy-to-edit dest-edit start end dest-position)
(split-snip start)
(split-snip end)
(let loop ([snip (find-snip end 'before)])
@ -553,9 +595,13 @@ WARNING: printf is rebound in the body of the unit to always
(define searching<%>
(interface (editor:keymap<%> basic<%>)
set-searching-str))
set-searching-str
get-search-hits))
(define searching-mixin
(mixin (editor:keymap<%> basic<%>) (searching<%>)
(inherit run-after-edit-sequence invalidate-bitmap-cache)
(define/override (get-keymaps)
(cons (keymap:get-search) (super get-keymaps)))
@ -564,7 +610,6 @@ WARNING: printf is rebound in the body of the unit to always
(define search-hits 0)
(define/public (get-search-hits) search-hits)
(inherit invalidate-bitmap-cache)
(define/public (set-searching-str s [cs? #t])
(unless (and (equal? searching-str s)
(equal? case-sensitive? cs?))
@ -572,12 +617,29 @@ WARNING: printf is rebound in the body of the unit to always
(set! case-sensitive? cs?)
(redo-search)))
(define/augment (after-insert start len)
(redo-search)
(unless updating-search?
(content-changed))
(inner (void) after-insert start len))
(define/augment (after-delete start len)
(redo-search)
(unless updating-search?
(content-changed))
(inner (void) after-delete start len))
(define updating-search? #f)
(define/private (content-changed)
(when searching-str
(run-after-edit-sequence
(λ ()
(set! updating-search? #t)
(redo-search)
(let ([tlw (get-top-level-window)])
(when (and tlw
(is-a? tlw frame:searchable<%>))
(send tlw search-results-changed)))
(set! updating-search? #f))
'framework:search-results-changed)))
(inherit get-top-level-window)
(define/override (on-focus on?)
(let ([f (get-top-level-window)])
@ -585,7 +647,7 @@ WARNING: printf is rebound in the body of the unit to always
(when on?
(send f set-text-to-search this))))
(super on-focus on?))
(inherit highlight-range begin-edit-sequence end-edit-sequence find-string)
(define clear-regions void)
@ -603,10 +665,11 @@ WARNING: printf is rebound in the body of the unit to always
searching-str)])
(set! search-hits (+ search-hits counts))
(let ([old clear-regions]
[new (highlight-range next end (send the-color-database find-color "yellow"))])
[new (highlight-range next end "plum" #f 'low 'ellipse)])
(set! clear-regions (λ () (old) (new))))
(loop end (+ n 1))))))]
[else
(set! clear-regions void)
(invalidate-bitmap-cache)])
(end-edit-sequence))
@ -855,14 +918,15 @@ WARNING: printf is rebound in the body of the unit to always
(send delegate last-position)
(send delegate last-position))
(loop (send snip next)))))
(for-each
(λ (range)
(send delegate unhighlight-range
(range-start range)
(range-end range)
(range-color range)
(range-b/w-bitmap range)
(range-caret-space? range)))
(range-caret-space? range)
(range-style range)))
(send delegate get-highlighted-ranges))
(for-each
(λ (range)
@ -870,25 +934,22 @@ WARNING: printf is rebound in the body of the unit to always
(range-start range)
(range-end range)
(range-color range)
(range-b/w-bitmap range)
(range-caret-space? range)
'high))
'high
(range-style range)))
(reverse (get-highlighted-ranges)))
(send delegate lock #t)
(send delegate end-edit-sequence)))
(define/override highlight-range
(opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low])
(when delegate
(send delegate highlight-range
start end color bitmap caret-space? priority))
(super highlight-range start end color bitmap caret-space? priority)))
(define/override (highlight-range start end color [caret-space? #f] [priority 'low] [style 'rectangle])
(when delegate
(send delegate highlight-range start end color caret-space? priority style))
(super highlight-range start end color caret-space? priority style))
(define/override unhighlight-range
(opt-lambda (start end color [bitmap #f] [caret-space? #f])
(when delegate
(send delegate unhighlight-range start end color bitmap caret-space?))
(super unhighlight-range start end color bitmap caret-space?)))
(define/override (unhighlight-range start end color [caret-space? #f] [style 'rectangle])
(when delegate
(send delegate unhighlight-range start end color caret-space? style))
(super unhighlight-range start end color caret-space? style))
(inherit get-canvases get-active-canvas has-focus?)
(define/override (on-paint before? dc left top right bottom dx dy draw-caret?)
@ -976,9 +1037,10 @@ WARNING: printf is rebound in the body of the unit to always
run-after-edit-sequence)
(define/private (enqueue-for-frame call-method tag)
(run-after-edit-sequence
(rec from-enqueue-for-frame
(λ ()
(call-with-frame call-method)))
(let ([from-enqueue-for-frame
(λ ()
(call-with-frame call-method))])
from-enqueue-for-frame)
tag))
;; call-with-frame : ((is-a?/c frame:text-info<%>) -> void) -> void

5
collects/macro-debugger/view/frame.ss
View File

@ -67,10 +67,7 @@
edit-menu:create-redo?
;edit-menu:create-cut?
;edit-menu:create-paste?
edit-menu:create-clear?
;edit-menu:create-find?
;edit-menu:create-find-again?
edit-menu:create-replace-and-find-again?)
edit-menu:create-clear?)
(define file-menu (get-file-menu))
(define edit-menu (get-edit-menu))

3
collects/scribblings/drscheme/keybindings.scrbl
View File

@ -86,6 +86,9 @@ inspired by Emacs.}
@keybinding["A-C-up"]{move up out of an embedded editor}
@keybinding["M-C-down"]{move down into an embedded editor}
@keybinding["A-C-down"]{move down into an embedded editor}
@keybinding["C-F6"]{move the cursor from the definitions
window to the interactions window (or the search window, if it is open).}
]
@section{Editing Operations}

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

@ -886,6 +886,33 @@
}
@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].
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*[(((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%))))]{
Returns the last value passed to
@method[frame:searchable<%> set-text-to-search].
@ -893,6 +920,9 @@
@defmethod[(set-text-to-search [txt (or/c false/c (is-a?/c (subclass?/c text%)))]) void?]{
Sets the current text to be searched.
}
@defmethod[(search-hidden?) boolean?]{
Returns @scheme[#t] if the search subwindow is visiable and @scheme[#f] otherwise.
}
@defmethod*[(((hide-search) void))]{
This method hides the searching information on the bottom of the
frame.
@ -902,79 +932,19 @@
When the searching sub window is hidden, makes it visible.
}
@defmethod*[(((set-search-direction (dir (union -1 1))) void))]{
Sets the direction that future searches will be performed.
If @scheme[dir] is @scheme[1] searches will be performed forwards and if
@scheme[dir] is @scheme[-1] searches will be performed backwards.
@defmethod[(get-case-sensitive-search?) boolean?]{
Returns @scheme[#t] if the search is currently case-sensitive.
}
@defmethod*[(((replace&search) boolean))]{
Calls
@method[frame:searchable<%> replace]
and if it returns @scheme[#t], calls
@method[frame:searchable<%> search-again].
@defmethod[(search-results-changed) void?]{
This method is called to notify the frame when
}
@defmethod*[(((replace-all) void))]{
Loops through the text from the current position to the end, replacing
all occurrences of the search string with the contents of the replace
edit. Only searches forward, does not loop around to the beginning of
the text.
}
@defmethod*[(((replace) boolean))]{
If the selected text matches the search string, this method replaces
the text with the contents of the replace text. If the replace was
successful, @scheme[#t] is returned. Otherwise, @scheme[#f] is returned.
}
@defmethod*[(((can-replace?) boolean))]{
Returns @scheme[#t] if a replace command would succeed.
Defaultly is @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.
}
@defmethod*[(((toggle-search-focus) void))]{
Toggles the keyboard focus between the searching edit, the replacing edit and the result of
@method[frame:searchable<%> get-text-to-search].
}
@defmethod*[(((move-to-search-or-search) (union boolean void)))]{
This method moves the focus to the text that contains the search
string, or if the focus is there already, performs a forward search.
It returns void if the focus was not to the search text, otherwise it
returns a boolean indicating the success of the search.
}
@defmethod*[(((move-to-search-or-reverse-search) (union boolean void)))]{
This method moves the focus to the text that contains the search
string, or if the focus is there already, performs a reverse search.
It returns void if the focus was not to the search text, otherwise it
returns a boolean indicating the success of the search.
}
@defmethod*[(((search-again (direction Symbol (rm previous searching direction)) (beep? bool |#t|)) boolean))]{
Searches for the text in the search edit in the result of
@method[frame:searchable<%> get-text-to-search].
Returns @scheme[#t] if the text is found and sets the selection to the
found text. If the text is not found it returns @scheme[#f].
}
}
@defmixin[frame:searchable-mixin (frame:standard-menus<%>) (frame:searchable<%>)]{
This mixin adds support for searching in the
@scheme[editor<%>]
in this frame.
The result of this mixin uses the same initialization arguments as the
mixin's argument.
@defmethod*[#:mode override (((edit-menu:find-callback (item (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void))]{
Calls
@ -1016,10 +986,6 @@
Builds a panel for the searching information.
}
@defmethod*[#:mode override (((on-activate) void))]{
When the frame is activated, searches will take place in this frame.
}
@defmethod*[#:mode augment (((on-close) void))]{
Cleans up after the searching frame.
@ -1043,7 +1009,7 @@
@defmethod*[#:mode override (((get-editor%) (is-a?/c editor<%>)))]{
Returns
@scheme[text:searching%].
@scheme[(text:searching-mixin (super get-editor%))].
}
}
@defclass[frame:basic% (frame:register-group-mixin (frame:basic-mixin frame%)) ()]{}

60
collects/scribblings/framework/standard-menus.scrbl
View File

@ -245,29 +245,65 @@
@(defmethod (edit-menu:find-help-string) string? "The result of this method is used as the help string" "\n" "when the " (scheme menu-item%) " object is created." "\n" "\n" "Defaults to " (scheme (string-constant find-info)) ".")
@(defmethod (edit-menu:get-find-again-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (scheme menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-find-again?) ").")
@(defmethod (edit-menu:get-find-backwards-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (scheme menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-find-backwards?) ").")
@(defmethod (edit-menu:create-find-again?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (scheme #f) ".")
@(defmethod (edit-menu:create-find-backwards?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (scheme #f) ".")
@(defmethod (edit-menu:find-again-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (schemeblock (void)) " ")
@(defmethod (edit-menu:find-backwards-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (schemeblock (void)) " ")
@(defmethod (edit-menu:find-again-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (schemeblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
@(defmethod (edit-menu:find-backwards-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (schemeblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
@(defmethod (edit-menu:find-again-string) string? "The result of this method is used as the name of the " (scheme menu-item%) "." "\n" "\n" "Defaults to " (scheme (string-constant find-again-menu-item)) ".")
@(defmethod (edit-menu:find-backwards-string) string? "The result of this method is used as the name of the " (scheme menu-item%) "." "\n" "\n" "Defaults to " (scheme (string-constant find-backwards-menu-item)) ".")
@(defmethod (edit-menu:find-again-help-string) string? "The result of this method is used as the help string" "\n" "when the " (scheme menu-item%) " object is created." "\n" "\n" "Defaults to " (scheme (string-constant find-again-info)) ".")
@(defmethod (edit-menu:find-backwards-help-string) string? "The result of this method is used as the help string" "\n" "when the " (scheme menu-item%) " object is created." "\n" "\n" "Defaults to " (scheme (string-constant find-backwards-info)) ".")
@(defmethod (edit-menu:get-replace-and-find-again-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (scheme menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-replace-and-find-again?) ").")
@(defmethod (edit-menu:get-replace-and-find-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (scheme menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-replace-and-find?) ").")
@(defmethod (edit-menu:create-replace-and-find-again?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (scheme #f) ".")
@(defmethod (edit-menu:create-replace-and-find?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (scheme #f) ".")
@(defmethod (edit-menu:replace-and-find-again-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (schemeblock (void)) " ")
@(defmethod (edit-menu:replace-and-find-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (schemeblock (void)) " ")
@(defmethod (edit-menu:replace-and-find-again-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (schemeblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
@(defmethod (edit-menu:replace-and-find-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (schemeblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
@(defmethod (edit-menu:replace-and-find-again-string) string? "The result of this method is used as the name of the " (scheme menu-item%) "." "\n" "\n" "Defaults to " (scheme (string-constant replace-and-find-again-menu-item)) ".")
@(defmethod (edit-menu:replace-and-find-string) string? "The result of this method is used as the name of the " (scheme menu-item%) "." "\n" "\n" "Defaults to " (scheme (string-constant replace-and-find-menu-item)) ".")
@(defmethod (edit-menu:replace-and-find-again-help-string) string? "The result of this method is used as the help string" "\n" "when the " (scheme menu-item%) " object is created." "\n" "\n" "Defaults to " (scheme (string-constant replace-and-find-again-info)) ".")
@(defmethod (edit-menu:replace-and-find-help-string) string? "The result of this method is used as the help string" "\n" "when the " (scheme menu-item%) " object is created." "\n" "\n" "Defaults to " (scheme (string-constant replace-and-find-info)) ".")
@(defmethod (edit-menu:get-replace-and-find-backwards-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (scheme menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-replace-and-find-backwards?) ").")
@(defmethod (edit-menu:create-replace-and-find-backwards?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (scheme #f) ".")
@(defmethod (edit-menu:replace-and-find-backwards-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (schemeblock (void)) " ")
@(defmethod (edit-menu:replace-and-find-backwards-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (schemeblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
@(defmethod (edit-menu:replace-and-find-backwards-string) string? "The result of this method is used as the name of the " (scheme menu-item%) "." "\n" "\n" "Defaults to " (scheme (string-constant replace-and-find-backwards-menu-item)) ".")
@(defmethod (edit-menu:replace-and-find-backwards-help-string) string? "The result of this method is used as the help string" "\n" "when the " (scheme menu-item%) " object is created." "\n" "\n" "Defaults to " (scheme (string-constant replace-and-find-backwards-info)) ".")
@(defmethod (edit-menu:get-replace-all-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (scheme menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-replace-all?) ").")
@(defmethod (edit-menu:create-replace-all?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (scheme #f) ".")
@(defmethod (edit-menu:replace-all-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (schemeblock (void)) " ")
@(defmethod (edit-menu:replace-all-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (schemeblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
@(defmethod (edit-menu:replace-all-string) string? "The result of this method is used as the name of the " (scheme menu-item%) "." "\n" "\n" "Defaults to " (scheme (string-constant replace-all-menu-item)) ".")
@(defmethod (edit-menu:replace-all-help-string) string? "The result of this method is used as the help string" "\n" "when the " (scheme menu-item%) " object is created." "\n" "\n" "Defaults to " (scheme (string-constant replace-all-info)) ".")
@(defmethod (edit-menu:get-find-case-sensitive-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (scheme menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-find-case-sensitive?) ").")
@(defmethod (edit-menu:create-find-case-sensitive?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (scheme #f) ".")
@(defmethod (edit-menu:find-case-sensitive-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (schemeblock (void)) " ")
@(defmethod (edit-menu:find-case-sensitive-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (schemeblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>))))))
@(defmethod (edit-menu:find-case-sensitive-string) string? "The result of this method is used as the name of the " (scheme menu-item%) "." "\n" "\n" "Defaults to " (scheme (string-constant find-case-sensitive-menu-item)) ".")
@(defmethod (edit-menu:find-case-sensitive-help-string) string? "The result of this method is used as the help string" "\n" "when the " (scheme menu-item%) " object is created." "\n" "\n" "Defaults to " (scheme (string-constant find-case-sensitive-info)) ".")
@(defmethod (edit-menu:between-find-and-preferences (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "find") " and the " (tt "preferences") " menu-item." "\n" "Override it to add additional menu items at that point. ")

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

@ -7,28 +7,36 @@
@definterface[text:basic<%> (editor:basic<%> text%)]{
Classes matching this interface are expected to implement the basic
functionality needed by the framework.
@defmethod*[(((highlight-range (start exact-integer) (end exact-integer) (color (instance color%)) (bitmap (union |#f| (instance bitmap%)) |#f|) (caret-space boolean |#f|) (priority (union (quote high) (quote low)) (quote low))) (-> void)))]{
@defmethod*[(((highlight-range (start exact-nonnegative-integer?)
(end exact-nonnegative-integer?)
(color (or/c string? (is-a?/c color%)))
(caret-space boolean? #f)
(priority (symbols 'high 'low) 'low)
(style (symbols 'rectangle 'ellipse) 'rectangle))
(-> void)))]{
This function highlights a region of text in the buffer.
The range between @scheme[start] and @scheme[end] will
be highlighted with the color in color, if the style is
@scheme['rectangle] (the default). If the style is
@scheme['ellipse], then the outline of an ellipse is
drawn around the range in the editor, using the color.
The range between @scheme[start] and @scheme[end] will be highlighted with the
color in color, and @scheme[bitmap] will be painted over the range of text in
black and white. If @scheme[bitmap] is @scheme[#f], the range will be inverted,
using the platform specific xor. This method is not recommended, because the
selection is also displayed using xor.
If @scheme[caret-space?] is not @scheme[#f], the left edge of the range
will be one pixel short, to leave space for the caret. The caret does
not interfere with the right hand side of the range. Note that under X
windows the caret is drawn with XOR, which means almost anything can
happen. So if the caret is in the middle of the range it may be hard
to see, or if it is on the left of the range and @scheme[caret-space?] is
If @scheme[caret-space?] is not @scheme[#f], the left
edge of the range will be one pixel short, to leave
space for the caret. The caret does not interfere with
the right hand side of the range. Note that under some
platforms, the caret is drawn with XOR, which means
almost anything can happen. So if the caret is in the
middle of the range it may be hard to see, or if it is
on the left of the range and @scheme[caret-space?] is
@scheme[#f] it may also be hard to see.
The @scheme[priority] argument indicates the relative priority for
drawing overlapping regions. If two regions overlap and have different
priorities, the region with @scheme['high] priority will be drawn second
and only it will be visible in the overlapping region.
The @scheme[priority] argument indicates the relative
priority for drawing overlapping regions. If two regions
overlap and have different priorities, the region with
@scheme['high] priority will be drawn second and only it
will be visible in the overlapping region.
This method returns a thunk, which, when invoked, will turn off
the highlighting from this range.
@ -36,15 +44,19 @@
See also
@method[text:basic<%> unhighlight-range].
}
@defmethod*[(((unhighlight-range (start exact-integer) (end exact-integer) (color (instance color%)) (bitmap (union |#f| (instance bitmap%)) |#f|) (caret-space boolean |#f|)) void))]{
@defmethod*[(((unhighlight-range
(start exact-nonnegative-integer?)
(end exact-nonnegative-integer?)
(color (or/c string? (is-a?/c color%)))
(caret-space boolean? #f)
(style (symbols 'rectangle 'ellipse) 'rectangle))
void))]{
This method removes the highlight from a region of text in
the buffer.
The region must match up to a region specified
from an earlier call to
@method[text:basic<%> highlight-range].
}
@defmethod*[(((get-highlighted-ranges) (listof range)))]{
@ -216,6 +228,10 @@
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.
}
}
@defmixin[text:searching-mixin (editor:keymap<%> text:basic<%>) (text:searching<%>)]{
This
@ -230,6 +246,18 @@
result of
@scheme[keymap:get-search]
}
@defmethod[#:mode augment (after-insert [start nonnegative-exact-integer?][len nonnegative-exact-integer?]) void?]{
Re-does any search now that the contents of the window have changed.
}
@defmethod[#:mode augment (after-delete [start nonnegative-exact-integer?][len nonnegative-exact-integer?]) void?]{
Re-does any search now that the contents of the window have changed.
}
@defmethod[#:mode override (on-focus [on? boolean?]) void?]{
Tells the frame containing the editor to search based on this editor via
the @method[frame:searchable<%> set-text-to-search] method.
}
}
@definterface[text:return<%> (text%)]{
Objects supporting this interface were created by

1
collects/string-constants/danish-string-constants.ss
View File

@ -473,7 +473,6 @@ please adhere to these guidelines:
(dock "Minimer")
(undock "Gendan")
(replace&find-again "Erstat og Søg igen") ;;; need double & to get a single &
(replace-to-end "Erstat til slutning")
(forward "Frem")
(backward "Tilbage")
(hide "Skjul")

1
collects/string-constants/dutch-string-constants.ss
View File

@ -274,7 +274,6 @@
(dock "Aanhaken")
(undock "Zweven")
(replace&find-again "Vervang && Zoek opnieuw") ;;; need double & to get a single &
(replace-to-end "Vervang tot einde")
(forward "Voorwaarts")
(backward "Terug")
(hide "Sluiten")

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

@ -509,7 +509,6 @@ please adhere to these guidelines:
(dock "Dock")
(undock "Undock")
(replace&find-again "Replace && Find Again") ;;; need double & to get a single &
(replace-to-end "Replace to End")
(forward "Forward")
(backward "Backward")
(hide "Hide")
@ -647,19 +646,24 @@ please adhere to these guidelines:
(select-all-info "Select the entire document")
(select-all-menu-item "Select A&ll")
(find-info "Search for a string")
(find-menu-item "Find...")
(find-again-info "Search for the same string as before")
(find-again-menu-item "Find Again")
(find-again-backwards-info "Search for the same string as before, but backwards")
(find-again-backwards-menu-item "Find Again Backwards")
(find-info "Skip to the next occurrence of the string in the find window")
(find-menu-item "Find")
(find-backwards-info "Skip to the previous occurrence of the string in the find window")
(find-backwards-menu-item "Find Backwards")
(replace-and-find-again-info "Replace the current text and search for the same string as before")
(replace-and-find-again-menu-item "Replace && Find Again")
(replace-and-find-info "Replace the current text and skip to the next occurrence")
(replace-and-find-menu-item "Replace && Find")
(replace-and-find-backwards-info "Replace the current text and skip to the previous occurrence")
(replace-and-find-backwards-menu-item "Replace && Find Backwards")
(replace-all-info "Replace all occurrences of the search string")
(replace-all-menu-item "Replace All")
(find-case-sensitive-info "Toggles between case-sensitive and case-insensitive search")
(find-case-sensitive-menu-item "Find Case Sensitive")
(complete-word "Complete Word") ; the complete word menu item in the edit menu
(no-completions "... no completions available") ; shows up in the completions menu when there are no completions (in italics)

1
collects/string-constants/french-string-constants.ss
View File

@ -501,7 +501,6 @@
(dock "Attacher")
(undock "Détacher")
(replace&find-again "Remplacer && chercher à nouveau") ;;; need double & to get a single &
(replace-to-end "Remplacer jusqu'à la fin")
(forward "En avant")
(backward "En arrière")
(hide "Cacher")

1
collects/string-constants/german-string-constants.ss
View File

@ -407,7 +407,6 @@
(dock "Andocken")
(undock "Ablegen")
(replace&find-again "Nochmals Suchen && Ersetzen") ;;; need double & to get a single &
(replace-to-end "Ersetzen bis zum Ende")
(forward "Vorwärts")
(backward "Rückwärts")
(hide "Ausblenden")

1
collects/string-constants/japanese-string-constants.ss
View File

@ -486,7 +486,6 @@ please adhere to these guidelines:
(dock "結合")
(undock "分離")
(replace&find-again "置換＋再検索") ;;; need double & to get a single &
(replace-to-end "最後まで置換")
(forward "前方")
(backward "後方")
(hide "隠す")

1
collects/string-constants/portuguese-string-constants.ss
View File

@ -474,7 +474,6 @@ please adhere to these guidelines:
(dock "Esconder")
(undock "Não Esconder")
(replace&find-again "Substituir && Procurar de Novo") ;;; need double & to get a single &
(replace-to-end "Substituir até ao Fim")
(forward "Avançar")
(backward "Recuar")
(hide "Esconder")

1
collects/string-constants/simplified-chinese-string-constants.ss
View File

@ -436,7 +436,6 @@
(dock "面板")
(undock "对话框")
(replace&find-again "替换并查找下一个") ;;; need double & to get a single &
(replace-to-end "全部替换")
(forward "下一个")
(backward "上一个")
(hide "隐藏")

1
collects/string-constants/spanish-string-constants.ss
View File

@ -367,7 +367,6 @@
(dock "Atracar")
(undock "Des-atracar")
(replace&find-again "Reemplazar && Vuelve a buscar") ;;; need double & to get a single &
(replace-to-end "Reemplazar hasta el final")
(forward "Hacia adelante")
(backward "Hacia atrás")
(hide "Esconder")

1
collects/string-constants/traditional-chinese-string-constants.ss
View File

@ -432,7 +432,6 @@
(dock "面板")
(undock "對話框")
(replace&find-again "替換並查找下一個") ;;; need double & to get a single &
(replace-to-end "全部替換")
(forward "下一個")
(backward "上一個")
(hide "隱藏")