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

..

Browse Source 
original commit: a5f57c6907ebaa68449195980a382247cf28540a
This commit is contained in:
Robby Findler 2003-09-03 19:35:15 +00:00
parent 113aab5fc4
commit b2cab72ff6
1 changed files with 106 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3,7 +3,6 @@
(require (lib "string-constant.ss" "string-constants") (require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
(lib "class100.ss")
(lib "include.ss") (lib "include.ss")
"sig.ss" "sig.ss"
"../gui-utils.ss" "../gui-utils.ss"
@ -1565,18 +1564,17 @@
(loop (send snip next)))))] (loop (send snip next)))))]
[text-keymap/editor% [text-keymap/editor%
(class100 text:keymap% args (class text:keymap%
(rename [super-get-keymaps get-keymaps]) (rename [super-get-keymaps get-keymaps])
(override (define/override (get-keymaps)
[get-keymaps (if (preferences:get 'framework:menu-bindings)
(lambda () (append (list (keymap:get-editor))
(if (preferences:get 'framework:menu-bindings) (super-get-keymaps))
(append (list (keymap:get-editor)) (append (super-get-keymaps)
(super-get-keymaps)) (list (keymap:get-editor)))))
(append (super-get-keymaps) (inherit set-styles-fixed)
(list (keymap:get-editor)))))]) (super-new)
(sequence (set-styles-fixed #t))]
(apply super-init args)))]
[find-panel (make-object horizontal-panel% dialog)] [find-panel (make-object horizontal-panel% dialog)]
@ -1812,126 +1810,116 @@
(set! searching-frame frame)) (set! searching-frame frame))
(define find-text% (define find-text%
(class100 text:keymap% args (class text:keymap%
(inherit get-text) (inherit get-text)
(rename [super-after-insert after-insert] (rename [super-after-insert after-insert]
[super-after-delete after-delete] [super-after-delete after-delete]
[super-on-focus on-focus]) [super-on-focus on-focus])
(private (define/private (get-searching-edit)
[get-searching-edit (and searching-frame
(lambda () (send searching-frame get-text-to-search)))
(and searching-frame (define/public search
(send searching-frame get-text-to-search)))]) (opt-lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t])
(public (when searching-frame
[search (let* ([string (get-text)]
(opt-lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t]) [top-searching-edit (get-searching-edit)]
(when searching-frame
(let* ([string (get-text)]
[top-searching-edit (get-searching-edit)]
[searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)]) [searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)])
(if focus-snip (if focus-snip
(send focus-snip get-editor) (send focus-snip get-editor)
top-searching-edit))] top-searching-edit))]
[not-found [not-found
(lambda (found-edit skip-beep?) (lambda (found-edit skip-beep?)
(send found-edit set-position search-anchor) (send found-edit set-position search-anchor)
(when (and beep? (when (and beep?
(not skip-beep?)) (not skip-beep?))
(bell)) (bell))
#f)] #f)]
[found [found
(lambda (edit first-pos) (lambda (edit first-pos)
(let ([last-pos ((if (eq? searching-direction 'forward) + -) (let ([last-pos ((if (eq? searching-direction 'forward) + -)
first-pos (string-length string))]) first-pos (string-length string))])
(send* edit (send* edit
(set-caret-owner #f 'display) (set-caret-owner #f 'display)
(set-position (set-position
(min first-pos last-pos) (min first-pos last-pos)
(max first-pos last-pos) (max first-pos last-pos)
#f #t 'local)) #f #t 'local))
#t))]) #t))])
(if (string=? string "") (if (string=? string "")
(not-found top-searching-edit #t) (not-found top-searching-edit #t)
(begin (begin
(when reset-search-anchor? (when reset-search-anchor?
(reset-search-anchor searching-edit)) (reset-search-anchor searching-edit))
(let-values ([(found-edit first-pos) (let-values ([(found-edit first-pos)
(find-string-embedded (find-string-embedded
searching-edit searching-edit
string string
searching-direction searching-direction
search-anchor search-anchor
'eof #t #t #t)]) 'eof #t #t #t)])
(cond (cond
[(not first-pos) [(not first-pos)
(if wrap? (if wrap?
(let-values ([(found-edit pos) (let-values ([(found-edit pos)
(find-string-embedded (find-string-embedded
top-searching-edit top-searching-edit
string string
searching-direction searching-direction
(if (eq? 'forward searching-direction) (if (eq? 'forward searching-direction)
0 0
(send searching-edit last-position)))]) (send searching-edit last-position)))])
(if (not pos) (if (not pos)
(not-found found-edit #f) (not-found found-edit #f)
(found found-edit pos))) (found found-edit pos)))
(not-found found-edit #f))] (not-found found-edit #f))]
[else [else
(found found-edit first-pos)])))))))]) (found found-edit first-pos)]))))))))
(private-field (field
[dont-search #f]) [dont-search #f])
(public (define/public (stop-searching)
[stop-searching (set! dont-search #t))
(lambda () (define/public (start-searching)
(set! dont-search #t))] (set! dont-search #f))
[start-searching
(lambda ()
(set! dont-search #f))])
(override (define/override (on-focus on?)
[on-focus (when on?
(lambda (on?) (let ([edit (get-searching-edit)])
(when on? (when edit
(let ([edit (get-searching-edit)]) (reset-search-anchor (get-searching-edit)))))
(when edit (super-on-focus on?))
(reset-search-anchor (get-searching-edit))))) (define/override (after-insert x y)
(super-on-focus on?))] (super-after-insert x y)
[after-insert (unless dont-search
(lambda (x y) (search #f)))
(super-after-insert x y) (define/override (after-delete x y)
(unless dont-search (super-after-delete x y)
(search #f)))] (unless dont-search
[after-delete (search #f)))
(lambda (x y) (super-new)
(super-after-delete x y) (inherit set-styles-fixed)
(unless dont-search (set-styles-fixed #t)))
(search #f)))])
(sequence (apply super-init args))))
; this is here for when editors are printed, during debugging
(define replace-text% (define replace-text%
(class text:keymap% (class text:keymap%
(super-instantiate ()))) (inherit set-styles-fixed)
(super-instantiate ())
(set-styles-fixed #t)))
(define find-edit #f) (define find-edit #f)
(define replace-edit #f) (define replace-edit #f)
(define searchable-canvas% (define searchable-canvas%
(class100 editor-canvas% (parent) (class editor-canvas%
(inherit get-top-level-window set-line-count) (inherit get-top-level-window set-line-count)
(rename [super-on-focus on-focus]) (rename [super-on-focus on-focus])
(override (define/override (on-focus x)
[on-focus (when x
(lambda (x) (set-searching-frame (get-top-level-window)))
(when x (super-on-focus x))
(set-searching-frame (get-top-level-window))) (super-new (style '(hide-hscroll hide-vscroll)))
(super-on-focus x))]) (set-line-count 2)))
(sequence
(super-init parent #f '(hide-hscroll hide-vscroll))
(set-line-count 2))))
(define (init-find/replace-edits) (define (init-find/replace-edits)
(unless find-edit (unless find-edit
@ -2283,7 +2271,7 @@
(super-instantiate ()))) (super-instantiate ())))
; to see printouts in memory debugging better. ; to see printouts in memory debugging better.
(define memory-text% (class100 text% args (sequence (apply super-init args)))) (define memory-text% (class text% (super-new)))
(define memory-text (make-object memory-text%)) (define memory-text (make-object memory-text%))
(send memory-text hide-caret #t) (send memory-text hide-caret #t)
(define show-memory-text? (define show-memory-text?