fixed a bug in preferences reading
svn: r5158
This commit is contained in:
Robby Findler
parent
01a4a5c804
commit
41675aa2ec
|
|
@ -65,24 +65,24 @@
|
|||
#f]
|
||||
[else f]))))))
|
||||
|
||||
(define (*get-file style)
|
||||
(opt-lambda ([directory #f]
|
||||
[prompt (string-constant select-file)]
|
||||
[filter #f]
|
||||
[filter-msg (string-constant file-wrong-form)]
|
||||
[parent-win (dialog-parent-parameter)])
|
||||
(let ([f (get-file prompt parent-win directory #f #f style)])
|
||||
(and f (or (not filter) (filter-match? filter f filter-msg))
|
||||
(let ([f (normalize-path f)])
|
||||
(cond [(directory-exists? f)
|
||||
(message-box (string-constant error)
|
||||
(string-constant that-is-dir-name))
|
||||
#f]
|
||||
[(not (file-exists? f))
|
||||
(message-box (string-constant error)
|
||||
(string-constant file-dne))
|
||||
#f]
|
||||
[else f]))))))
|
||||
(define (*get-file style)
|
||||
(opt-lambda ([directory #f]
|
||||
[prompt (string-constant select-file)]
|
||||
[filter #f]
|
||||
[filter-msg (string-constant file-wrong-form)]
|
||||
[parent-win (dialog-parent-parameter)])
|
||||
(let ([f (get-file prompt parent-win directory #f #f style)])
|
||||
(and f (or (not filter) (filter-match? filter f filter-msg))
|
||||
(let ([f (normalize-path f)])
|
||||
(cond [(directory-exists? f)
|
||||
(message-box (string-constant error)
|
||||
(string-constant that-is-dir-name))
|
||||
#f]
|
||||
[(not (file-exists? f))
|
||||
(message-box (string-constant error)
|
||||
(string-constant file-dne))
|
||||
#f]
|
||||
[else f]))))))
|
||||
|
||||
;; external interfaces to file functions
|
||||
|
||||
|
|
@ -94,13 +94,14 @@
|
|||
|
||||
(define -put-file
|
||||
(λ args
|
||||
(apply (case (preferences:get 'framework:file-dialogs)
|
||||
(printf "put-file ~s\n" (preferences:get 'framework:file-dialogs))
|
||||
(apply (case (preferences:get 'framework:file-dialogs)
|
||||
[(std) std-put-file]
|
||||
[(common) common-put-file])
|
||||
args)))
|
||||
(define -get-file
|
||||
(λ args
|
||||
(apply (case (preferences:get 'framework:file-dialogs)
|
||||
(apply (case (preferences:get 'framework:file-dialogs)
|
||||
[(std) std-get-file]
|
||||
[(common) common-get-file])
|
||||
args))))
|
||||
|
|
|
|||
|
|
@ -8,8 +8,8 @@
|
|||
(lib "mred-sig.ss" "mred")
|
||||
(lib "file.ss")
|
||||
(lib "string-constant.ss" "string-constants"))
|
||||
|
||||
|
||||
|
||||
|
||||
(import mred^
|
||||
[prefix finder: framework:finder^]
|
||||
[prefix group: framework:group^]
|
||||
|
|
@ -19,375 +19,374 @@
|
|||
(export framework:handler^)
|
||||
(init-depend framework:frame^)
|
||||
|
||||
(define-struct handler (name extension handler))
|
||||
|
||||
(define format-handlers '())
|
||||
|
||||
(define make-insert-handler
|
||||
(letrec ([string-list?
|
||||
(λ (l)
|
||||
(cond
|
||||
[(null? l) #t]
|
||||
[(not (pair? l)) #f]
|
||||
[else
|
||||
(and (string? (car l))
|
||||
(string-list? (cdr l)))]))])
|
||||
(λ (who name extension handler)
|
||||
(cond
|
||||
[(not (string? name))
|
||||
(error who "name was not a string")]
|
||||
[(and (not (procedure? extension))
|
||||
(not (string? extension))
|
||||
(not (string-list? extension)))
|
||||
(error who
|
||||
"extension was not a string, list of strings, or a predicate")]
|
||||
[(not (procedure? handler))
|
||||
(error who "handler was not a function")]
|
||||
[else (make-handler name
|
||||
(if (string? extension)
|
||||
(list extension)
|
||||
extension)
|
||||
handler)]))))
|
||||
(define-struct handler (name extension handler))
|
||||
|
||||
(define format-handlers '())
|
||||
|
||||
(define make-insert-handler
|
||||
(letrec ([string-list?
|
||||
(λ (l)
|
||||
(cond
|
||||
[(null? l) #t]
|
||||
[(not (pair? l)) #f]
|
||||
[else
|
||||
(and (string? (car l))
|
||||
(string-list? (cdr l)))]))])
|
||||
(λ (who name extension handler)
|
||||
(cond
|
||||
[(not (string? name))
|
||||
(error who "name was not a string")]
|
||||
[(and (not (procedure? extension))
|
||||
(not (string? extension))
|
||||
(not (string-list? extension)))
|
||||
(error who
|
||||
"extension was not a string, list of strings, or a predicate")]
|
||||
[(not (procedure? handler))
|
||||
(error who "handler was not a function")]
|
||||
[else (make-handler name
|
||||
(if (string? extension)
|
||||
(list extension)
|
||||
extension)
|
||||
handler)]))))
|
||||
|
||||
(define insert-format-handler
|
||||
(λ args
|
||||
(set! format-handlers
|
||||
(cons (apply make-insert-handler 'insert-format-handler args)
|
||||
format-handlers))))
|
||||
|
||||
(define find-handler
|
||||
(λ (name handlers)
|
||||
(let/ec exit
|
||||
(let ([extension (if (string? name)
|
||||
(or (filename-extension name)
|
||||
"")
|
||||
"")])
|
||||
(for-each
|
||||
(λ (handler)
|
||||
(let ([ext (handler-extension handler)])
|
||||
(when (or (and (procedure? ext)
|
||||
(ext name))
|
||||
(and (pair? ext)
|
||||
(ormap (λ (ext) (string=? ext extension))
|
||||
ext)))
|
||||
(exit (handler-handler handler)))))
|
||||
handlers)
|
||||
#f))))
|
||||
|
||||
(define find-format-handler
|
||||
(λ (name)
|
||||
(find-handler name format-handlers)))
|
||||
|
||||
; Finding format & mode handlers by name
|
||||
(define find-named-handler
|
||||
(λ (name handlers)
|
||||
(let loop ([l handlers])
|
||||
(cond
|
||||
[(null? l) #f]
|
||||
[(string-ci=? (handler-name (car l)) name)
|
||||
(handler-handler (car l))]
|
||||
[else (loop (cdr l))]))))
|
||||
|
||||
(define find-named-format-handler
|
||||
(λ (name)
|
||||
(find-named-handler name format-handlers)))
|
||||
|
||||
; 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
|
||||
(case-lambda
|
||||
[(filename) (edit-file
|
||||
filename
|
||||
(λ ()
|
||||
((current-create-new-window) filename)))]
|
||||
[(filename make-default)
|
||||
(with-handlers ([(λ (x) #f) ;exn:fail?
|
||||
(λ (exn)
|
||||
(message-box
|
||||
(string-constant error-loading)
|
||||
(string-append
|
||||
(format (string-constant error-loading-file/name)
|
||||
(or filename
|
||||
(string-constant unknown-filename)))
|
||||
"\n\n"
|
||||
(if (exn? exn)
|
||||
(format "~a" (exn-message exn))
|
||||
(format "~s" exn))))
|
||||
#f)])
|
||||
(gui-utils:show-busy-cursor
|
||||
(λ ()
|
||||
(if filename
|
||||
(let ([already-open (send (group:get-the-frame-group)
|
||||
locate-file
|
||||
filename)])
|
||||
(cond
|
||||
[already-open
|
||||
(send already-open make-visible filename)
|
||||
(send already-open show #t)
|
||||
already-open]
|
||||
[(and (preferences:get 'framework:open-here?)
|
||||
(send (group:get-the-frame-group) get-open-here-frame))
|
||||
=>
|
||||
(λ (fr)
|
||||
(add-to-recent filename)
|
||||
(send fr open-here filename)
|
||||
(send fr show #t)
|
||||
fr)]
|
||||
[else
|
||||
(let ([handler
|
||||
(if (path? filename)
|
||||
(find-format-handler filename)
|
||||
#f)])
|
||||
(add-to-recent filename)
|
||||
(if handler
|
||||
(handler filename)
|
||||
(make-default)))]))
|
||||
(make-default)))))]))
|
||||
|
||||
;; type recent-list-item = (list/p string? number? number?)
|
||||
|
||||
;; 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)))
|
||||
old-list)]
|
||||
[old-ent (if (null? old-ents)
|
||||
#f
|
||||
(car old-ents))]
|
||||
[new-ent (list filename
|
||||
(if old-ent (cadr old-ent) 0)
|
||||
(if old-ent (caddr old-ent) 0))]
|
||||
[added-in (cons new-ent (remove new-ent old-list compare-recent-list-items))]
|
||||
[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)
|
||||
(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)
|
||||
(let loop ([n n]
|
||||
[new-recent new-recent])
|
||||
(cond
|
||||
[(zero? n) null]
|
||||
[(null? new-recent) null]
|
||||
[else
|
||||
(cons (car new-recent)
|
||||
(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)
|
||||
(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)
|
||||
(let ([recent-items
|
||||
(filter (λ (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)])
|
||||
(set-car! (cdr recent-item) start)
|
||||
(set-car! (cddr recent-item) end)))))
|
||||
|
||||
;; install-recent-items : (is-a?/c menu%) -> void?
|
||||
(define (install-recent-items menu)
|
||||
(let ([recently-opened-files
|
||||
(preferences:get
|
||||
'framework:recently-opened-files/pos)])
|
||||
(for-each (λ (item) (send item delete))
|
||||
(send menu get-items))
|
||||
|
||||
(define insert-format-handler
|
||||
(λ args
|
||||
(set! format-handlers
|
||||
(cons (apply make-insert-handler 'insert-format-handler args)
|
||||
format-handlers))))
|
||||
|
||||
(define find-handler
|
||||
(λ (name handlers)
|
||||
(let/ec exit
|
||||
(let ([extension (if (string? name)
|
||||
(or (filename-extension name)
|
||||
"")
|
||||
"")])
|
||||
(for-each
|
||||
(λ (handler)
|
||||
(let ([ext (handler-extension handler)])
|
||||
(when (or (and (procedure? ext)
|
||||
(ext name))
|
||||
(and (pair? ext)
|
||||
(ormap (λ (ext) (string=? ext extension))
|
||||
ext)))
|
||||
(exit (handler-handler handler)))))
|
||||
handlers)
|
||||
#f))))
|
||||
(instantiate menu-item% ()
|
||||
(parent menu)
|
||||
(label (string-constant show-recent-items-window-menu-item))
|
||||
(callback (λ (x y) (show-recent-items-window))))
|
||||
|
||||
(define find-format-handler
|
||||
(λ (name)
|
||||
(find-handler name format-handlers)))
|
||||
|
||||
; Finding format & mode handlers by name
|
||||
(define find-named-handler
|
||||
(λ (name handlers)
|
||||
(let loop ([l handlers])
|
||||
(cond
|
||||
[(null? l) #f]
|
||||
[(string-ci=? (handler-name (car l)) name)
|
||||
(handler-handler (car l))]
|
||||
[else (loop (cdr l))]))))
|
||||
(instantiate separator-menu-item% ()
|
||||
(parent menu))
|
||||
|
||||
(define find-named-format-handler
|
||||
(λ (name)
|
||||
(find-named-handler name format-handlers)))
|
||||
|
||||
; 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
|
||||
(case-lambda
|
||||
[(filename) (edit-file
|
||||
filename
|
||||
(λ ()
|
||||
((current-create-new-window) filename)))]
|
||||
[(filename make-default)
|
||||
(with-handlers ([(λ (x) #f) ;exn:fail?
|
||||
(λ (exn)
|
||||
(message-box
|
||||
(string-constant error-loading)
|
||||
(string-append
|
||||
(format (string-constant error-loading-file/name)
|
||||
(or filename
|
||||
(string-constant unknown-filename)))
|
||||
"\n\n"
|
||||
(if (exn? exn)
|
||||
(format "~a" (exn-message exn))
|
||||
(format "~s" exn))))
|
||||
#f)])
|
||||
(gui-utils:show-busy-cursor
|
||||
(λ ()
|
||||
(if filename
|
||||
(let ([already-open (send (group:get-the-frame-group)
|
||||
locate-file
|
||||
filename)])
|
||||
(cond
|
||||
[already-open
|
||||
(send already-open make-visible filename)
|
||||
(send already-open show #t)
|
||||
already-open]
|
||||
[(and (preferences:get 'framework:open-here?)
|
||||
(send (group:get-the-frame-group) get-open-here-frame))
|
||||
=>
|
||||
(λ (fr)
|
||||
(add-to-recent filename)
|
||||
(send fr open-here filename)
|
||||
(send fr show #t)
|
||||
fr)]
|
||||
[else
|
||||
(let ([handler
|
||||
(if (path? filename)
|
||||
(find-format-handler filename)
|
||||
#f)])
|
||||
(add-to-recent filename)
|
||||
(if handler
|
||||
(handler filename)
|
||||
(make-default)))]))
|
||||
(make-default)))))]))
|
||||
(for-each (λ (recent-list-item)
|
||||
(let ([filename (car recent-list-item)])
|
||||
(instantiate menu-item% ()
|
||||
(parent menu)
|
||||
(label (gui-utils:trim-string
|
||||
(regexp-replace*
|
||||
"&"
|
||||
(path->string filename)
|
||||
"&&")
|
||||
200))
|
||||
(callback (λ (x y) (open-recent-list-item recent-list-item))))))
|
||||
recently-opened-files)
|
||||
(void)))
|
||||
|
||||
;; 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)])
|
||||
(cond
|
||||
[(file-exists? filename)
|
||||
(let ([fr (edit-file filename)])
|
||||
(when (is-a? fr frame:open-here<%>)
|
||||
(let ([ed (send fr get-open-here-editor)])
|
||||
(when (equal? (send ed get-filename) filename)
|
||||
(send ed set-position start end)))))]
|
||||
[else
|
||||
(message-box (string-constant error)
|
||||
(format (string-constant cannot-open-because-dne)
|
||||
filename))])))
|
||||
|
||||
;; 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-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)
|
||||
|
||||
(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 (set-recent-items-frame-superclass super%)
|
||||
(set! recent-items-super% super%))
|
||||
|
||||
(define (get-recent-items-window%)
|
||||
(class recent-items-super%
|
||||
|
||||
;; type recent-list-item = (list/p string? number? number?)
|
||||
;; remove extraneous separators
|
||||
(define/override (file-menu:between-print-and-close menu) (void))
|
||||
(define/override (edit-menu:between-find-and-preferences menu) (void))
|
||||
|
||||
;; 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)))
|
||||
old-list)]
|
||||
[old-ent (if (null? old-ents)
|
||||
#f
|
||||
(car old-ents))]
|
||||
[new-ent (list filename
|
||||
(if old-ent (cadr old-ent) 0)
|
||||
(if old-ent (caddr old-ent) 0))]
|
||||
[added-in (cons new-ent (remove new-ent old-list compare-recent-list-items))]
|
||||
[new-recent (size-down added-in (preferences:get 'framework:recent-max-count))])
|
||||
(preferences:set 'framework:recently-opened-files/pos new-recent)))
|
||||
(define/override (on-size w h)
|
||||
(preferences:set 'framework:recent-items-window-w w)
|
||||
(preferences:set 'framework:recent-items-window-h h))
|
||||
|
||||
;; 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)
|
||||
(let loop ([n n]
|
||||
[new-recent new-recent])
|
||||
(cond
|
||||
[(zero? n) null]
|
||||
[(null? new-recent) null]
|
||||
[else
|
||||
(cons (car new-recent)
|
||||
(loop (- n 1)
|
||||
(cdr new-recent)))])))
|
||||
;; refresh-hl : (listof recent-list-item) -> void
|
||||
(define/private (refresh-hl recent-list-items)
|
||||
(let ([ed (send hl get-editor)])
|
||||
(send ed begin-edit-sequence)
|
||||
(for-each (λ (item) (send hl delete-item item)) (send hl get-items))
|
||||
(for-each (λ (item) (add-recent-item item))
|
||||
(if (eq? (preferences:get 'framework:recently-opened-sort-by) 'name)
|
||||
(sort recent-list-items
|
||||
(λ (x y) (string<=? (path->string (car x))
|
||||
(path->string (car y)))))
|
||||
recent-list-items))
|
||||
(send ed end-edit-sequence)))
|
||||
|
||||
;; 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)))
|
||||
(define/private (add-recent-item recent-list-item)
|
||||
(let ([item (send hl new-item (make-hierlist-item-mixin recent-list-item))])
|
||||
(send (send item get-editor) insert (path->string (car recent-list-item)))))
|
||||
|
||||
;; 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
|
||||
(filter (λ (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)])
|
||||
(set-car! (cdr recent-item) start)
|
||||
(set-car! (cddr recent-item) end)))))
|
||||
|
||||
;; install-recent-items : (is-a?/c menu%) -> void?
|
||||
(define (install-recent-items menu)
|
||||
(let ([recently-opened-files
|
||||
(preferences:get
|
||||
'framework:recently-opened-files/pos)])
|
||||
(for-each (λ (item) (send item delete))
|
||||
(send menu get-items))
|
||||
|
||||
(instantiate menu-item% ()
|
||||
(parent menu)
|
||||
(label (string-constant show-recent-items-window-menu-item))
|
||||
(callback (λ (x y) (show-recent-items-window))))
|
||||
|
||||
(instantiate separator-menu-item% ()
|
||||
(parent menu))
|
||||
|
||||
(for-each (λ (recent-list-item)
|
||||
(let ([filename (car recent-list-item)])
|
||||
(instantiate menu-item% ()
|
||||
(parent menu)
|
||||
(label (gui-utils:trim-string
|
||||
(regexp-replace*
|
||||
"&"
|
||||
(path->string filename)
|
||||
"&&")
|
||||
200))
|
||||
(callback (λ (x y) (open-recent-list-item recent-list-item))))))
|
||||
recently-opened-files)
|
||||
(void)))
|
||||
|
||||
;; 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)])
|
||||
(cond
|
||||
[(file-exists? filename)
|
||||
(let ([fr (edit-file filename)])
|
||||
(when (is-a? fr frame:open-here<%>)
|
||||
(let ([ed (send fr get-open-here-editor)])
|
||||
(when (equal? (send ed get-filename) filename)
|
||||
(send ed set-position start end)))))]
|
||||
[else
|
||||
(message-box (string-constant error)
|
||||
(format (string-constant cannot-open-because-dne)
|
||||
filename))])))
|
||||
(field [remove-prefs-callback
|
||||
(preferences:add-callback
|
||||
'framework:recently-opened-files/pos
|
||||
(λ (p v)
|
||||
(refresh-hl v)))])
|
||||
|
||||
;; 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))
|
||||
(define/augment (on-close)
|
||||
(inner (void) on-close)
|
||||
(remove-prefs-callback)
|
||||
(set! recent-items-window #f))
|
||||
|
||||
;; 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)
|
||||
|
||||
(define recent-items-hierarchical-list%
|
||||
(class hierarchical-list%
|
||||
(define/override (on-double-select item)
|
||||
(send item open-item))
|
||||
(super-instantiate ())))
|
||||
(super-new)
|
||||
|
||||
(define recent-items-super% (frame:standard-menus-mixin frame:basic%))
|
||||
|
||||
(define (set-recent-items-frame-superclass super%)
|
||||
(set! recent-items-super% super%))
|
||||
(inherit get-area-container)
|
||||
(field [bp (make-object horizontal-panel% (get-area-container))]
|
||||
[hl (make-object recent-items-hierarchical-list% (get-area-container) '())]
|
||||
[sort-by-name-button
|
||||
(make-object button%
|
||||
(string-constant recent-items-sort-by-name)
|
||||
bp
|
||||
(λ (x y) (set-sort-by 'name)))]
|
||||
[sort-by-age-button
|
||||
(make-object button%
|
||||
(string-constant recent-items-sort-by-age)
|
||||
bp
|
||||
(λ (x y) (set-sort-by 'age)))])
|
||||
|
||||
(define (get-recent-items-window%)
|
||||
(class recent-items-super%
|
||||
|
||||
;; remove extraneous separators
|
||||
(define/override (file-menu:between-print-and-close menu) (void))
|
||||
(define/override (edit-menu:between-find-and-preferences menu) (void))
|
||||
|
||||
(define/override (on-size w h)
|
||||
(preferences:set 'framework:recent-items-window-w w)
|
||||
(preferences:set 'framework:recent-items-window-h h))
|
||||
|
||||
;; refresh-hl : (listof recent-list-item) -> void
|
||||
(define/private (refresh-hl recent-list-items)
|
||||
(let ([ed (send hl get-editor)])
|
||||
(send ed begin-edit-sequence)
|
||||
(for-each (λ (item) (send hl delete-item item)) (send hl get-items))
|
||||
(for-each (λ (item) (add-recent-item item))
|
||||
(if (eq? (preferences:get 'framework:recently-opened-sort-by) 'name)
|
||||
(sort recent-list-items
|
||||
(λ (x y) (string<=? (path->string (car x))
|
||||
(path->string (car y)))))
|
||||
recent-list-items))
|
||||
(send ed end-edit-sequence)))
|
||||
|
||||
(define/private (add-recent-item recent-list-item)
|
||||
(let ([item (send hl new-item (make-hierlist-item-mixin recent-list-item))])
|
||||
(send (send item get-editor) insert (path->string (car recent-list-item)))))
|
||||
|
||||
(field [remove-prefs-callback
|
||||
(preferences:add-callback
|
||||
'framework:recently-opened-files/pos
|
||||
(λ (p v)
|
||||
(refresh-hl v)))])
|
||||
|
||||
(define/augment (on-close)
|
||||
(inner (void) on-close)
|
||||
(remove-prefs-callback)
|
||||
(set! recent-items-window #f))
|
||||
|
||||
(super-new)
|
||||
|
||||
(inherit get-area-container)
|
||||
(field [bp (make-object horizontal-panel% (get-area-container))]
|
||||
[hl (make-object recent-items-hierarchical-list% (get-area-container) '())]
|
||||
[sort-by-name-button
|
||||
(make-object button%
|
||||
(string-constant recent-items-sort-by-name)
|
||||
bp
|
||||
(λ (x y) (set-sort-by 'name)))]
|
||||
[sort-by-age-button
|
||||
(make-object button%
|
||||
(string-constant recent-items-sort-by-age)
|
||||
bp
|
||||
(λ (x y) (set-sort-by 'age)))])
|
||||
|
||||
(send bp stretchable-height #f)
|
||||
(send sort-by-name-button stretchable-width #t)
|
||||
(send sort-by-age-button stretchable-width #t)
|
||||
|
||||
(define/private (set-sort-by flag)
|
||||
(preferences:set 'framework:recently-opened-sort-by flag)
|
||||
(case flag
|
||||
[(name)
|
||||
(send sort-by-age-button enable #t)
|
||||
(send sort-by-name-button enable #f)]
|
||||
[(age)
|
||||
(send sort-by-age-button enable #f)
|
||||
(send sort-by-name-button enable #t)])
|
||||
(refresh-hl (preferences:get 'framework:recently-opened-files/pos)))
|
||||
|
||||
(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)
|
||||
(λ (%)
|
||||
(class %
|
||||
(define/public (open-item)
|
||||
(open-recent-list-item recent-item))
|
||||
(super-instantiate ()))))
|
||||
(send bp stretchable-height #f)
|
||||
(send sort-by-name-button stretchable-width #t)
|
||||
(send sort-by-age-button stretchable-width #t)
|
||||
|
||||
(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
|
||||
(λ ()
|
||||
(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))
|
||||
(and file
|
||||
(edit-file file))))))
|
||||
(define/private (set-sort-by flag)
|
||||
(preferences:set 'framework:recently-opened-sort-by flag)
|
||||
(case flag
|
||||
[(name)
|
||||
(send sort-by-age-button enable #t)
|
||||
(send sort-by-name-button enable #f)]
|
||||
[(age)
|
||||
(send sort-by-age-button enable #f)
|
||||
(send sort-by-name-button enable #t)])
|
||||
(refresh-hl (preferences:get 'framework:recently-opened-files/pos)))
|
||||
|
||||
(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)
|
||||
(λ (%)
|
||||
(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)
|
||||
(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))
|
||||
(and file
|
||||
(edit-file file)))))
|
||||
|
|
|
|||
|
|
@ -101,7 +101,9 @@ the state transitions / contracts are:
|
|||
|
||||
;; unmarshall, if required
|
||||
(when (hash-table-bound? marshalled p)
|
||||
(hash-table-put! preferences p (unmarshall-pref p (hash-table-get marshalled p)))
|
||||
;; if `preferences' is already bound, that means the unmarshalled value isn't useful.
|
||||
(unless (hash-table-bound? preferences p)
|
||||
(hash-table-put! preferences p (unmarshall-pref p (hash-table-get marshalled p))))
|
||||
(hash-table-remove! marshalled p))
|
||||
|
||||
;; if there is no value in the preferences table, but there is one
|
||||
|
|
|
|||
|
|
@ -24,7 +24,8 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
[prefix color-model: framework:color-model^]
|
||||
[prefix frame: framework:frame^]
|
||||
[prefix scheme: framework:scheme^]
|
||||
[prefix number-snip: framework:number-snip^])
|
||||
[prefix number-snip: framework:number-snip^]
|
||||
[prefix finder: framework:finder^])
|
||||
(export (rename framework:text^
|
||||
[-keymap% keymap%]))
|
||||
(init-depend framework:editor^)
|
||||
|
|
@ -52,7 +53,7 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
|
||||
(define basic-mixin
|
||||
(mixin (editor:basic<%> (class->interface text%)) (basic<%>)
|
||||
(inherit get-canvases get-admin split-snip get-snip-position
|
||||
(inherit get-canvas get-canvases get-admin split-snip get-snip-position
|
||||
begin-edit-sequence end-edit-sequence
|
||||
set-autowrap-bitmap
|
||||
delete find-snip invalidate-bitmap-cache
|
||||
|
|
@ -350,7 +351,18 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(public initial-autowrap-bitmap)
|
||||
(define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap))
|
||||
|
||||
(super-instantiate ())
|
||||
(define/override (put-file directory default-name)
|
||||
(let* ([canvas (get-canvas)]
|
||||
[parent (and canvas (send canvas get-top-level-window))])
|
||||
(finder:put-file default-name
|
||||
directory
|
||||
#f
|
||||
(string-constant select-file)
|
||||
#f
|
||||
""
|
||||
parent)))
|
||||
|
||||
(super-new)
|
||||
(set-autowrap-bitmap (initial-autowrap-bitmap))))
|
||||
|
||||
(define foreground-color<%>
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user