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

started refactoring to fix the preferences problem

Browse Source 
svn: r7226

original commit: af46ef56221814eead6ee5a2951cb455c444f923
This commit is contained in:
Robby Findler 2007-08-30 04:08:56 +00:00
parent 7f2515e200
commit 7a3a15e6be
6 changed files with 59 additions and 181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/framework/framework.ss
View File

@ -344,7 +344,7 @@
(filename)
"Generates a name for an backup file from \\var{filename}.")
(finder:dialog-parent-parameter
any/c
(parameter/c (or/c false/c (is-ac dialog%) (is-a/c frame%)))
()
"This is a parameter (see "
"\\Mzhyperref{parameters}{mz:parameters} for information about parameters)"
@ -602,6 +602,29 @@
()
"This returns the frame group.")
(group:on-close-action
(-> void?)
()
"See also "
"@flink group:can-close-check %"
"."
""
"Call this function from the"
"@ilink top-level-window can-close?"
"callback of a frame"
"in order for the group to properly close the application.")
(group:can-close-check
(-> boolean?)
()
"See also "
"@flink group:on-close-action %"
"."
""
"Call this function from the"
"@ilink top-level-window can-close?"
"callback of a frame"
"in order for the group to properly close the application.")
(handler:handler?
(any/c . -> . boolean?)
(obj)

2
collects/framework/preferences.ss
View File

@ -348,7 +348,7 @@ the state transitions / contracts are:
"Determines if a value is an unknown preference exn.")
(preferences:low-level-put-preferences
any/c
(parameter/c (-> (listof symbol?) (listof any?) any))
()
"This is a parameter (see "
"\\Mzhyperref{parameters}{mz:parameters} for information about parameters)"

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

@ -237,23 +237,14 @@
(mixin (basic<%>) (register-group<%>)
(define/augment (can-close?)
(let ([number-of-frames
(length (send (group:get-the-frame-group)
get-frames))])
(and (inner #t can-close?)
(or (not (preferences:get 'framework:exit-when-no-frames))
(exit:exiting?)
(not (= 1 number-of-frames))
(exit:user-oks-exit)))))
(and (inner #t can-close?)
(group:can-close-check)))
(define/augment (on-close)
(send (group:get-the-frame-group)
remove-frame
this)
(inner (void) on-close)
(when (preferences:get 'framework:exit-when-no-frames)
(unless (exit:exiting?)
(when (null? (send (group:get-the-frame-group) get-frames))
(exit:exit)))))
(group:on-close-action))
(define/override (on-activate on?)
(super on-activate on?)

46
collects/framework/private/group.ss
View File

@ -14,7 +14,8 @@
[prefix frame: framework:frame^]
[prefix text: framework:text^]
[prefix canvas: framework:canvas^]
[prefix menu: framework:menu^])
[prefix menu: framework:menu^]
[prefix exit: framework:exit^])
(export framework:group^)
(define-struct frame (frame id))
@ -156,11 +157,7 @@
#f
(frame-frame (car candidates))))]))
(public get-mdi-parent frame-label-changed for-each-frame
get-active-frame set-active-frame insert-frame
remove-frame clear on-close-all can-close-all? locate-file get-frames
frame-shown/hidden)
(define (get-mdi-parent)
(define/public (get-mdi-parent)
(when (and (eq? (system-type) 'windows)
(preferences:get 'framework:windows-mdi)
(not mdi-parent))
@ -170,35 +167,35 @@
(send mdi-parent show #t))
mdi-parent)
(define (get-frames) (map frame-frame frames))
(define/public (get-frames) (map frame-frame frames))
(define (frame-label-changed frame)
(define/public (frame-label-changed frame)
(when (memq frame (map frame-frame frames))
(update-windows-menus)))
(define (frame-shown/hidden frame)
(define/public (frame-shown/hidden frame)
(when (memq frame (map frame-frame frames))
(update-windows-menus)))
(define (for-each-frame f)
(define/public (for-each-frame f)
(for-each (λ (x) (f (frame-frame x))) frames)
(set! todo-to-new-frames
(let ([old todo-to-new-frames])
(λ (frame) (old frame) (f frame)))))
(define (get-active-frame)
(define/public (get-active-frame)
(cond
[active-frame active-frame]
[(null? frames) #f]
[else (frame-frame (car frames))]))
(define (set-active-frame f)
(define/public (set-active-frame f)
(when (and active-frame
(not (eq? active-frame f)))
(set! most-recent-window-box (make-weak-box active-frame)))
(set! active-frame f))
(define (insert-frame new-frame)
(define/public (insert-frame new-frame)
(unless (memf (λ (fr) (eq? (frame-frame fr) new-frame))
frames)
(set! frame-counter (add1 frame-counter))
@ -210,7 +207,7 @@
(update-windows-menus))
(todo-to-new-frames new-frame)))
(define (remove-frame f)
(define/public (remove-frame f)
(when (eq? f active-frame)
(set! active-frame #f))
(let ([new-frames
@ -222,24 +219,24 @@
(remove-windows-menu f)
(update-windows-menus)))
(define (clear)
(define/public (clear)
(set! frames null)
#t)
(define (on-close-all)
(define/public (on-close-all)
(for-each (λ (f)
(let ([frame (frame-frame f)])
(send frame on-close)
(send frame show #f)))
frames))
(define (can-close-all?)
(define/public (can-close-all?)
(andmap (λ (f)
(let ([frame (frame-frame f)])
(send frame can-close?)))
frames))
(define (locate-file name)
(define/public (locate-file name)
(let* ([normalized
;; allow for the possiblity of filenames that are urls
(with-handlers ([(λ (x) #t)
@ -261,6 +258,19 @@
(super-new)))
(define (can-close-check)
(let ([number-of-frames (length (send (get-the-frame-group) get-frames))])
(or (not (preferences:get 'framework:exit-when-no-frames))
(exit:exiting?)
(not (= 1 number-of-frames))
(exit:user-oks-exit))))
(define (on-close-action)
(when (preferences:get 'framework:exit-when-no-frames)
(unless (exit:exiting?)
(when (null? (send (get-the-frame-group) get-frames))
(exit:exit)))))
(define (choose-a-frame parent)
(letrec-values ([(sorted-frames)
(sort

4
collects/framework/private/sig.ss
View File

@ -281,7 +281,9 @@
(define-signature group-class^
(%))
(define-signature group^ extends group-class^
(get-the-frame-group))
(get-the-frame-group
on-close-action
can-close-check))
(define-signature handler-class^
())

148
collects/macro-debugger/view/util.ss
View File

@ -1,148 +0,0 @@
(module util mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred"))
(provide define/listen
field/notify
override/return-false
notify-box%
notify-box/pref
menu-option/notify-box
menu-group/notify-box
check-box/notify-box
choice/notify-box)
(define notification-lock (make-parameter #f))
(define-for-syntax (join . args)
(define (->string x)
(cond [(string? x) x]
[(symbol? x) (symbol->string)]
[(identifier? x) (symbol->string (syntax-e x))]
[else (error '->string)]))
(string->symbol (apply string-append (map ->string args))))
(define-syntax override/return-false
(syntax-rules ()
[(override/return-false m ...)
(begin (define/override (m) #f) ...)]))
(define-syntax (field/notify stx)
(syntax-case stx ()
[(field/notify name value)
(with-syntax ([get-name
(datum->syntax-object #'name (join "get-" #'name))]
[set-name
(datum->syntax-object #'name (join "set-" #'name))]
[listen-name
(datum->syntax-object #'name (join "listen-" #'name))])
#'(begin (field [name value])
(define/public (get-name)
(send name get))
(define/public (set-name new-value)
(send name set new-value))
(define/public (listen-name listener)
(send name listen listener))))]))
(define-syntax (define/listen stx)
(syntax-case stx ()
[(define/listen name value)
(unless (identifier? #'name)
(raise-syntax-error 'define/listen "expected identifier" #'name))
(with-syntax ([get-name
(datum->syntax-object #'name (join "get-" #'name))]
[set-name
(datum->syntax-object #'name (join "set-" #'name))]
[listen-name
(datum->syntax-object #'name (join "listen-" #'name))])
#'(begin
(define name value)
(define listeners null)
(define/public (get-name) name)
(define/public (set-name new-value)
(set! name new-value)
(for-each (lambda (listener) (listener new-value)) listeners))
(define/public (listen-name listener)
(set! listeners (cons listener listeners)))))]))
(define notify-box%
(class object%
(init value)
(define v value)
(define listeners null)
;; get : -> value
;; Fetch current value
(define/public (get)
v)
;; set : value -> void
;; Update value and notify listeners
(define/public (set nv)
(when (notification-lock)
(error 'notify-box%::set "nested mutation"))
(set! v nv)
(parameterize ((notification-lock #t))
(for-each (lambda (p) (p nv)) listeners)))
;; listen : (value -> void) -> void
;; Add a listener
(define/public (listen p)
(set! listeners (cons p listeners)))
(super-new)))
(define (notify-box/pref pref)
(define nb (new notify-box% (value (pref))))
(send nb listen pref)
nb)
(define (menu-option/notify-box parent label nb)
(define menu-item
(new checkable-menu-item%
(label label)
(parent parent)
(checked (send nb get))
(callback
(lambda _ (send nb set (send menu-item is-checked?))))))
(send nb listen (lambda (value) (send menu-item check value)))
menu-item)
(define (check-box/notify-box parent label nb)
(define checkbox
(new check-box%
(label label)
(parent parent)
(value (send nb get))
(callback
(lambda (c e) (send nb set (send c get-value))))))
(send nb listen (lambda (value) (send checkbox set-value value)))
checkbox)
(define (choice/notify-box parent label choices nb)
(define choice
(new choice%
(label label)
(parent parent)
(style '(horizontal-label))
(choices choices)
(callback (lambda (c e) (send nb set (send c get-string-selection))))))
(send choice set-string-selection (send nb get))
(send nb listen (lambda (value) (send choice set-string-selection value)))
choice)
(define (menu-group/notify-box parent labels nb)
(map (lambda (option)
(define label (if (pair? option) (car option) option))
(define menu-item
(new checkable-menu-item%
(label label)
(parent parent)
(checked (eq? (send nb get) option))
(callback
(lambda _ (send nb set option)))))
(send nb listen
(lambda (value) (send menu-item check (eq? value option))))
menu-item)
labels))
)