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

..

Browse Source 
original commit: a5599e717d491ef3c4af0f090de9a308e9b4cda9
This commit is contained in:
Robby Findler 2003-01-01 16:49:19 +00:00
parent 4487be6b84
commit 15adacd282
5 changed files with 73 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/framework/framework.ss
View File

@ -629,11 +629,13 @@
(frame:reorder-menus
((is-a?/c frame%) . -> . void?)
(frame)
"Re-orders the menus in a frame. This is useful in conjunction with the "
"@link frame:standard-menus "
"class. After instantiating that class and adding menus, the menus will"
"be mis-ordered. This will put the File and Edit menus at the front of"
"the menubar and the Help menu at the end.")
"Re-orders the menus in a frame. It moves the ``File'' and ``Edit'' menus to"
"the front of the menubar and moves the ``Windows'' and ``Help'' menus"
"to the end of the menubar."
""
"This is useful in conjunction with the "
"frame classes. After instantiating the class and adding ones own menus,"
"the menus will be mis-ordered. This function fixes them up.")
(group:get-the-frame-group
(-> (is-a?/c group:%))
()

15
collects/framework/private/editor.ss
View File

@ -128,7 +128,7 @@
(string-constant cancel)
(string-constant warning)
#f
(get-top-level-focus-window))
(get-top-level-window))
#t)
#t)
(super-can-save-file? filename format)))]
@ -521,14 +521,21 @@
(inherit get-top-level-window run-after-edit-sequence)
(rename [super-lock lock])
(override lock)
(define callback-running? #f)
[define lock
(lambda (x)
(super-lock x)
(run-after-edit-sequence
(rec send-frame-update-lock-icon
(lambda ()
(let ([frame (get-top-level-window)])
(when (is-a? frame frame:info<%>)
(send frame lock-status-changed)))))
(unless callback-running?
(set! callback-running? #t)
(queue-callback
(lambda ()
(let ([frame (get-top-level-window)])
(when (is-a? frame frame:info<%>)
(send frame lock-status-changed)))
(set! callback-running? #f))
#f))))
'framework:update-lock-icon))]
(super-instantiate ()))))))

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

@ -721,6 +721,7 @@
get-editor<%>
make-editor
revert
save
save-as
get-canvas
@ -834,29 +835,38 @@
(if (or (not filename)
(unbox b))
(bell)
(let ([start
(if (is-a? edit text%)
(send edit get-start-position)
#f)])
(when (gui-utils:get-choice
(string-constant are-you-sure-revert)
(string-constant yes)
(string-constant no)
(string-constant are-you-sure-revert-title)
#f
this)
(send edit begin-edit-sequence)
(let ([status (send edit load-file/gui-error
filename
'same
#f)])
(if status
(begin
(when (is-a? edit text%)
(send edit set-position start start))
(send edit end-edit-sequence))
(send edit end-edit-sequence)))))))
(when (gui-utils:get-choice
(string-constant are-you-sure-revert)
(string-constant yes)
(string-constant no)
(string-constant are-you-sure-revert-title)
#f
this)
(revert))))
#t))
(define/public (revert)
(let* ([edit (get-editor)]
[b (box #f)]
[filename (send edit get-filename b)])
(when (and filename
(not (unbox b)))
(let ([start
(if (is-a? edit text%)
(send edit get-start-position)
#f)])
(send edit begin-edit-sequence)
(let ([status (send edit load-file/gui-error
filename
'same
#f)])
(if status
(begin
(when (is-a? edit text%)
(send edit set-position start start))
(send edit end-edit-sequence))
(send edit end-edit-sequence)))))))
(define/override file-menu:create-revert? (lambda () #t))
(define file-menu:save-callback (lambda (item control)
(save)

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

@ -88,9 +88,10 @@
(hash-table-put! hash-table x 'lambda))
'(
cases
instantiate super-instantiate
lambda let let* letrec recur
match-lambda match-lambda*
instantiate super-instantiate
syntax/loc
lambda let let* letrec recur
match-lambda match-lambda*
letrec-values
with-syntax
with-continuation-mark

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

@ -11,7 +11,7 @@
(lib "list.ss")
(lib "etc.ss"))
(provide text@)
(define text@
(unit/sig framework:text^
(import mred^
@ -386,8 +386,8 @@
(define small-version-of-snip%
(class snip%
(init-field big-snip)
(field (width 0)
(height 0))
(define width 0)
(define height 0)
(define/override (get-extent dc x y wb hb db sb lb rb)
(set/f! db 0)
(set/f! sb 0)
@ -438,7 +438,7 @@
(set/f! lb 0)
(set/f! rb 0))
(field (cache-function #f))
(define cache-function #f)
(rename [super-insert insert])
(define/override (insert s len pos)
@ -529,7 +529,7 @@
(inherit split-snip find-snip get-snip-position
find-first-snip get-style-list set-tabs)
(field (linked-snips #f))
(define linked-snips #f)
(define/private (copy snip)
(let ([new-snip
@ -550,7 +550,7 @@
(send new-snip set-flags (send snip get-flags))
new-snip))
(field (delegate #f))
(define delegate #f)
(inherit get-highlighted-ranges)
(define/public (get-delegate) delegate)
(define/public (set-delegate _d)
@ -672,8 +672,8 @@
(send delegate lock #f)
(send delegate end-edit-sequence)))
(field (filename #f)
(format #f))
(define filename #f)
(define format #f)
(rename [super-on-load-file on-load-file]
[super-after-load-file after-load-file])
(define/override (on-load-file _filename _format)
@ -738,17 +738,18 @@
;; maybe-queue-editor-position-update : -> void
;; updates the editor-position in the frame,
;; but delays it until the next low-priority event occurs.
(field (callback-running? #f))
(define callback-running? #f)
(define/private (maybe-queue-editor-position-update)
(unless callback-running?
(set! callback-running? #t)
(queue-callback
(lambda ()
(call-with-frame
(lambda (frame)
(send frame editor-position-changed)))
(set! callback-running? #f))
#f)))
(enqueue-for-frame
(lambda (frame)
(unless callback-running?
(set! callback-running? #t)
(queue-callback
(lambda ()
(send frame editor-position-changed)
(set! callback-running? #f))
#f)))
'framework:info-frame:update-editor-position))
(define (after-insert start len)
(super-after-insert start len)