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

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

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

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

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

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

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

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

@ -910,7 +910,7 @@ WARNING: printf is rebound in the body of the unit to always
(channel-put this-eventspace-flush-chan c)
(let ([viable-bytes (channel-get c)])
(do-insertion viable-bytes))))
(define/public (get-in-port)
(unless in-port (error 'get-in-port "not ready"))
in-port)

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

@ -34,12 +34,14 @@
;; label : string
(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)
(set! paths (if (and file-name?
path-name
(file-exists? path-name))
(explode-path (normalize-path path-name))
(map path->string (explode-path (normalize-path path-name)))
#f))
(let ([new-label (cond
[(and paths (not (null? paths)))