1445 lines
43 KiB
Scheme
1445 lines
43 KiB
Scheme
|
|
(unit/sig framework:frame^
|
|
(import mred^
|
|
[group : framework:group^]
|
|
[preferences : framework:preferences^]
|
|
[icon : framework:icon^]
|
|
[handler : framework:handler^]
|
|
[application : framework:application^]
|
|
[panel : framework:panel^]
|
|
[gui-utils : framework:gui-utils^]
|
|
[exit : framework:exit^]
|
|
[finder : framework:finder^]
|
|
[keymap : framework:keymap^]
|
|
[text : framework:text^]
|
|
[pasteboard : framework:pasteboard^]
|
|
[editor : framework:editor^]
|
|
[canvas : framework:canvas^]
|
|
[mzlib:function : mzlib:function^]
|
|
[mzlib:file : mzlib:file^])
|
|
|
|
(rename [-editor<%> editor<%>]
|
|
[-pasteboard% pasteboard%]
|
|
[-text% text%])
|
|
|
|
(define (reorder-menus frame)
|
|
(let* ([items (send (send frame get-menu-bar) get-items)]
|
|
[move-to-back
|
|
(lambda (name items)
|
|
(let loop ([items items]
|
|
[back null])
|
|
(cond
|
|
[(null? items) back]
|
|
[else (let ([item (car items)])
|
|
(if (string=? (send item get-plain-label) name)
|
|
(loop (cdr items)
|
|
(cons item back))
|
|
(cons item (loop (cdr items) back))))])))]
|
|
[move-to-front
|
|
(lambda (name items)
|
|
(reverse (move-to-back name (reverse items))))]
|
|
[re-ordered
|
|
(move-to-front
|
|
"File"
|
|
(move-to-front
|
|
"Edit"
|
|
(move-to-back
|
|
"Help"
|
|
items)))])
|
|
(for-each (lambda (item) (send item delete)) items)
|
|
(for-each (lambda (item) (send item restore)) re-ordered)))
|
|
|
|
(define frame-width 600)
|
|
(define frame-height 650)
|
|
(let ([window-trimming-upper-bound-width 20]
|
|
[window-trimming-upper-bound-height 50])
|
|
(let-values ([(w h) (get-display-size)])
|
|
(set! frame-width (min frame-width (- w window-trimming-upper-bound-width)))
|
|
(set! frame-height (min frame-height (- h window-trimming-upper-bound-height)))))
|
|
|
|
(define basic<%> (interface ((class->interface frame%))
|
|
get-area-container%
|
|
get-area-container
|
|
get-menu-bar%
|
|
make-root-area-container
|
|
close
|
|
get-filename))
|
|
(define basic-mixin
|
|
(mixin ((class->interface frame%)) (basic<%>)
|
|
(label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null])
|
|
(rename [super-can-close? can-close?]
|
|
[super-on-close on-close]
|
|
[super-on-focus on-focus])
|
|
(public
|
|
[get-filename
|
|
(case-lambda
|
|
[() (get-filename #f)]
|
|
[(b) #f])])
|
|
(private
|
|
[after-init? #f])
|
|
(override
|
|
[can-close?
|
|
(lambda ()
|
|
(let ([super (super-can-close?)]
|
|
[group
|
|
(send (group:get-the-frame-group)
|
|
can-remove-frame?
|
|
this)])
|
|
(and super group)))]
|
|
[on-close
|
|
(lambda ()
|
|
(super-on-close)
|
|
(send (group:get-the-frame-group)
|
|
remove-frame
|
|
this))]
|
|
[on-focus
|
|
(lambda (on?)
|
|
(super-on-focus on?)
|
|
(when on?
|
|
(send (group:get-the-frame-group) set-active-frame this)))]
|
|
|
|
[on-drop-file
|
|
(lambda (filename)
|
|
(handler:edit-file filename))])
|
|
|
|
;; added call to set label here to hopefully work around a problem in mac mred
|
|
(inherit set-label change-children)
|
|
(override
|
|
[after-new-child
|
|
(lambda (child)
|
|
(when after-init?
|
|
(change-children (lambda (l) (mzlib:function: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"
|
|
)))])
|
|
|
|
(inherit show)
|
|
(public
|
|
[get-area-container% (lambda () vertical-panel%)]
|
|
[get-menu-bar% (lambda () menu-bar%)]
|
|
[make-root-area-container
|
|
(lambda (% parent)
|
|
(make-object % parent))]
|
|
[close
|
|
(lambda ()
|
|
(when (can-close?)
|
|
(on-close)
|
|
(show #f)))])
|
|
|
|
(inherit accept-drop-files)
|
|
(sequence
|
|
(let ([mdi-parent (send (group:get-the-frame-group) get-mdi-parent)])
|
|
(super-init label
|
|
(or parent mdi-parent)
|
|
width height x y
|
|
(cond
|
|
[parent style]
|
|
[mdi-parent (cons 'mdi-child style)]
|
|
[else style])))
|
|
|
|
(accept-drop-files #t)
|
|
|
|
(make-object menu% "&Windows" (make-object (get-menu-bar%) this))
|
|
(reorder-menus this)
|
|
(send (group:get-the-frame-group) insert-frame this))
|
|
(private
|
|
[panel (make-root-area-container (get-area-container%) this)])
|
|
(public
|
|
[get-area-container (lambda () panel)])
|
|
(sequence
|
|
(set! after-init? #t))))
|
|
|
|
(define info<%> (interface (basic<%>)
|
|
determine-width
|
|
lock-status-changed
|
|
update-info
|
|
set-info-canvas
|
|
get-info-canvas
|
|
get-info-editor
|
|
get-info-panel))
|
|
|
|
(define info-mixin
|
|
(mixin (basic<%>) (info<%>) args
|
|
(rename [super-make-root-area-container make-root-area-container])
|
|
(private
|
|
[rest-panel 'uninitialized-root]
|
|
[super-root 'uninitialized-super-root])
|
|
(override
|
|
[make-root-area-container
|
|
(lambda (% parent)
|
|
(let* ([s-root (super-make-root-area-container
|
|
vertical-panel%
|
|
parent)]
|
|
[r-root (make-object % s-root)])
|
|
(set! super-root s-root)
|
|
(set! rest-panel r-root)
|
|
r-root))])
|
|
|
|
(private
|
|
[info-canvas #f])
|
|
(public
|
|
[get-info-canvas
|
|
(lambda ()
|
|
info-canvas)]
|
|
[set-info-canvas
|
|
(lambda (c)
|
|
(set! info-canvas c))]
|
|
[get-info-editor
|
|
(lambda ()
|
|
(and info-canvas
|
|
(send info-canvas get-editor)))])
|
|
|
|
(public
|
|
[determine-width
|
|
(let ([magic-space 25])
|
|
(lambda (string canvas edit)
|
|
(send edit set-autowrap-bitmap #f)
|
|
(send canvas call-as-primary-owner
|
|
(lambda ()
|
|
(let ([lb (box 0)]
|
|
[rb (box 0)])
|
|
(send edit erase)
|
|
(send edit insert string)
|
|
(send edit position-location
|
|
(send edit last-position)
|
|
rb)
|
|
(send edit position-location 0 lb)
|
|
(send canvas min-width
|
|
(+ magic-space (- (inexact->exact (floor (unbox rb)))
|
|
(inexact->exact (floor (unbox lb)))))))))))])
|
|
|
|
(rename [super-on-close on-close])
|
|
(private
|
|
[outer-info-panel 'top-info-panel-uninitialized]
|
|
[close-panel-callback
|
|
(preferences:add-callback
|
|
'framework:show-status-line
|
|
(lambda (p v)
|
|
(if v
|
|
(register-gc-blit)
|
|
(unregister-collecting-blit gc-canvas))
|
|
(send super-root change-children
|
|
(lambda (l)
|
|
(if v
|
|
(list rest-panel outer-info-panel)
|
|
(list rest-panel))))))])
|
|
(private
|
|
[memory-cleanup void]) ;; only for CVSers; used with memory-text
|
|
(override
|
|
[on-close
|
|
(lambda ()
|
|
(super-on-close)
|
|
(unregister-collecting-blit gc-canvas)
|
|
(close-panel-callback)
|
|
(memory-cleanup))])
|
|
|
|
(public
|
|
[lock-status-changed
|
|
(let ([icon-currently-locked? #f])
|
|
(lambda ()
|
|
(let ([info-edit (get-info-editor)])
|
|
(cond
|
|
[(not (object? lock-message))
|
|
(void)]
|
|
[info-edit
|
|
(unless (send lock-message is-shown?)
|
|
(send lock-message show #t))
|
|
(let ([locked-now? (ivar info-edit locked?)])
|
|
(unless (eq? locked-now? icon-currently-locked?)
|
|
(set! icon-currently-locked? locked-now?)
|
|
(let ([label
|
|
(if locked-now?
|
|
(icon:get-lock-bitmap)
|
|
(icon:get-unlock-bitmap))])
|
|
(when (object? lock-message)
|
|
(send lock-message
|
|
set-label
|
|
(if (send label ok?)
|
|
label
|
|
(if locked-now? "Locked" "Unlocked")))))))]
|
|
[else
|
|
(when (send lock-message is-shown?)
|
|
(send lock-message show #f))]))))])
|
|
(public
|
|
[update-info
|
|
(lambda ()
|
|
(lock-status-changed))])
|
|
(sequence
|
|
(apply super-init args))
|
|
|
|
(public
|
|
[get-info-panel
|
|
(begin
|
|
(set! outer-info-panel (make-object horizontal-panel% super-root))
|
|
(let ([info-panel (make-object horizontal-panel% outer-info-panel)]
|
|
[spacer (make-object grow-box-spacer-pane% outer-info-panel)])
|
|
(lambda ()
|
|
(send outer-info-panel stretchable-height #f)
|
|
info-panel)))])
|
|
(public
|
|
[update-memory-text
|
|
(lambda ()
|
|
(when show-memory-text?
|
|
(send memory-text begin-edit-sequence)
|
|
(send memory-text lock #f)
|
|
(send memory-text erase)
|
|
(send memory-text insert (number->string (current-memory-use)))
|
|
(send memory-text lock #t)
|
|
(send memory-text end-edit-sequence)))])
|
|
|
|
(sequence
|
|
;; only for CVSers
|
|
(when show-memory-text?
|
|
(let* ([panel (make-object horizontal-panel% (get-info-panel) '(border))]
|
|
[button (make-object button% "Collect" panel
|
|
(lambda x
|
|
(collect-garbage)
|
|
(update-memory-text)))]
|
|
[ec (make-object editor-canvas% panel memory-text '(no-hscroll no-vscroll))])
|
|
(determine-width "000000000" ec memory-text)
|
|
(update-memory-text)
|
|
(set! memory-cleanup
|
|
(lambda ()
|
|
(send memory-text remove-canvas ec)
|
|
(send ec set-editor #f)))
|
|
(send panel stretchable-width #f))))
|
|
(private
|
|
[lock-message (make-object message%
|
|
(let ([b (icon:get-unlock-bitmap)])
|
|
(if (and #f (send b ok?))
|
|
b
|
|
"Unlocked"))
|
|
(get-info-panel))]
|
|
[gc-canvas (make-object canvas% (get-info-panel) '(border))]
|
|
[register-gc-blit
|
|
(lambda ()
|
|
(let ([onb (icon:get-gc-on-bitmap)]
|
|
[offb (icon:get-gc-off-bitmap)])
|
|
(when (and (send onb ok?)
|
|
(send offb ok?))
|
|
(register-collecting-blit gc-canvas
|
|
0 0
|
|
(send onb get-width)
|
|
(send onb get-height)
|
|
onb offb))))])
|
|
|
|
(sequence
|
|
(unless (preferences:get 'framework:show-status-line)
|
|
(send super-root change-children
|
|
(lambda (l)
|
|
(list rest-panel))))
|
|
(register-gc-blit)
|
|
|
|
(let* ([gcb (icon:get-gc-on-bitmap)]
|
|
[gc-width (if (send gcb ok?)
|
|
(send gcb get-width)
|
|
10)]
|
|
[gc-height (if (send gcb ok?)
|
|
(send gcb get-height)
|
|
10)])
|
|
(send* gc-canvas
|
|
(min-client-width (max (send gc-canvas min-width) gc-width))
|
|
(min-client-height (max (send gc-canvas min-height) gc-height))
|
|
(stretchable-width #f)
|
|
(stretchable-height #f)))
|
|
(send* (get-info-panel)
|
|
(set-alignment 'right 'center)
|
|
(stretchable-height #f)
|
|
(spacing 3)
|
|
(border 3)))))
|
|
|
|
(define text-info<%> (interface (info<%>)
|
|
overwrite-status-changed
|
|
anchor-status-changed
|
|
editor-position-changed))
|
|
(define text-info-mixin
|
|
(mixin (info<%>) (text-info<%>) args
|
|
(inherit get-info-editor)
|
|
(rename [super-on-close on-close])
|
|
(private
|
|
[remove-pref-callback
|
|
(let ([one
|
|
(preferences:add-callback
|
|
'framework:line-offsets
|
|
(lambda (p v)
|
|
(editor-position-changed-offset/numbers
|
|
v
|
|
(preferences:get 'framework:display-line-numbers))
|
|
#t))]
|
|
[two
|
|
(preferences:add-callback
|
|
'framework:display-line-numbers
|
|
(lambda (p v)
|
|
(editor-position-changed-offset/numbers
|
|
(preferences:get 'framework:line-offsets)
|
|
v)
|
|
#t))])
|
|
(lambda ()
|
|
(one)
|
|
(two)))])
|
|
|
|
(override
|
|
[on-close
|
|
(lambda ()
|
|
(super-on-close)
|
|
(remove-pref-callback))])
|
|
|
|
(private
|
|
[editor-position-changed-offset/numbers
|
|
(let ([last-start #f]
|
|
[last-end #f]
|
|
[last-params #f])
|
|
(lambda (offset? line-numbers?)
|
|
(let* ([edit (get-info-editor)]
|
|
[make-one
|
|
(lambda (pos)
|
|
(let* ([line (send edit position-line pos)]
|
|
[line-start (send edit line-start-position line)]
|
|
[char (- pos line-start)])
|
|
(if line-numbers?
|
|
(format "~a:~a"
|
|
(if offset?
|
|
(add1 line)
|
|
line)
|
|
(if offset?
|
|
(add1 char)
|
|
char))
|
|
(format "~a"
|
|
(if offset?
|
|
(+ pos 1)
|
|
pos)))))])
|
|
(cond
|
|
[(not (object? position-canvas))
|
|
(void)]
|
|
[edit
|
|
(unless (send position-canvas is-shown?)
|
|
(send position-canvas show #t))
|
|
(let ([start (send edit get-start-position)]
|
|
[end (send edit get-end-position)])
|
|
(unless (and last-start
|
|
(equal? last-params (list offset? line-numbers?))
|
|
(= last-start start)
|
|
(= last-end end))
|
|
(set! last-params (list offset? line-numbers?))
|
|
(set! last-start start)
|
|
(set! last-end end)
|
|
(when (object? position-edit)
|
|
(send* position-edit
|
|
(lock #f)
|
|
(erase)
|
|
(insert
|
|
(if (= start end)
|
|
(make-one start)
|
|
(string-append (make-one start)
|
|
"-"
|
|
(make-one end))))
|
|
(lock #t)))))]
|
|
[else
|
|
(when (send position-canvas is-shown?)
|
|
(send position-canvas show #f))]))))])
|
|
(public
|
|
[anchor-status-changed
|
|
(let ([last-state? #f])
|
|
(lambda ()
|
|
(let ([info-edit (get-info-editor)]
|
|
[failed
|
|
(lambda ()
|
|
(unless (eq? last-state? #f)
|
|
(set! last-state? #f)
|
|
(send anchor-message show #f)))])
|
|
(cond
|
|
[info-edit
|
|
(let ([anchor-now? (send info-edit get-anchor)])
|
|
(unless (eq? anchor-now? last-state?)
|
|
(cond
|
|
[(object? anchor-message)
|
|
(send anchor-message
|
|
show
|
|
anchor-now?)
|
|
(set! last-state? anchor-now?)]
|
|
[else (failed)])))]
|
|
[else
|
|
(failed)]))))]
|
|
[editor-position-changed
|
|
(lambda ()
|
|
(editor-position-changed-offset/numbers
|
|
(preferences:get 'framework:line-offsets)
|
|
(preferences:get 'framework:display-line-numbers)))]
|
|
[overwrite-status-changed
|
|
(let ([last-state? #f])
|
|
(lambda ()
|
|
(let ([info-edit (get-info-editor)]
|
|
[failed
|
|
(lambda ()
|
|
(set! last-state? #f)
|
|
(send overwrite-message show #f))])
|
|
(cond
|
|
[info-edit
|
|
(let ([overwrite-now? (send info-edit get-overwrite-mode)])
|
|
(unless (eq? overwrite-now? last-state?)
|
|
(cond
|
|
[(object? overwrite-message)
|
|
(send overwrite-message
|
|
show
|
|
overwrite-now?)
|
|
(set! last-state? overwrite-now?)]
|
|
[else
|
|
(failed)])))]
|
|
[else
|
|
(failed)]))))])
|
|
(rename [super-update-info update-info])
|
|
(override
|
|
[update-info
|
|
(lambda ()
|
|
(super-update-info)
|
|
(overwrite-status-changed)
|
|
(anchor-status-changed)
|
|
(editor-position-changed))])
|
|
(sequence
|
|
(apply super-init args))
|
|
|
|
(inherit get-info-panel)
|
|
(private
|
|
[anchor-message
|
|
(make-object message%
|
|
(let ([b (icon:get-anchor-bitmap)])
|
|
(if (and #f (send b ok?))
|
|
b
|
|
"Auto-extend Selection"))
|
|
(get-info-panel))]
|
|
[overwrite-message
|
|
(make-object message%
|
|
"Overwrite"
|
|
(get-info-panel))]
|
|
[position-canvas (make-object editor-canvas% (get-info-panel) #f '(no-hscroll no-vscroll))]
|
|
[position-edit (make-object text%)])
|
|
|
|
(inherit determine-width)
|
|
(sequence
|
|
(let ([move-front
|
|
(lambda (x l)
|
|
(cons x (mzlib:function:remq x l)))])
|
|
(send (get-info-panel) change-children
|
|
(lambda (l)
|
|
(move-front
|
|
anchor-message
|
|
(move-front
|
|
overwrite-message
|
|
(move-front
|
|
position-canvas
|
|
l))))))
|
|
(send anchor-message show #f)
|
|
(send overwrite-message show #f)
|
|
(send* position-canvas
|
|
(set-line-count 1)
|
|
(set-editor position-edit)
|
|
(stretchable-width #f)
|
|
(stretchable-height #f))
|
|
(determine-width "0000:000-0000:000"
|
|
position-canvas
|
|
position-edit)
|
|
(editor-position-changed)
|
|
(send position-edit hide-caret #t)
|
|
(send position-edit lock #t))))
|
|
|
|
(define pasteboard-info<%> (interface (info<%>)))
|
|
(define pasteboard-info-mixin
|
|
(mixin (basic<%>) (pasteboard-info<%>) args
|
|
(sequence
|
|
(apply super-init args))))
|
|
|
|
(include "standard-menus.ss")
|
|
|
|
(define -editor<%> (interface (standard-menus<%>)
|
|
get-entire-label
|
|
get-label-prefix
|
|
set-label-prefix
|
|
|
|
get-canvas%
|
|
get-canvas<%>
|
|
get-editor%
|
|
get-editor<%>
|
|
|
|
make-editor
|
|
save-as
|
|
get-canvas
|
|
get-editor))
|
|
|
|
(define editor-mixin
|
|
(mixin (standard-menus<%>) (-editor<%>)
|
|
(file-name
|
|
[parent #f]
|
|
[width frame-width]
|
|
[height frame-height]
|
|
.
|
|
args)
|
|
(inherit get-area-container get-client-size
|
|
show get-edit-target-window get-edit-target-object)
|
|
(rename [super-on-close on-close]
|
|
[super-set-label set-label])
|
|
|
|
(override
|
|
[get-filename
|
|
(case-lambda
|
|
[() (get-filename #f)]
|
|
[(b)
|
|
(let ([e (get-editor)])
|
|
(and e (send e get-filename b)))])]
|
|
[on-close
|
|
(lambda ()
|
|
(super-on-close)
|
|
(send (get-editor) on-close))])
|
|
(private
|
|
[label (if file-name
|
|
(mzlib:file:file-name-from-path file-name)
|
|
(gui-utils:next-untitled-name))]
|
|
[label-prefix (application:current-app-name)]
|
|
[do-label
|
|
(lambda ()
|
|
(super-set-label (get-entire-label))
|
|
(send (group:get-the-frame-group) frame-label-changed this))])
|
|
|
|
(public
|
|
[get-entire-label
|
|
(lambda ()
|
|
(cond
|
|
[(string=? "" label)
|
|
label-prefix]
|
|
[(string=? "" label-prefix)
|
|
label]
|
|
[else
|
|
(string-append label " - " label-prefix)]))]
|
|
[get-label-prefix (lambda () label-prefix)]
|
|
[set-label-prefix
|
|
(lambda (s)
|
|
(when (and (string? s)
|
|
(not (string=? s label-prefix)))
|
|
(set! label-prefix s)
|
|
(do-label)))])
|
|
(override
|
|
[get-label (lambda () label)]
|
|
[set-label
|
|
(lambda (t)
|
|
(when (and (string? t)
|
|
(not (string=? t label)))
|
|
(set! label t)
|
|
(do-label)))])
|
|
(public
|
|
[get-canvas% (lambda () editor-canvas%)]
|
|
[get-canvas<%> (lambda () (class->interface editor-canvas%))]
|
|
[make-canvas (lambda ()
|
|
(let ([% (get-canvas%)]
|
|
[<%> (get-canvas<%>)])
|
|
(unless (implementation? % <%>)
|
|
(error 'frame:editor%
|
|
"result of get-canvas% method must match ~e interface; got: ~e"
|
|
<%> %))
|
|
(make-object % (get-area-container))))]
|
|
[get-editor% (lambda () (error 'editor-frame% "no editor% class specified"))]
|
|
[get-editor<%> (lambda () editor<%>)]
|
|
[make-editor (lambda ()
|
|
(let ([% (get-editor%)]
|
|
[<%> (get-editor<%>)])
|
|
(unless (implementation? % <%>)
|
|
(error 'frame:editor%
|
|
"result of get-editor% method must match ~e interface; got: ~e"
|
|
<%> %))
|
|
(make-object %)))])
|
|
|
|
|
|
(public
|
|
[save-as
|
|
(opt-lambda ([format 'same])
|
|
(let* ([name (send (get-editor) get-filename)]
|
|
[file (parameterize ([finder:dialog-parent-parameter this])
|
|
(finder:put-file name))])
|
|
(when file
|
|
(send (get-editor) save-file file format))))])
|
|
(inherit get-checkable-menu-item% get-menu-item%)
|
|
(override
|
|
[file-menu:revert
|
|
(lambda (item control)
|
|
(let* ([b (box #f)]
|
|
[edit (get-editor)]
|
|
[filename (send edit get-filename b)])
|
|
(if (or (not filename) (unbox b))
|
|
(bell)
|
|
(let ([start
|
|
(if (is-a? edit text%)
|
|
(send edit get-start-position)
|
|
#f)])
|
|
(send edit begin-edit-sequence)
|
|
(let ([status (send edit load-file
|
|
filename
|
|
'same
|
|
#f)])
|
|
(if status
|
|
(begin
|
|
(when (is-a? edit text%)
|
|
(send edit set-position start start))
|
|
(send edit end-edit-sequence))
|
|
(begin
|
|
(send edit end-edit-sequence)
|
|
(message-box
|
|
"Error Reverting"
|
|
(format "could not read ~a" filename)))))))
|
|
#t))]
|
|
[file-menu:save (lambda (item control)
|
|
(send (get-editor) save-file)
|
|
#t)]
|
|
[file-menu:save-as (lambda (item control) (save-as) #t)]
|
|
[file-menu:print (lambda (item control)
|
|
(send (get-editor) print
|
|
#t
|
|
#t
|
|
(preferences:get 'framework:print-output-mode))
|
|
#t)])
|
|
|
|
(private
|
|
[edit-menu:do (lambda (const)
|
|
(lambda (menu evt)
|
|
(let ([edit (get-edit-target-object)])
|
|
(when (and edit
|
|
(is-a? edit editor<%>))
|
|
(send edit do-edit-operation const)))
|
|
#t))])
|
|
|
|
(override
|
|
[edit-menu:between-select-all-and-find
|
|
(lambda (edit-menu)
|
|
(make-object separator-menu-item% edit-menu)
|
|
|
|
(let ([c% (class (get-menu-item%) args
|
|
(inherit enable)
|
|
(rename [super-on-demand on-demand])
|
|
(override
|
|
[on-demand
|
|
(lambda ()
|
|
(let ([edit (get-edit-target-object)])
|
|
(enable (and edit (is-a? edit editor<%>)))))])
|
|
(sequence (apply super-init args)))])
|
|
|
|
(make-object c% "Insert Text Box" edit-menu (edit-menu:do 'insert-text-box))
|
|
(make-object c% "Insert Pasteboard Box" edit-menu (edit-menu:do 'insert-pasteboard-box))
|
|
(make-object c% "Insert Image..." edit-menu (edit-menu:do 'insert-image)))
|
|
|
|
(let* ([c% (class (get-checkable-menu-item%) args
|
|
(rename [super-on-demand on-demand])
|
|
(inherit check enable)
|
|
(override
|
|
[on-demand
|
|
(lambda ()
|
|
(let ([edit (get-edit-target-object)])
|
|
(if (and edit
|
|
(is-a? edit editor<%>))
|
|
(begin
|
|
(enable #t)
|
|
(check (send edit auto-wrap)))
|
|
(begin
|
|
(check #f)
|
|
(enable #f)))))])
|
|
(sequence (apply super-init args)))])
|
|
(make-object c% "Wrap Text" edit-menu
|
|
(lambda (item event)
|
|
(let ([edit (get-edit-target-object)])
|
|
(when (and edit
|
|
(is-a? edit editor<%>))
|
|
(send edit auto-wrap (not (send edit auto-wrap))))))))
|
|
|
|
(make-object separator-menu-item% edit-menu))])
|
|
|
|
(override
|
|
[help-menu:about
|
|
(lambda (menu evt)
|
|
(message-box (application:current-app-name)
|
|
(format "Welcome to ~a" (application:current-app-name))))]
|
|
[help-menu:about-string (lambda () (application:current-app-name))])
|
|
|
|
(sequence
|
|
(apply super-init
|
|
(get-entire-label)
|
|
parent
|
|
width
|
|
height
|
|
args))
|
|
|
|
(public
|
|
[get-canvas (let ([c #f])
|
|
(lambda ()
|
|
(unless c
|
|
(set! c (make-canvas))
|
|
(send c set-editor (get-editor)))
|
|
c))]
|
|
[get-editor (let ([e #f])
|
|
(lambda ()
|
|
(unless e
|
|
(set! e (make-editor))
|
|
(send (get-canvas) set-editor e))
|
|
e))])
|
|
(sequence
|
|
(do-label)
|
|
(cond
|
|
[(and file-name (file-exists? file-name))
|
|
(send (get-editor) load-file file-name 'guess #f)]
|
|
[file-name
|
|
(send (get-editor) set-filename file-name)]
|
|
[else (void)])
|
|
(let ([canvas (get-canvas)])
|
|
(send canvas focus)))))
|
|
|
|
(define text<%> (interface (-editor<%>)))
|
|
(define text-mixin
|
|
(mixin (-editor<%>) (text<%>) args
|
|
(override
|
|
[get-editor<%> (lambda () (class->interface text%))]
|
|
[get-editor% (lambda () text:keymap%)])
|
|
(sequence (apply super-init args))))
|
|
|
|
(define pasteboard<%> (interface (-editor<%>)))
|
|
(define pasteboard-mixin
|
|
(mixin (-editor<%>) (pasteboard<%>) args
|
|
(override
|
|
[get-editor<%> (lambda () (class->interface pasteboard%))]
|
|
[get-editor% (lambda () pasteboard:keymap%)])
|
|
(sequence (apply super-init args))))
|
|
|
|
(define (search-dialog frame)
|
|
(init-find/replace-edits)
|
|
(keymap:call/text-keymap-initializer
|
|
(lambda ()
|
|
(let* ([to-be-searched-text (send frame get-text-to-search)]
|
|
[to-be-searched-canvas (send to-be-searched-text get-canvas)]
|
|
|
|
[dialog (make-object dialog% "Find and Replace" frame)]
|
|
|
|
[copy-text
|
|
(lambda (from to)
|
|
(send to erase)
|
|
(let loop ([snip (send from find-first-snip)])
|
|
(when snip
|
|
(send to insert (send snip copy))
|
|
(loop (send snip next)))))]
|
|
|
|
[text-keymap/editor%
|
|
(class text:keymap% args
|
|
(rename [super-get-keymaps get-keymaps])
|
|
(override
|
|
[get-keymaps
|
|
(lambda ()
|
|
(if (preferences:get 'framework:menu-bindings)
|
|
(append (list (keymap:get-editor))
|
|
(super-get-keymaps))
|
|
(append (super-get-keymaps)
|
|
(list (keymap:get-editor)))))])
|
|
(sequence
|
|
(apply super-init args)))]
|
|
|
|
|
|
[find-panel (make-object horizontal-panel% dialog)]
|
|
[find-message (make-object message% "Find" find-panel)]
|
|
[f-text (make-object text-keymap/editor%)]
|
|
[find-canvas (make-object editor-canvas% find-panel f-text
|
|
'(hide-hscroll hide-vscroll))]
|
|
|
|
[replace-panel (make-object horizontal-panel% dialog)]
|
|
[replace-message (make-object message% "Replace" replace-panel)]
|
|
[r-text (make-object text-keymap/editor%)]
|
|
[replace-canvas (make-object editor-canvas% replace-panel r-text
|
|
'(hide-hscroll hide-vscroll))]
|
|
|
|
[button-panel (make-object horizontal-panel% dialog)]
|
|
[pref-check (make-object check-box%
|
|
"Use separate dialog for searching"
|
|
dialog
|
|
(lambda (pref-check evt)
|
|
(preferences:set
|
|
'framework:search-using-dialog?
|
|
(send pref-check get-value))))]
|
|
|
|
[update-texts
|
|
(lambda ()
|
|
(send find-edit stop-searching)
|
|
(copy-text f-text find-edit)
|
|
(send find-edit start-searching)
|
|
(copy-text r-text replace-edit))]
|
|
|
|
[find-button (make-object button% "Find" button-panel
|
|
(lambda x
|
|
(update-texts)
|
|
(send frame search-again))
|
|
'(border))]
|
|
[replace-button (make-object button% "Replace" button-panel
|
|
(lambda x
|
|
(update-texts)
|
|
(send frame replace)))]
|
|
[replace-button (make-object button% "Replace && Find Again" button-panel
|
|
(lambda x
|
|
(update-texts)
|
|
(send frame replace&search)))]
|
|
[replace-button (make-object button% "Replace to End" button-panel
|
|
(lambda x
|
|
(update-texts)
|
|
(send frame replace-all)))]
|
|
[close-button (make-object button% "Close" button-panel
|
|
(lambda x
|
|
(send to-be-searched-canvas force-display-focus #f)
|
|
(send dialog show #f)))])
|
|
(copy-text find-edit f-text)
|
|
(copy-text replace-edit r-text)
|
|
(send find-canvas min-width 400)
|
|
(send find-canvas set-line-count 2)
|
|
(send find-canvas stretchable-height #f)
|
|
(send find-canvas allow-tab-exit #t)
|
|
(send replace-canvas min-width 400)
|
|
(send replace-canvas set-line-count 2)
|
|
(send replace-canvas stretchable-height #f)
|
|
(send replace-canvas allow-tab-exit #t)
|
|
(let ([msg-width (max (send find-message get-width)
|
|
(send replace-message get-width))])
|
|
(send find-message min-width msg-width)
|
|
(send replace-message min-width msg-width))
|
|
(send find-canvas focus)
|
|
(send f-text set-position 0 (send f-text last-position))
|
|
(send pref-check set-value (preferences:get 'framework:search-using-dialog?))
|
|
(send button-panel set-alignment 'right 'center)
|
|
(send dialog center 'both)
|
|
(send to-be-searched-canvas force-display-focus #t)
|
|
(send dialog show #t)))))
|
|
|
|
(define searchable<%> (interface (text<%>)
|
|
get-text-to-search
|
|
hide-search
|
|
unhide-search
|
|
set-search-direction
|
|
replace&search
|
|
replace-all
|
|
replace
|
|
toggle-search-focus
|
|
move-to-search-or-search
|
|
move-to-search-or-reverse-search
|
|
search-again))
|
|
(define search-anchor 0)
|
|
(define searching-direction 'forward)
|
|
(define (set-searching-direction x)
|
|
(unless (or (eq? x 'forward)
|
|
(eq? x 'backward))
|
|
(error 'set-searching-direction "expected ~e or ~e, got ~e" 'forward 'backward x))
|
|
(set! searching-direction x))
|
|
|
|
(define old-search-highlight void)
|
|
(define clear-search-highlight
|
|
(lambda ()
|
|
(begin (old-search-highlight)
|
|
(set! old-search-highlight void))))
|
|
(define reset-search-anchor
|
|
(let ([color (make-object color% "BLUE")])
|
|
(lambda (edit)
|
|
(old-search-highlight)
|
|
(let ([position
|
|
(if (eq? 'forward searching-direction)
|
|
(send edit get-end-position)
|
|
(send edit get-start-position))])
|
|
(set! search-anchor position)
|
|
|
|
;; don't draw the anchor
|
|
'(set! old-search-highlight
|
|
(send edit highlight-range position position color #f))))))
|
|
|
|
(define find-string-embedded
|
|
(let ([default-direction 'forward]
|
|
[default-start 'start]
|
|
[default-end 'eof]
|
|
[default-get-start #t]
|
|
[default-case-sensitive? #t]
|
|
[default-pop-out? #f])
|
|
(case-lambda
|
|
[(edit str)
|
|
(find-string-embedded edit str default-direction default-start default-end default-get-start default-case-sensitive? default-pop-out?)]
|
|
[(edit str direction)
|
|
(find-string-embedded edit str direction default-start default-end default-get-start default-case-sensitive? default-pop-out?)]
|
|
[(edit str direction start)
|
|
(find-string-embedded edit str direction start default-end default-get-start default-case-sensitive? default-pop-out?)]
|
|
[(edit str direction start end)
|
|
(find-string-embedded edit str direction start end default-get-start default-case-sensitive? default-pop-out?)]
|
|
[(edit str direction start end get-start)
|
|
(find-string-embedded edit str direction start end get-start default-case-sensitive? default-pop-out?)]
|
|
[(edit str direction start end get-start case-sensitive?)
|
|
(find-string-embedded edit str direction start end get-start case-sensitive? default-pop-out?)]
|
|
[(edit str direction start end get-start case-sensitive? pop-out?)
|
|
(unless (member direction '(forward backward))
|
|
(error 'find-string-embedded
|
|
"expected ~e or ~e as first argument, got: ~e" 'forward 'backward direction))
|
|
(let/ec k
|
|
(let* ([start (if (eq? start 'start)
|
|
(send edit get-start-position)
|
|
start)]
|
|
[end (if (eq? 'eof end)
|
|
(if (eq? direction 'forward)
|
|
(send edit last-position)
|
|
0)
|
|
end)]
|
|
[flat (send edit find-string str direction
|
|
start end get-start
|
|
case-sensitive?)]
|
|
[pop-out
|
|
(lambda ()
|
|
(let ([admin (send edit get-admin)])
|
|
(if (is-a? admin editor-snip-editor-admin<%>)
|
|
(let* ([snip (send admin get-snip)]
|
|
[edit-above (send (send snip get-admin) get-editor)]
|
|
[pos (send edit-above get-snip-position snip)]
|
|
[pop-out-pos (if (eq? direction 'forward) (add1 pos) pos)])
|
|
(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
|
|
(lambda ()
|
|
(if (eq? direction 'forward)
|
|
(loop (send current-snip next))
|
|
(loop (send current-snip previous))))])
|
|
(cond
|
|
[(or (not current-snip)
|
|
(and flat
|
|
(let* ([start (send edit get-snip-position current-snip)]
|
|
[end (+ start (send current-snip get-count))])
|
|
(if (eq? direction 'forward)
|
|
(and (<= start flat)
|
|
(< flat end))
|
|
(and (< start flat)
|
|
(<= flat end))))))
|
|
(if (and (not flat) pop-out?)
|
|
(pop-out)
|
|
(values edit flat))]
|
|
[(is-a? current-snip 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)])))))])))
|
|
|
|
|
|
(define searching-frame #f)
|
|
(define (set-searching-frame frame)
|
|
(set! searching-frame frame))
|
|
|
|
(define find-text%
|
|
(class-asi text:keymap%
|
|
(inherit get-text)
|
|
(rename [super-after-insert after-insert]
|
|
[super-after-delete after-delete]
|
|
[super-on-focus on-focus])
|
|
(private
|
|
[get-searching-edit
|
|
(lambda ()
|
|
(and searching-frame
|
|
(send searching-frame get-text-to-search)))])
|
|
(public
|
|
[search
|
|
(opt-lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t])
|
|
(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)])
|
|
(if focus-snip
|
|
(send focus-snip get-editor)
|
|
top-searching-edit))]
|
|
|
|
[not-found
|
|
(lambda (found-edit)
|
|
(send found-edit set-position search-anchor)
|
|
(when beep?
|
|
(bell))
|
|
#f)]
|
|
[found
|
|
(lambda (edit first-pos)
|
|
(let ([last-pos ((if (eq? searching-direction 'forward) + -)
|
|
first-pos (string-length string))])
|
|
(send* edit
|
|
(set-caret-owner #f 'display)
|
|
(set-position
|
|
(min first-pos last-pos)
|
|
(max first-pos last-pos)
|
|
#f #t 'local))
|
|
#t))])
|
|
(if (string=? string "")
|
|
(not-found top-searching-edit)
|
|
(begin
|
|
(when reset-search-anchor?
|
|
(reset-search-anchor searching-edit))
|
|
(let-values ([(found-edit first-pos)
|
|
(find-string-embedded
|
|
searching-edit
|
|
string
|
|
searching-direction
|
|
search-anchor
|
|
'eof #t #t #t)])
|
|
(cond
|
|
[(not first-pos)
|
|
(if wrap?
|
|
(let-values ([(found-edit pos)
|
|
(find-string-embedded
|
|
top-searching-edit
|
|
string
|
|
searching-direction
|
|
(if (eq? 'forward searching-direction)
|
|
0
|
|
(send searching-edit last-position)))])
|
|
(if (not pos)
|
|
(not-found found-edit)
|
|
(found found-edit pos)))
|
|
(not-found found-edit))]
|
|
[else
|
|
(found found-edit first-pos)])))))))])
|
|
(private
|
|
[dont-search #f])
|
|
(public
|
|
[stop-searching
|
|
(lambda ()
|
|
(set! dont-search #t))]
|
|
[start-searching
|
|
(lambda ()
|
|
(set! dont-search #f))])
|
|
|
|
(override
|
|
[on-focus
|
|
(lambda (on?)
|
|
(when on?
|
|
(let ([edit (get-searching-edit)])
|
|
(when edit
|
|
(reset-search-anchor (get-searching-edit)))))
|
|
(super-on-focus on?))]
|
|
[after-insert
|
|
(lambda args
|
|
(apply super-after-insert args)
|
|
(unless dont-search
|
|
(search #f)))]
|
|
[after-delete
|
|
(lambda args
|
|
(apply super-after-delete args)
|
|
(unless dont-search
|
|
(search #f)))])))
|
|
|
|
(define find-edit #f)
|
|
(define replace-edit #f)
|
|
|
|
(define searchable-canvas%
|
|
(class editor-canvas% (parent)
|
|
(inherit get-top-level-window set-line-count)
|
|
(rename [super-on-focus on-focus])
|
|
(override
|
|
[on-focus
|
|
(lambda (x)
|
|
(when x
|
|
(set-searching-frame (get-top-level-window)))
|
|
(super-on-focus x))])
|
|
(sequence
|
|
(super-init parent #f '(hide-hscroll hide-vscroll))
|
|
(set-line-count 2))))
|
|
|
|
(define (init-find/replace-edits)
|
|
(unless find-edit
|
|
(set! find-edit (make-object find-text%))
|
|
(set! replace-edit (make-object text:keymap%))
|
|
(for-each (lambda (keymap)
|
|
(send keymap chain-to-keymap
|
|
(keymap:get-search)
|
|
#t))
|
|
(list (send find-edit get-keymap)
|
|
(send replace-edit get-keymap)))))
|
|
|
|
(define searchable-mixin
|
|
(mixin (text<%>) (searchable<%>) args
|
|
(sequence (init-find/replace-edits))
|
|
(inherit get-editor)
|
|
(rename [super-make-root-area-container make-root-area-container]
|
|
[super-on-activate on-activate]
|
|
[super-on-close on-close])
|
|
(private
|
|
[super-root 'unitiaialized-super-root])
|
|
(override
|
|
[get-editor<%> (lambda () text:searching<%>)]
|
|
[get-editor% (lambda () text:searching%)]
|
|
[edit-menu:find (lambda (menu evt) (move-to-search-or-search) #t)]
|
|
[edit-menu:find-again (lambda (menu evt) (search-again) #t)]
|
|
[edit-menu:replace-and-find-again (lambda (menu evt) (replace&search) #t)])
|
|
(override
|
|
[make-root-area-container
|
|
(lambda (% parent)
|
|
(let* ([s-root (super-make-root-area-container
|
|
vertical-panel%
|
|
parent)]
|
|
[root (make-object % s-root)])
|
|
(set! super-root s-root)
|
|
root))])
|
|
(override
|
|
[on-activate
|
|
(lambda (on?)
|
|
(unless hidden?
|
|
(if on?
|
|
(reset-search-anchor (get-text-to-search))
|
|
(clear-search-highlight)))
|
|
(super-on-activate on?))])
|
|
(public
|
|
[get-text-to-search
|
|
(lambda ()
|
|
(get-editor))]
|
|
[hide-search
|
|
(opt-lambda ([startup? #f])
|
|
(send super-root change-children
|
|
(lambda (l)
|
|
(mzlib:function:remove search-panel l)))
|
|
(clear-search-highlight)
|
|
(unless startup?
|
|
(send
|
|
(send (get-text-to-search) get-canvas)
|
|
focus))
|
|
(set! hidden? #t))]
|
|
[unhide-search
|
|
(lambda ()
|
|
(when (and hidden?
|
|
(not (preferences:get 'framework:search-using-dialog?)))
|
|
(set! hidden? #f)
|
|
(send search-panel focus)
|
|
(send super-root add-child search-panel)
|
|
(reset-search-anchor (get-text-to-search))))])
|
|
(private
|
|
[remove-callback
|
|
(preferences:add-callback
|
|
'framework:search-using-dialog?
|
|
(lambda (p v)
|
|
(when p
|
|
(hide-search))))])
|
|
(override
|
|
[on-close
|
|
(lambda ()
|
|
(super-on-close)
|
|
(remove-callback)
|
|
(let ([close-canvas
|
|
(lambda (canvas edit)
|
|
(send edit remove-canvas canvas)
|
|
(send canvas set-editor #f))])
|
|
(close-canvas find-canvas find-edit)
|
|
(close-canvas replace-canvas replace-edit))
|
|
(when (eq? this searching-frame)
|
|
(set-searching-frame #f)))])
|
|
(public
|
|
[set-search-direction
|
|
(lambda (x)
|
|
(set-searching-direction x)
|
|
(send dir-radio set-selection (if (eq? x 'forward) 0 1)))]
|
|
[replace&search
|
|
(lambda ()
|
|
(when (replace)
|
|
(search-again)))]
|
|
[replace-all
|
|
(lambda ()
|
|
(let* ([replacee-edit (get-text-to-search)]
|
|
[pos (if (eq? searching-direction 'forward)
|
|
(send replacee-edit get-start-position)
|
|
(send replacee-edit get-end-position))]
|
|
[get-pos
|
|
(if (eq? searching-direction 'forward)
|
|
(ivar replacee-edit get-end-position)
|
|
(ivar replacee-edit get-start-position))]
|
|
[done? (if (eq? 'forward searching-direction)
|
|
(lambda (x) (>= x (send replacee-edit last-position)))
|
|
(lambda (x) (<= x 0)))])
|
|
(send* replacee-edit
|
|
(begin-edit-sequence)
|
|
(set-position pos))
|
|
(when (search-again)
|
|
(send replacee-edit set-position pos)
|
|
(let loop ()
|
|
(when (send find-edit search #t #f #f)
|
|
(replace)
|
|
(loop))))
|
|
(send replacee-edit end-edit-sequence)))]
|
|
[replace
|
|
(lambda ()
|
|
(let* ([search-text (send find-edit get-text)]
|
|
[replacee-edit (get-text-to-search)]
|
|
[replacee-start (send replacee-edit get-start-position)]
|
|
[new-text (send replace-edit get-text)]
|
|
[replacee (send replacee-edit get-text
|
|
replacee-start
|
|
(send replacee-edit get-end-position))])
|
|
(if (string=? replacee search-text)
|
|
(begin (send replacee-edit insert new-text)
|
|
(send replacee-edit set-position
|
|
replacee-start
|
|
(+ replacee-start (string-length new-text)))
|
|
#t)
|
|
#f)))]
|
|
[toggle-search-focus
|
|
(lambda ()
|
|
(set-searching-frame this)
|
|
(unhide-search)
|
|
(send (cond
|
|
[(send find-canvas has-focus?)
|
|
replace-canvas]
|
|
[(send replace-canvas has-focus?)
|
|
(send (get-text-to-search) get-canvas)]
|
|
[else
|
|
find-canvas])
|
|
focus))]
|
|
[move-to-search-or-search
|
|
(lambda ()
|
|
(set-searching-frame this)
|
|
(unhide-search)
|
|
(cond
|
|
[(preferences:get 'framework:search-using-dialog?)
|
|
(search-dialog this)]
|
|
[else
|
|
(if (or (send find-canvas has-focus?)
|
|
(send replace-canvas has-focus?))
|
|
(search-again 'forward)
|
|
(send find-canvas focus))]))]
|
|
[move-to-search-or-reverse-search
|
|
(lambda ()
|
|
(set-searching-frame this)
|
|
(unhide-search)
|
|
(if (or (send find-canvas has-focus?)
|
|
(send replace-canvas has-focus?))
|
|
(search-again 'backward)
|
|
(send find-canvas focus)))]
|
|
[search-again
|
|
(opt-lambda ([direction searching-direction] [beep? #t])
|
|
(set-searching-frame this)
|
|
(unhide-search)
|
|
(set-search-direction direction)
|
|
(send find-edit search #t beep?))])
|
|
(sequence
|
|
(apply super-init args))
|
|
(private
|
|
[search-panel (make-object horizontal-panel% super-root '(border))]
|
|
|
|
[left-panel (make-object vertical-panel% search-panel)]
|
|
[find-canvas (make-object searchable-canvas% left-panel)]
|
|
[replace-canvas (make-object searchable-canvas% left-panel)]
|
|
|
|
[middle-left-panel (make-object vertical-pane% search-panel)]
|
|
[middle-middle-panel (make-object vertical-pane% search-panel)]
|
|
[middle-right-panel (make-object vertical-pane% search-panel)]
|
|
|
|
[search-button (make-object button%
|
|
"Search"
|
|
middle-left-panel
|
|
(lambda args (search-again)))]
|
|
|
|
[replace&search-button (make-object button%
|
|
"Replace && Search"
|
|
middle-middle-panel
|
|
(lambda x (replace&search)))]
|
|
[replace-button (make-object button% "Replace" middle-left-panel (lambda x (replace)))]
|
|
[replace-all-button (make-object button%
|
|
"Replace To End"
|
|
middle-middle-panel
|
|
(lambda x (replace-all)))]
|
|
|
|
[dir-radio (make-object radio-box%
|
|
#f
|
|
(list "Forward" "Backward")
|
|
middle-right-panel
|
|
(lambda (dir-radio evt)
|
|
(let ([forward (if (= (send dir-radio get-selection) 0)
|
|
'forward
|
|
'backward)])
|
|
(set-search-direction forward)
|
|
(reset-search-anchor (get-text-to-search)))))]
|
|
[close-button (make-object button% "Hide"
|
|
middle-right-panel
|
|
(lambda args (hide-search)))]
|
|
[hidden? #f])
|
|
(sequence
|
|
(let ([align
|
|
(lambda (x y)
|
|
(let ([m (max (send x get-width)
|
|
(send y get-width))])
|
|
(send x min-width m)
|
|
(send y min-width m)))])
|
|
(align search-button replace-button)
|
|
(align replace&search-button replace-all-button))
|
|
(for-each (lambda (x) (send x set-alignment 'center 'center))
|
|
(list middle-left-panel middle-middle-panel))
|
|
(for-each (lambda (x) (send x stretchable-height #f))
|
|
(list search-panel left-panel middle-left-panel middle-middle-panel middle-right-panel))
|
|
(for-each (lambda (x) (send x stretchable-width #f))
|
|
(list middle-left-panel middle-middle-panel middle-right-panel))
|
|
(send find-canvas set-editor find-edit)
|
|
(send replace-canvas set-editor replace-edit)
|
|
(send find-edit add-canvas find-canvas)
|
|
(send replace-edit add-canvas replace-canvas)
|
|
(hide-search #t))))
|
|
|
|
(define memory-text (make-object text%))
|
|
(send memory-text hide-caret #t)
|
|
(define show-memory-text? (directory-exists? (build-path (collection-path "framework") "CVS")))
|
|
|
|
(define file<%> (interface (-editor<%>)))
|
|
(define file-mixin
|
|
(mixin (-editor<%>) (file<%>) args
|
|
(inherit get-editor get-filename get-label)
|
|
(rename [super-can-close? can-close?])
|
|
(override
|
|
[can-close?
|
|
(lambda ()
|
|
(let* ([edit (get-editor)]
|
|
[user-allowed-or-not-modified
|
|
(or (not (send edit is-modified?))
|
|
(case (gui-utils:unsaved-warning
|
|
(let ([fn (get-filename)])
|
|
(if (string? fn)
|
|
fn
|
|
(get-label)))
|
|
"Close"
|
|
#t
|
|
this)
|
|
[(continue) #t]
|
|
[(save) (send edit save-file)]
|
|
[else #f]))])
|
|
(and user-allowed-or-not-modified
|
|
(super-can-close?))))])
|
|
(sequence (apply super-init args))))
|
|
|
|
(define basic% (basic-mixin frame%))
|
|
(define info% (info-mixin basic%))
|
|
(define text-info% (text-info-mixin info%))
|
|
(define pasteboard-info% (pasteboard-info-mixin text-info%))
|
|
(define standard-menus% (standard-menus-mixin pasteboard-info%))
|
|
(define editor% (editor-mixin standard-menus%))
|
|
|
|
(define -text% (text-mixin editor%))
|
|
(define text-info-file% (file-mixin -text%))
|
|
(define searchable% (searchable-mixin text-info-file%))
|
|
|
|
(define -pasteboard% (pasteboard-mixin editor%))
|
|
(define pasteboard-info-file% (file-mixin -pasteboard%))
|
|
|
|
)
|