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

PR 9289

Browse Source 
svn: r9259
This commit is contained in:
Robby Findler 2008-04-11 17:56:18 +00:00
parent 251491e17f
commit 3b09127a48
5 changed files with 408 additions and 415 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/drscheme/private/frame.ss
View File

@ -158,7 +158,6 @@
(drscheme:app:add-language-items-to-help-menu menu))
(define/override (file-menu:open-callback item evt) (handler:open-file))
(define/override (file-menu:new-string) (string-constant new-menu-item))
(define/override (file-menu:open-string) (string-constant open-menu-item))

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

@ -1039,23 +1039,20 @@
(super set-label (gui-utils:trim-string (get-entire-label) 200))
(send (group:get-the-frame-group) frame-label-changed this))
(public get-entire-label get-label-prefix set-label-prefix)
[define get-entire-label
(λ ()
(define/public (get-entire-label)
(cond
[(string=? "" label)
label-prefix]
[(string=? "" label-prefix)
label]
[else
(string-append label " - " label-prefix)]))]
[define get-label-prefix (λ () label-prefix)]
[define set-label-prefix
(λ (s)
(string-append label " - " label-prefix)]))
(define/public (get-label-prefix) label-prefix)
(define/public (set-label-prefix s)
(when (and (string? s)
(not (string=? s label-prefix)))
(set! label-prefix s)
(do-label)))]
(do-label)))
[define/override get-label (λ () label)]
[define/override set-label
(λ (t)
@ -1116,6 +1113,14 @@
(inherit get-checkable-menu-item% get-menu-item%)
(define/override (file-menu:open-callback item evt)
(let* ([e (get-editor)]
[fn (and e (send e get-filename))]
[dir (and fn
(let-values ([(base name dir) (split-path fn)])
base))])
(handler:open-file dir)))
(define/override (file-menu:revert-on-demand item)
(send item enable (not (send (get-editor) is-locked?))))

8
collects/framework/private/framework-exports.ss
View File

@ -642,13 +642,15 @@
]})
(handler:open-file
(-> (or/c false/c (is-a?/c frame:basic<%>)))
()
(->* ()
((or/c false/c path? string?))
(or/c false/c (is-a?/c frame:basic<%>)))
(((dir #f)))
@{This function queries the user for a filename and opens the file for
editing. It uses @scheme[handler:edit-file] to open the file, once
the user has chosen it.
Calls @scheme[finder:get-file] and @scheme[handler:edit-file].})
Calls @scheme[finder:get-file] and @scheme[handler:edit-file], passing along @scheme[dir].})
(handler:install-recent-items
((is-a?/c menu%) . -> . void?)

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

@ -1,6 +1,6 @@
#lang scheme/unit
(require mzlib/class
(require mzlib/class
mzlib/list
(lib "hierlist.ss" "hierlist")
"sig.ss"
@ -11,19 +11,19 @@
string-constants)
(import mred^
(import mred^
[prefix finder: framework:finder^]
[prefix group: framework:group^]
[prefix text: framework:text^]
[prefix frame: framework:frame^])
(export framework:handler^)
(init-depend framework:frame^)
(export framework:handler^)
(init-depend framework:frame^)
(define-struct handler (name extension handler))
(define-struct handler (name extension handler))
(define format-handlers '())
(define format-handlers '())
(define make-insert-handler
(define make-insert-handler
(letrec ([string-list?
(λ (l)
(cond
@ -49,13 +49,13 @@
extension)
handler)]))))
(define insert-format-handler
(define insert-format-handler
(λ args
(set! format-handlers
(cons (apply make-insert-handler 'insert-format-handler args)
format-handlers))))
(define find-handler
(define find-handler
(λ (name handlers)
(let/ec exit
(let ([extension (if (string? name)
@ -74,12 +74,12 @@
handlers)
#f))))
(define find-format-handler
(define find-format-handler
(λ (name)
(find-handler name format-handlers)))
; Finding format & mode handlers by name
(define find-named-handler
; Finding format & mode handlers by name
(define find-named-handler
(λ (name handlers)
(let loop ([l handlers])
(cond
@ -88,19 +88,19 @@
(handler-handler (car l))]
[else (loop (cdr l))]))))
(define find-named-format-handler
(define find-named-format-handler
(λ (name)
(find-named-handler name format-handlers)))
; Open a file for editing
(define current-create-new-window
; Open a file for editing
(define current-create-new-window
(make-parameter
(λ (filename)
(let ([frame (make-object frame:text% filename)])
(send frame show #t)
frame))))
(define edit-file
(define edit-file
(case-lambda
[(filename) (edit-file
filename
@ -150,10 +150,10 @@
(make-default)))]))
(make-default)))))]))
;; type recent-list-item = (list/p string? number? number?)
;; type recent-list-item = (list/p string? number? number?)
;; add-to-recent : path -> void
(define (add-to-recent filename)
;; add-to-recent : path -> void
(define (add-to-recent filename)
(let* ([old-list (preferences:get 'framework:recently-opened-files/pos)]
[old-ents (filter (λ (x) (string=? (path->string (car x))
(path->string filename)))
@ -168,15 +168,15 @@
[new-recent (size-down added-in (preferences:get 'framework:recent-max-count))])
(preferences:set 'framework:recently-opened-files/pos new-recent)))
;; compare-recent-list-items : recent-list-item recent-list-item -> boolean
(define (compare-recent-list-items l1 l2)
;; compare-recent-list-items : recent-list-item recent-list-item -> boolean
(define (compare-recent-list-items l1 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
;; front of the list, up to `recent-max-count' items
(define (size-down new-recent n)
;; size-down : (listof X) -> (listof X)[< recent-max-count]
;; takes a list of stuff and returns the
;; front of the list, up to `recent-max-count' items
(define (size-down new-recent n)
(let loop ([n n]
[new-recent new-recent])
(cond
@ -187,19 +187,19 @@
(loop (- n 1)
(cdr new-recent)))])))
;; size-recently-opened-files : number -> void
;; sets the recently-opened-files/pos preference
;; to a size limited by `n'
(define (size-recently-opened-files n)
;; size-recently-opened-files : number -> void
;; sets the recently-opened-files/pos preference
;; to a size limited by `n'
(define (size-recently-opened-files n)
(preferences:set
'framework:recently-opened-files/pos
(size-down (preferences:get 'framework:recently-opened-files/pos)
n)))
;; set-recent-position : path number number -> void
;; updates the recent menu preferences
;; with the positions `start' and `end'
(define (set-recent-position filename start end)
;; set-recent-position : path number number -> void
;; updates the recent menu preferences
;; with the positions `start' and `end'
(define (set-recent-position filename start end)
(let* ([recent-items
(preferences:get 'framework:recently-opened-files/pos)]
[new-recent-items
@ -213,8 +213,8 @@
(preferences:set 'framework:recently-opened-files/pos
new-recent-items))))
;; install-recent-items : (is-a?/c menu%) -> void?
(define (install-recent-items menu)
;; install-recent-items : (is-a?/c menu%) -> void?
(define (install-recent-items menu)
(let ([recently-opened-files
(preferences:get
'framework:recently-opened-files/pos)])
@ -243,8 +243,8 @@
recently-opened-files)
(void)))
;; open-recent-list-item : recent-list-item -> void
(define (open-recent-list-item recent-list-item)
;; open-recent-list-item : recent-list-item -> void
(define (open-recent-list-item recent-list-item)
(let* ([filename (car recent-list-item)]
[start (cadr recent-list-item)]
[end (caddr recent-list-item)])
@ -260,35 +260,35 @@
(format (string-constant cannot-open-because-dne)
filename))])))
;; show-recent-items-window : -> void
(define (show-recent-items-window)
;; show-recent-items-window : -> void
(define (show-recent-items-window)
(unless recent-items-window
(set! recent-items-window (make-recent-items-window)))
(send recent-items-window show #t))
;; make-recent-items-window : -> frame
(define (make-recent-items-window)
;; make-recent-items-window : -> frame
(define (make-recent-items-window)
(make-object (get-recent-items-window%)
(string-constant show-recent-items-window-label)
#f
(preferences:get 'framework:recent-items-window-w)
(preferences:get 'framework:recent-items-window-h)))
;; recent-items-window : (union #f (is-a?/c frame%))
(define recent-items-window #f)
;; recent-items-window : (union #f (is-a?/c frame%))
(define recent-items-window #f)
(define recent-items-hierarchical-list%
(define recent-items-hierarchical-list%
(class hierarchical-list%
(define/override (on-double-select item)
(send item open-item))
(super-instantiate ())))
(define recent-items-super% (frame:standard-menus-mixin frame:basic%))
(define recent-items-super% (frame:standard-menus-mixin frame:basic%))
(define (set-recent-items-frame-superclass super%)
(define (set-recent-items-frame-superclass super%)
(set! recent-items-super% super%))
(define (get-recent-items-window%)
(define (get-recent-items-window%)
(class recent-items-super%
;; remove extraneous separators
@ -360,37 +360,20 @@
(set-sort-by (preferences:get 'framework:recently-opened-sort-by))))
;; make-hierlist-item-mixin : recent-item -> mixin(arg to new-item method of hierlist)
(define (make-hierlist-item-mixin recent-item)
;; make-hierlist-item-mixin : recent-item -> mixin(arg to new-item method of hierlist)
(define (make-hierlist-item-mixin recent-item)
(λ (%)
(class %
(define/public (open-item)
(open-recent-list-item recent-item))
(super-instantiate ()))))
(define *open-directory* ; object to remember last directory
(new (class object%
(field [the-dir #f])
[define/public get (λ () the-dir)]
[define/public set-from-file!
(λ (file)
(set! the-dir (path-only file)))]
[define/public set-to-default
(λ ()
(set! the-dir (current-directory)))]
(set-to-default)
(super-new))))
(define (open-file)
(define (open-file [directory #f])
(let* ([parent (and (or (not (eq? 'macosx (system-type)))
(preferences:get 'framework:open-here?))
(get-top-level-focus-window))]
[file
(parameterize ([finder:dialog-parent-parameter parent])
(finder:get-file
(send *open-directory* get)))])
(when file
(send *open-directory*
set-from-file! file))
(finder:get-file directory))])
(and file
(edit-file file))))

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

@ -1349,7 +1349,11 @@
#t)]
[load-file
(λ (edit event)
(handler:open-file)
(let ([fn (send edit get-filename)])
(handler:open-file
(and fn
(let-values ([(base name dir) (split-path fn)])
base))))
#t)])
(λ (kmap)
(let* ([map (λ (key func)