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

..

Browse Source 
original commit: acbc28ecaacc6ba5dcc305ec303ba53194a7f068
This commit is contained in:
Robby Findler 2001-02-25 21:13:27 +00:00
parent b1614ca557
commit 376157f67a
15 changed files with 78 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/framework/framework.ss
View File

@ -1,3 +1,6 @@
;; should import the flattened test and guiutils stuff and
;; dynamically link to that.
(module framework mzscheme (module framework mzscheme
(require (lib "unitsig.ss")) (require (lib "unitsig.ss"))

0
collects/framework/guiutils.ss → collects/framework/gui-utils.ss
View File

4
collects/framework/private/color-model.ss
View File

@ -1,8 +1,8 @@
(module canvas mzscheme (module color-model mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
"sig.ss" "sig.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "function.ss")) (lib "list.ss"))
(provide color-model@) (provide color-model@)

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

@ -1,6 +1,7 @@
(module editor mzscheme (module editor mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
"sig.ss" "sig.ss"
"../guiutils-sig.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "file.ss")) (lib "file.ss"))
@ -310,7 +311,7 @@
[update-filename [update-filename
(lambda (name) (lambda (name)
(let ([filename (if name (let ([filename (if name
(mzlib:file:file-name-from-path (mzlib:file:normalize-path name)) (file-name-from-path (normalize-path name))
"")]) "")])
(for-each (lambda (canvas) (for-each (lambda (canvas)
(let ([tlw (send canvas get-top-level-window)]) (let ([tlw (send canvas get-top-level-window)])

16
collects/framework/private/exit.ss
View File

@ -1,6 +1,7 @@
(module exit mzscheme (module exit mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
"sig.ss" "sig.ss"
"../guiutils-sig.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "file.ss")) (lib "file.ss"))
@ -61,11 +62,10 @@
user-says) user-says)
#t)) #t))
(define -exit (define (-exit)
(opt-lambda () (unless exiting?
(unless exiting? (set! exiting? #t)
(set! exiting? #t) (when (can-exit?)
(when (can-exit?) (on-exit)
(on-exit) (queue-callback (lambda () (exit))))
(queue-callback (lambda () (exit)))) (set! exiting? #f))))))
(set! exiting? #f)))))))

45
collects/framework/private/finder.ss
View File

@ -3,7 +3,7 @@
"sig.ss" "sig.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "string.ss") (lib "string.ss")
(lib "function.ss") (lib "list.ss")
(lib "file.ss")) (lib "file.ss"))
(provide finder@) (provide finder@)
@ -22,7 +22,7 @@
(define filter-match? (define filter-match?
(lambda (filter name msg) (lambda (filter name msg)
(let-values ([(base name dir?) (split-path name)]) (let-values ([(base name dir?) (split-path name)])
(if (mzlib:string:regexp-match-exact? filter name) (if (regexp-match-exact? filter name)
#t #t
(begin (begin
(message-box "Error" msg) (message-box "Error" msg)
@ -104,7 +104,7 @@
(let-values ([(base-dir in-dir dir?) (let-values ([(base-dir in-dir dir?)
(split-path this-dir)]) (split-path this-dir)])
(if (eq? (system-type) 'windows) (if (eq? (system-type) 'windows)
(mzlib:string:string-lowercase! in-dir)) (string-lowercase! in-dir))
(let* ([dir-list (cons this-dir dir-list)] (let* ([dir-list (cons this-dir dir-list)]
[menu-list (cons in-dir menu-list)]) [menu-list (cons in-dir menu-list)])
(if base-dir (if base-dir
@ -121,7 +121,7 @@
(send name-list clear) (send name-list clear)
(send name-list set (send name-list set
(mzlib:function:quicksort (quicksort
(let ([no-periods? (let ([no-periods?
(not (preferences:get (not (preferences:get
'framework:show-periods-in-dirlist))]) 'framework:show-periods-in-dirlist))])
@ -138,8 +138,7 @@
[(directory-exists? (build-path dir s)) [(directory-exists? (build-path dir s))
(cons s rest)] (cons s rest)]
[(or (not file-filter) [(or (not file-filter)
(mzlib:string:regexp-match-exact? (regexp-match-exact? file-filter s))
file-filter s))
(cons s rest)] (cons s rest)]
[else rest]))))) [else rest])))))
;(if (eq? (system-type) 'unix) string<? string-ci<?) ;(if (eq? (system-type) 'unix) string<? string-ci<?)
@ -176,7 +175,7 @@
(if (eq? (send evt get-event-type) 'list-box-dclick) (if (eq? (send evt get-event-type) 'list-box-dclick)
(let ([dir (send directory-field get-value)]) (let ([dir (send directory-field get-value)])
(if (directory-exists? dir) (if (directory-exists? dir)
(set-directory (normal-case-path (mzlib:file:normalize-path dir))) (set-directory (normal-case-path (normalize-path dir)))
(if multi-mode? (if multi-mode?
(do-add) (do-add)
(do-ok)))) (do-ok))))
@ -216,7 +215,7 @@
(string=? name "")) (string=? name ""))
(let ([file (send directory-field get-value)]) (let ([file (send directory-field get-value)])
(if (directory-exists? file) (if (directory-exists? file)
(set-directory (normal-case-path (mzlib:file:normalize-path file))) (set-directory (normal-case-path (normalize-path file)))
(message-box (message-box
"Error" "Error"
"You must specify a file name")))] "You must specify a file name")))]
@ -224,7 +223,7 @@
[(and save-mode? [(and save-mode?
non-empty? non-empty?
file-filter file-filter
(not (mzlib:string:regexp-match-exact? file-filter name))) (not (regexp-match-exact? file-filter name)))
(message-box "Error" file-filter-msg)] (message-box "Error" file-filter-msg)]
[else [else
@ -234,7 +233,7 @@
(let ([dir-name (send directory-field get-value)]) (let ([dir-name (send directory-field get-value)])
(if (directory-exists? dir-name) (if (directory-exists? dir-name)
(set-directory (normal-case-path (mzlib:file:normalize-path dir-name))) (set-directory (normal-case-path (normalize-path dir-name)))
; otherwise, try to return absolute path ; otherwise, try to return absolute path
@ -282,7 +281,7 @@
" contains nonexistent directory or cycle.")) " contains nonexistent directory or cycle."))
#f)]) #f)])
(normal-case-path (normal-case-path
(mzlib:file:normalize-path file)))]) (normalize-path file)))])
(when normal-path (when normal-path
(set-box! result-box normal-path) (set-box! result-box normal-path)
(show #f))))))))]))))] (show #f))))))))]))))]
@ -292,7 +291,7 @@
(unless (or (directory-exists? name) (unless (or (directory-exists? name)
(send result-list find-string name)) (send result-list find-string name))
(send result-list append (send result-list append
(normal-case-path (mzlib:file:normalize-path name)))))] (normal-case-path (normalize-path name)))))]
[do-add [do-add
(lambda args (lambda args
@ -464,7 +463,7 @@
(make-relative which))]) (make-relative which))])
(if (directory-exists? dir) (if (directory-exists? dir)
(set-directory (normal-case-path (set-directory (normal-case-path
(mzlib:file:normalize-path dir))) (normalize-path dir)))
(if multi-mode? (if multi-mode?
(do-add) (do-add)
(do-ok))))))]))] (do-ok))))))]))]
@ -497,7 +496,7 @@
(let ([dir (send directory-field get-value)]) (let ([dir (send directory-field get-value)])
(if (directory-exists? dir) (if (directory-exists? dir)
(set-directory (normal-case-path (set-directory (normal-case-path
(mzlib:file:normalize-path dir))) (normalize-path dir)))
(if multi-mode? (if multi-mode?
(do-add) (do-add)
(do-ok)))))))))] (do-ok)))))))))]
@ -587,7 +586,7 @@
[(and start-dir [(and start-dir
(directory-exists? start-dir)) (directory-exists? start-dir))
(set-directory (normal-case-path (set-directory (normal-case-path
(mzlib:file:normalize-path start-dir)))] (normalize-path start-dir)))]
[last-directory (set-directory last-directory)] [last-directory (set-directory last-directory)]
[else (set-directory (current-directory))]) [else (set-directory (current-directory))])
@ -622,11 +621,11 @@
[parent-win (dialog-parent-parameter)]) [parent-win (dialog-parent-parameter)])
(let* ([directory (if (and (not in-directory) (let* ([directory (if (and (not in-directory)
(string? name)) (string? name))
(mzlib:file:path-only name) (path-only name)
in-directory)] in-directory)]
[saved-directory last-directory] [saved-directory last-directory]
[name (or (and (string? name) [name (or (and (string? name)
(mzlib:file:file-name-from-path name)) (file-name-from-path name))
name)]) name)])
(make-object finder-dialog% (make-object finder-dialog%
parent-win parent-win
@ -699,10 +698,10 @@
[parent-win (dialog-parent-parameter)]) [parent-win (dialog-parent-parameter)])
(let* ([directory (if (and (not directory) (let* ([directory (if (and (not directory)
(string? name)) (string? name))
(mzlib:file:path-only name) (path-only name)
directory)] directory)]
[name (or (and (string? name) [name (or (and (string? name)
(mzlib:file:file-name-from-path name)) (file-name-from-path name))
name)] name)]
[f (put-file [f (put-file
prompt prompt
@ -717,9 +716,9 @@
f f
filter-msg)))) filter-msg))))
#f #f
(let* ([f (normal-case-path (mzlib:file:normalize-path f))] (let* ([f (normal-case-path (normalize-path f))]
[dir (mzlib:file:path-only f)] [dir (path-only f)]
[name (mzlib:file:file-name-from-path f)]) [name (file-name-from-path f)])
(cond (cond
[(not (and (string? dir) (directory-exists? dir))) [(not (and (string? dir) (directory-exists? dir)))
(message-box "Error" "That directory does not exist.") (message-box "Error" "That directory does not exist.")
@ -742,7 +741,7 @@
(if f (if f
(if (or (not filter) (filter-match? filter f filter-msg)) (if (or (not filter) (filter-match? filter f filter-msg))
(let ([f (mzlib:file:normalize-path f)]) (let ([f (normalize-path f)])
(cond (cond
[(directory-exists? f) [(directory-exists? f)
(message-box "Error" "That is a directory name.") (message-box "Error" "That is a directory name.")

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

@ -2,7 +2,7 @@
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
"sig.ss" "sig.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "function.ss") (lib "list.ss")
(lib "file.ss")) (lib "file.ss"))
(provide frame@) (provide frame@)
@ -116,7 +116,7 @@
[after-new-child [after-new-child
(lambda (child) (lambda (child)
(when after-init? (when after-init?
(change-children (lambda (l) (mzlib:function:remq child l))) (change-children (lambda (l) (remq child l)))
(error 'frame:basic-mixin (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" "do not add children directly to a frame:basic (unless using make-root-area-container); use the get-area-container method instead"
)))]) )))])
@ -560,7 +560,7 @@
(sequence (sequence
(let ([move-front (let ([move-front
(lambda (x l) (lambda (x l)
(cons x (mzlib:function:remq x l)))]) (cons x (remq x l)))])
(send (get-info-panel) change-children (send (get-info-panel) change-children
(lambda (l) (lambda (l)
(move-front (move-front
@ -635,7 +635,7 @@
(send (get-editor) on-close))]) (send (get-editor) on-close))])
(private (private
[label (if file-name [label (if file-name
(mzlib:file:file-name-from-path file-name) (file-name-from-path file-name)
(gui-utils:next-untitled-name))] (gui-utils:next-untitled-name))]
[label-prefix (application:current-app-name)] [label-prefix (application:current-app-name)]
[do-label [do-label
@ -1271,7 +1271,7 @@
(opt-lambda ([startup? #f]) (opt-lambda ([startup? #f])
(send super-root change-children (send super-root change-children
(lambda (l) (lambda (l)
(mzlib:function:remove search-panel l))) (remove search-panel l)))
(clear-search-highlight) (clear-search-highlight)
(unless startup? (unless startup?
(send (send

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

@ -50,7 +50,7 @@
(lambda (frame) (lambda (frame)
(let* ([menu (get-windows-menu frame)]) (let* ([menu (get-windows-menu frame)])
(set! windows-menus (set! windows-menus
(mzlib:function:remove (remove
menu menu
windows-menus windows-menus
eq?))))] eq?))))]
@ -71,7 +71,7 @@
default-name) default-name)
label)))] label)))]
[sorted-frames [sorted-frames
(mzlib:function:quicksort (quicksort
frames frames
(lambda (f1 f2) (lambda (f1 f2)
(string-ci<=? (get-name (frame-frame f1)) (string-ci<=? (get-name (frame-frame f1))
@ -161,7 +161,7 @@
[can-remove-frame? [can-remove-frame?
(opt-lambda (f) (opt-lambda (f)
(let ([new-frames (let ([new-frames
(mzlib:function: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)
@ -172,7 +172,7 @@
(when (eq? f active-frame) (when (eq? f active-frame)
(set! active-frame #f)) (set! active-frame #f))
(let ([new-frames (let ([new-frames
(mzlib:function: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)
@ -207,7 +207,7 @@
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(lambda (x) name)]) (lambda (x) name)])
(normal-case-path (normal-case-path
(mzlib:file: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<%>)
@ -217,7 +217,7 @@
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(lambda (x) filename)]) (lambda (x) filename)])
(normal-case-path (normal-case-path
(mzlib:file:normalize-path (normalize-path
filename))))))))]) filename))))))))])
(let loop ([frames frames]) (let loop ([frames frames])
(cond (cond

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

@ -54,7 +54,7 @@
(lambda (name handlers) (lambda (name handlers)
(let/ec exit (let/ec exit
(let ([extension (if (string? name) (let ([extension (if (string? name)
(or (mzlib:file:filename-extension name) (or (filename-extension name)
"") "")
"")]) "")])
(for-each (for-each
@ -128,7 +128,7 @@
[get (lambda () the-dir)] [get (lambda () the-dir)]
[set-from-file! [set-from-file!
(lambda (file) (lambda (file)
(set! the-dir (mzlib:file:path-only file)))] (set! the-dir (path-only file)))]
[set-to-default [set-to-default
(lambda () (lambda ()
(set! the-dir (current-directory)))]) (set! the-dir (current-directory)))])

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

@ -118,7 +118,7 @@
[(null? mods) null] [(null? mods) null]
[(null? (cdr mods)) null] [(null? (cdr mods)) null]
[else (cons (car mods) (loop (cdr mods)))]))] [else (cons (car mods) (loop (cdr mods)))]))]
[key (car (mzlib:function:last-pair mods/key))] [key (car (last-pair mods/key))]
[shift (if neg? #f 'd/c)] [shift (if neg? #f 'd/c)]
[control (if neg? #f 'd/c)] [control (if neg? #f 'd/c)]
[alt (if neg? #f 'd/c)] [alt (if neg? #f 'd/c)]
@ -144,7 +144,7 @@
[(#\m) (set! meta val)]))) [(#\m) (set! meta val)])))
mods) mods)
(join-strings ":" (join-strings ":"
(mzlib:function:filter (filter
(lambda (x) x) (lambda (x) x)
(list (list
(do-key #\a alt) (do-key #\a alt)

10
collects/framework/private/panel.ss
View File

@ -1,14 +1,14 @@
(module panel mzscheme (module panel mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
"sig" "sig"
(lib "mred-sig.ss" "mred")) (lib "mred-sig.ss" "mred")
(lib "list.ss"))
(provide panel@) (provide panel@)
(define panel@ (define panel@
(unit/sig framework:panel^ (unit/sig framework:panel^
(import mred^ (import mred^)
[mzlib:function : mzlib:function^])
(rename [-editor<%> editor<%>]) (rename [-editor<%> editor<%>])
@ -383,7 +383,7 @@
(let ([len (length children)]) (let ([len (length children)])
(unless (= (- len 1) (length (send thumb-canvas get-percentages))) (unless (= (- len 1) (length (send thumb-canvas get-percentages)))
(send thumb-canvas set-percentages (send thumb-canvas set-percentages
(mzlib:function:build-list (build-list
(- len 1) (- len 1)
(lambda (i) (/ 1 (- len 1))))))))]) (lambda (i) (/ 1 (- len 1))))))))])
(rename [super-change-children change-children]) (rename [super-change-children change-children])
@ -395,7 +395,7 @@
(if thumb-canvas (if thumb-canvas
(let* ([res (cons (let* ([res (cons
thumb-canvas thumb-canvas
(mzlib:function:filter (filter
(lambda (c) (not (eq? c thumb-canvas))) (lambda (c) (not (eq? c thumb-canvas)))
(f l)))]) (f l)))])
(fix-percentage-length res) (fix-percentage-length res)

9
collects/framework/private/preferences.ss
View File

@ -1,7 +1,8 @@
(module preferences mzscheme (module preferences mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
"sig" "sig"
(lib "mred-sig.ss" "mred")) (lib "mred-sig.ss" "mred")
(lib "pretty.ss"))
(provide preferences@) (provide preferences@)
(define preferences@ (define preferences@
@ -10,9 +11,7 @@
[prefs-file : framework:prefs-file^] [prefs-file : framework:prefs-file^]
[exn : framework:exn^] [exn : framework:exn^]
[exit : framework:exit^] [exit : framework:exit^]
[panel : framework:panel^] [panel : framework:panel^])
[mzlib:pretty-print : mzlib:pretty-print^]
[mzlib:function : mzlib:function^])
(rename [-read read]) (rename [-read read])
@ -218,7 +217,7 @@
(exn-message exn)))]) (exn-message exn)))])
(call-with-output-file (prefs-file:get-preferences-filename) (call-with-output-file (prefs-file:get-preferences-filename)
(lambda (p) (lambda (p)
(mzlib:pretty-print:pretty-print (pretty-print
(hash-table-map preferences marshall-pref) p)) (hash-table-map preferences marshall-pref) p))
'truncate 'text))))) 'truncate 'text)))))

18
collects/framework/private/scheme.ss
View File

@ -6,7 +6,9 @@
(module scheme mzscheme (module scheme mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
"sig" "sig"
(lib "mred-sig.ss" "mred")) (lib "mred-sig.ss" "mred")
(lib "list.ss")
(lib "thread.ss"))
(provide scheme@) (provide scheme@)
@ -20,9 +22,7 @@
[icon : framework:icon^] [icon : framework:icon^]
[keymap : framework:keymap^] [keymap : framework:keymap^]
[text : framework:text^] [text : framework:text^]
[frame : framework:frame^] [frame : framework:frame^])
[mzlib:thread : mzlib:thread^]
[mzlib:function : mzlib:function^])
(rename [-text% text%] (rename [-text% text%]
[-text<%> text<%>]) [-text<%> text<%>])
@ -312,9 +312,9 @@
[else #f])] [else #f])]
[handle-single [handle-single
(lambda (single) (lambda (single)
(let* ([left (mzlib:function:first single)] (let* ([left (first single)]
[right (mzlib:function:second single)] [right (second single)]
[error? (mzlib:function:third single)] [error? (third single)]
[off (highlight-range [off (highlight-range
left left
right right
@ -539,7 +539,7 @@
(let loop ([para first-para]) (let loop ([para first-para])
(when (<= para end-para) (when (<= para end-para)
(tabify (paragraph-start-position para)) (tabify (paragraph-start-position para))
(mzlib:thread:dynamic-enable-break (lambda () (break-enabled))) (dynamic-enable-break (lambda () (break-enabled)))
(loop (add1 para)))) (loop (add1 para))))
(when (and (>= (position-paragraph start-pos) end-para) (when (and (>= (position-paragraph start-pos) end-para)
(<= (paren:skip-whitespace (<= (paren:skip-whitespace
@ -960,7 +960,7 @@
(letrec ([all-keywords (hash-table-map hash-table list)] (letrec ([all-keywords (hash-table-map hash-table list)]
[pick-out (lambda (wanted in out) [pick-out (lambda (wanted in out)
(cond (cond
[(null? in) (mzlib:function:quicksort out string<=?)] [(null? in) (quicksort out string<=?)]
[else (if (eq? wanted (cadr (car in))) [else (if (eq? wanted (cadr (car in)))
(pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out)) (pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out))
(pick-out wanted (cdr in) out))]))]) (pick-out wanted (cdr in) out))]))])

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

@ -1,8 +1,8 @@
(module text mzscheme (module text mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
"sig" "sig"
(lib "mred-sig.ss" "mred")) (lib "mred-sig.ss" "mred")
(lib "list.ss"))
(provide text@) (provide text@)
(define text@ (define text@
@ -14,8 +14,7 @@
[keymap : framework:keymap^] [keymap : framework:keymap^]
[gui-utils : framework:gui-utils^] [gui-utils : framework:gui-utils^]
[color-model : framework:color-model^] [color-model : framework:color-model^]
[frame : framework:frame^] [frame : framework:frame^])
[mzlib:function : mzlib:function^])
(rename [-keymap% keymap%]) (rename [-keymap% keymap%])
@ -182,8 +181,8 @@
[old-rectangles range-rectangles]) [old-rectangles range-rectangles])
(set! range-rectangles (set! range-rectangles
(mzlib:function:foldl (lambda (x l) (append (new-rectangles x) l)) (foldl (lambda (x l) (append (new-rectangles x) l))
null ranges))))] null ranges))))]
[ranges null] [ranges null]
[pen (make-object pen% "BLACK" 0 'solid)] [pen (make-object pen% "BLACK" 0 'solid)]
[brush (make-object brush% "black" 'solid)]) [brush (make-object brush% "black" 'solid)])

5
collects/framework/private/version.ss
View File

@ -19,8 +19,9 @@
(lambda () (lambda ()
(foldr (foldr
(lambda (entry sofar) (lambda (entry sofar)
(match entry (let ([sep (first entry)]
[(sep num) (string-append sofar sep num)])) [num (second entry)])
(string-append sofar sep num)))
(version) (version)
specs))) specs)))