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

.

Browse Source 
original commit: af55da650cc28c688a50c53ab34ed354c338d4f1
This commit is contained in:
Robby Findler 2004-04-13 22:14:42 +00:00
parent 596ff32336
commit 81abad71e8
8 changed files with 98 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/framework/framework.ss
View File

@ -445,7 +445,7 @@
(filename) (filename)
"Generates a name for an autosave file from \\var{filename}.") "Generates a name for an autosave file from \\var{filename}.")
(path-utils:generate-backup-name (path-utils:generate-backup-name
(string? . -> . string?) (path? . -> . path?)
(filename) (filename)
"Generates a name for an backup file from \\var{filename}.") "Generates a name for an backup file from \\var{filename}.")
(finder:dialog-parent-parameter (finder:dialog-parent-parameter
@ -500,13 +500,13 @@
(opt-> (opt->
() ()
(string? (string?
(union false? string?) (union false? path?)
boolean? boolean?
string? string?
(union false? regexp?) (union false? regexp?)
string? string?
(union (is-a?/c top-level-window<%>) false?)) (union (is-a?/c top-level-window<%>) false?))
(union false? string?)) (union false? path?))
(() (()
((name "Untitled") ((name "Untitled")
(directory #f) (directory #f)
@ -524,12 +524,12 @@
(finder:common-get-file (finder:common-get-file
(opt-> (opt->
() ()
((union string? false?) ((union path? false?)
string? string?
(union regexp? false?) (union regexp? false?)
string? string?
(union false? (is-a?/c top-level-window<%>))) (union false? (is-a?/c top-level-window<%>)))
(union string? false?)) (union path? false?))
(() (()
((directory #f) ((directory #f)
(prompt "Select File") (prompt "Select File")
@ -546,13 +546,13 @@
(opt-> (opt->
() ()
(string? (string?
(union false? string?) (union false? path?)
boolean? boolean?
string? string?
(union false? regexp?) (union false? regexp?)
string? string?
(union (is-a?/c top-level-window<%>) false?)) (union (is-a?/c top-level-window<%>) false?))
(union false? string?)) (union false? path?))
(() (()
((name "Untitled") ((name "Untitled")
(directory #f) (directory #f)
@ -570,12 +570,12 @@
(finder:std-get-file (finder:std-get-file
(opt-> (opt->
() ()
((union string? false?) ((union path? false?)
string? string?
(union regexp? false?) (union regexp? false?)
string? string?
(union false? (is-a?/c top-level-window<%>))) (union false? (is-a?/c top-level-window<%>)))
(union string? false?)) (union path? false?))
(() (()
((directory #f) ((directory #f)
(prompt "Select File") (prompt "Select File")
@ -592,13 +592,13 @@
(opt-> (opt->
() ()
(string? (string?
(union false? string?) (union false? path?)
boolean? boolean?
string? string?
(union false? regexp?) (union false? regexp?)
string? string?
(union (is-a?/c top-level-window<%>) false?)) (union (is-a?/c top-level-window<%>) false?))
(union false? string?)) (union false? path?))
(() (()
((name "Untitled") ((name "Untitled")
(directory #f) (directory #f)
@ -620,12 +620,12 @@
(finder:get-file (finder:get-file
(opt-> (opt->
() ()
((union string? false?) ((union path? false?)
string? string?
(union regexp? string? false?) (union regexp? string? false?)
string? string?
(union false? (is-a?/c top-level-window<%>))) (union false? (is-a?/c top-level-window<%>)))
(union string? false?)) (union path? false?))
(() (()
((directory #f) ((directory #f)
(prompt "Select File") (prompt "Select File")
@ -645,12 +645,12 @@
(finder:common-get-file-list (finder:common-get-file-list
(opt-> (opt->
() ()
((union false? string?) ((union false? path?)
string? string?
(union false? regexp?) (union false? regexp?)
string? string?
(union false? (is-a?/c top-level-window<%>))) (union false? (is-a?/c top-level-window<%>)))
(union (listof string?) false?)) (union (listof path?) false?))
(() (()
((directory #f) ((directory #f)
(prompt "Select File") (prompt "Select File")
@ -696,17 +696,17 @@
(handler) (handler)
"Extracts the name from a handler.") "Extracts the name from a handler.")
(handler:handler-extension (handler:handler-extension
(handler:handler? . -> . string?) (handler:handler? . -> . (union (path? . -> . boolean?) (listof string?)))
(handler) (handler)
"Extracts the extension from a handler.") "Extracts the extension from a handler.")
(handler:handler-handler (handler:handler-handler
(handler:handler? . -> . (string? . -> . (is-a?/c frame:editor<%>))) (handler:handler? . -> . (path? . -> . (is-a?/c frame:editor<%>)))
(handler) (handler)
"Extracs the handler's handling function") "Extracs the handler's handling function")
(handler:insert-format-handler (handler:insert-format-handler
(string? (string?
(union string? (listof string?) (string? . -> . boolean?)) (union string? (listof string?) (path? . -> . boolean?))
(string? . -> . (union false? (is-a?/c frame:editor<%>))) (path? . -> . (union false? (is-a?/c frame:editor<%>)))
. -> . . -> .
void?) void?)
(name pred handler) (name pred handler)
@ -721,7 +721,7 @@
". If it is a function, the filename is applied to the function and the" ". If it is a function, the filename is applied to the function and the"
"functions result determines if this is the handler to use.") "functions result determines if this is the handler to use.")
(handler:find-named-format-handler (handler:find-named-format-handler
(string? . -> . (string? . -> . (is-a?/c frame:editor<%>))) (string? . -> . (path? . -> . (is-a?/c frame:editor<%>)))
(name) (name)
"This function selects a format handler. See also" "This function selects a format handler. See also"
"@flink handler:insert-format-handler %" "@flink handler:insert-format-handler %"
@ -729,7 +729,7 @@
"" ""
"It finds a handler based on \\var{name}.") "It finds a handler based on \\var{name}.")
(handler:find-format-handler (handler:find-format-handler
(string? . -> . (string? . -> . (is-a?/c frame:editor<%>))) (path? . -> . (path? . -> . (is-a?/c frame:editor<%>)))
(filename) (filename)
"This function selects a format handler. See also" "This function selects a format handler. See also"
"@flink handler:insert-format-handler %" "@flink handler:insert-format-handler %"
@ -739,7 +739,7 @@
(handler:edit-file (handler:edit-file
(opt-> (opt->
((union string? false?)) ((union path? false?))
((-> (is-a?/c frame:editor<%>))) ((-> (is-a?/c frame:editor<%>)))
(union false? (is-a?/c frame:editor<%>))) (union false? (is-a?/c frame:editor<%>)))
((filename) ((filename)
@ -785,7 +785,7 @@
(handler:current-create-new-window (handler:current-create-new-window
(case-> (case->
(((union false? string?) . -> . (is-a?/c frame%)) . -> . void) (((union false? path?) . -> . (is-a?/c frame%)) . -> . void)
(-> ((union false? string?) . -> . (is-a?/c frame%)))) (-> ((union false? string?) . -> . (is-a?/c frame%))))
((new-window-handler) ()) ((new-window-handler) ())
"This is a parameter that controls how the framework" "This is a parameter that controls how the framework"
@ -833,7 +833,7 @@
".") ".")
(handler:add-to-recent (handler:add-to-recent
(string? . -> . void?) (path? . -> . void?)
(filename) (filename)
"Adds a filename to the list of recently opened files.") "Adds a filename to the list of recently opened files.")

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

@ -420,7 +420,7 @@
(define/public (update-frame-filename) (define/public (update-frame-filename)
(let* ([filename (get-filename)] (let* ([filename (get-filename)]
[name (if filename [name (if filename
(file-name-from-path (normalize-path filename)) (path->string (file-name-from-path (normalize-path filename)))
(get-filename/untitled-name))]) (get-filename/untitled-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)])
@ -436,7 +436,7 @@
(define/public (get-filename/untitled-name) (define/public (get-filename/untitled-name)
(let ([filename (get-filename)]) (let ([filename (get-filename)])
(if filename (if filename
filename (path->string filename)
(begin (begin
(unless untitled-name (unless untitled-name
(set! untitled-name (gui-utils:next-untitled-name))) (set! untitled-name (gui-utils:next-untitled-name)))

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

@ -993,6 +993,7 @@
[define get-label (lambda () label)] [define get-label (lambda () label)]
[define set-label [define set-label
(lambda (t) (lambda (t)
(printf "set-label ~s\n" t)
(when (and (string? t) (when (and (string? t)
(not (string=? t label))) (not (string=? t label)))
(set! label t) (set! label t)
@ -1180,7 +1181,7 @@
(let ([ed-fn (send (get-editor) get-filename)]) (let ([ed-fn (send (get-editor) get-filename)])
(set! label (or (and ed-fn (set! label (or (and ed-fn
(file-name-from-path ed-fn)) (path->string (file-name-from-path ed-fn)))
(send (get-editor) get-filename/untitled-name)))) (send (get-editor) get-filename/untitled-name))))
(do-label) (do-label)
(let ([canvas (get-canvas)]) (let ([canvas (get-canvas)])

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

@ -46,7 +46,9 @@
[(not (procedure? handler)) [(not (procedure? handler))
(error who "handler was not a function")] (error who "handler was not a function")]
[else (make-handler name [else (make-handler name
extension (if (string? extension)
(list extension)
extension)
handler)])))) handler)]))))
(define insert-format-handler (define insert-format-handler
@ -67,11 +69,8 @@
(let ([ext (handler-extension handler)]) (let ([ext (handler-extension handler)])
(when (or (and (procedure? ext) (when (or (and (procedure? ext)
(ext name)) (ext name))
(and (string? ext)
(string=? ext extension))
(and (pair? ext) (and (pair? ext)
(ormap (lambda (ext) (ormap (lambda (ext) (string=? ext extension))
(string=? ext extension))
ext))) ext)))
(exit (handler-handler handler))))) (exit (handler-handler handler)))))
handlers) handlers)
@ -110,7 +109,7 @@
(lambda () (lambda ()
((current-create-new-window) filename)))] ((current-create-new-window) filename)))]
[(filename make-default) [(filename make-default)
(with-handlers ([exn:fail? (with-handlers ([(lambda (x) #f) ;exn:fail?
(lambda (exn) (lambda (exn)
(message-box (message-box
(string-constant error-loading) (string-constant error-loading)
@ -144,7 +143,7 @@
fr)] fr)]
[else [else
(let ([handler (let ([handler
(if (string? filename) (if (path? filename)
(find-format-handler filename) (find-format-handler filename)
#f)]) #f)])
(add-to-recent filename) (add-to-recent filename)
@ -155,10 +154,12 @@
;; type recent-list-item = (list/p string? number? number?) ;; type recent-list-item = (list/p string? number? number?)
;; add-to-recent : string -> void ;; add-to-recent : path -> void
(define (add-to-recent filename) (define (add-to-recent filename)
(let* ([old-list (preferences:get 'framework:recently-opened-files/pos)] (let* ([old-list (preferences:get 'framework:recently-opened-files/pos)]
[old-ents (filter (lambda (x) (string=? (car x) filename)) old-list)] [old-ents (filter (lambda (x) (string=? (path->string (car x))
(path->string filename)))
old-list)]
[old-ent (if (null? old-ents) [old-ent (if (null? old-ents)
#f #f
(car old-ents))] (car old-ents))]
@ -171,7 +172,8 @@
;; compare-recent-list-items : recent-list-item recent-list-item -> boolean ;; compare-recent-list-items : recent-list-item recent-list-item -> boolean
(define (compare-recent-list-items l1 l2) (define (compare-recent-list-items l1 l2)
(string=? (car l1) (car l2))) (string=? (path->string (car l1))
(path->string (car l2))))
;; size-down : (listof X) -> (listof X)[< recent-max-count] ;; size-down : (listof X) -> (listof X)[< recent-max-count]
;; takes a list of stuff and returns the ;; takes a list of stuff and returns the
@ -201,7 +203,8 @@
;; with the positions `start' and `end' ;; with the positions `start' and `end'
(define (set-recent-position filename start end) (define (set-recent-position filename start end)
(let ([recent-items (let ([recent-items
(filter (lambda (x) (string=? (car x) filename)) (filter (lambda (x) (string=? (path->string (car x))
(path->string filename)))
(preferences:get 'framework:recently-opened-files/pos))]) (preferences:get 'framework:recently-opened-files/pos))])
(unless (null? recent-items) (unless (null? recent-items)
(let ([recent-item (car recent-items)]) (let ([recent-item (car recent-items)])
@ -228,10 +231,12 @@
(let ([filename (car recent-list-item)]) (let ([filename (car recent-list-item)])
(instantiate menu-item% () (instantiate menu-item% ()
(parent menu) (parent menu)
(label (regexp-replace* (label (gui-utils:trim-string
(regexp-replace*
"&" "&"
(gui-utils:trim-string filename 200) (path->string filename)
"&&")) "&&")
200))
(callback (lambda (x y) (open-recent-list-item recent-list-item)))))) (callback (lambda (x y) (open-recent-list-item recent-list-item))))))
recently-opened-files))) recently-opened-files)))
@ -299,7 +304,8 @@
(for-each (lambda (item) (add-recent-item item)) (for-each (lambda (item) (add-recent-item item))
(if (eq? (preferences:get 'framework:recently-opened-sort-by) 'name) (if (eq? (preferences:get 'framework:recently-opened-sort-by) 'name)
(quicksort recent-list-items (quicksort recent-list-items
(lambda (x y) (string<=? (car x) (car y)))) (lambda (x y) (string<=? (path->string (car x))
(path->string (car y)))))
recent-list-items)) recent-list-items))
(send ed end-edit-sequence))) (send ed end-edit-sequence)))

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

@ -58,6 +58,35 @@
(lambda (c) (list (send c red) (send c green) (send c blue))) (lambda (c) (list (send c red) (send c green) (send c blue)))
(lambda (l) (make-object color% (car l) (cadr l) (caddr l)))) (lambda (l) (make-object color% (car l) (cadr l) (caddr l))))
(preferences:set-default 'framework:recently-opened-files/pos
null
(lambda (x) (and (list? x)
(andmap
(lambda (x)
(and (list? x)
(= 3 (length x))
(bytes? (car x))
(number? (cadr x))
(number? (caddr x))))
x))))
(preferences:set-un/marshall
'framework:recently-opened-files/pos
(lambda (l) (map (lambda (ele) (cons (path->bytes (car ele)) (cdr ele))) l))
(lambda (l)
(let/ec k
(unless (list? l)
(k '()))
(map (lambda (x)
(unless (and (list? x)
(= 3 (length x))
(bytes? (car x))
(number? (cadr x))
(number? (caddr x)))
(k '()))
(cons (bytes->path (car x)) (cdr x)))
l))))
(preferences:set-default 'framework:last-directory (find-system-path 'home-dir) (preferences:set-default 'framework:last-directory (find-system-path 'home-dir)
(lambda (x) (or (not x) path-string?))) (lambda (x) (or (not x) path-string?)))
@ -84,17 +113,6 @@
(preferences:set-default 'framework:recent-items-window-h 600 number?) (preferences:set-default 'framework:recent-items-window-h 600 number?)
(preferences:set-default 'framework:open-here? #f boolean?) (preferences:set-default 'framework:open-here? #f boolean?)
(preferences:set-default 'framework:show-delegate? #f boolean?) (preferences:set-default 'framework:show-delegate? #f boolean?)
(preferences:set-default 'framework:recently-opened-files/pos
null
(lambda (x) (and (list? x)
(andmap
(lambda (x)
(and (list? x)
(= 3 (length x))
(string? (car x))
(number? (cadr x))
(number? (caddr x))))
x))))
(preferences:set-default 'framework:search-using-dialog? #t boolean?) (preferences:set-default 'framework:search-using-dialog? #t boolean?)
(preferences:set-default 'framework:windows-mdi #f boolean?) (preferences:set-default 'framework:windows-mdi #f boolean?)
(preferences:set-default 'framework:menu-bindings #t boolean?) (preferences:set-default 'framework:menu-bindings #t boolean?)

15
collects/framework/private/path-utils.ss
View File

@ -49,18 +49,17 @@
(loop (add1 n)) (loop (add1 n))
new-name))))))) new-name)))))))
(define re:backup (regexp "(.*)\\.[^.]*")) (define (generate-backup-name full-name)
(let-values ([(base name dir?) (split-path full-name)])
(define generate-backup-name (let ([name-str (path->string name)])
(lambda (name)
(cond (cond
[(and (eq? (system-type) 'windows) [(and (eq? (system-type) 'windows)
(regexp-match re:backup name)) (regexp-match #rx"(.*)\\.[^.]*" name-str))
=> =>
(lambda (m) (lambda (m)
(string-append (cadr m) ".bak"))] (build-path base (string-append (cadr m) ".bak")))]
[(eq? (system-type) 'windows) [(eq? (system-type) 'windows)
(string-append name ".bak")] (build-path base (string-append name-str ".bak"))]
[else [else
(string-append name "~")])))))) (build-path base (string-append name-str "~"))])))))))

6
collects/mrlib/name-message.ss
View File

@ -34,12 +34,14 @@
;; label : string ;; label : string
(define label (string-constant untitled)) (define label (string-constant untitled))
;; set-message : boolean (union #f string) -> void ;; set-message : boolean (union #f path string) -> void
;; if file-name? is #t, path-name should be a path (or #f)
;; if file-name? is #f, path-name should be a string (or #f)
(define/public (set-message file-name? path-name) (define/public (set-message file-name? path-name)
(set! paths (if (and file-name? (set! paths (if (and file-name?
path-name path-name
(file-exists? path-name)) (file-exists? path-name))
(explode-path (normalize-path path-name)) (map path->string (explode-path (normalize-path path-name)))
#f)) #f))
(let ([new-label (cond (let ([new-label (cond
[(and paths (not (null? paths))) [(and paths (not (null? paths)))