364 lines
14 KiB
Racket
364 lines
14 KiB
Racket
#lang scheme/unit
|
|
|
|
(require mzlib/class
|
|
mrlib/hierlist
|
|
"sig.rkt"
|
|
"../preferences.rkt"
|
|
"../gui-utils.rkt"
|
|
mred/mred-sig
|
|
racket/path
|
|
string-constants)
|
|
|
|
(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^)
|
|
|
|
(define-struct handler (name extension handler))
|
|
|
|
(define format-handlers '())
|
|
|
|
(define (make-insert-handler who name extension handler)
|
|
(cond [(not (string? name))
|
|
(error who "name was not a string")]
|
|
[(not (or (procedure? extension)
|
|
(string? extension)
|
|
(and (list? extension) (andmap string? 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 ([handler handlers])
|
|
(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)))))
|
|
#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 filename [make-default
|
|
(λ () ((current-create-new-window) filename))])
|
|
(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]
|
|
[else
|
|
(let ([handler (and (path? filename)
|
|
(find-format-handler filename))])
|
|
(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)
|
|
|
|
(define old-list (preferences:get 'framework:recently-opened-files/pos))
|
|
(define old-ents (filter (λ (x) (recently-opened-files-same-enough-path? (car x) filename))
|
|
old-list))
|
|
(define new-ent (if (null? old-ents)
|
|
(list filename 0 0)
|
|
(cons filename (cdr (car old-ents)))))
|
|
(define added-in (cons new-ent
|
|
(remove* (list new-ent)
|
|
old-list
|
|
(λ (l1 l2)
|
|
(recently-opened-files-same-enough-path? (car l1) (car l2))))))
|
|
(define new-recent (size-down added-in
|
|
(preferences:get 'framework:recent-max-count)))
|
|
(preferences:set 'framework:recently-opened-files/pos new-recent))
|
|
|
|
;; same-enough-path? : path path -> boolean
|
|
;; used to determine if the open-recent-files menu item considers two paths to be the same
|
|
(define (recently-opened-files-same-enough-path? p1 p2)
|
|
(equal? (simplify-path (normal-case-path p1) #f)
|
|
(simplify-path (normal-case-path p2) #f)))
|
|
|
|
|
|
|
|
;; 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
|
|
(preferences:get 'framework:recently-opened-files/pos)]
|
|
[new-recent-items
|
|
(map (λ (x)
|
|
(if (recently-opened-files-same-enough-path? (path->string (car x))
|
|
(path->string filename))
|
|
(list* (car x) start end (cdddr x))
|
|
x))
|
|
(preferences:get 'framework:recently-opened-files/pos))])
|
|
(unless (equal? recent-items new-recent-items)
|
|
(preferences:set 'framework:recently-opened-files/pos
|
|
new-recent-items))))
|
|
|
|
;; install-recent-items : (is-a?/c menu%) -> void?
|
|
(define (install-recent-items menu)
|
|
;; sometimes, we get here via an on-demand callback
|
|
;; and we run out of time during the callback and
|
|
;; things go awry with the menu. So, to hack around
|
|
;; that problem, lets try to do it twice; once here
|
|
;; when we notice that things are wrong, and then once
|
|
;; in a later event callback, when we know we won't run
|
|
;; afoul of any time limits.
|
|
(do-install-recent-items menu)
|
|
(queue-callback (λ () (do-install-recent-items menu)) #f)
|
|
(void))
|
|
|
|
(define (do-install-recent-items menu)
|
|
(define recently-opened-files
|
|
(preferences:get
|
|
'framework:recently-opened-files/pos))
|
|
|
|
(unless (menu-items-still-same? recently-opened-files menu)
|
|
(for ([item (send menu get-items)]) (send item delete))
|
|
|
|
(for ([recent-list-item recently-opened-files])
|
|
(new menu-item%
|
|
[parent menu]
|
|
[label (recent-list-item->menu-label recent-list-item)]
|
|
[callback (λ (x y) (open-recent-list-item recent-list-item))]))
|
|
(new separator-menu-item% [parent menu])
|
|
(new menu-item%
|
|
[parent menu]
|
|
[label (string-constant show-recent-items-window-menu-item)]
|
|
[callback (λ (x y) (show-recent-items-window))])))
|
|
|
|
(define (recent-list-item->menu-label recent-list-item)
|
|
(let ([filename (car recent-list-item)])
|
|
(gui-utils:quote-literal-label
|
|
(path->string filename))))
|
|
|
|
;; this function must mimic what happens in install-recent-items
|
|
;; it returns #t if all of the labels of menus are the same, or approximation to
|
|
;; the menus actually being different
|
|
(define (menu-items-still-same? recently-opened-files menu)
|
|
(let ([current-items
|
|
(map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
|
|
(send menu get-items))]
|
|
;; the new-items variable should match up to what install-recent-items actually does when it creates the menu
|
|
[new-items
|
|
(append
|
|
(for/list ([recent-list-item recently-opened-files])
|
|
(recent-list-item->menu-label recent-list-item))
|
|
(list #f
|
|
(string-constant show-recent-items-window-menu-item)))])
|
|
(equal? current-items new-items)))
|
|
|
|
;; 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)
|
|
(edit-file filename)]
|
|
[else
|
|
(preferences:set 'framework:recently-opened-files/pos
|
|
(remove* (list recent-list-item)
|
|
(preferences:get 'framework:recently-opened-files/pos)
|
|
(λ (l1 l2)
|
|
(recently-opened-files-same-enough-path?
|
|
(car l1)
|
|
(car l2)))))
|
|
(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%
|
|
|
|
;; 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 ([item (send hl get-items)]) (send hl delete-item item))
|
|
(for-each (λ (item) (add-recent-item item))
|
|
(if (eq? (preferences:get 'framework:recently-opened-sort-by)
|
|
'name)
|
|
(sort recent-list-items string<?
|
|
#:key (compose path->string car) #:cache-keys? #t)
|
|
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 ()))))
|
|
|
|
(define (open-file [directory #f])
|
|
(let* ([parent (and (not (eq? 'macosx (system-type)))
|
|
(get-top-level-focus-window))]
|
|
[file
|
|
(parameterize ([finder:dialog-parent-parameter parent])
|
|
(finder:get-file directory))])
|
|
(and file
|
|
(edit-file file))))
|