...
original commit: 6cd40de9ccf0d15a24d9590c875de9e822b99bef
This commit is contained in:
Robby Findler
parent
4537d37219
commit
89a5e422e1
|
|
@ -393,10 +393,10 @@
|
|||
|
||||
(public
|
||||
[save-as
|
||||
(opt-lambda ([format wx:const-media-ff-same])
|
||||
(opt-lambda ([format 'same])
|
||||
(let ([file (parameterize ([mred:finder:dialog-parent-parameter
|
||||
this])
|
||||
(mred:finder:put-file))])
|
||||
(finder:put-file))])
|
||||
(when file
|
||||
(send (get-edit) save-file file format))))]
|
||||
[file-menu:revert
|
||||
|
|
@ -423,9 +423,9 @@
|
|||
(send edit end-edit-sequence))
|
||||
(begin
|
||||
(send edit end-edit-sequence)
|
||||
(mred:gui-utils:message-box
|
||||
(format "could not read ~a" filename)
|
||||
"Error Reverting"))))))
|
||||
(message-box
|
||||
"Error Reverting"
|
||||
(format "could not read ~a" filename)))))))
|
||||
#t))]
|
||||
[file-menu:save (lambda ()
|
||||
(send (get-edit) save-file)
|
||||
|
|
@ -439,8 +439,8 @@
|
|||
(lambda ()
|
||||
(when (active-canvas)
|
||||
(send panel split (active-canvas) panel%))))])
|
||||
(send file-menu append-item "Split Horizontally" (split mred:container:horizontal-panel%))
|
||||
(send file-menu append-item "Split Vertically" (split mred:container:vertical-panel%))
|
||||
(send file-menu append-item "Split Horizontally" (split horizontal-panel%))
|
||||
(send file-menu append-item "Split Vertically" (split vertical-panel%))
|
||||
(send file-menu append-item "Collapse"
|
||||
(lambda ()
|
||||
(when (active-canvas)
|
||||
|
|
@ -451,7 +451,7 @@
|
|||
'()
|
||||
#t
|
||||
#t
|
||||
(mred:preferences:get-preference 'mred:print-output-mode))
|
||||
(preferences:get 'framework:print-output-mode))
|
||||
#t)])
|
||||
|
||||
(private
|
||||
|
|
@ -569,6 +569,682 @@
|
|||
(do-title)
|
||||
(let ([canvas (get-canvas)])
|
||||
(send canvas set-focus)))))
|
||||
|
||||
(define make-searchable%
|
||||
(let* ([anchor 0]
|
||||
[searching-direction 1]
|
||||
[old-highlight void]
|
||||
[get-active-embedded-edit
|
||||
(lambda (edit)
|
||||
(let loop ([edit edit])
|
||||
(let ([snip (send edit get-focus-snip)])
|
||||
(if (or (null? snip)
|
||||
(not (is-a? snip wx:media-snip%)))
|
||||
edit
|
||||
(loop (send snip get-this-media))))))]
|
||||
[clear-highlight
|
||||
(lambda ()
|
||||
(begin (old-highlight)
|
||||
(set! old-highlight void)))]
|
||||
[reset-anchor
|
||||
(let ([color (make-object wx:colour% "BLUE")])
|
||||
(lambda (edit)
|
||||
(old-highlight)
|
||||
(let ([position
|
||||
(if (= 1 searching-direction)
|
||||
(send edit get-end-position)
|
||||
(send edit get-start-position))])
|
||||
(set! anchor position)
|
||||
(set! old-highlight
|
||||
(send edit highlight-range position position color #f)))))]
|
||||
[replace-edit (make-object text%)]
|
||||
[find-edit
|
||||
(make-object
|
||||
(class-asi text%
|
||||
(inherit get-text)
|
||||
(rename [super-after-insert after-insert]
|
||||
[super-after-delete after-delete]
|
||||
[super-on-focus on-focus])
|
||||
(public
|
||||
[searching-frame #f]
|
||||
[set-searching-frame
|
||||
(lambda (frame)
|
||||
(set! searching-frame frame))]
|
||||
[get-searching-edit
|
||||
(lambda ()
|
||||
(get-active-embedded-edit
|
||||
(send searching-frame get-edit-to-search)))]
|
||||
[search
|
||||
(opt-lambda ([reset-anchor? #t] [beep? #t] [wrap? #t])
|
||||
(when searching-frame
|
||||
(let* ([string (get-text)]
|
||||
[searching-edit (get-searching-edit)]
|
||||
[not-found
|
||||
(lambda (found-edit)
|
||||
(send found-edit set-position anchor)
|
||||
(when beep?
|
||||
(wx:bell))
|
||||
#f)]
|
||||
[found
|
||||
(lambda (edit first-pos)
|
||||
(let ([last-pos (+ first-pos (* searching-direction
|
||||
(string-length string)))])
|
||||
(send* edit
|
||||
(set-caret-owner null wx:const-focus-display)
|
||||
(set-position
|
||||
(min first-pos last-pos)
|
||||
(max first-pos last-pos)))
|
||||
#t))])
|
||||
(when reset-anchor?
|
||||
(reset-anchor searching-edit))
|
||||
(let-values ([(found-edit first-pos)
|
||||
(send searching-edit
|
||||
find-string-embedded
|
||||
string
|
||||
searching-direction
|
||||
anchor
|
||||
-1 #t #t #t)])
|
||||
(cond
|
||||
[(= -1 first-pos)
|
||||
(if wrap?
|
||||
(let-values ([(found-edit pos)
|
||||
(send searching-edit
|
||||
find-string-embedded
|
||||
string
|
||||
searching-direction
|
||||
(if (= 1 searching-direction)
|
||||
0
|
||||
(send searching-edit last-position)))])
|
||||
(if (= -1 pos)
|
||||
(not-found found-edit)
|
||||
(found found-edit
|
||||
((if (= searching-direction 1)
|
||||
+
|
||||
-)
|
||||
pos
|
||||
(string-length string)))))
|
||||
(not-found found-edit))]
|
||||
[else
|
||||
(found found-edit first-pos)])))))]
|
||||
[on-focus
|
||||
(lambda (on?)
|
||||
(when on?
|
||||
(reset-anchor (get-searching-edit)))
|
||||
(super-on-focus on?))]
|
||||
[after-insert
|
||||
(lambda args
|
||||
(apply super-after-insert args)
|
||||
(search #f))]
|
||||
[after-delete
|
||||
(lambda args
|
||||
(apply super-after-delete args)
|
||||
(search #f))])))]
|
||||
[canvas%
|
||||
(class editor-canvas% args
|
||||
(inherit get-parent frame set-line-count)
|
||||
(rename [super-on-set-focus on-set-focus])
|
||||
(public
|
||||
[lines 2]
|
||||
[style-flags wx:const-mcanvas-hide-h-scroll]
|
||||
[on-set-focus
|
||||
(lambda ()
|
||||
(send find-edit set-searching-frame frame)
|
||||
(super-on-set-focus))])
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(set-line-count 1)))])
|
||||
(for-each (lambda (keymap)
|
||||
(send keymap chain-to-keymap
|
||||
keymap:global-search-keymap
|
||||
#t))
|
||||
(list (send find-edit get-keymap)
|
||||
(send replace-edit get-keymap)))
|
||||
(mixin frame:edit<%> frame:searchable<%> args
|
||||
(inherit active-edit active-canvas get-edit)
|
||||
(rename [super-make-root-panel make-root-panel]
|
||||
[super-on-activate on-activate]
|
||||
[super-do-close do-close])
|
||||
(private
|
||||
[super-root 'unitiaialized-super-root])
|
||||
(public
|
||||
[make-root-panel
|
||||
(lambda (% parent)
|
||||
(let* ([s-root (super-make-root-panel
|
||||
vertical-panel%
|
||||
parent)]
|
||||
[root (make-object % s-root)])
|
||||
(set! super-root s-root)
|
||||
root))])
|
||||
(public
|
||||
[on-activate
|
||||
(lambda (on?)
|
||||
(unless hidden?
|
||||
(if on?
|
||||
(reset-anchor (get-edit-to-search))
|
||||
(clear-highlight)))
|
||||
(super-on-activate on?))]
|
||||
[get-edit-to-search
|
||||
(lambda ()
|
||||
(get-edit))]
|
||||
[hide-search
|
||||
(opt-lambda ([startup? #f])
|
||||
(send super-root delete-child search-panel)
|
||||
(clear-highlight)
|
||||
(unless startup?
|
||||
(send
|
||||
(send (get-edit-to-search) get-canvas)
|
||||
set-focus))
|
||||
(set! hidden? #t))]
|
||||
[unhide-search
|
||||
(lambda ()
|
||||
(set! hidden? #f)
|
||||
(send super-root add-child search-panel)
|
||||
(reset-anchor (get-edit-to-search)))])
|
||||
(public
|
||||
[do-close
|
||||
(lambda ()
|
||||
(super-do-close)
|
||||
(let ([close-canvas
|
||||
(lambda (canvas edit)
|
||||
(send edit remove-canvas canvas)
|
||||
(send canvas set-media ()))])
|
||||
(close-canvas find-canvas find-edit)
|
||||
(close-canvas replace-canvas replace-edit))
|
||||
(when (eq? this (ivar find-edit searching-frame))
|
||||
(send find-edit set-searching-frame #f)))]
|
||||
[set-search-direction
|
||||
(lambda (x)
|
||||
(set! searching-direction x)
|
||||
(send dir-radio set-selection (if (= x 1) 0 1)))]
|
||||
[replace&search
|
||||
(lambda ()
|
||||
(when (replace)
|
||||
(search)))]
|
||||
[replace-all
|
||||
(lambda ()
|
||||
(let* ([replacee-edit (get-edit-to-search)]
|
||||
[pos (if (= searching-direction 1)
|
||||
(send replacee-edit get-start-position)
|
||||
(send replacee-edit get-end-position))]
|
||||
[get-pos
|
||||
(if (= searching-direction 1)
|
||||
(ivar replacee-edit get-end-position)
|
||||
(ivar replacee-edit get-start-position))]
|
||||
[done? (if (= 1 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)
|
||||
(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-edit-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 ()
|
||||
(when hidden?
|
||||
(unhide-search))
|
||||
(send (cond
|
||||
[(send find-canvas is-focus-on?)
|
||||
replace-canvas]
|
||||
[(send replace-canvas is-focus-on?)
|
||||
(send (get-edit-to-search) get-canvas)]
|
||||
[else
|
||||
find-canvas])
|
||||
set-focus))]
|
||||
[move-to-search-or-search
|
||||
(lambda ()
|
||||
(when hidden?
|
||||
(unhide-search))
|
||||
(if (or (send find-canvas is-focus-on?)
|
||||
(send replace-canvas is-focus-on?))
|
||||
(search 1)
|
||||
(send find-canvas set-focus)))]
|
||||
[move-to-search-or-reverse-search
|
||||
(lambda ()
|
||||
(when hidden?
|
||||
(unhide-search))
|
||||
(if (or (send find-canvas is-focus-on?)
|
||||
(send replace-canvas is-focus-on?))
|
||||
(search -1)
|
||||
(send find-canvas set-focus)))]
|
||||
[search
|
||||
(opt-lambda ([direction searching-direction] [beep? #t])
|
||||
|
||||
(send find-edit set-searching-frame this)
|
||||
(when hidden?
|
||||
(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)]
|
||||
|
||||
[left-panel (make-object vertical-panel% search-panel)]
|
||||
[find-canvas (make-object canvas% left-panel)]
|
||||
[replace-canvas (make-object canvas% left-panel)]
|
||||
|
||||
[middle-left-panel (make-object vertical-panel% search-panel)]
|
||||
[middle-middle-panel (make-object vertical-panel% search-panel)]
|
||||
[middle-right-panel (make-object vertical-panel% search-panel)]
|
||||
|
||||
[search-button (make-object button%
|
||||
"Search"
|
||||
middle-left-panel
|
||||
(lambda args (search)))]
|
||||
|
||||
[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% middle-right-panel
|
||||
(lambda (dir-radio evt)
|
||||
(let ([forward (if (= 0 (send evt get-command-int))
|
||||
1
|
||||
-1)])
|
||||
(set-search-direction forward)
|
||||
(reset-anchor (get-edit-to-search))))
|
||||
null
|
||||
-1 -1 -1 -1
|
||||
(list "Forward" "Backward"))]
|
||||
[close-button (make-object button% middle-right-panel
|
||||
(lambda args (hide-search)) "Hide")]
|
||||
[hidden? #f])
|
||||
(sequence
|
||||
(let ([align
|
||||
(lambda (x y)
|
||||
(let ([m (max (send x get-width)
|
||||
(send y get-width))])
|
||||
(send x user-min-width m)
|
||||
(send y user-min-width m)))])
|
||||
(align search-button replace-button)
|
||||
(align replace&search-button replace-all-button))
|
||||
(for-each (lambda (x) (send x major-align-center))
|
||||
(list middle-left-panel middle-middle-panel))
|
||||
(for-each (lambda (x) (send x stretchable-in-y #f))
|
||||
(list search-panel left-panel middle-left-panel middle-middle-panel middle-right-panel))
|
||||
(for-each (lambda (x) (send x stretchable-in-x #f))
|
||||
(list middle-left-panel middle-middle-panel middle-right-panel))
|
||||
(send find-canvas set-media find-edit)
|
||||
(send replace-canvas set-media replace-edit)
|
||||
(send find-edit add-canvas find-canvas)
|
||||
(send replace-edit add-canvas replace-canvas)
|
||||
(hide-search #t)))))
|
||||
|
||||
(define make-info%
|
||||
(let* ([time-edit (make-object text%)]
|
||||
[time-semaphore (make-semaphore 1)]
|
||||
[wide-time "00:00pm"]
|
||||
[_ (send time-edit lock #t)]
|
||||
[update-time
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(semaphore-wait time-semaphore)
|
||||
(send time-edit lock #f))
|
||||
(lambda ()
|
||||
(send* time-edit
|
||||
(erase)
|
||||
(insert
|
||||
(let* ([date (seconds->date
|
||||
(current-seconds))]
|
||||
[hours (date-hour date)]
|
||||
[minutes (date-minute date)])
|
||||
(format "~a:~a~a~a"
|
||||
(cond
|
||||
[(= hours 0) 12]
|
||||
[(<= hours 12) hours]
|
||||
[else (- hours 12)])
|
||||
(quotient minutes 10)
|
||||
(modulo minutes 10)
|
||||
(if (< hours 12) "am" "pm"))))))
|
||||
(lambda ()
|
||||
(send time-edit lock #t)
|
||||
(semaphore-post time-semaphore))))]
|
||||
[time-thread
|
||||
(thread
|
||||
(rec loop
|
||||
(lambda ()
|
||||
(update-time)
|
||||
(sleep 30)
|
||||
(loop))))])
|
||||
(mixin frame:edit<%> frame:info<%> args
|
||||
(rename [super-make-root-panel make-root-panel])
|
||||
(private
|
||||
[rest-panel 'uninitialized-root]
|
||||
[super-root 'uninitialized-super-root])
|
||||
(public
|
||||
[make-root-panel
|
||||
(lambda (% parent)
|
||||
(let* ([s-root (super-make-root-panel
|
||||
vertical-panel%
|
||||
parent)]
|
||||
[r-root (make-object % s-root)])
|
||||
(set! super-root s-root)
|
||||
(set! rest-panel r-root)
|
||||
r-root))])
|
||||
|
||||
(public
|
||||
[determine-width
|
||||
(let ([magic-space 25])
|
||||
(lambda (string canvas edit)
|
||||
(send edit set-autowrap-bitmap null)
|
||||
(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 user-min-width
|
||||
(+ magic-space (- (unbox rb) (unbox lb)))))))))])
|
||||
|
||||
(rename [super-do-close do-close])
|
||||
(private
|
||||
[close-panel-callback
|
||||
(preferences:add-callback
|
||||
'framework:show-status-line
|
||||
(lambda (p v)
|
||||
(if v
|
||||
(register-gc-blit)
|
||||
(wx:unregister-collecting-blit gc-canvas))
|
||||
(send super-root change-children
|
||||
(lambda (l)
|
||||
(if v
|
||||
(list rest-panel info-panel)
|
||||
(list rest-panel))))))])
|
||||
(public
|
||||
[do-close
|
||||
(lambda ()
|
||||
(super-do-close)
|
||||
(send time-canvas set-media null)
|
||||
(unregister-collecting-blit gc-canvas)
|
||||
(close-panel-callback))])
|
||||
|
||||
(inherit get-edit)
|
||||
(public
|
||||
[get-info-edit
|
||||
(lambda ()
|
||||
(and (procedure? get-edit)
|
||||
(get-edit)))])
|
||||
|
||||
(public
|
||||
[lock-status-changed
|
||||
(let ([icon-currently-locked? #f])
|
||||
(lambda ()
|
||||
(let ([info-edit (get-info-edit)])
|
||||
(when info-edit
|
||||
(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?
|
||||
(cons (icon:get-lock-mdc)
|
||||
(icon:get-lock-bitmap))
|
||||
(cons (icon:get-unlock-mdc)
|
||||
(icon:get-unlock-bitmap)))])
|
||||
(send lock-message
|
||||
set-label
|
||||
(if (send (car label) ok?)
|
||||
label
|
||||
(if locked-now? "Locked" "Unlocked"))))))))))])
|
||||
(public
|
||||
[update-info
|
||||
(lambda ()
|
||||
(lock-status-changed))])
|
||||
(sequence
|
||||
(apply super-init args))
|
||||
|
||||
(public
|
||||
[info-panel (make-object horizontal-panel%
|
||||
super-root)])
|
||||
(private
|
||||
[lock-message (make-object message%
|
||||
(let ([b (mred:icon:get-unlock-bitmap)])
|
||||
(if (send b ok?)
|
||||
(cons (mred:icon:get-unlock-mdc) b)
|
||||
"Unlocked"))
|
||||
info-panel
|
||||
'(border))]
|
||||
[time-canvas (make-object editor-canvas% info-panel)]
|
||||
[_ (send time-canvas set-line-count 1)]
|
||||
[gc-canvas (make-object canvas% info-panel '(border))]
|
||||
[register-gc-blit
|
||||
(lambda ()
|
||||
(let ([mdc (mred:icon:get-gc-on-dc)])
|
||||
(when (send mdc ok?)
|
||||
(register-collecting-blit gc-canvas
|
||||
0 0
|
||||
(mred:icon:get-gc-width)
|
||||
(mred:icon:get-gc-height)
|
||||
(mred:icon:get-gc-on-dc)
|
||||
(mred:icon:get-gc-off-dc)))))])
|
||||
|
||||
(sequence
|
||||
(unless (mred:preferences:get-preference 'mred:show-status-line)
|
||||
(send super-root change-children
|
||||
(lambda (l)
|
||||
(list rest-panel))))
|
||||
(register-gc-blit)
|
||||
|
||||
(let ([bw (box 0)]
|
||||
[bh (box 0)]
|
||||
[gc-width (icon:get-gc-width)]
|
||||
[gc-height (icon:get-gc-height)])
|
||||
(send* gc-canvas
|
||||
(set-size 0 0 gc-width gc-height)
|
||||
(get-client-size bw bh))
|
||||
(send* gc-canvas
|
||||
(user-min-client-width gc-width)
|
||||
(user-min-client-height gc-height)
|
||||
(stretchable-in-x #f)
|
||||
(stretchable-in-y #f)))
|
||||
(send* info-panel
|
||||
(major-align-right)
|
||||
(stretchable-in-y #f)
|
||||
(spacing 3)
|
||||
(border 3))
|
||||
(send* time-canvas
|
||||
(set-media time-edit)
|
||||
(stretchable-in-x #f))
|
||||
(semaphore-wait time-semaphore)
|
||||
(determine-width wide-time time-canvas time-edit)
|
||||
(semaphore-post time-semaphore)
|
||||
(update-time)))))
|
||||
|
||||
(define make-edit-info%
|
||||
(mixin (interface (frame:info<%> frame:edit<%>)) frame:edit-info<%> args
|
||||
(inherit get-info-edit)
|
||||
(rename [super-do-close do-close])
|
||||
(private
|
||||
[remove-pref-callback
|
||||
(preferences:add-callback
|
||||
'framework:line-offsets
|
||||
(lambda (p v)
|
||||
(edit-position-changed-offset v)
|
||||
#t))])
|
||||
(public
|
||||
[do-close
|
||||
(lambda ()
|
||||
(super-do-close)
|
||||
(remove-pref-callback))])
|
||||
|
||||
(public
|
||||
[overwrite-status-changed
|
||||
(let ([last-state? #f])
|
||||
(lambda ()
|
||||
(let ([info-edit (get-info-edit)])
|
||||
(when info-edit
|
||||
(let ([overwrite-now? (send info-edit get-overwrite-mode)])
|
||||
(unless (eq? overwrite-now? last-state?)
|
||||
(send overwrite-message
|
||||
show
|
||||
overwrite-now?)
|
||||
(set! last-state? overwrite-now?)))))))]
|
||||
[anchor-status-changed
|
||||
(let ([last-state? #f])
|
||||
(lambda ()
|
||||
(let ([info-edit (get-info-edit)])
|
||||
(when info-edit
|
||||
(let ([anchor-now? (send info-edit get-anchor)])
|
||||
(unless (eq? anchor-now? last-state?)
|
||||
(send anchor-message
|
||||
show
|
||||
anchor-now?)
|
||||
(set! last-state? anchor-now?)))))))]
|
||||
|
||||
[edit-position-changed-offset
|
||||
(let ([last-start #f]
|
||||
[last-end #f])
|
||||
(lambda (offset?)
|
||||
(let* ([edit (get-info-edit)]
|
||||
[make-one
|
||||
(lambda (pos)
|
||||
(let* ([line (send edit position-line pos)]
|
||||
[line-start (send edit line-start-position line)]
|
||||
[char (- pos line-start)])
|
||||
(if (preferences:get 'framework:display-line-numbers)
|
||||
(format "~a:~a"
|
||||
(if offset?
|
||||
(add1 line)
|
||||
line)
|
||||
(if offset?
|
||||
(add1 char)
|
||||
char))
|
||||
(format "~a"
|
||||
(if offset?
|
||||
(+ pos 1)
|
||||
pos)))))])
|
||||
(when edit
|
||||
(let ([start (send edit get-start-position)]
|
||||
[end (send edit get-end-position)])
|
||||
(unless (and last-start
|
||||
(= last-start start)
|
||||
(= last-end end))
|
||||
(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)))))))))]
|
||||
[edit-position-changed
|
||||
(lambda ()
|
||||
(edit-position-changed-offset
|
||||
(preferences:get 'framework:line-offsets)))])
|
||||
(rename [super-update-info update-info])
|
||||
(public
|
||||
[update-info
|
||||
(lambda ()
|
||||
(super-update-info)
|
||||
(overwrite-status-changed)
|
||||
(anchor-status-changed)
|
||||
(edit-position-changed))])
|
||||
(sequence
|
||||
(apply super-init args))
|
||||
|
||||
(inherit info-panel)
|
||||
(private
|
||||
[anchor-message
|
||||
(make-object message%
|
||||
(let ([b (mred:icon:get-anchor-bitmap)])
|
||||
(if (send b ok?)
|
||||
(cons (mred:icon:get-anchor-mdc) b)
|
||||
"Anchor"))
|
||||
info-panel '(border))]
|
||||
[overwrite-message
|
||||
(make-object mred:container:canvas-message%
|
||||
"Overwrite"
|
||||
info-panel
|
||||
'(border))]
|
||||
[position-canvas (make-object editor-canvas% info-panel)]
|
||||
[_2 (send position-canvas set-line-count 1)]
|
||||
[position-edit (make-object text%)])
|
||||
|
||||
(inherit determine-width)
|
||||
(sequence
|
||||
(let ([move-front
|
||||
(lambda (x l)
|
||||
(cons x (mzlib:function:remq x l)))])
|
||||
(send 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-media position-edit)
|
||||
(stretchable-in-x #f))
|
||||
(determine-width "0000:000-0000:000"
|
||||
position-canvas
|
||||
position-edit)
|
||||
(edit-position-changed)
|
||||
(send position-edit lock #t))))
|
||||
|
||||
(define make-file%
|
||||
(lambda (super%)
|
||||
(rec mred:file-frame%
|
||||
(class-asi super%
|
||||
(inherit get-edit)
|
||||
(rename [super-can-close? can-close?])
|
||||
(public
|
||||
[can-close?
|
||||
(lambda ()
|
||||
(let* ([edit (get-edit)]
|
||||
[user-allowed-or-not-modified
|
||||
(or (not (send edit modified?))
|
||||
(case (mred:gui-utils:unsaved-warning
|
||||
(let ([fn (send edit get-filename)])
|
||||
(if (string? fn)
|
||||
fn
|
||||
"Untitled"))
|
||||
"Close"
|
||||
#t)
|
||||
[(continue) #t]
|
||||
[(save) (send edit save-file)]
|
||||
[else #f]))])
|
||||
(and user-allowed-or-not-modified
|
||||
(super-can-close?))))])))))
|
||||
|
||||
(define empty% (make-empty% frame%))
|
||||
(define standard-menus% (make-standard-menus% empty%))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
[mzlib:function : mzlib:function^]
|
||||
[mzlib:file : mzlib:file^])
|
||||
|
||||
(define frame-group%
|
||||
(define %
|
||||
(let-struct frame (frame id)
|
||||
(class null ()
|
||||
(private
|
||||
|
|
@ -194,39 +194,4 @@
|
|||
frame
|
||||
(loop (cdr frames))))]))))]))))
|
||||
|
||||
(define the-frame-group (make-object frame-group%))
|
||||
|
||||
(define at-most-one-maker
|
||||
(lambda ()
|
||||
(let ([s (make-semaphore 1)]
|
||||
[test #f])
|
||||
(lambda (return thunk)
|
||||
(semaphore-wait s)
|
||||
(if test
|
||||
(begin (semaphore-post s)
|
||||
return)
|
||||
(begin
|
||||
(set! test #t)
|
||||
(semaphore-post s)
|
||||
(begin0 (thunk)
|
||||
(semaphore-wait s)
|
||||
(set! test #f)
|
||||
(semaphore-post s))))))))
|
||||
|
||||
(define at-most-one (at-most-one-maker))
|
||||
|
||||
(send the-frame-group set-empty-callbacks
|
||||
(lambda ()
|
||||
(at-most-one (void)
|
||||
(lambda () (exit:exit #t))))
|
||||
(lambda ()
|
||||
(at-most-one #t
|
||||
(lambda ()
|
||||
(exit:run-exit-callbacks)))))
|
||||
|
||||
(exit:insert-exit-callback
|
||||
(lambda ()
|
||||
(at-most-one
|
||||
#t
|
||||
(lambda ()
|
||||
(send the-frame-group close-all))))))
|
||||
(define the-frame-group (make-object %)))
|
||||
|
|
@ -4,6 +4,25 @@
|
|||
|
||||
;; preferences
|
||||
|
||||
|
||||
(preferences:set-default 'framework:display-line-numbers #t boolean?)
|
||||
|
||||
(preferences:set-preference-default 'mred:show-status-line
|
||||
#t
|
||||
boolean?)
|
||||
(preferences:set-preference-default 'mred:line-offsets
|
||||
#t
|
||||
boolean?)
|
||||
|
||||
|
||||
|
||||
|
||||
(preferences:set 'framework:print-output-mode
|
||||
0
|
||||
(lambda (x) (or (= x 0) (= x 1))))
|
||||
|
||||
|
||||
|
||||
(preferences:set-default 'framework:highlight-parens #t boolean?)
|
||||
(preferences:set-default 'framework:fixup-parens #t boolean?)
|
||||
(preferences:set-default 'framework:paren-match #t boolean?)
|
||||
|
|
@ -23,22 +42,22 @@
|
|||
sequence))
|
||||
(for-each (lambda (x) (hash-table-put! hash-table x 'lambda))
|
||||
'(lambda let let* letrec letrec* recur
|
||||
let/cc let/ec letcc catch
|
||||
let-syntax letrec-syntax syntax-case
|
||||
let-signature fluid-let
|
||||
let-struct let-macro let-values let*-values
|
||||
case when unless match
|
||||
let-enumerate
|
||||
class class* class-asi class-asi*
|
||||
define-some do opt-lambda send*
|
||||
local catch shared
|
||||
unit/sig
|
||||
with-handlers with-parameterization
|
||||
interface
|
||||
parameterize
|
||||
call-with-input-file with-input-from-file
|
||||
with-input-from-port call-with-output-file
|
||||
with-output-to-file with-output-to-port))
|
||||
let/cc let/ec letcc catch
|
||||
let-syntax letrec-syntax syntax-case
|
||||
let-signature fluid-let
|
||||
let-struct let-macro let-values let*-values
|
||||
case when unless match
|
||||
let-enumerate
|
||||
class class* class-asi class-asi*
|
||||
define-some do opt-lambda send*
|
||||
local catch shared
|
||||
unit/sig
|
||||
with-handlers with-parameterization
|
||||
interface
|
||||
parameterize
|
||||
call-with-input-file with-input-from-file
|
||||
with-input-from-port call-with-output-file
|
||||
with-output-to-file with-output-to-port))
|
||||
(mred:preferences:set-preference-un/marshall
|
||||
'mred:tabify
|
||||
(lambda (t) (hash-table-map t list))
|
||||
|
|
@ -46,8 +65,8 @@
|
|||
(for-each (lambda (x) (apply hash-table-put! h x)) l)
|
||||
h)))
|
||||
(mred:preferences:set-preference-default 'mred:tabify hash-table hash-table?))
|
||||
|
||||
|
||||
|
||||
|
||||
(preferences:set-default 'framework:autosave-delay 300 number?)
|
||||
(preferences:set-default 'framework:autosaving-on? #t boolean?)
|
||||
(preferences:set-default 'framework:verify-exit #t boolean?)
|
||||
|
|
@ -120,8 +139,8 @@
|
|||
[add-button (make-object mred:button% button-panel (add-callback string symbol box) "Add")]
|
||||
[delete-button (make-object mred:button% button-panel (delete-callback box) "Remove")])
|
||||
(send* button-panel
|
||||
(major-align-center)
|
||||
(stretchable-in-y #f))
|
||||
(major-align-center)
|
||||
(stretchable-in-y #f))
|
||||
(send add-button user-min-width (send delete-button get-width))
|
||||
box))]
|
||||
[begin-list-box (make-column "Begin" 'begin begin-keywords)]
|
||||
|
|
@ -139,11 +158,49 @@
|
|||
#t))])
|
||||
(mred:preferences:add-preference-callback 'mred:tabify (lambda (p v) (update-list-boxes v)))
|
||||
main-panel))))
|
||||
|
||||
|
||||
(preferences:read)
|
||||
|
||||
|
||||
;; groups
|
||||
|
||||
(define at-most-one-maker
|
||||
(lambda ()
|
||||
(let ([s (make-semaphore 1)]
|
||||
[test #f])
|
||||
(lambda (return thunk)
|
||||
(semaphore-wait s)
|
||||
(if test
|
||||
(begin (semaphore-post s)
|
||||
return)
|
||||
(begin
|
||||
(set! test #t)
|
||||
(semaphore-post s)
|
||||
(begin0 (thunk)
|
||||
(semaphore-wait s)
|
||||
(set! test #f)
|
||||
(semaphore-post s))))))))
|
||||
|
||||
(let ([at-most-one (at-most-one-maker)])
|
||||
(send the-frame-group set-empty-callbacks
|
||||
(lambda ()
|
||||
(at-most-one (void)
|
||||
(lambda () (exit:exit #t))))
|
||||
(lambda ()
|
||||
(at-most-one #t
|
||||
(lambda ()
|
||||
(exit:run-exit-callbacks)))))
|
||||
|
||||
(exit:insert-exit-callback
|
||||
(lambda ()
|
||||
(at-most-one
|
||||
#t
|
||||
(lambda ()
|
||||
(send the-frame-group close-all))))))
|
||||
|
||||
|
||||
|
||||
;; misc other stuff
|
||||
|
||||
|
||||
(exit:insert-callback
|
||||
(lambda ()
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
|
|
@ -153,5 +210,5 @@
|
|||
(exn-message exn))
|
||||
"Saving Prefs"))])
|
||||
(save-user-preferences))))
|
||||
|
||||
|
||||
(wx:application-file-handler edit-file))
|
||||
|
|
|
|||
|
|
@ -32,51 +32,15 @@
|
|||
pasteboard-info%
|
||||
pasteboard-info-file%))
|
||||
|
||||
(define-signature mred:graph^
|
||||
(node-snip%
|
||||
make-node-snip%
|
||||
graph-pasteboard%
|
||||
make-graph-pasteboard%))
|
||||
|
||||
(define-signature mred:connections^
|
||||
(connections-frame%
|
||||
connections-dialog-box%
|
||||
connections-media-edit%
|
||||
connections-media-pasteboard%
|
||||
connections-media-canvas%
|
||||
connections-panel%
|
||||
|
||||
make-connections-frame%
|
||||
make-connections-media-buffer%
|
||||
make-connections-media-canvas%
|
||||
make-connections-panel%))
|
||||
|
||||
(define-signature mred:version^
|
||||
(add-version-spec
|
||||
(define-signature framework:version^
|
||||
(add-spec
|
||||
version))
|
||||
|
||||
(define-signature mred:html^
|
||||
(html-convert))
|
||||
|
||||
(define-signature mred:panel^
|
||||
(make-edit-panel%
|
||||
horizontal-edit-panel%
|
||||
vertical-edit-panel%))
|
||||
|
||||
(define-signature mred:url^
|
||||
((struct url (scheme host port path params query fragment))
|
||||
unixpath->path
|
||||
get-pure-port ; url [x list (str)] -> in-port
|
||||
get-impure-port ; url [x list (str)] -> in-port
|
||||
display-pure-port ; in-port -> ()
|
||||
purify-port ; in-port -> list (mime-header)
|
||||
netscape/string->url ; (string -> url)
|
||||
string->url ; str -> url
|
||||
url->string
|
||||
call/input-url ; url x (url -> in-port) x
|
||||
; (in-port -> ())
|
||||
; [x list (str)] -> ()
|
||||
combine-url/relative)) ; url x str -> url
|
||||
(make-edit%
|
||||
edit<%>
|
||||
horizontal-edit%
|
||||
vertical-edit%))
|
||||
|
||||
(define-signature framework:exn^
|
||||
((struct exn ())
|
||||
|
|
@ -84,17 +48,9 @@
|
|||
(struct exn:during-preferences ())
|
||||
(struct exn:url ())))
|
||||
|
||||
(define-signature mred:hyper-loader^
|
||||
(open-hyper-make
|
||||
open-hyper-view
|
||||
hyper-text-require))
|
||||
|
||||
(define-signature framework:application^
|
||||
(current-app-name))
|
||||
|
||||
(define-signature mred:exn-external^
|
||||
(exn? exn:unknown-preference? exn:during-preferences? exn:url?))
|
||||
|
||||
(define-signature framework:preferences^
|
||||
(get
|
||||
add-callback
|
||||
|
|
@ -113,57 +69,26 @@
|
|||
(define-signature framework:autosave^
|
||||
(register))
|
||||
|
||||
(define-signature mred:exit^
|
||||
(define-signature framework:exit^
|
||||
(insert-callback
|
||||
remove-callback
|
||||
run-callbacks
|
||||
exit))
|
||||
|
||||
(define-signature mred:gui-utils^
|
||||
(get-font-from-user
|
||||
get-colour-from-user
|
||||
get-text-from-user
|
||||
message-box
|
||||
cursor-delay
|
||||
(define-signature framework:gui-utils^
|
||||
(cursor-delay
|
||||
show-busy-cursor
|
||||
delay-action
|
||||
local-busy-cursor
|
||||
get-choice
|
||||
unsaved-warning
|
||||
read-snips/chars-from-buffer
|
||||
open-input-buffer
|
||||
print-paper-names
|
||||
get-single-choice))
|
||||
open-input-buffer))
|
||||
|
||||
(define-signature mred:console^
|
||||
(credits-proc
|
||||
credits
|
||||
copyright-string
|
||||
welcome-message
|
||||
|
||||
separator-snip%
|
||||
|
||||
console-max-save-previous-exprs
|
||||
|
||||
show-interactions-history
|
||||
|
||||
make-scheme-mode-edit%
|
||||
scheme-mode-edit%
|
||||
|
||||
make-console-edit%
|
||||
console-edit%
|
||||
|
||||
transparent-io-edit%
|
||||
make-transparent-io-edit%
|
||||
|
||||
make-console-frame%
|
||||
console-frame%))
|
||||
|
||||
(define-signature mred:path-utils^
|
||||
(define-signature framework:path-utils^
|
||||
(generate-autosave-name
|
||||
generate-backup-name))
|
||||
|
||||
(define-signature mred:finder^
|
||||
(define-signature framework:finder^
|
||||
(filter-match?
|
||||
dialog-parent-parameter
|
||||
common-put-file
|
||||
|
|
@ -175,12 +100,43 @@
|
|||
get-file
|
||||
put-file))
|
||||
|
||||
(define-signature mred:find-string^
|
||||
(make-find-frame%
|
||||
find-frame%
|
||||
find-string))
|
||||
(define framework:editor^
|
||||
(editor:basic<%>
|
||||
editor:info<%>
|
||||
editor:autosave<%>
|
||||
|
||||
editor:make-basic%
|
||||
editor:make-info%
|
||||
editor:make-file%
|
||||
editor:make-backup-autosave%))
|
||||
|
||||
(define-signature mred:edit^
|
||||
(define-signature framework:text^
|
||||
(text:basic<%>
|
||||
text:searching<%>
|
||||
|
||||
text:make-basic%
|
||||
text:make-return%
|
||||
text:make-searching%
|
||||
text:make-clever-file-format%
|
||||
text:make-scheme%
|
||||
|
||||
text:basic%
|
||||
text:return%
|
||||
text:searching%
|
||||
text:info%
|
||||
text:clever-file-format%
|
||||
text:file%
|
||||
text:backup-autosave%
|
||||
text:scheme%))
|
||||
|
||||
(define-signature framework:pasteboard%
|
||||
(pasteboard:basic%
|
||||
pasteboard:info%
|
||||
pasteboard:file%
|
||||
pasteboard:backup-autosave%))
|
||||
|
||||
|
||||
(define-signature framework:edit^
|
||||
(make-std-buffer%
|
||||
make-pasteboard%
|
||||
make-info-buffer%
|
||||
|
|
@ -212,39 +168,33 @@
|
|||
(make-wide-snip-canvas%
|
||||
wide-snip-canvas%))
|
||||
|
||||
(define-signature mred:frame^
|
||||
(frame-width
|
||||
frame-height
|
||||
(define-signature framework:frame^
|
||||
(empty<%>
|
||||
standard-menus<%>
|
||||
empty-standard-menus<%>
|
||||
edit<%>
|
||||
searchable<%>
|
||||
pasteboard<%>
|
||||
info<%>
|
||||
info-file<%>
|
||||
|
||||
make-simple-frame%
|
||||
make-menu-frame%
|
||||
make-standard-menus-frame%
|
||||
make-searchable-frame%
|
||||
|
||||
make-info-frame%
|
||||
make-edit-info-frame%
|
||||
|
||||
make-file-frame%
|
||||
|
||||
make-pasteboard-frame%
|
||||
make-pasteboard-file-frame%
|
||||
make-pasteboard-info-frame%
|
||||
|
||||
empty-frame%
|
||||
menu-frame%
|
||||
standard-menus-frame%
|
||||
simple-menu-frame%
|
||||
searchable-frame%
|
||||
info-frame%
|
||||
info-file-frame%
|
||||
pasteboard-frame%
|
||||
pasteboard-info-frame%
|
||||
pasteboard-info-file-frame%))
|
||||
|
||||
(define-signature mred:editor-frame^
|
||||
(make-editor-frame%
|
||||
editor-frame%
|
||||
make-status-frame%))
|
||||
make-empty%
|
||||
make-standard-menus%
|
||||
make-edit%
|
||||
make-searchable%
|
||||
make-pasteboard%
|
||||
make-info%
|
||||
make-file%
|
||||
|
||||
empty%
|
||||
standard-menus%
|
||||
edit%
|
||||
searchable%
|
||||
info%
|
||||
info-file%
|
||||
pasteboard%
|
||||
pasteboard-info%
|
||||
pasteboard-info-file%))
|
||||
|
||||
(define-signature mred:group^
|
||||
(frame-group%
|
||||
|
|
|
|||
|
|
@ -1,7 +1,5 @@
|
|||
(unit/sig mred:version^
|
||||
(import [wx : wx^]
|
||||
[mzlib:function : mzlib:function^]
|
||||
[mzlib:string^ : mzlib:string^])
|
||||
(import [mzlib:string^ : mzlib:string^])
|
||||
|
||||
(rename [-version version])
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user