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

...

Browse Source 
original commit: 18fb67f98b884f89a9b94142fe9101b32942b368
This commit is contained in:
Robby Findler 2001-06-28 21:02:31 +00:00
parent 05c24425e8
commit f22b17caf3
7 changed files with 149 additions and 145 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/framework/framework.ss
View File

@ -6,10 +6,10 @@
"test.ss" "test.ss"
"test-sig.ss" "test-sig.ss"
(prefix prefs-file: "prefs-file.ss") "prefs-file.ss"
"prefs-file-sig.ss" "prefs-file-sig.ss"
(prefix gui-utils: "gui-utils.ss") "gui-utils.ss"
"gui-utils-sig.ss" "gui-utils-sig.ss"
"framework-unit.ss" "framework-unit.ss"

9
collects/framework/gui-utils.ss
View File

@ -5,10 +5,13 @@
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "mred.ss" "mred")) (lib "mred.ss" "mred"))
(provide-signature-elements framework:gui-utils^) (provide-signature-elements ((unit gui-utils : framework:gui-utils^)))
(define-values/invoke-unit/sig (define-values/invoke-unit/sig
framework:gui-utils^ ((unit gui-utils : framework:gui-utils^))
framework:gui-utils@ (compound-unit/sig
(import [mred : mred^])
(link [gui-utils : framework:gui-utils^ (framework:gui-utils@ mred)])
(export (unit gui-utils)))
#f #f
mred^)) mred^))

2
collects/framework/private/canvas.ss
View File

@ -25,7 +25,7 @@
(inherit has-focus? get-top-level-window) (inherit has-focus? get-top-level-window)
(rename [super-on-focus on-focus] (rename [super-on-focus on-focus]
[super-set-editor set-editor]) [super-set-editor set-editor])
(override on-focus) (override on-focus set-editor)
[define on-focus [define on-focus
(lambda (on?) (lambda (on?)
(super-on-focus on?) (super-on-focus on?)

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

@ -2,7 +2,6 @@
(module group mzscheme (module group mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
(lib "class100.ss")
"sig.ss" "sig.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "list.ss") (lib "list.ss")
@ -22,19 +21,18 @@
(define mdi-parent #f) (define mdi-parent #f)
(define % (define %
(class100 object% () (class object%
(private-field
[active-frame #f] [define active-frame #f]
[frame-counter 0] [define frame-counter 0]
[frames null] [define frames null]
[todo-to-new-frames void] [define todo-to-new-frames void]
[empty-close-down (lambda () (void))] [define empty-close-down (lambda () (void))]
[empty-test (lambda () #t)] [define empty-test (lambda () #t)]
[windows-menus null]) [define windows-menus null]
(private [define get-windows-menu
[get-windows-menu
(lambda (frame) (lambda (frame)
(let ([menu-bar (send frame get-menu-bar)]) (let ([menu-bar (send frame get-menu-bar)])
(and menu-bar (and menu-bar
@ -44,12 +42,12 @@
x x
#f)) #f))
menus)))))] menus)))))]
[insert-windows-menu [define insert-windows-menu
(lambda (frame) (lambda (frame)
(let ([menu (get-windows-menu frame)]) (let ([menu (get-windows-menu frame)])
(when menu (when menu
(set! windows-menus (cons menu windows-menus)))))] (set! windows-menus (cons menu windows-menus)))))]
[remove-windows-menu [define remove-windows-menu
(lambda (frame) (lambda (frame)
(let* ([menu (get-windows-menu frame)]) (let* ([menu (get-windows-menu frame)])
(set! windows-menus (set! windows-menus
@ -58,7 +56,7 @@
windows-menus windows-menus
eq?))))] eq?))))]
[update-windows-menus [define update-windows-menus
(lambda () (lambda ()
(let* ([windows (length windows-menus)] (let* ([windows (length windows-menus)]
[default-name "Untitled"] [default-name "Untitled"]
@ -91,10 +89,9 @@
(lambda (_1 _2) (lambda (_1 _2)
(send frame show #t))))) (send frame show #t)))))
sorted-frames)) sorted-frames))
windows-menus)))]) windows-menus)))]
(private [define update-close-menu-item-state
[update-close-menu-item-state
(lambda () (lambda ()
(let* ([set-close-menu-item-state! (let* ([set-close-menu-item-state!
(lambda (frame state) (lambda (frame state)
@ -106,127 +103,128 @@
(set-close-menu-item-state! (car frames) #f) (set-close-menu-item-state! (car frames) #f)
(for-each (lambda (a-frame) (for-each (lambda (a-frame)
(set-close-menu-item-state! a-frame #t)) (set-close-menu-item-state! a-frame #t))
frames))))]) frames))))]
(public (public get-mdi-parent set-empty-callbacks frame-label-changed for-each-frame
[get-mdi-parent get-active-frame set-active-frame insert-frame can-remove-frame?
(lambda () remove-frame clear on-close-all can-close-all? locate-file get-frames)
(when (and (eq? (system-type) 'windows) [define get-mdi-parent
(preferences:get 'framework:windows-mdi) (lambda ()
(not mdi-parent)) (when (and (eq? (system-type) 'windows)
(set! mdi-parent (make-object frame% (application:current-app-name) (preferences:get 'framework:windows-mdi)
#f #f #f #f #f (not mdi-parent))
'(mdi-parent))) (set! mdi-parent (make-object frame% (application:current-app-name)
(send mdi-parent show #t)) #f #f #f #f #f
mdi-parent)] '(mdi-parent)))
(send mdi-parent show #t))
mdi-parent)]
[set-empty-callbacks [define set-empty-callbacks
(lambda (test close-down) (lambda (test close-down)
(set! empty-test test) (set! empty-test test)
(set! empty-close-down close-down))] (set! empty-close-down close-down))]
[get-frames (lambda () (map frame-frame frames))] [define get-frames (lambda () (map frame-frame frames))]
[frame-label-changed [define frame-label-changed
(lambda (frame) (lambda (frame)
(when (member frame (map frame-frame frames)) (when (member frame (map frame-frame frames))
(update-windows-menus)))] (update-windows-menus)))]
[for-each-frame [define for-each-frame
(lambda (f) (lambda (f)
(for-each (lambda (x) (f (frame-frame x))) frames) (for-each (lambda (x) (f (frame-frame x))) frames)
(set! todo-to-new-frames (set! todo-to-new-frames
(let ([old todo-to-new-frames]) (let ([old todo-to-new-frames])
(lambda (frame) (old frame) (f frame)))))] (lambda (frame) (old frame) (f frame)))))]
[get-active-frame [define get-active-frame
(lambda () (lambda ()
(cond (cond
[active-frame active-frame] [active-frame active-frame]
[(null? frames) #f] [(null? frames) #f]
[else (frame-frame (car frames))]))] [else (frame-frame (car frames))]))]
[set-active-frame [define set-active-frame
(lambda (f) (lambda (f)
(set! active-frame f))] (set! active-frame f))]
[insert-frame [define insert-frame
(lambda (f) (lambda (f)
(set! frame-counter (add1 frame-counter)) (set! frame-counter (add1 frame-counter))
(let ([new-frames (cons (make-frame f frame-counter) (let ([new-frames (cons (make-frame f frame-counter)
frames)]) frames)])
(set! frames new-frames) (set! frames new-frames)
(update-close-menu-item-state) (update-close-menu-item-state)
(insert-windows-menu f) (insert-windows-menu f)
(update-windows-menus)) (update-windows-menus))
(todo-to-new-frames f))] (todo-to-new-frames f))]
[can-remove-frame? [define can-remove-frame?
(lambda (f) (lambda (f)
(let ([new-frames (let ([new-frames
(remove (remove
f frames f frames
(lambda (f fr) (eq? f (frame-frame fr))))]) (lambda (f fr) (eq? f (frame-frame fr))))])
(if (null? new-frames) (if (null? new-frames)
(empty-test) (empty-test)
#t)))] #t)))]
[remove-frame [define remove-frame
(lambda (f) (lambda (f)
(when (eq? f active-frame) (when (eq? f active-frame)
(set! active-frame #f)) (set! active-frame #f))
(let ([new-frames (let ([new-frames
(remove (remove
f frames f frames
(lambda (f fr) (eq? f (frame-frame fr))))]) (lambda (f fr) (eq? f (frame-frame fr))))])
(set! frames new-frames) (set! frames new-frames)
(update-close-menu-item-state) (update-close-menu-item-state)
(remove-windows-menu f) (remove-windows-menu f)
(update-windows-menus) (update-windows-menus)
(when (null? frames) (when (null? frames)
(empty-close-down))))] (empty-close-down))))]
[clear [define clear
(lambda () (lambda ()
(and (empty-test) (and (empty-test)
(begin (set! frames null) (begin (set! frames null)
(empty-close-down) (empty-close-down)
#t)))] #t)))]
[on-close-all [define on-close-all
(lambda () (lambda ()
(for-each (lambda (f) (for-each (lambda (f)
(let ([frame (frame-frame f)]) (let ([frame (frame-frame f)])
(send frame on-close) (send frame on-close)
(send frame show #f))) (send frame show #f)))
frames))] frames))]
[can-close-all? [define can-close-all?
(lambda () (lambda ()
(andmap (lambda (f) (andmap (lambda (f)
(let ([frame (frame-frame f)]) (let ([frame (frame-frame f)])
(send frame can-close?))) (send frame can-close?)))
frames))] frames))]
[locate-file [define locate-file
(lambda (name) (lambda (name)
(let* ([normalized (let* ([normalized
;; allow for the possiblity of filenames that are urls ;; allow for the possiblity of filenames that are urls
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(lambda (x) name)]) (lambda (x) name)])
(normal-case-path (normal-case-path
(normalize-path name)))] (normalize-path name)))]
[test-frame [test-frame
(lambda (frame) (lambda (frame)
(and (is-a? frame frame:basic<%>) (and (is-a? frame frame:basic<%>)
(let* ([filename (send frame get-filename)]) (let* ([filename (send frame get-filename)])
(and (string? filename) (and (string? filename)
(string=? normalized (string=? normalized
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(lambda (x) filename)]) (lambda (x) filename)])
(normal-case-path (normal-case-path
(normalize-path (normalize-path
filename))))))))]) filename))))))))])
(let loop ([frames frames]) (let loop ([frames frames])
(cond (cond
[(null? frames) #f] [(null? frames) #f]
[else [else
(let* ([frame (frame-frame (car frames))]) (let* ([frame (frame-frame (car frames))])
(if (test-frame frame) (if (test-frame frame)
frame frame
(loop (cdr frames))))]))))]) (loop (cdr frames))))]))))]
(sequence (super-instantiate ())))
(super-init))))
(define (internal-get-the-frame-group) (define (internal-get-the-frame-group)
(let ([the-frame-group (make-object %)]) (let ([the-frame-group (make-object %)])
@ -234,4 +232,4 @@
(internal-get-the-frame-group))) (internal-get-the-frame-group)))
(define (get-the-frame-group) (define (get-the-frame-group)
(internal-get-the-frame-group))))) (internal-get-the-frame-group)))))

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

@ -131,21 +131,21 @@
(define-signature framework:text^ (define-signature framework:text^
(basic<%> (basic<%>
hide/selection<%> hide-caret/selection<%>
searching<%> searching<%>
return<%> return<%>
info<%> info<%>
clever-file-format<%> clever-file-format<%>
basic-mixin basic-mixin
hide/selection-mixin hide-caret/selection-mixin
searching-mixin searching-mixin
return-mixin return-mixin
info-mixin info-mixin
clever-file-format-mixin clever-file-format-mixin
basic% basic%
hide/selection% hide-caret/selection%
keymap% keymap%
return% return%
autowrap% autowrap%

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

@ -338,9 +338,9 @@
(super-instantiate ()) (super-instantiate ())
(set-autowrap-bitmap (initial-autowrap-bitmap)))) (set-autowrap-bitmap (initial-autowrap-bitmap))))
(define hide/selection<%> (interface (basic<%>))) (define hide-caret/selection<%> (interface (basic<%>)))
(define hide/selection-mixin (define hide-caret/selection-mixin
(mixin (basic<%>) (hide/selection<%>) (mixin (basic<%>) (hide-caret/selection<%>)
(override after-set-position) (override after-set-position)
(inherit get-start-position get-end-position hide-caret) (inherit get-start-position get-end-position hide-caret)
(define (after-set-position) (define (after-set-position)
@ -460,7 +460,7 @@
(super-instantiate ()))) (super-instantiate ())))
(define basic% (basic-mixin (editor:basic-mixin text%))) (define basic% (basic-mixin (editor:basic-mixin text%)))
(define hide/selection% (hide/selection-mixin basic%)) (define hide-caret/selection% (hide-caret/selection-mixin basic%))
(define -keymap% (editor:keymap-mixin basic%)) (define -keymap% (editor:keymap-mixin basic%))
(define return% (return-mixin -keymap%)) (define return% (return-mixin -keymap%))
(define autowrap% (editor:autowrap-mixin -keymap%)) (define autowrap% (editor:autowrap-mixin -keymap%))

11
collects/tests/framework/load.ss
View File

@ -26,17 +26,20 @@
(load-framework-automatically #f) (load-framework-automatically #f)
(test/load "prefs-file-unit.ss" 'framework:prefs-file@) (test/load "prefs-file-unit.ss" 'framework:prefs-file@)
(test/load "prefs-file.ss" 'get-preferences-filename) (test/load "prefs-file.ss" 'prefs-file:get-preferences-filename)
(test/load "gui-utils-unit.ss" 'framework:gui-utils@) (test/load "gui-utils-unit.ss" 'framework:gui-utils@)
(test/load "gui-utils.ss" 'next-untitled-name) (test/load "gui-utils.ss" 'gui-utils:next-untitled-name)
(test/load "test-unit.ss" 'framework:test@) (test/load "test-unit.ss" 'framework:test@)
(test/load "test.ss" 'test:run-interval) (test/load "test.ss" 'test:run-interval)
(test/load "macro.ss" '(mixin () () ())) (test/load "macro.ss" '(mixin () () ()))
(test/load "framework-unit.ss" 'framework@) (test/load "framework-unit.ss" '(list framework@ framework-no-prefs@ framework-small-part@))
(test/load "framework.ss" 'frame:basic-mixin) (test/load "framework.ss" '(list prefs-file:get-preferences-filename
test:button-push
gui-utils:next-untitled-name
frame:basic-mixin))
(load-framework-automatically old-load-framework-automatically?)) (load-framework-automatically old-load-framework-automatically?))